Microsoft Excel Webinar

Results 1 to 2 of 2

Thread: Autocad blok description to Excel

  1. #1

    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"


    VB:
     
    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 
    
    
    Formatting tags added by mark007

Posting Permissions

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