| Home |
| Search |
| Today's Posts |
|
#1
|
|||
|
|||
Modify Code to loop back through table after its been updated and process it
I have been looking for a way to expand the following code to update some attribute block values (Tagstrings) after modifying the spreadsheet but with no success.
What I am trying to do is, after populating the Attribute Table, update the table with new values, then send the updated Attribute Table values back to the attributes. I am not sure how to pull it back in to VBA and then loop through it in order to update the attribute blocks I really appreciate any help that can be provided. I have been searching and working at this for days. Code:
Sub ExtractAtts_With_Filters()
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
Dim blk As AcadBlockReference
'****************************************************
'Delete the .xls Attribute Report File
Dim KillFile As String
varPath = ThisDrawing.Path
On Error GoTo Exit_XL_App
KillFile = varPath & "\" & "Attribute.xls"
'Check that file exists
If Len(Dir$(KillFile)) 0 Then
'First remove readonly attribute, if set
SetAttr KillFile, vbNormal
'Then delete the file
Kill KillFile
End If
' Launch Excel and Get Attributes***************************.
Set Xl = New Excel.Application
Xl.Visible = True
' Create a new workbook and find the active sheet.
Set XlWorkbook = Xl.Workbooks.Add
Set XlSheet = Xl.ActiveSheet
XlWorkbook.SaveAs fileName:=varPath & "\" & "Attribute.xls", FileFormat:=1
RowNum = 1
Header = False
' 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
' Filter through a list of attribute tagstrings in the current block.
' Cycle throught the list of attributes.
For i = LBound(Array1) To UBound(Array1)
' Check for the correct attribute tag.
Dim Attrib As AcadAttributeReference
Set Attrib = Array1(i)
' If the Tagstring containd "Addresses" then
' Copy the Tagstrings into Excel
If Attrib.TagString = "ADDRESS" Then
' 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" 'Code below adds column names
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 'Fill the columns with block data from modelspace
End If
XlSheet.Cells(RowNum, count + 2).value = Array1(count).TextString
Next count
Header = True
End If
Next i 'Next Filter Check
End If
End If
End With
Next elem
Xl.Sheets("Sheet1").Cells.EntireColumn.AutoFit
'************************************************************
' 'HERE is where the code to pull updated table from access goes…
' Attribs(0).TextString = "THIS IS THE NEW NEW VALUE!"
'
' ' Get the attributes again
' Dim newAttrib As Variant
' newAttrib = blkEntity.GetAttributes
'
' ' Again, display the tags and values
' strAttributes = ""
' For i = LBound(newAttrib) To UBound(newAttrib)
' strAttributes = strAttributes + " Tag: " + _
' newAttribs(i).TagString + vbCrLf + _
' " Value: " + newAttribs(i).TextString
'************************************************************
'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
'XlBook.Save
XlWorkbook.Close True '*** uncomment to keep open
Xl.DisplayAlerts = True
Xl.Quit
Set XlSheet = Nothing
Set XlWorkbook = Nothing
Set Xl = Nothing
Exit_Sub:
End Sub
|
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Modify Code to loop back through table after its been updated and process it
Set XlSheet = Nothing
Set XlWorkbook = Nothing Set Xl = Nothing This is duplicate code that could be inside your Exit_Sub label 1x only. You can 'dump' an entire range into a variant in 1 shot... Dim vAttrData I switched to using SolidWorks in 1998 and so I can't recall how you'd load an entire Acad Attribute Table into a VBA variable in 1 shot, or vice versa. (Seems we used a text file source, perhaps?) To go from a worksheet to the variable... vAttrData = XlSheet.UsedRange ...which results a 2D array equal to the num rows/cols of data on the worksheet. Similarly, you could load your Attribute Table into an array and 'dump' it into the worksheet in 1 shot.(Note that this needs to be a 2D array for all to work smoothly!) -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion --- This email has been checked for viruses by Avast antivirus software. https://www.avast.com/antivirus |
|
#3
|
|||
|
|||
|
Thank you for the tips, I did use it, however I still need a little help looping through it. I tried but its not working...I need a little more direction
Thanks again Quote:
Sub ExtractAtts_With_Filters() 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 'Dim blk As AcadBlockReference '************************************************* *** 'Delete the .xls Attribute Report File Dim KillFile As String varPath = ThisDrawing.Path On Error GoTo Exit_XL_App KillFile = varPath & "\" & "Attribute.xls" 'Check that file exists If Len(Dir$(KillFile)) 0 Then 'First remove readonly attribute, if set SetAttr KillFile, vbNormal 'Then delete the file Kill KillFile End If ' Launch Excel and Get Attributes***************************. Set Xl = New Excel.Application Xl.Visible = True ' Create a new workbook and find the active sheet. Set XlWorkbook = Xl.Workbooks.Add Set XlSheet = Xl.ActiveSheet XlWorkbook.SaveAs fileName:=varPath & "\" & "Attribute.xls", FileFormat:=1 RowNum = 1 Header = False ' 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 ' Filter through a list of attribute tagstrings in the current block. ' Cycle throught the list of attributes. For i = LBound(Array1) To UBound(Array1) ' Check for the correct attribute tag. Dim Attrib As AcadAttributeReference Set Attrib = Array1(i) ' If the Tagstring containd "Addresses" then ' Copy the Tagstrings into Excel If Attrib.TagString = "ADDRESS" Then ' 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" 'Code below adds column names 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 'Fill the columns with block data from modelspace End If XlSheet.Cells(RowNum, count + 2).value = Array1(count).TextString Next count Header = True End If Next i 'Next Filter Check End If End If End With Next elem Xl.Sheets("Sheet1").Cells.EntireColumn.AutoFit '************************************************* ********** ' Code to import a field database and update the attribute table '************************************************* ********** Dim ssnew As Object Dim Entity As AcadEntity Dim blkEntity As AcadBlockReference Dim n As Variant 'Defaults to Variant Dim Handle As String Dim blockName As String Dim tag As String Dim Loops As String Dim Address As String Dim Label1 As String Dim Label2 As String Dim Device_Label As String Dim Extended_Label As String Dim Qty As String Dim Model_Num As String Dim Description As String Dim Vendor As String Dim CSFM_Num As String Dim vAttrData vAttrData = XlSheet.UsedRange ' Make Selection set of Blocks ' ---------------------------- Set activeDoc = ThisDrawing.Application.ActiveDocument ThisDrawing.ActiveSpace = acModelSpace With activeDoc Set setColl = .SelectionSets For Each setObj In .SelectionSets If setObj.Name = "VBA" Then .SelectionSets.Item("VBA").Delete Exit For End If Next Set ssnew = activeDoc.SelectionSets.Add("VBA") End With ssnew.Select acSelectionSetAll ' Get Attribute values For Each Entity In ssnew If Entity.ObjectName = "AcDbBlockReference" Then Set blkEntity = Entity If blkEntity.HasAttributes Then Dim newAttribs As Variant newAttribs = blkEntity.GetAttributes For n = LBound(newAttribs) To UBound(newAttribs) Select Case newAttribs(n).TagString Case "HANDLE" Handle = newAttribs(n).TextString Case "BLOCKNAME" blockName = newAttribs(n).TextString Case "TAG" tag = newAttribs(n).TextString Case "LOOP" Loops = newAttribs(n).TextString Case "ADDRESS" Address = newAttribs(n).TextString Case "LABEL1" Label1 = newAttribs(n).TextString Case "LABEL2" Label2 = newAttribs(n).TextString Case "DEVICE_LABEL" Device_Label = newAttribs(n).TextString Case "EXTENDED_LABEL" Extended_Label = newAttribs(n).TextString Case "QTY" Qty = newAttribs(n).TextString Case "MODEL_NUM" Model_Num = newAttribs(n).TextString Case "DESCRIPTION" Description = newAttribs(n).TextString Case "VENDOR" Vendor = newAttribs(n).TextString Case "CSFM_NUM" CSFM_Num = newAttribs(n).TextString End Select Next n 'Entity(n).Update 'This line does not work End If End If Next Entity '************************************************* *********** Exit_XL_App: MsgBox Err.Number & " - " & Err.Description & " Error occurred in Excel App Process" Xl.DisplayAlerts = False 'XlBook.Save XlWorkbook.Close True '*** uncomment to keep open Xl.DisplayAlerts = True Xl.Quit Set XlSheet = Nothing Set XlWorkbook = Nothing Set Xl = Nothing Exit_Sub: End Sub [\code] |
|
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Modify Code to loop back through table after its been updated and process it
Just a FYI.., row/col indices are Long type NOT Integer!
Your loops are confusing to say the least. I'd have to rewrite this code so it's easier to read/understand. I'll post it back with comments... Which loop in particular is not working? -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion --- This email has been checked for viruses by Avast antivirus software. https://www.avast.com/antivirus |
|
#5
|
|||
|
|||
|
Quote:
Quote:
I have trouble following the logic in it and so I resort back to the original at times when doing test modifications since I am no programmer... I now need to filter the Array1 to only attribute blocks that have addresses and couldn't figure out how to add it. Also I need to add the ability to send the revised attribute table back in to acad blocks which is ultimately what I am trying to code... Quote:
"For n = LBound(newAttribs) To UBound(newAttribs)" It seems to run through the "n" values fine but Doesn't update the respective .textstring. I have been trying the "blkEntity.Update" but it doesn't update and at some point it gives an error and closes... |
|
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Modify Code to loop back through table after its been updated and process it
Yes, I recall the post. As I'm rewriting your code I find myself
following in the same context as that 4/15 post. So here more than a year later we are back to the same task? -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion --- This email has been checked for viruses by Avast antivirus software. https://www.avast.com/antivirus |
|
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Modify Code to loop back through table after its been updated and process it
I'm curious as to whether or not you can simply load the attributes
into an array and 'dump' the array into a blank worksheet like this... XlSheet.Cells(1).Resize(Ubound(Array1), Ubound(Array1, 2)) = Array1 ...which assumes Array1 becomes a 2D array after the attributes are loaded into it! -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion --- This email has been checked for viruses by Avast antivirus software. https://www.avast.com/antivirus |
|
#8
|
|||
|
|||
|
Quote:
However the following does array in 2D Dim vAttrData vAttrData = XlSheet.UsedRange So I been trying to figure out how to grab it and sent it back in to autocad.. Anyways I need to do a lot more reading up on this... Code:
For i = LBound(newAttribs) To UBound(newAttribs)
For Count = LBound(newAttribs) + 2 To UBound(newAttribs) + 2
If blkEntity.handle = vAttrData(Count, 1) Then
Select Case newAttribs(i).TagString
' Case "HANDLE"
' handle = newAttr.TextString
Case "TAG"
newAttribs(i).TextString = vAttrData(Count, 2).TextString
Case "LOOP"
tmpAttr(2) = vAttrData(Count, 3).TextString
Case "ADDRESS"
tmpAttr(3) = vAttrData(Count, 4).TextString
Case "LABEL1"
tmpAttr(4) = vAttrData(Count, 5).TextString
Case "LABEL2"
tmpAttr(5) = vAttrData(Count, 6).TextString
Case "DEVICE_LABEL"
tmpAttr(6) = vAttrData(Count, 7).TextString
Case "EXTENDED_LABEL"
tmpAttr(7) = vAttrData(Count, 8).TextString
Case "QTY"
tmpAttr(8) = vAttrData(Count, 9).TextString
Case "MODEL_NUM"
tmpAttr(9) = vAttrData(Count, 10).TextString
Case "DESCRIPTION"
tmpAttr(10) = vAttrData(Count, 11).TextString
Case "VENDOR"
tmpAttr(11) = vAttrData(Count, 12).TextString
Case "CSFM_NUM"
tmpAttr(12) = vAttrData(Count, 13).TextString
End Select
End If
Next Count
Next i
AttrData.Add tmpAttr 'Entity(i).Update
End If
End If
Next Entity
|
|
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Modify Code to loop back through table after its been updated and process it
If acad puts attributes into Array1 it might be worthwhile testing it's
dims... Debug.Print UBound(Array1) & ":" & UBound(Array1, 2) ...to see if it's 2D. Then loop thru and list each attribute. In any case, the acad online VBA help should tell you what you need to know about loading the attributes into a variant, and if it results a 2D array! -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion --- This email has been checked for viruses by Avast antivirus software. https://www.avast.com/antivirus |
|
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Modify Code to loop back through table after its been updated and process it
This is sort of where I went using the following enum structure and
modifying your Select Case construct as follows... Enum acAttribs Handle '0 BlockName '1 Tag '2 Loops '3 Address '4 Label1 '5 Label2 '6 DeviceLabel '7 ExtLabel '8 Qty '9 ModelNum '10 Descr '11 Vendor '12 CSFM_Num '13 End Enum Select Case vNewAttribs(n).TagString Case "HANDLE" saAttribs(acAttribs.Handle) = vNewAttribs(n).TextString Case "BLOCKNAME" saAttribs(acAttribs.BlockName) = vNewAttribs(n).TextString Case "TAG" saAttribs(acAttribs.Tag) = vNewAttribs(n).TextString Case "LOOP" saAttribs(acAttribs.Loops) = vNewAttribs(n).TextString Case "ADDRESS" saAttribs(acAttribs.Address) = vNewAttribs(n).TextString Case "LABEL1" saAttribs(acAttribs.Label1) = vNewAttribs(n).TextString Case "LABEL2" saAttribs(acAttribs.Label2) = vNewAttribs(n).TextString Case "DEVICE_LABEL" saAttribs(acAttribs.DeviceLabel) = vNewAttribs(n).TextString Case "EXTENDED_LABEL" saAttribs(acAttribs.ExtLabel) = vNewAttribs(n).TextString Case "QTY" saAttribs(acAttribs.Qty) = vNewAttribs(n).TextString Case "MODEL_NUM" saAttribs(acAttribs.ModelNum) = vNewAttribs(n).TextString Case "DESCRIPTION" saAttribs(acAttribs.Descr) = vNewAttribs(n).TextString Case "VENDOR" saAttribs(acAttribs.Vendor) = vNewAttribs(n).TextString Case "CSFM_NUM" saAttribs(acAttribs.CSFM_Num) = vNewAttribs(n).TextString End Select -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion --- This email has been checked for viruses by Avast antivirus software. https://www.avast.com/antivirus |
|
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Modify Code to loop back through table after its been updated and process it
I defined the array as follows...
Dim saAttribs$(14) '//replaces individual vars; uses acAttribs enum -- Garry Free usenet access at http://www.eternal-september.org Classic VB Users Regroup! comp.lang.basic.visual.misc microsoft.public.vb.general.discussion --- This email has been checked for viruses by Avast antivirus software. https://www.avast.com/antivirus |
|
#12
|
|||
|
|||
|
Quote:
I did finally pieced/wrote something to send the updated values back to ACAD using following code. I hope it is built correctly, this is a major accomplishment for me... Pointers are appreciated... Code:
Dim attributeObj As AcadAttribute
Dim BlockObj As AcadBlock
Dim Cnt As Long
Dim vAttrData
vAttrData = xlSheet.UsedRange 'Copy Data as an Array from spreadsheet
'Selection Set codeE
Cnt = 2
For Each elem In ThisDrawing.ModelSpace
With elem
If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
If elem.HasAttributes Then
handle = elem.handle
newAttribs = elem.GetAttributes
' For i = LBound(newAttribs) To UBound(newAttribs)
For i = 0 To UBound(newAttribs) ' For Count = LBound(newAttribs) To UBound(newAttribs) 'Read attributes from block
Dim Attr As AcadAttributeReference
Set Attr = newAttribs(i)
'Filter the Tagstring that contain "Addresses"
If Attr.TagString = "ADDRESS" Then
If handle = vAttrData(Cnt, 1) Then
newAttribs(0).TextString = vAttrData(Cnt, 2)
newAttribs(1).TextString = vAttrData(Cnt, 3)
newAttribs(2).TextString = vAttrData(Cnt, 4)
newAttribs(3).TextString = vAttrData(Cnt, 5)
newAttribs(4).TextString = vAttrData(Cnt, 6)
newAttribs(5).TextString = vAttrData(Cnt, 7)
newAttribs(6).TextString = vAttrData(Cnt, 8)
newAttribs(7).TextString = vAttrData(Cnt, 9)
newAttribs(8).TextString = vAttrData(Cnt, 10)
newAttribs(9).TextString = vAttrData(Cnt, 11)
newAttribs(10).TextString = vAttrData(Cnt, 12)
newAttribs(11).TextString = vAttrData(Cnt, 13)
newAttribs(0).Update
newAttribs(1).Update
newAttribs(2).Update
newAttribs(3).Update
newAttribs(4).Update
newAttribs(5).Update
newAttribs(6).Update
newAttribs(7).Update
newAttribs(8).Update
newAttribs(9).Update
newAttribs(10).Update
newAttribs(11).Update
End If
Cnt = Cnt + 1
Exit For
End If 'Address
Next i
End If
End If
End With 'elem
Next elem
Last edited by TimLeonard : June 9th 16 at 02:47 PM Reason: Typo |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| Process dumped into an array...and then back to sheet | Excel Programming | |||
| Modify RDB's Copy filtered data code to loop through multiple shee | Excel Programming | |||
| returning back to loop check condition without completing the loop | Excel Programming | |||
| Pivot Table Code in a For loop | Excel Programming | |||
| Modify a process priority | Excel Programming | |||
Linear Mode
