[VBA]R2005 TABLE提取图面中所有带属性图块值并列表
Sub Att2Table()On Error Resume Next
Dim Ent As AcadEntity
Dim Pnt As Variant
Do
ThisDrawing.Utility.GetEntity Ent, Pnt, vbCrLf & "请选择要提取属性的块："
If Err.Number <> 0 Then Exit Sub
If Ent.ObjectName = "AcDbBlockReference" Then
If Ent.HasAttributes = True Then
Exit Do
End If
End If
Loop
Dim BlkRef As AcadBlockReference
Set BlkRef = Ent
Dim BlkName As String
BlkName = BlkRef.Name
Dim SS As AcadSelectionSet
Set SS = CreatSSet
Dim FilterType As Variant
Dim FilterData As Variant
Dim FType(2) As Integer
Dim FData(2) As Variant
FType(0) = 0
FData(0) = "INSERT" '图元名
FType(1) = 66
FData(1) = 1 '带属性
FType(2) = 2
FData(2) = BlkName '图块名
FilterType = FType
FilterData = FData
SS.Select acSelectionSetAll, , , FilterType, FilterData
Dim i As Integer
Dim j As Integer
Dim Blk As AcadBlock
Dim Att As AcadAttribute
Dim AttRef As AcadAttributeReference
Dim AttRefs As Variant
Dim Rows As Double
Dim Cols As Double
Dim Table As AcadTable
For i = 0 To SS.Count - 1
Set BlkRef = SS(i)
AttRefs = BlkRef.GetAttributes
If i = 0 Then
Cols = UBound(AttRefs) + 1
Rows = SS.Count
Set Table = AddBlkTable(Cols, Rows)
Set Blk = ThisDrawing.Blocks(BlkRef.Name)
For Each Ent In Blk
If Ent.ObjectName = "AcDbAttributeDefinition" Then
Set Att = Ent
Table.SetText 0, j, Att.PromptString
j = j + 1
End If
Next
End If
For j = 0 To UBound(AttRefs)
Set AttRef = AttRefs(j)
Table.SetText i + 1, j, AttRef.TextString
Next
Next
End Sub
Function AddBlkTable(TableColCount As Double, TableRowCount As Double)
Dim Table As AcadTable
Dim InsertionPoint As Variant
InsertionPoint = ThisDrawing.Utility.GetPoint(, vbCrLf & "请选择表格插入点：")
Dim RowHeight As Double, Colwidth As Double
RowHeight = 8: Colwidth = 70 '行高及列宽
Set Table = ThisDrawing.ModelSpace.AddTable _
(InsertionPoint, TableRowCount + 1, TableColCount, RowHeight, Colwidth)
Table.HeaderSuppressed = True
'取消原先表格格式中的首行合并
Table.UnmergeCells 0, 0, 0, TableColCount - 1 '按顺序为合并的起始行号、结束行号、起始列号、结束列号
Table.SetTextHeight 7, 7
'Table.SetAlignment 3, 5
Set AddBlkTable = Table
'Debug.Print Table.Rows
End Function
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><FONT size=3><FONT face="Times New Roman">SS & TABLE</FONT>都是<FONT face="Times New Roman">NOTHING???</FONT>問題出在那<FONT face="Times New Roman">??</FONT></FONT>
问题可能出在这一句吧，Set SS = CreatSSet，没有对应的创建选择集的逊数。
999<BR> 呵呵，少给一个函数：Function CreatSSet() As AcadSelectionSet
On Error Resume Next
ThisDrawing.SelectionSets("mccad").Delete
Set CreatSSet = ThisDrawing.SelectionSets.Add("mccad")
End Function 我试了一下，2004中没有AcadTable对象，可以用别的替一下吗？另外这个程序可以找出嵌套图块下的属性吗？ Table.SetTextHeight 7, 7
研究下第一个行的类型为什么是7? Table.SetText 0, j, Att.PromptString
貌似无法实现。行列要求长整型，j好像不是长整型，怎样转换？
页:
[1]