AutoCAD到Excel

ronjonp · 发表于 2004-10-29 11:51:34

你好，
我相信对于你们中的很多人来说，这是一个古老的话题，但对我来说仍然很新和有趣。我想知道是否可以在Excel中创建自定义电子表格，然后让我在AutoCAD中的属性干净地填充电子表格？
我过去曾尝试过这个，但运气不好。
如果有人能让我走上正确的轨道，我将不胜感激？
我对VBA有相当好的了解
任何帮助真的非常感谢
谢谢
马克

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

Trev · 发表于 2004-10-29 12:39:49

快速工具 - attout ？
罗恩

Trev · 发表于 2004-10-29 13:37:12

不，那太草率了。这将需要VBA和可能的ODBC

Trev · 发表于 2004-10-29 20:47:48

更好地描述你想做什么，我会帮助你。

Trev · 发表于 2004-11-3 01:50:50

首先，我们需要列出图形中的所有块名
使用名为Listbox1的列表框创建表单。
初始化表单时，可以调用函数列出图形中的所有块名。

copy


Option Explicit
Dim blkname As String
Public objSS As AcadSelectionSet
Dim MyBlist() As String
Dim ObjBlockRef As AcadBlockReference
Dim MaxAtt As Integer
Sub UserForm_Initialize()
    UserForm1.Caption = "Block attributes to Excel"
    Call ListBlocks
End Sub

以下函数将创建当前图形中所有块名的数组（VBA数组），并将它们按字母顺序排列

copy


Function ListBlocks()
    Dim ObjBlk As AcadBlock
    Dim MyBlkList() As String
    Dim iCounter As Integer
    Dim i As Variant
       
On Error Resume Next
    
    iCounter = 0
    For Each ObjBlk In ThisDrawing.Blocks
        If Not (ObjBlk.IsXRef) Then
            If Left(ObjBlk.Name, 1)  "*" Then
                ReDim Preserve MyBlkList(iCounter)
                MyBlkList(iCounter) = ObjBlk.Name
                iCounter = iCounter + 1
            End If
        End If
    Next
'   sort list order into alphabetical order
    SortArray MyBlkList
'   place the sorted array list into a ListBox
    For i = LBound(MyBlkList) To UBound(MyBlkList)
        UserForm1.ListBox1.List() = MyBlkList
    Next
End Function
'begin array sort, this will sort the array into alphabetical order
Public Sub SortArray(StringArray() As String)
    Dim loopOuter As Integer
    Dim loopInner As Integer
    Dim i As Integer
    For loopOuter = UBound(StringArray) To _
      LBound(StringArray) Step -1
        For loopInner = 0 To loopOuter - 1
            If UCase(StringArray(loopInner)) > _
              UCase(StringArray(loopInner + 1)) Then
                Swap StringArray(loopInner), _
                  StringArray(loopInner + 1)
            End If
        Next loopInner
    Next loopOuter
End Sub
Private Sub Swap(a As String, b As String)
    Dim c As String: c = a: a = b: b = c
End Sub
'End array sort

现在您有了一个包含所有块的列表框，您现在可以选择一个列表框将任何属性导出到excel
在名为CommandButton1的表单上创建一个命令按钮

copy


Sub CommandButton1_Click()
'send attribute data to excel
Dim i As Integer
Dim intType(0 To 1) As Integer
Dim varData(0 To 1) As Variant
On Error Resume Next
    If Not IsNull(objSS) Then
        ThisDrawing.SelectionSets.Item("Export_SelectionSet").Delete
    Else
    End If
    For i = 0 To UserForm1.ListBox1.ListCount
        If UserForm1.ListBox1.Selected(i) = True Then
            intType(0) = 0
            varData(0) = "INSERT"
            intType(1) = 2
            varData(1) = UserForm1.ListBox1.List(i)
            Set objSS = ThisDrawing.SelectionSets.Add("Export_SelectionSet")
            objSS.Select acSelectionSetAll, FilterType:=intType, FilterData:=varData
        End If
    Next i
        Call GetAtts
        Call Export2Excel
