Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > microsoft.public.excel.programming > #108891

Re: Modify Code to loop back through table after its been updated and process it

Show all headers | View raw

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

> 
> 
> 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!) -- 
> 
> Not sure where in the code or how to apply this suggestion
> 
> 


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
  
  
  '***********************************************************
  
  ' 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]




-- 
TimLeonard

Back to microsoft.public.excel.programming | Previous | Next — Previous in thread | Next in thread | Find similar | Unroll thread

Thread

Modify Code to loop back through table after its been updated and process it TimLeonard <TimLeonard.119a37a8@excelbanter.com> - 2016-06-05 20:21 +0100
  Re: Modify Code to loop back through table after its been updated and process it GS <gs@v.invalid> - 2016-06-05 20:06 -0400
    Re: Modify Code to loop back through table after its been updated and process it TimLeonard <TimLeonard.119b6d08@excelbanter.com> - 2016-06-06 18:27 +0100
      Re: Modify Code to loop back through table after its been updated and process it GS <gs@v.invalid> - 2016-06-06 14:42 -0400
        Re: Modify Code to loop back through table after its been updated and process it TimLeonard <TimLeonard.119bc168@excelbanter.com> - 2016-06-06 23:54 +0100
          Re: Modify Code to loop back through table after its been updated and process it GS <gs@v.invalid> - 2016-06-06 23:41 -0400
          Re: Modify Code to loop back through table after its been updated and process it GS <gs@v.invalid> - 2016-06-07 12:42 -0400
            Re: Modify Code to loop back through table after its been updated and process it TimLeonard <TimLeonard.119d5938@excelbanter.com> - 2016-06-08 05:34 +0100
              Re: Modify Code to loop back through table after its been updated and process it GS <gs@v.invalid> - 2016-06-08 03:46 -0400
              Re: Modify Code to loop back through table after its been updated and process it GS <gs@v.invalid> - 2016-06-08 13:45 -0400
                Re: Modify Code to loop back through table after its been updated and process it GS <gs@v.invalid> - 2016-06-08 13:55 -0400
                Re: Modify Code to loop back through table after its been updated and process it TimLeonard <TimLeonard.119e8e98@excelbanter.com> - 2016-06-09 03:45 +0100

csiph-web