Consulting

Results 1 to 2 of 2

Thread: Autocad blok description to Excel

  1. #1
    VBAX Newbie
    Joined
    Jul 2011
    Posts
    1
    Location

    Autocad blok description to Excel

    Hello

    First of all sorry for my English, its not my native language. I will try to describe my problem as much as I can.

    Im new to Autocad and Visual Basic. I've already successfully wrote some Excel script's, and now its time for Autocad.

    Can anyone help me to read block description fields ? Ive already successfully wrote an script counting every block in the drawing.

    Please help.

    Best regards.

  2. #2
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by advance
    Hello

    First of all sorry for my English, its not my native language. I will try to describe my problem as much as I can.

    Im new to Autocad and Visual Basic. I've already successfully wrote some Excel script's, and now its time for Autocad.

    Can anyone help me to read block description fields ? Ive already successfully wrote an script counting every block in the drawing.

    Please help.

    Best regards.
    Welcome on board
    Try this code, it will create Excel file in the drawing folder named "...\Attributes.xls"


    [vba]
    Option Explicit
    ''--> Make sure under Tools--> Options --> General tab you have to select "Break on Unhandled Errors"
    ''--> Add reference to Excel Object Library
    Public Sub WriteAttributes()
    Dim oSset As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim oBlkRef As AcadBlockReference
    Dim oAtt As AcadAttributeReference
    Dim varAtt As Variant
    Dim i As Long
    Dim ftype(1) As Integer
    Dim fdata(1) As Variant
    ftype(0) = 0: fdata(0) = "INSERT"
    ftype(1) = 66: fdata(1) = 1
    Dim dxftype As Variant
    Dim dxfdata As Variant
    dxftype = ftype
    dxfdata = fdata
    '---------------------
    Dim xlApp As Object
    Dim xlBook As Workbook
    Dim xlSheet As Worksheet
    Dim lngRow As Long, lngCol As Long
    '---------------------
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
    Err.Clear
    Set xlApp = CreateObject("Excel.Application")
    If Err <> 0 Then
    MsgBox "Impossible to initialize an Excel.", vbExclamation
    End
    End If
    End If
    '---------------------
    On Error Resume Next
    Set oSset = ThisDrawing.SelectionSets.Item("$Attribs$")
    If Err Then
    Err.Clear
    Set oSset = ThisDrawing.SelectionSets.Add("$Attribs$")
    End If
    On Error GoTo Err_Control
    oSset.SelectOnScreen dxftype, dxfdata
    '---------------------
    xlApp.Visible = True
    Set xlBook = xlApp.Workbooks.Add
    xlBook.Sheets.Add.Name = 1
    Set xlSheet = xlBook.Sheets(1)
    lngRow = 1
    xlSheet.Cells(lngRow, 1).Value = "Block Name"
    'For i = 2 To 11
    'xlSheet.Cells(lngRow, i).Value = "Attribue " & CStr(i - 1)
    'Next
    xlSheet.Rows(1).Font.Bold = True
    xlSheet.Rows(1).Font.ColorIndex = 5
    '---------------------
    lngRow = 2
    For Each oEnt In oSset
    Set oBlkRef = oEnt
    If oBlkRef.IsDynamicBlock Then
    xlSheet.Cells(lngRow, 1).Value = oBlkRef.EffectiveName
    Else
    xlSheet.Cells(lngRow, 1).Value = oBlkRef.Name
    End If
    varAtt = oBlkRef.GetAttributes
    lngCol = 2
    For i = 0 To UBound(varAtt)
    Set oAtt = varAtt(i)
    xlSheet.Cells(lngRow, lngCol).Value = oAtt.TagString
    xlSheet.Cells(lngRow + 1, lngCol).Value = oAtt.TextString
    lngCol = lngCol + 1
    Next i
    lngRow = lngRow + 2
    Next oEnt
    '--------------------
    Dim oRange As Range
    Set oRange = xlSheet.UsedRange
    For i = 2 To oRange.Columns.Count
    xlSheet.Cells(1, i).Value = "Attribue " & CStr(i - 1)
    Next
    '--------------------
    xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
    xlSheet.Columns.AutoFit
    xlBook.SaveAs ThisDrawing.Path & "\Attributes.xls"
    xlBook.Close
    '--------------------
    xlApp.Application.Quit
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    '--------------------
    MsgBox "Done"
    '--------------------
    Err_Control:
    End Sub
    [/vba]

Posting Permissions

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