'    UnloadDVB This VBA program
'    ThisDrawing.SendCommand "_vbaunload" & vbCr & "DVBFILENAME.dvb" & vbCr
    End 'ends program closes form
End Sub

以下内容将获得图形中每个块（如列表中所选）的属性值

copy


Sub GetAtts()
Dim varPick As Variant
Dim objEnt As AcadEntity
Dim varAttribs As Variant
Dim strAttribs As String
Dim BlkCount As Integer
Dim lngI As Integer
Dim iCounter As Integer
On Error Resume Next
    iCounter = 0
    MaxAtt = 1
    BlkCount = objSS.Count
    For Each ObjBlockRef In objSS
        If ObjBlockRef.HasAttributes Then
            'get attributes
            varAttribs = ObjBlockRef.GetAttributes
            For lngI = LBound(varAttribs) To UBound(varAttribs)
                ReDim Preserve MyBlist(BlkCount, MaxAtt + 1)
                MyBlist(iCounter, 0) = ObjBlockRef.Name
                MyBlist(iCounter, lngI + 1) = varAttribs(lngI).TextString
                If UBound(varAttribs) > MaxAtt Then
                    MaxAtt = UBound(varAttribs)
                End If
            Next lngI
                iCounter = iCounter + 1
        End If
    Next
End Sub

以下函数将每个块属性发送到excel，将其放入单元格中，为遇到的每个块创建新行

copy


Function Export2Excel()
'export data to Excel
    Dim excel As Object 'Excel itself
    Dim excelsheet As Object 'the Excel sheet
    Dim exapp As Object 'the Excel file
    Dim RowNum As Integer
    Dim i As Variant
    Dim ia As Integer
On Error Resume Next 'prevent stopping if Excel is not open
    Set excel = GetObject(, "Excel.application") 'activate Excel if open
    If Err  0 Then
        Set excel = CreateObject("Excel.application") 'Open Excel if not open
    End If
    excel.Visible = True
    Set exapp = excel.Workbooks.Add '("C:\My Documents\Sample.xls") 'open the file
    ia = 0
    With excel
        Set excelsheet = excel.ActiveWorkbook.Sheets("sheet1") 'activate the sheet
        excelsheet.Cells(2, ia + 1).Value = "BlockName"
        With exapp
            RowNum = 3 'start in row 3 (data already exists in rows 1-8 in the formatted file)
            For i = LBound(MyBlist, 1) To UBound(MyBlist, 1) 'for the number of lines add the length to a cell
                Do While ia < MaxAtt + 2
                    If MyBlist(i, ia) = "" Then
                        ia = ia + 1
                    Else
                        ' send this info to excel spreedsheet
                        excelsheet.Cells(RowNum, ia + 1).Value = MyBlist(i, ia)
'                        Debug.Print MyBlist(i, ia)
                        ia = ia + 1
                    End If
                Loop
                RowNum = RowNum + 1 'increment the row number for the next entry
                ia = 0
            Next
        End With
    End With
    Erase MyBlist
End Function

好了，现在应该可以了
这有点粗糙，因为如果您选择的块不包含任何属性，我不允许进行测试或绕过。它将简单地执行程序，就好像它执行了一样。因此，它将打开excel创建一个空白工作表
您可以添加或修改的是一个测试，因此它不会这样做，并且可能会给您一个消息框，说明块不包含属性，因此无需执行任何操作
上述编程仅允许单个块名。因此，它对编号的项目等非常有用。
完成后，您可以在excel中创建更多的编译来构建一个漂亮的表，或者您甚至可以将其添加到acad vba程序中，以这种方式将其全部包含在一个程序中。这有点棘手，因为您必须从acad中使用control excel，但可以轻松完成
大多数编程都是从我的全局属性编辑器中提取的，如之前在沼泽中发布的。

Trev · 发表于 2004-11-4 19:11:47

酷特雷夫
它看起来很棒，当我有机会时，我需要尝试一
下非常感谢
马克

AutoCAD到Excel

发表回复

精选推荐

浏览过的版块