首先,我们需要列出图形中的所有块名
使用名为Listbox1的列表框创建表单。
初始化表单时,可以调用函数列出图形中的所有块名。
-
- 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数组),并将它们按字母顺序排列
-
- 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的表单上创建一个命令按钮
-
- 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
以下内容将获得图形中每个块(如列表中所选)的属性值
-
- 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,将其放入单元格中,为遇到的每个块创建新行
-
- 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,但可以轻松完成
大多数编程都是从我的全局属性编辑器中提取的,如之前在沼泽中发布的。 |