010集——查询(添加)CAD文件扩展属性（vba代码实现）

 cass文件中图元经常有扩展属性，查询扩展属性代码及方法如下：

打开dwg文件 —> alt+F11打开ide窗口，粘贴如下代码，并运行：

Sub 查看扩展属性()
    '提取块的扩展属性
    '只针对带有属性的图元
    'On Error Resume Next
    Dim sst As AcadSelectionSet
    Set sst = ThisDrawing.SelectionSets.Add("sst113")
    MsgBox "请回cad界面选择图元："
    sst.SelectOnScreen
    Dim xdataout As Variant, xtypeout As Variant
    Dim ent As AcadEntity
    Dim str
    For Each ent In sst
        ent.GetXData "", xtypeout, xdataout
        On Error GoTo line1
        For i = LBound(xtypeout) To UBound(xtypeout)
            str = str & xtypeout(i) & "--" & xdataout(i) & Chr(10)
        Next
    Next
    ThisDrawing.Utility.Prompt str
line1:
    If Err <> 0 Then
        MsgBox "没有扩展属性", vbOKOnly, "查看扩展属性"
    Else
        MsgBox str, vbOKOnly, "查看扩展属性"
    End If
    sst.Delete
End Sub

以下为手工为图元录入xdata扩展属性并查询的代码（扩展属性应用程序名（1001）一次只能设置一个，若想设置多个，需多次setxdata）：

'Public Function creatsel(ByVal selname As String) As AcadSelectionSet
'On Error Resume Next
'Dim sel As AcadSelectionSet
'  For i = 0 To ThisDrawing.SelectionSets.Count - 1
'     Set sel = ThisDrawing.SelectionSets.Item(i)
'     If StrComp(sel.Name, selname, 1) = 0 Then
'        sel.Delete
'        Exit For
'     End If
'  Next i
'Set creatsel = ThisDrawing.SelectionSets.Add(selname)
'End Function
'Sub a()
' Dim xt(0 To 3) As Integer, xd(0 To 3) As Variant
'  Dim xt1(0 To 3) As Integer, xd1(0 To 3) As Variant
' Dim xtypeout(0 To 3) As Integer, xdataout(0 To 3) As Variant
'    xt(0) = 1001: xd(0) = "djh"
'    xt(1) = 1000: xd(1) = 410103 '文本格式的数字，不用加引号“”
'    xt1(0) = 1001: xd1(0) = "qlr"
'    xt(1) = 1000: xd1(1) = "三国社区"
'Dim sel As AcadSelectionSet, str As String
'Dim ent As AcadEntity
'Set sel = creatsel("myse")
''sel.Select acSelectionSetAll '全选
'sel.SelectOnScreen   '窗选
''MsgBox sel.Count
'For Each ent In sel
'    ent.SetXData xt, xd
'    ent.SetXData xt1, xd1
'
'Next
' ent.GetXData "", xtypeout, xdataout
'On Error GoTo 2000
'For i = LBound(xdataout) To UBound(xdataout)
'   str = str & xtypeout(i) & "--" & xdataout(i) & Chr(10)
'Next
'2000:
'If Err <> 0 Then
'        MsgBox "没有扩展属性", vbOKOnly, "查看扩展属性"
'    Else
'        MsgBox str, vbOKOnly, "查看扩展属性"
'    End If
'    mysel.Delete
'End Sub
'
'

Public Function creatsel(ByVal selname As String) As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
  For i = 0 To ThisDrawing.SelectionSets.Count - 1
     Set sel = ThisDrawing.SelectionSets.Item(i)
     If StrComp(sel.Name, selname, 1) = 0 Then
        sel.Delete
        Exit For
     End If
  Next i
Set creatsel = ThisDrawing.SelectionSets.Add(selname)
End Function
Sub 设置查询多个扩展属性()
    Dim sel As AcadSelectionSet
    Set sel = creatsel("mysel")
    sel.SelectOnScreen
    Dim xdataout As Variant, xtypeout As Variant
    Dim ent As AcadEntity
    Dim str As String, i As Integer
    Dim xt(0 To 1) As Integer, xd(0 To 1) As Variant
     xt(0) = 1001: xd(0) = "djh"
     xt(1) = 1000: xd(1) = "310103"

    Dim xta(0 To 1) As Integer, xda(0 To 1) As Variant
       xta(0) = 1001: xda(0) = "qlr"
       xta(1) = 1000: xda(1) = "下和社区"
 
    For Each ent In sel
         ent.SetXData xt, xd
         ent.SetXData xta, xda
         ent.GetXData "", xtypeout, xdataout
        On Error GoTo line1
        For i = LBound(xtypeout) To UBound(xtypeout)
            str = str & xtypeout(i) & "--" & xdataout(i) & Chr(34)
        Next
    Next
    ThisDrawing.Utility.Prompt str
line1:
    If Err <> 0 Then
        MsgBox "没有扩展属性", vbOKOnly, "查看扩展属性"
    Else
        MsgBox str, vbOKOnly, "查看扩展属性"
    End If
    sel.Delete
End Sub