给cad设置并查询扩展属性xdata——vba实现

cad图形设置扩展属性可采用vba插件实现，如下：

使用方法:cad命令行输入“vbaman”加载此插件，“vbarun”运行此插件，根据提示选对应的图形即可设置扩展属性。

扩展属性可根据自己需求输入。

部分代码如下：

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 4) As Integer, xd(0 To 4) As Variant
     xt(0) = 1001: xd(0) = "south"
     xt(1) = 1000: xd(1) = "社区名称"
     xt(2) = 1000: xd(2) = "上河社区"
     xt(3) = 1000: xd(3) = "宗地号"
     xt(4) = 1000: xd(4) = "310103"
 
    For Each ent In sel
         ent.SetXData xt, xd
        
         ent.GetXData "", xtypeout, xdataout
        On Error GoTo line1
        For i = LBound(xtypeout) To UBound(xtypeout)
            str = str & xtypeout(i) & "内容是:" & xdataout(i) & vbCrLf
        Next
    Next
    ThisDrawing.Utility.Prompt str
line1:
    If Err <> 0 Then
        MsgBox "没有扩展属性", vbOKOnly, "查看扩展属性"
    Else
        MsgBox str, vbOKOnly, "查看扩展属性"
    End If
    sel.Delete
End Sub

如果实体没属性，用isempty函数可找到该图形

        Set SelectA = ThisDrawing.SelectionSets.Add("mysel")

             fType(0) = 0: fData(0) = "*Polyline"
        SelectA.Select acSelectionSetAll, , , fType, fData
'        SelectA.Highlight (True)
        For Each Entry In SelectA
            Entry.GetXData "", XDType, xData
'            MsgBox Entry.ObjectName
'          ThisDrawing.Regen acActiveViewport
If not IsEmpty(xData) Then
   *******************
    Else
endif