看这里死气沉沉，继续放码，查看对象扩展属性
这里个查看对象扩展属性的过程，网上有类似的，但是，哪个代码有问题，好像还是一本正规出版物里的代码！Public Sub ViewXData() ' 查找上例中创建的选择集
' On Error Resume Next
Dim sset As AcadSelectionSet
For Each sset In ThisDrawing.SelectionSets
If sset.Name = "SS1" Then
ThisDrawing.SelectionSets.Item("SS1").Delete
Exit For
End If
Next
Set sset = ThisDrawing.SelectionSets.Add("SS1")
sset.SelectOnScreen
' 定义扩展数据变量以保存扩展数据信息
Dim xdataType As Variant
Dim xdata As Variant
Dim xd As Variant
'定义索引计数器
Dim xdi As Integer
xdi = 0
' 遍历选择集中的对象
' 并检索对象的扩展数据
Dim msgstr As String
Dim strAppName As String
Dim ent As AcadEntity
strAppName = ""
For Each ent In sset
msgstr = ""
xdi = 0
' 检索 appName 扩展数据类型和值
ent.GetXData strAppName, xdataType, xdata
' 如果未初始化 xdataType 变量，
' 则没有可供该图元检索的 appName 扩展数据
If VarType(xdataType) <> vbEmpty Then
For Each xd In xdata
If VarType(xd) And vbArray Then
msgstr = msgstr & vbCrLf & xdataType(xdi) & ": " & CStr(xd(0)) & "," & CStr(xd(1)) & "," & CStr(xd(2))
Else
msgstr = msgstr & vbCrLf & xdataType(xdi) & ": " & CStr(xd) 'xd如果是数组或其他对象类型就会出错
End If
xdi = xdi + 1
Next xd
End If
' 如果 msgstr 变量为 NULL，则没有扩展数据
If msgstr = "" Then msgstr = vbCrLf & "NONE"
'MsgBox strAPPNAME & " xdata on " & ent.ObjectName & _
": " & vbCrLf & msgstr
ThisDrawing.Utility.Prompt strAppName & " XData on " & ent.ObjectName & ":" & _
vbCrLf & msgstr & vbCrLf
'ThisDrawing.SendCommand Chr$(vbKeyCancel)
Next ent
End Sub
谢谢您的好代码 谢谢了！收藏了！ 谢谢了！谢谢了！谢谢了！谢谢了！
页:
[1]