[VBA]R2005 TABLE提取图面中所有带属性图块值并列表

mccad

2. Sub Att2Table()
3.        On Error Resume Next
4.        Dim Ent As AcadEntity
5.        Dim Pnt As Variant
6.        Do
7.                ThisDrawing.Utility.GetEntity Ent, Pnt, vbCrLf & "请选择要提取属性的块："
8.                If Err.Number <> 0 Then Exit Sub
9.                If Ent.ObjectName = "AcDbBlockReference" Then
10.                        If Ent.HasAttributes = True Then
11.                                Exit Do
12.                        End If
13.                End If
14.        Loop
15.        Dim BlkRef As AcadBlockReference
16.        Set BlkRef = Ent
17.        Dim BlkName As String
18.        BlkName = BlkRef.Name
19.       
20.       
21.        Dim SS As AcadSelectionSet
22.        Set SS = CreatSSet
23.        Dim FilterType As Variant
24.        Dim FilterData As Variant
25.        Dim FType(2) As Integer
26.        Dim FData(2) As Variant
27.        FType(0) = 0
28.        FData(0) = "INSERT" '图元名
29.        FType(1) = 66
30.        FData(1) = 1   '带属性
31.        FType(2) = 2
32.        FData(2) = BlkName   '图块名
33.        FilterType = FType
34.        FilterData = FData
35.        SS.Select acSelectionSetAll, , , FilterType, FilterData
36.        Dim i As Integer
37.        Dim j As Integer
38.        Dim Blk As AcadBlock
39.        Dim Att As AcadAttribute
40.        Dim AttRef As AcadAttributeReference
41.        Dim AttRefs As Variant
42.        Dim Rows As Double
43.        Dim Cols As Double
44.        Dim Table As AcadTable
45.        For i = 0 To SS.Count - 1
46.                Set BlkRef = SS(i)
47.                AttRefs = BlkRef.GetAttributes
48.                If i = 0 Then
49.                        Cols = UBound(AttRefs) + 1
50.                        Rows = SS.Count
51.                        Set Table = AddBlkTable(Cols, Rows)
52.                        Set Blk = ThisDrawing.Blocks(BlkRef.Name)
53.                        For Each Ent In Blk
54.                                If Ent.ObjectName = "AcDbAttributeDefinition" Then
55.                                        Set Att = Ent
56.                                        Table.SetText 0, j, Att.PromptString
57.                                        j = j + 1
58.                                End If
59.                        Next
60.                End If
61.                For j = 0 To UBound(AttRefs)
62.                        Set AttRef = AttRefs(j)
63.                        Table.SetText i + 1, j, AttRef.TextString
64.                Next
65.        Next
66. End Sub
67. Function AddBlkTable(TableColCount As Double, TableRowCount As Double)
68.        Dim Table As AcadTable
69.        Dim InsertionPoint As Variant
70.        InsertionPoint = ThisDrawing.Utility.GetPoint(, vbCrLf & "请选择表格插入点：")
71.        Dim RowHeight As Double, Colwidth As Double
72.        RowHeight = 8: Colwidth = 70 '行高及列宽
73.        Set Table = ThisDrawing.ModelSpace.AddTable _
74.                                (InsertionPoint, TableRowCount + 1, TableColCount, RowHeight, Colwidth)
75.        Table.HeaderSuppressed = True
76.        '取消原先表格格式中的首行合并
77.        Table.UnmergeCells 0, 0, 0, TableColCount - 1 '按顺序为合并的起始行号、结束行号、起始列号、结束列号
78.        Table.SetTextHeight 7, 7
79.        'Table.SetAlignment 3, 5
80.        Set AddBlkTable = Table
81.        'Debug.Print Table.Rows
82. End Function

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

龙龙仔

SS & TABLE都是NOTHING???問題出在那??

efan2000

问题可能出在这一句吧，Set SS = CreatSSet，没有对应的创建选择集的逊数。 999

mccad

呵呵，少给一个函数：

2. Function CreatSSet() As AcadSelectionSet
3.        On Error Resume Next
4.        ThisDrawing.SelectionSets("mccad").Delete
5.        Set CreatSSet = ThisDrawing.SelectionSets.Add("mccad")
6. End Function

Function CreatSSet() As AcadSelectionSet        On Error Resume Next        ThisDrawing.SelectionSets("mccad").Delete        Set CreatSSet = ThisDrawing.SelectionSets.Add("mccad") End Function

WOODTANK

我试了一下，2004中没有AcadTable对象，可以用别的替一下吗？另外这个程序可以找出嵌套图块下的属性吗？

crazylsp

Table.SetTextHeight 7, 7

研究下第一个行的类型为什么是7?

crazylsp

Table.SetText 0, j, Att.PromptString

貌似无法实现。行列要求长整型，j好像不是长整型，怎样转换？