Results 1 to 6 of 6

Thread: attribute extraction to excel

  1. #1
    Member
    Join Date
    2007-04
    Posts
    31
    Login to Give a bone
    0

    Default attribute extraction to excel

    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.

    Code:
    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

    Attached Files Attached Files
    Last edited by Opie; 2008-02-14 at 10:28 PM. Reason: [CODE] tags added, see Moderator Note

  2. #2
    AUGI Addict MikeJarosz's Avatar
    Join Date
    2015-10
    Location
    New York NY
    Posts
    1,497
    Login to Give a bone
    0

    Default Re: attribute extraction to excel

    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.

  3. #3
    Member
    Join Date
    2007-04
    Posts
    31
    Login to Give a bone
    0

    Default Re: attribute extraction to excel

    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

  4. #4
    AUGI Addict fixo's Avatar
    Join Date
    2005-05
    Location
    Pietari, Venäjä
    Posts
    1,269
    Login to Give a bone
    0

    Default Re: attribute extraction to excel

    Quote Originally Posted by jbortoli View Post
    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)

    Code:
    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'~

  5. #5
    Member
    Join Date
    2007-04
    Posts
    31
    Login to Give a bone
    0

    Default Re: attribute extraction to excel

    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

  6. #6
    AUGI Addict fixo's Avatar
    Join Date
    2005-05
    Location
    Pietari, Venäjä
    Posts
    1,269
    Login to Give a bone
    0

    Default Re: attribute extraction to excel

    Quote Originally Posted by jbortoli View Post
    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'~

Similar Threads

  1. VBA and ObjectDbx - AutoCAD to Excel Attribute Extraction Tool
    By katrinanjim in forum VBA/COM Interop
    Replies: 53
    Last Post: 2017-06-11, 09:56 PM
  2. Help needed with Attribute extraction and import into MS Excel
    By Lee Buckmaster in forum Productstream - General
    Replies: 0
    Last Post: 2012-04-30, 08:23 PM
  3. Attribute extraction
    By lee.johnson in forum AutoLISP
    Replies: 3
    Last Post: 2010-10-21, 05:26 PM
  4. Attribute extraction to Word or Excel
    By KristiS in forum CAD Management - General
    Replies: 6
    Last Post: 2009-01-06, 09:16 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •