乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 95|回复: 5

AutoCAD到Excel

[复制链接]

58

主题

3353

帖子

33

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1761
发表于 2004-10-29 11:51:34 | 显示全部楼层 |阅读模式
你好,
我相信对于你们中的很多人来说,这是一个古老的话题,但对我来说仍然很新和有趣。我想知道是否可以在Excel中创建自定义电子表格,然后让我在AutoCAD中的属性干净地填充电子表格?
我过去曾尝试过这个,但运气不好。
如果有人能让我走上正确的轨道,我将不胜感激?
我对VBA有相当好的了解
任何帮助真的非常感谢
谢谢
马克

本帖以下内容被隐藏保护;需要你回复后,才能看到!

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

使用道具 举报

0

主题

27

帖子

2

银币

初来乍到

Rank: 1

铜币
27
发表于 2004-10-29 12:39:49 | 显示全部楼层
快速工具 - attout ?
罗恩
回复

使用道具 举报

0

主题

27

帖子

2

银币

初来乍到

Rank: 1

铜币
27
发表于 2004-10-29 13:37:12 | 显示全部楼层
不,那太草率了。这将需要VBA和可能的ODBC
回复

使用道具 举报

0

主题

27

帖子

2

银币

初来乍到

Rank: 1

铜币
27
发表于 2004-10-29 20:47:48 | 显示全部楼层
更好地描述你想做什么,我会帮助你。
回复

使用道具 举报

0

主题

27

帖子

2

银币

初来乍到

Rank: 1

铜币
27
发表于 2004-11-3 01:50:50 | 显示全部楼层
首先,我们需要列出图形中的所有块名
使用名为Listbox1的列表框创建表单。
初始化表单时,可以调用函数列出图形中的所有块名。
  1. Option Explicit
  2. Dim blkname As String
  3. Public objSS As AcadSelectionSet
  4. Dim MyBlist() As String
  5. Dim ObjBlockRef As AcadBlockReference
  6. Dim MaxAtt As Integer
  7. Sub UserForm_Initialize()
  8.     UserForm1.Caption = "Block attributes to Excel"
  9.     Call ListBlocks
  10. End Sub

以下函数将创建当前图形中所有块名的数组(VBA数组),并将它们按字母顺序排列
  1. Function ListBlocks()
  2.     Dim ObjBlk As AcadBlock
  3.     Dim MyBlkList() As String
  4.     Dim iCounter As Integer
  5.     Dim i As Variant
  6.       
  7. On Error Resume Next
  8.    
  9.     iCounter = 0
  10.     For Each ObjBlk In ThisDrawing.Blocks
  11.         If Not (ObjBlk.IsXRef) Then
  12.             If Left(ObjBlk.Name, 1)  "*" Then
  13.                 ReDim Preserve MyBlkList(iCounter)
  14.                 MyBlkList(iCounter) = ObjBlk.Name
  15.                 iCounter = iCounter + 1
  16.             End If
  17.         End If
  18.     Next
  19. '   sort list order into alphabetical order
  20.     SortArray MyBlkList
  21. '   place the sorted array list into a ListBox
  22.     For i = LBound(MyBlkList) To UBound(MyBlkList)
  23.         UserForm1.ListBox1.List() = MyBlkList
  24.     Next
  25. End Function
  26. 'begin array sort, this will sort the array into alphabetical order
  27. Public Sub SortArray(StringArray() As String)
  28.     Dim loopOuter As Integer
  29.     Dim loopInner As Integer
  30.     Dim i As Integer
  31.     For loopOuter = UBound(StringArray) To _
  32.       LBound(StringArray) Step -1
  33.         For loopInner = 0 To loopOuter - 1
  34.             If UCase(StringArray(loopInner)) > _
  35.               UCase(StringArray(loopInner + 1)) Then
  36.                 Swap StringArray(loopInner), _
  37.                   StringArray(loopInner + 1)
  38.             End If
  39.         Next loopInner
  40.     Next loopOuter
  41. End Sub
  42. Private Sub Swap(a As String, b As String)
  43.     Dim c As String: c = a: a = b: b = c
  44. End Sub
  45. 'End array sort

