attribute extraction to excel

[jbortoli]

All,
The following code is used to extract attribute information from an autocad drawing to create a bill of quantities worksheet. This macro is run through Autocad and opens excel and dumps the attribute info into the worksheet sample attached.
At present we need to sort the data which has a header row first by column b then by column a as well as autofit columns.

Sub Pmark()
  Dim Excel As Object
  Dim ExcelSheet As Object
  Dim RowNum As Integer
  Dim Array1 As Variant
  Dim Count As Integer
  Dim NumberOfAttributes As Integer
  Dim Ssnew As AcadSelectionSet
  Dim Sheet As Object
  Dim Max As Integer
  Dim Min As Integer
  Dim NoOfIndices As Integer

  ' Start Excel if not running
  On Error Resume Next
  Set Excel = GetObject(, "Excel.Application")
  If Err <> 0 Then
    Err.Clear
    Set Excel = CreateObject("Excel.Application")
    If Err <> 0 Then
      MsgBox "Could Not Load Excel!", vbExclamation
      End
    End If
  End If
  On Error GoTo 0
  Excel.Visible = True
  Excel.Workbooks.Add '............................
  Excel.workSheets("Sheet1").Select
  Excel.workSheets("Sheet1").Activate '.......................
  Set ExcelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
  ''Clear the cells
  ExcelSheet.Range("A1", "DZ100").Clear
  ExcelSheet.Range("A1:N1").Font.Bold = True
  
  'Get Selection Set of Specific Block with Attributes
  RowNum = 1
  Dim Header As Boolean
  Header = False
  ' The following sets up a selection set from the user for all objects
On Error Resume Next
' create set
Set Ssnew = ThisDrawing.SelectionSets.Add("BOM")
'if statement handles possible selection set error
If Err.Number <> 0 Then
Set Ssnew = ThisDrawing.SelectionSets.Item("BOM")
Ssnew.Clear
End If
  
  
  
  Dim GC(0 To 1) As Integer
  Dim GV(0 To 1) As Variant
  Dim atribs
  GC(0) = 0
  GV(0) = "INSERT"
  GC(1) = 2
  '---------------------------------------------------
  'Revise the block name "tendnum1" for your application
  GV(1) = "cable"
  '---------------------------------------------------
  Ssnew.Select acSelectionSetAll, , , GC, GV
  For Each entity In Ssnew
    Array1 = entity.GetAttributes
      For Count = LBound(Array1) To UBound(Array1)
        If Header = False Then
          If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
            ExcelSheet.cells(RowNum, Count + 1).Value = Array1(Count).TagString
          End If
        End If
      Next Count
      RowNum = RowNum + 1
      For Count = LBound(Array1) To UBound(Array1)
        ExcelSheet.cells(RowNum, Count + 1).Value = Array1(Count).TextString
      Next Count
    Header = True
  Next
  Set ExcelSheet = Nothing
Ssnew.Delete
End Sub

What i want to do is have the macro in autocad do all the autofit and sorting automatically and then append the filename of the drawing to a cell somewhere. Can anyone help me by giving me the additional code requirements to achieve this.
Thanking you all in anticipation
John

Moderator Note:

How to use [ CODE ] tags...

[MikeJarosz]

Another consideration is formatting Excel from Acad. The VBA code for formatting excel is pretty verbose. I wrote many applications that did it, but lately I'm just writing comma delimited text using the PRINT command, and uploading the CSV into freestanding Excel. I do the formatting there using the built in Excel interface rather than VBA.

[jbortoli]

Mike,
I already have the vba code to create the block with the above "pmark" code as a subroutine in it. I want to be able to format the resulting excel file from within the pmark routine which is run from the command line in Autocad. Are you able to either give me an example of code for formatting and sorting or point me to somewhere that i can find what i need.
Thanks John

[fixo]

Mike,
I already have the vba code to create the block with the above "pmark" code as a subroutine in it. I want to be able to format the resulting excel file from within the pmark routine which is run from the command line in Autocad. Are you able to either give me an example of code for formatting and sorting or point me to somewhere that i can find what i need.
Thanks John

Hi John,
Try this code, seems to be worked for me nice
(A2008eng/MS Office 2003rus)

Option Explicit

