ExcelBanter - View Single Post

TimLeonard

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