现在您有了一个包含所有块的列表框,您现在可以选择一个列表框将任何属性导出到excel
在名为CommandButton1的表单上创建一个命令按钮
  1. Sub CommandButton1_Click()
  2. 'send attribute data to excel
  3. Dim i As Integer
  4. Dim intType(0 To 1) As Integer
  5. Dim varData(0 To 1) As Variant
  6. On Error Resume Next
  7.     If Not IsNull(objSS) Then
  8.         ThisDrawing.SelectionSets.Item("Export_SelectionSet").Delete
  9.     Else
  10.     End If
  11.     For i = 0 To UserForm1.ListBox1.ListCount
  12.         If UserForm1.ListBox1.Selected(i) = True Then
  13.             intType(0) = 0
  14.             varData(0) = "INSERT"
  15.             intType(1) = 2
  16.             varData(1) = UserForm1.ListBox1.List(i)
  17.             Set objSS = ThisDrawing.SelectionSets.Add("Export_SelectionSet")
  18.             objSS.Select acSelectionSetAll, FilterType:=intType, FilterData:=varData
  19.         End If
  20.     Next i
  21.         Call GetAtts
  22.         Call Export2Excel
  23. '    UnloadDVB This VBA program
  24. '    ThisDrawing.SendCommand "_vbaunload" & vbCr & "DVBFILENAME.dvb" & vbCr
  25.     End 'ends program closes form
  26. End Sub

以下内容将获得图形中每个块(如列表中所选)的属性值
  1. Sub GetAtts()
  2. Dim varPick As Variant
  3. Dim objEnt As AcadEntity
  4. Dim varAttribs As Variant
  5. Dim strAttribs As String
  6. Dim BlkCount As Integer
  7. Dim lngI As Integer
  8. Dim iCounter As Integer
  9. On Error Resume Next
  10.     iCounter = 0
  11.     MaxAtt = 1
  12.     BlkCount = objSS.Count
  13.     For Each ObjBlockRef In objSS
  14.         If ObjBlockRef.HasAttributes Then
  15.             'get attributes
  16.             varAttribs = ObjBlockRef.GetAttributes
  17.             For lngI = LBound(varAttribs) To UBound(varAttribs)
  18.                 ReDim Preserve MyBlist(BlkCount, MaxAtt + 1)
  19.                 MyBlist(iCounter, 0) = ObjBlockRef.Name
  20.                 MyBlist(iCounter, lngI + 1) = varAttribs(lngI).TextString
  21.                 If UBound(varAttribs) > MaxAtt Then
  22.                     MaxAtt = UBound(varAttribs)
  23.                 End If
  24.             Next lngI
  25.                 iCounter = iCounter + 1
  26.         End If
  27.     Next
  28. End Sub

以下函数将每个块属性发送到excel,将其放入单元格中,为遇到的每个块创建新行
  1. Function Export2Excel()
  2. 'export data to Excel
  3.     Dim excel As Object 'Excel itself
  4.     Dim excelsheet As Object 'the Excel sheet
  5.     Dim exapp As Object 'the Excel file
  6.     Dim RowNum As Integer
  7.     Dim i As Variant
  8.     Dim ia As Integer
  9. On Error Resume Next 'prevent stopping if Excel is not open
  10.     Set excel = GetObject(, "Excel.application") 'activate Excel if open
  11.     If Err  0 Then
  12.         Set excel = CreateObject("Excel.application") 'Open Excel if not open
  13.     End If
  14.     excel.Visible = True
  15.     Set exapp = excel.Workbooks.Add '("C:\My Documents\Sample.xls") 'open the file
  16.     ia = 0
  17.     With excel
  18.         Set excelsheet = excel.ActiveWorkbook.Sheets("sheet1") 'activate the sheet
  19.         excelsheet.Cells(2, ia + 1).Value = "BlockName"
  20.         With exapp
  21.             RowNum = 3 'start in row 3 (data already exists in rows 1-8 in the formatted file)
  22.             For i = LBound(MyBlist, 1) To UBound(MyBlist, 1) 'for the number of lines add the length to a cell
  23.                 Do While ia < MaxAtt + 2
  24.                     If MyBlist(i, ia) = "" Then
  25.                         ia = ia + 1
  26.                     Else
  27.                         ' send this info to excel spreedsheet
  28.                         excelsheet.Cells(RowNum, ia + 1).Value = MyBlist(i, ia)
  29. '                        Debug.Print MyBlist(i, ia)
  30.                         ia = ia + 1
  31.                     End If
  32.                 Loop
  33.                 RowNum = RowNum + 1 'increment the row number for the next entry
  34.                 ia = 0
  35.             Next
  36.         End With
  37.     End With
  38.     Erase MyBlist
  39. End Function

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

使用道具 举报

0

主题

27

帖子

2

银币

初来乍到

Rank: 1

铜币
27
发表于 2004-11-4 19:11:47 | 显示全部楼层
酷特雷夫
它看起来很棒,当我有机会时,我需要尝试一
下 非常感谢
马克
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-3-16 15:07 , Processed in 0.433688 second(s), 64 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表