Sub Pmark()
Dim Excel As Object
Dim ExcelSheet As Object
Dim RowNum As Integer
Dim Array1 As Variant
Dim cnt As Integer
Dim NumberOfAttributes As Integer
Dim Ssnew As AcadSelectionSet
Dim Sheet As Object
Dim Max As Integer
Dim Min As Integer
Dim NoOfIndices As Integer
Dim blkRef As AcadBlockReference
Dim objAtt As AcadAttributeReference
Dim objEnt As AcadEntity
' Start Excel if not running
On Error Resume Next
Set Excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set Excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could Not Load Excel!", vbExclamation
End
End If
End If
On Error GoTo 0
Excel.Visible = True
Excel.Workbooks.Add '............................
Excel.workSheets(1).Select
'Excel.workSheets("Sheet1").Activate '.......................
'Set ExcelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
Set ExcelSheet = Excel.ActiveSheet
ExcelSheet.Name = "BOM" '<-- cnange sheet name by suit
''Clear the cells
ExcelSheet.Range("A1", "DZ100").Clear 
ExcelSheet.Range("A1:N1").Font.Bold = True

'Get Selection Set of Specific Block with Attributes
RowNum = 1
Dim Header As Boolean
Header = False
' The following sets up a selection set from the user for all objects
On Error Resume Next
' create set
Set Ssnew = ThisDrawing.SelectionSets.Add("BOM")
'if statement handles possible selection set error
If Err.Number <> 0 Then
   Set Ssnew = ThisDrawing.SelectionSets.Item("BOM")
   Ssnew.Clear
End If

Dim GC(0 To 1) As Integer
Dim GV(0 To 1) As Variant
Dim atribs
GC(0) = 0
GV(0) = "INSERT"
GC(1) = 2
'---------------------------------------------------
'Revise the block name "tendnum1" for your application
GV(1) = "cable"
'---------------------------------------------------
Ssnew.Select acSelectionSetAll, , , GC, GV
For Each objEnt In Ssnew
   Set blkRef = objEnt
   Array1 = blkRef.GetAttributes
For cnt = LBound(Array1) To UBound(Array1)
   Set objAtt = Array1(cnt)
   If Header = False Then
'If StrComp(Array1(cnt).EntityName, "AcDbAttribute", 1) = 0 Then '<--extrafluous, you already know this is attribute only
   ExcelSheet.Cells(RowNum, cnt + 1).Value = objAtt.TagString
'End If
End If
Next cnt
RowNum = RowNum + 1
For cnt = LBound(Array1) To UBound(Array1)
   Set objAtt = Array1(cnt)
   ExcelSheet.Cells(RowNum, cnt + 1).Value = objAtt.TextString
Next cnt
Header = True
Next
'some formatting goes here:
With ExcelSheet.UsedRange
    .Columns.AutoFit
    Dim headRng As Excel.Range
Set headRng = .Range(Cells(1, 1), Cells(1, UBound(Array1) + 1))
   With headRng
       .Borders.LineStyle = xlContinuous
       .Interior.ColorIndex = 35
       .Font.ColorIndex = 5
   End With
Dim dataRng As Excel.Range
    Set dataRng = .Range(Cells(2, 1), Cells(.Rows.Count, UBound(Array1) + 1))
         dataRng.Select
    With Excel.Selection
        .Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
        .Borders.LineStyle = xlContinuous
        .Font.ColorIndex = 9
        .Interior.ColorIndex = 34
    End With
End With
Set dataRng = Nothing
Set headRng = Nothing
Set ExcelSheet = Nothing
Ssnew.Delete
End Sub

~'J'~

[jbortoli]

thanks for your help but It didnt work for me i got a compile error "user-defined type not defined" at line indicated below

'some formatting goes here:
With ExcelSheet.UsedRange
.Columns.AutoFit
Dim headRng As Excel.Range '<..............................this line (headRng As Excel.Range) was highlighted

[fixo]

thanks for your help but It didnt work for me i got a compile error "user-defined type not defined" at line indicated below

'some formatting goes here:
With ExcelSheet.UsedRange
.Columns.AutoFit
Dim headRng As Excel.Range '<..............................this line (headRng As Excel.Range) was highlighted

Hi John,
Add Reference to Microsoft Excel XX.0 Object Library, if this would not work,
then you can to try declare all the ranges As Object for the late biding
Hth

~'J'~