Home |
Search |
Today's Posts |
#1
|
|||
|
|||
Modify this Array
Is it possible to modify the array so that it checks the header to ensure that value is put in the correct column?
The following array will get the block attribute values out of a ACAD drawing and export them to excel. However not all attributes have the same headers and values. Some blocks fill in more columns with data than the others. I have also noticed at times the order of the headers change so that seems to complicate things a little. I have attached a sample showing how for instance the "tag" values do not line up... Please, any help is appreciated Code:
Public Function ExtractAtts() 'Open Excel file Dim Xl As Excel.Application Dim XlSheet As Object Dim XlWorkbook As Object Dim RowNum As Integer Dim Header As Boolean Dim elem As AcadEntity Dim Array1 As Variant Dim count As Integer FilePath = ("C:\Desktop\TempImport.xlsx") 'Launch Excel and Get Attributes*************************** Set Xl = New Excel.Application Set XlBook = Xl.Workbooks.Open(FilePath, ReadOnly:=False) Set XlSheet = XlBook.Worksheets("DwgAttributes") Xl.Visible = True 'False RowNum = 1 Header = False 'Extract Attyributes and populate the excel Tab With Xl.Worksheets("DwgAttributes") On Error Resume Next .Cells.Clear ' Iterate through model space finding ' all block references. For Each elem In ThisDrawing.ModelSpace With elem ' When a block reference has been found, ' check it for attributes If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then If .HasAttributes Then ' Get the attributes Array1 = .GetAttributes 'MODIFY THIS ARRAY***** ' Copy the Tagstrings for the Attributes into Excel For count = LBound(Array1) To UBound(Array1) If Header = False Then If StrComp(Array1(count).EntityName, "AcDbAttribute", 1) = 0 Then XlSheet.Range("A1") = "HANDLE" 'get the block handle XlSheet.Cells(RowNum, count + 2).Value = Array1(count).TagString End If End If Next count RowNum = RowNum + 1 For count = LBound(Array1) To UBound(Array1) If XlSheet.Range("A" & RowNum) = False Then XlSheet.Range("A" & RowNum) = "'" & "'" & elem.Handle 'Block Handle Header End If XlSheet.Cells(RowNum, count + 2).Value = Array1(count).TextString Next count Header = True End If End If End With Next elem Xl.Sheets("Sheet1").Cells.EntireColumn.AutoFit End With Xl.DisplayAlerts = False XlWorkbook.Save XlWorkbook.Close True '*** uncomment to keep open Xl.DisplayAlerts = True Xl.Quit Set XlSheet = Nothing Set XlWorkbook = Nothing Set Xl = Nothing GoTo Exit_Sub Exit_XL_App: MsgBox Err.Number & " - " & Err.Description & " Error occurred in Excel App Process" Xl.DisplayAlerts = False XlWorkbook.Close True '*** uncomment to keep open Xl.DisplayAlerts = True Xl.Quit Set XlSheet = Nothing Set XlWorkbook = Nothing Set Xl = Nothing GoTo Exit_Sub Exit_Sub: End Function |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Firstly, this 'very messy and inefficient' code sample needs a serious
revision to get rid of all the unnecessary duplication and If...Then constructs. One problem I see right away after reading your sample file is that you're processing 'components' of an assembly, and so not all will have the same 'attributes' by nature of their individual design. In this case you need a 'map' enum for your headers so you can assign non-blank attributes to their respective 'fields' so the data ends up in the correct columns. This requires a methodology that enums attributes so you can assign column indexes to values. It also requires your 'same' attributes be named identically so they can be identified for their respective position in the data table. I switched from using ACAD to using SolidWorks back in the 90's and so its equivalent to model 'attributes' is model 'properties'. I use model templates that have the same list of properties (via PropertyManager) for all (sldprt, sldasm) so list number of 'fields' is the same for all components and assemblies. (Assemblies can contain sub-assemblies) I don't have to figure things out 'after-the-fact' and so I can't help you here much beyond approach concept... 1. Loop all components in the model to build a unique list of 'attribute' IDs. (This can be as simple in construct as a delimited string list!) 2. Loop again to find the index of each component's 'attribute' in the string list. (This can be as simple as using a counter in a For...Each constructs!) 3. Assign the value of the components 'attribute' to the counter position in your 'output array'. The output array should be 2D... ReDim vaDataOut(<component.count, <attributes.count) ...so all data is processed in memory. Make sure you have a proper handle on the 'count' values as to their 'base' being zero or 1 so vaDataOut is correctly dimmed! Note that this array is being dimmed dynamically and so must be done using the 'ReDim' statement in order to use variables for the respective 'count' values. 4. Once all data is assign, 'dump' vaDataOut into the worksheet. However, I strongly suggest implementing a standard set of 'attributes' for all part/assembly files so you have a consistent 'set' of value 'placeholders' regardless if all are used for every part/assembly file. -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#4
|
|||
|
|||
Thanks for the reply...
I was looking at some examples of the ReDim vaDataOut and wow that is way over my head, but I will do some research... I'm not skilled at vba and not sure I can figure that out. I just know enough to put a few pieces code together and hope it works... Just for clarification, the headers shown in the example accounts for all the attribute values in the blocks used... |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Thanks for the reply...
I was looking at some examples of the ReDim vaDataOut and wow that is way over my head, but I will do some research... I'm not skilled at vba and not sure I can figure that out. I just know enough to put a few pieces code together and hope it works... Just for clarification, the headers shown in the example accounts for all the attribute values in the blocks used... +-------------------------------------------------------------------+ +-------------------------------------------------------------------+ According to what I've researched.., Enhanced Attribute Manager would be your equivalent for the PropertyLinks manager I use in SolidWorks. If you give all models a standard 'set' of attributes you should be alright. As for the code... Do me a favor and 'dump' Array1 into a blank worksheet... With Xl.Sheets("Sheet2").Range("A1") .Resize(UBound(Array1), UBound(Array1, 2) = Array1 End With ...so I can see an example of a set of attributes, and post a link to the file. -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Insert the code to dump Array1 after this line...
Array1 = .GetAttributes -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Can you explain why you open a specific workbook and clear the target
sheet? Could you not just use a new workbook? -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
In the case Array1 is 1D...
With Xl.Sheets("Sheet2").Range("A1") .Resize(1,UBound(Array1)) = Array1 End With ...and only for 1 elem! That means you have to step through the code and end it after the data is dumped. -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#9
|
|||
|
|||
Sim Đoàn Viên Giá Rẻ
Cơ hội cho bạn tiết kiệm tiền điện thoại một cách hợp lư. Là làm sim sinh viên và sim đoàn viên! liên hệ 0903.636.838 or 0906.904.888 DC: p3010CT10A chung cư Đại Thanh Nhận chuyển sim thường sang sim SINH VIÊN, đoàn viên KHÔNG CẦN THẺ SINH VIÊN 3 mạng chính Uy tín và Đảm bảo. Chuyên đại lư và khách hàng thn quen. Cam kết có giá tốt nhất nếu làm số lượng. ✔ Viettel x 200 k ...Xem thêm [center]https://scontent-dfw.xx.fbcdn.net/hp...e1&oe=55A23F97[url=https://www.facebook.com/simsinhviengiare.vn][b]Sim Sinh Viên Mobi Giá Rẻ |
#10
|
|||
|
|||
Quote:
Example: the field technician will put a description and extended labels of a device that the engineer would have to update as part of the as-builts. The intent is to automate that process by updating the dwgAttribute tab and then updating the drawing |
#11
|
|||
|
|||
Quote:
Quote:
Perhaps I could explain it.. I have basically two sets of attributes ---------------------------------------------------------------- Set1 HANDLE, BLOCKNAME, TAG, LABEL1, LABEL2, QTY, MODEL_NUM, DESCRIPTION, VENDOR, CSFM_NUM Set2 (Has more) HANDLE, BLOCKNAME, TAG, LOOP, ADDRESS, LABEL1, LABEL2, DEVICE_LABEL, EXTENDED_LABEL, QTY, MODEL_NUM, DESCRIPTION, VENDOR, CSFM_NUM ---------------------------------------------------------------- Currently I am writing them to one sheet and looking for the code to populate the correct cell... |
#12
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
'GS[_2_ Wrote:
;1620728']Can you explain why you open a specific workbook and clear the target sheet? Could you not just use a new workbook? I am using a specific workbook because I have other tabs in the WB that has information from a field panel. I am updating the attributes in the dwg with the actual information from the field panel description. Example: the field technician will put a description and extended labels of a device that the engineer would have to update as part of the as-builts. The intent is to automate that process by updating the dwgAttribute tab and then updating the drawing +-------------------------------------------------------------------+ +-------------------------------------------------------------------+ Makes sense! Can you provide me sample contents of Array1? -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#13
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Do me a favor and 'dump' Array1 into a blank worksheet... With Xl.Sheets("Sheet2").Range("A1") .Resize(UBound(Array1), UBound(Array1, 2) = Array1 End With ...so I can see an example of a set of attributes, and post a link to the file. Insert the code to dump Array1 after this line... Array1 = .GetAttributes Why I tried this Sheet2 is blank. Not sure what I'm doing wrong Perhaps I could explain it.. I have basically two sets of attributes ---------------------------------------------------------------- Set1 HANDLE, BLOCKNAME, TAG, LABEL1, LABEL2, QTY, MODEL_NUM, DESCRIPTION, VENDOR, CSFM_NUM Set2 (Has more) HANDLE, BLOCKNAME, TAG, LOOP, ADDRESS, LABEL1, LABEL2, DEVICE_LABEL, EXTENDED_LABEL, QTY, MODEL_NUM, DESCRIPTION, VENDOR, CSFM_NUM ---------------------------------------------------------------- Currently I am writing them to one sheet and looking for the code to populate the correct cell... +-------------------------------------------------------------------+ +-------------------------------------------------------------------+ Okay, this is pretty much what shows as headers in your sample worksheet. I was wanting to see how .GetAttributes returns values. I'll go online to see what I can find. What property is these attributes? (I'm guessing .TagString?) I want to provide code that builds headers of unique attributes so the values can be assigned to the appropriate column according to their attribute. I'm also guessing the attribute value is .TextString? -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#14
|
|||
|
|||
Quote:
Would a Screenshot of the Array1 Help (See the attached) |
#15
|
|||
|
|||
tin tức nước Nga Tất cả thông tin, h́nh ảnh, video clip về Nga tổng hợp từ tất cả các báo điện tử tại ... Cực để tạo điều kiện thuận lợi cho các công ty của nước này khai thác
đọc báo nga Xem thêm: http://vietbao.ru/vo-su-aikido-nhat-...post43065.html |
#16
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
What property is these attributes? (I'm guessing .TagString?) I want to provide code that builds headers of unique attributes so the values can be assigned to the appropriate column according to their attribute. I'm also guessing the attribute value is .TextString? Yes you are correct for both... Would a Screenshot of the Array1 Help (See the attached) +-------------------------------------------------------------------+ Filename: Array1.zip | Download: http://www.excelbanter.com/attachment.php?attachmentid=1011| +-------------------------------------------------------------------+ Yes, thanks! I found where you got your code sample online (augi.com) and better understand the object.property refs now. Here's what I'm doing... 1. Loop through entities for blocks that have attributes. If attributes found then add EntityName and its TagStrings to string lists. 2. Insert TagStrings string list as headers in row 1 3. Loop through entities again, matching EntityName to EntityNames string list. If match then .GetAttributes and load values for TagStrings into an output array according to TagString position. 4. dump the output array into the worksheet at row 2. ...which will put each TagString value in the correct column. -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#17
|
|||
|
|||
Sounds perfect...I'm glad you found the reference.
One thing I noticed is that the .getattribute does not get the handle .textstring. Thats why I added the the line XlSheet.Range("A" & RowNum) = "'" & "'" & elem.Handle It was the only way I was able to get it to give the handle and put the ' in front |
#18
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Sounds perfect...I'm glad you found the reference.
One thing I noticed is that the .getattribute does not get the handle .textstring. Thats why I added the the line XlSheet.Range("A" & RowNum) = "'" & "'" & elem.Handle It was the only way I was able to get it to give the handle and put the ' in front Yes.., .Handle is a property of the AcadEntity, though I don't see why you need 2 apostrophes to 'type' the value as text. Do you need to display a leading apostrophe as well? Why? I'm ready to post (shortly) something for you to test since I have no way to do so. Please post a file link showing the results so I know where to make any changes needed. Please include your comments... -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#19
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Try this in a standard module...
Option Explicit Public Sub ExtractAttributes() ' AutoCad VBA macro: ' Automates Excel to list any Block Attributes found in a Dwg file. ' Uses late binding so setting refernce to Excel is not required. Dim appXL As Excel.Application, wksXL As Object, wkbXL As Object Dim Header As Boolean, lRow&, n&, k&, j&, sTags$, sEnts$ Dim vTmp, vEntity As AcadEntity, vTags, vaDataOut() Const sFilePath$ = "C:\Desktop\TempImport.xlsx" Const sBlockRef$ = "AcDbBlockReference" On Error GoTo ErrExit 'Start an automated instance of Excel Set appXL = CreateObject("Excel.Application") Set wkbXL = appXL.Workbooks.Open(sFilePath, ReadOnly:=False) Set wksXL = wkbXL.Worksheets("DwgAttributes") appXL.Visible = True 'False lRow = 1: sTags = "HANDLE" '//initialize vars 'Find all block references For Each vEntity In ThisDrawing.ModelSpace With vEntity If bBlockRefsFound(.EntityName, sBlockRef) Then 'Get a list of any Attributes If .HasAttributes Then sEnts = sEnts & "," & .EntityName '//list its name vTmp = .GetAttributes For n = LBound(vTmp) To UBound(vTmp) If Not InStr(sTags, vTmp(n).TagString) 0 _ Then sTags = sTags & "," & vTmp(n).TagString Next 'n End If 'bBlockRefsFound End If '.HasAttributes End With 'vEntity Next 'vEntity 'Set the attribute TagStrings as headers in row 1 vTags = Split(sTags, ",") With wksXL .Cells.Clear .Cells(1, 1).Resize(1, UBound(vTags) + 1) = vTags End With 'wksXL 'Dim the output array k = UBound(Split(Mid(sEnts, 2), ",")) ReDim vaDataOut(k, UBound(vTags)): lRow = lRow + 1: 'Load the array with attribute values For Each vEntity In ThisDrawing.ModelSpace If InStr(sEnts, vEntity.EntityName) 0 Then vTmp = vEntity.GetAttributes For n = LBound(vaDataOut) To UBound(vaDataOut) For k = LBound(vTmp) To UBound(vTmp) For j = LBound(vTags) To UBound(vTags) If j = 0 Then vaDataOut(n, j) = Format(vEntity.Handle, "'@") Else If vTmp(k).TagString = vTags(j) Then vaDataOut(n, j) = vTmp(k).TextString: Exit For End If Next 'j Next 'k Next 'n End If Next 'vEntity With wksXL .Cells(lRow, 1).Resize(UBound(vaDataOut) + 1, UBound(vaDataOut, 2) + 1) = vaDataOut .Cells.EntireColumn.AutoFit End With ErrExit: MsgBox Err.Number & " - " & Err.Description & " Error occurred in Excel App Process" ' appXL.DisplayAlerts = False If (Err = 0) Then wkbXL.Save Else wkbXL.Close SaveChanges:=True '*** uncomment to keep open End If '(Err = 0) ' appXL.DisplayAlerts = True appXL.Quit Set wksXL = Nothing: Set wkbXL = Nothing: Set appXL = Nothing End Sub Function bBlockRefsFound(sName$, sText$) As Boolean bBlockRefsFound = StrComp(sName, sText, 1) = 0 End Function -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#20
|
|||
|
|||
WOW...Thank yo uso much for this...
After trying it the code won't compile it get hung up at the split part of the foollowing line..."vTags = Split(sTags, ","))" |
#21
|
|||
|
|||
Sim Sinh Viên Viettel Giá Rẻ
Cơ hội cho bạn tiết kiệm tiền điện thoại một cách hợp lư. Là làm sim sinh viên và sim đoàn viên! liên hệ 0903.636.838 or 0906.904.888 DC: p3010CT10A chung cư Đại Thanh Nhận chuyển sim thường sang sim SINH VIÊN, đoàn viên KHÔNG CẦN THẺ SINH VIÊN 3 mạng chính Uy tín và Đảm bảo. Chuyên đại lư và khách hàng thn quen. Cam kết có giá tốt nhất nếu làm số lượng. ✔ Viettel x 200 k ...Xem thêm [center]https://scontent-dfw.xx.fbcdn.net/hp...e1&oe=55A23F97[url=https://www.facebook.com/simsinhviengiare.vn][b]Sim Đoàn Viên Giá Rẻ |
#22
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
WOW...Thank yo uso much for this...
After trying it the code won't compile it get hung up at the split part of the foollowing line..."vTags = Split(sTags, ","))" +-------------------------------------------------------------------+ +-------------------------------------------------------------------+ My code line only has 1 closing parenthesis where you show 2 here... vTags = Split(sTags, ",") -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#23
|
|||
|
|||
Quote:
On my work machine it gets past that line and gets hung up at the Line "Next 'j" with an error message of "Next without a For" |
#24
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Yep! Missing an End If statement...
Public Sub ExtractAttributes() ' AutoCad VBA macro: ' Automates Excel to list any Block Attributes found in a Dwg file. ' Uses late binding so setting refernce to Excel is not required. Dim appXL As Excel.Application, wksXL As Object, wkbXL As Object Dim Header As Boolean, lRow&, n&, k&, j&, sTags$, sEnts$ Dim vTmp, vEntity As AcadEntity, vTags, vaDataOut() Const sFilePath$ = "C:\Desktop\TempImport.xlsx" Const sBlockRef$ = "AcDbBlockReference" On Error GoTo ErrExit 'Start an automated instance of Excel Set appXL = CreateObject("Excel.Application") Set wkbXL = appXL.Workbooks.Open(sFilePath, ReadOnly:=False) Set wksXL = wkbXL.Worksheets("DwgAttributes") appXL.Visible = True 'False lRow = 1: sTags = "HANDLE" '//initialize vars 'Find all block references For Each vEntity In ThisDrawing.ModelSpace With vEntity If bBlockRefsFound(.EntityName, sBlockRef) Then 'Get a list of any Attributes If .HasAttributes Then sEnts = sEnts & "," & .EntityName '//list its name vTmp = .GetAttributes For n = LBound(vTmp) To UBound(vTmp) If Not InStr(sTags, vTmp(n).TagString) 0 _ Then sTags = sTags & "," & vTmp(n).TagString Next 'n End If '.HasAttributes End If 'bBlockRefsFound End With 'vEntity Next 'vEntity 'Set the attribute TagStrings as headers in row 1 vTags = Split(sTags, ",") With wksXL .Cells.Clear .Cells(1, 1).Resize(1, UBound(vTags) + 1) = vTags End With 'wksXL 'Dim the output array k = UBound(Split(Mid(sEnts, 2), ",")) ReDim vaDataOut(k, UBound(vTags)): lRow = lRow + 1: 'Load the array with attribute values For Each vEntity In ThisDrawing.ModelSpace If InStr(sEnts, vEntity.EntityName) 0 Then vTmp = vEntity.GetAttributes For n = LBound(vaDataOut) To UBound(vaDataOut) For k = LBound(vTmp) To UBound(vTmp) For j = LBound(vTags) To UBound(vTags) If j = 0 Then vaDataOut(n, j) = Format(vEntity.Handle, "'@") Else If vTmp(k).TagString = vTags(j) Then vaDataOut(n, j) = vTmp(k).TextString: Exit For End If End If 'j=0 Next 'j Next 'k Next 'n End If Next 'vEntity With wksXL .Cells(lRow, 1).Resize(UBound(vaDataOut) + 1, UBound(vaDataOut, 2) + 1) = vaDataOut .Cells.EntireColumn.AutoFit End With ErrExit: MsgBox Err.Number & " - " & Err.Description & " Error occurred in Excel App Process" ' appXL.DisplayAlerts = False If (Err = 0) Then wkbXL.Save Else wkbXL.Close SaveChanges:=True '*** uncomment to keep open End If '(Err = 0) ' appXL.DisplayAlerts = True appXL.Quit Set wksXL = Nothing: Set wkbXL = Nothing: Set appXL = Nothing End Sub -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#25
|
|||
|
|||
Attached is the results...It appears to be writing the same attribute throughout
Also after following... With wksXL .Cells(lRow, 1).Resize(UBound(vaDataOut) + 1, UBound(vaDataOut, 2) + 1) = vaDataOut .Cells.EntireColumn.AutoFit End With It drops to the MsgBox Err.Number and give a "0 - Error Occurred in Excel App Process" |
#26
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Try...
Public Sub ExtractAttributes() ' AutoCad VBA macro: ' Automates Excel to list any Block Attributes found in a Dwg file. ' Uses late binding so setting refernce to Excel is not required. Dim appXL As Excel.Application, wksXL As Object, wkbXL As Object Dim Header As Boolean, lRow&, n&, k&, j&, sTags$, sEnts$ Dim vTmp, vEntity As AcadEntity, vTags, vaDataOut() Const sFilePath$ = "C:\Desktop\TempImport.xlsx" Const sBlockRef$ = "AcDbBlockReference" On Error GoTo ErrExit 'Start an automated instance of Excel Set appXL = CreateObject("Excel.Application") Set wkbXL = appXL.Workbooks.Open(sFilePath, ReadOnly:=False) Set wksXL = wkbXL.Worksheets("DwgAttributes") appXL.Visible = True 'False lRow = 1: sTags = "HANDLE" '//initialize vars 'Find all block references For Each vEntity In ThisDrawing.ModelSpace With vEntity If bBlockRefsFound(.EntityName, sBlockRef) Then 'Get a list of any Attributes If .HasAttributes Then sEnts = sEnts & "," & .EntityName '//list its name vTmp = .GetAttributes For n = LBound(vTmp) To UBound(vTmp) If Not InStr(sTags, vTmp(n).TagString) 0 _ Then sTags = sTags & "," & vTmp(n).TagString Next 'n End If '.HasAttributes End If 'bBlockRefsFound End With 'vEntity Next 'vEntity 'Set the attribute TagStrings as headers in row 1 vTags = Split(sTags, ",") With wksXL .Cells.Clear .Cells(1, 1).Resize(1, UBound(vTags) + 1) = vTags End With 'wksXL 'Dim the output array k = UBound(Split(Mid(sEnts, 2), ",")) ReDim vaDataOut(k, UBound(vTags)): lRow = lRow + 1: 'Load the array with attribute values For Each vEntity In ThisDrawing.ModelSpace If InStr(sEnts, vEntity.EntityName) 0 Then vTmp = vEntity.GetAttributes For n = LBound(vaDataOut) To UBound(vaDataOut) For k = LBound(vTmp) To UBound(vTmp) For j = LBound(vTags) To UBound(vTags) If j = 0 Then vaDataOut(n, j) = Format(vEntity.Handle, "'@") Else If vTmp(k).TagString = vTags(j) Then vaDataOut(n, j) = vTmp(k).TextString: GoTo NextEntity End If End If 'j=0 Next 'j Next 'k Next 'n End If NextEntity: Next 'vEntity With wksXL .Cells(lRow, 1).Resize(UBound(vaDataOut) + 1, UBound(vaDataOut, 2) + 1) = vaDataOut .Cells.EntireColumn.AutoFit End With ErrExit: MsgBox Err.Number & " - " & Err.Description & " Error occurred in Excel App Process" ' appXL.DisplayAlerts = False If (Err = 0) Then wkbXL.Save Else wkbXL.Close SaveChanges:=True '*** uncomment to keep open End If '(Err = 0) ' appXL.DisplayAlerts = True appXL.Quit Set wksXL = Nothing: Set wkbXL = Nothing: Set appXL = Nothing End Sub -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#27
|
|||
|
|||
Sorry for the late response. Apparently my home machine does not like the "split" portion. After running it on my work machine it still give a "0 - Error Occurred in Excel App Process" But now it only populates one row...
|
#28
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Sorry for the late response. Apparently my home machine does not
like the "split" portion. After running it on my work machine it still give a "0 - Error Occurred in Excel App Process" But now it only populates one row... +-------------------------------------------------------------------+ +-------------------------------------------------------------------+ That's what I suspected would happen. I suggests multiple instances of the same entity in the dwg at home. Restore the code to 'Exit For' in the j loop's 'If..Else' block and try it with your original dwg... -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#29
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
FYI...
The Split() function has been around since VBA6 as part of the new features for working with arrays. Two others were included: Join(), Filter(). If your home version of Acad doesn't like this function, it suggests you have a really old version. You might be able to install VBA6 over the older version. Current version now is VBA7 to work with x64 apps. -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#30
|
|||
|
|||
Quote:
|
#31
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify this Array
Restore the code to 'Exit For' in
the j loop's 'If..Else' block and try it with your original dwg... Sorry I am not sure what to do here. I tried the original dwg with both revisions of the code. the first populates the right row count but duplicates the same information. The second only populates one row +-------------------------------------------------------------------+ +-------------------------------------------------------------------+ Unfortunately, I can't debug it due to not having Acad. Once it finishes the attributes for each entity it should move on to the next entity. I'd normally step thru it using F8 and watch what happens after the 1st entity's attributes are done. Perhaps the sEnts string list needs to be observed during execution to see that it's being constructed correctly because your results suggest it doesn't add other entity names... -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion |
#32
|
|||
|
|||
Mă giảm giá Lazada [/color]Mă giảm giá Lazada, tổng hợp voucher Zalora khuyến măi, coupon Tiki, Cdiscount và các trang web lớn khác, chia sẻ kinh nghiệm mua hàng online.
|
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Modify code for multiple sheets-Help defining array | Excel Programming | |||
Modify array function length | Excel Worksheet Functions | |||
modify without unprotecting the sheet, array with wrong format | Excel Programming | |||
Modify SumIF... Array Formula | Excel Worksheet Functions | |||
Modify SumIF... Array Formula | Excel Worksheet Functions |