看这里死气沉沉，继续放码，查看对象扩展属性

zzyong00

这里个查看对象扩展属性的过程，网上有类似的，但是，哪个代码有问题，好像还是一本正规出版物里的代码！

1. Public Sub ViewXData()                                         ' 查找上例中创建的选择集
   
2. '   On Error Resume Next
   
3.     Dim sset As AcadSelectionSet
   
4.     For Each sset In ThisDrawing.SelectionSets
   
5.         If sset.Name = "SS1" Then
   
6.             ThisDrawing.SelectionSets.Item("SS1").Delete
   
7.             Exit For
   
8.         End If
   
9.     Next
   
10.     Set sset = ThisDrawing.SelectionSets.Add("SS1")
    
11.     sset.SelectOnScreen
    
12.     ' 定义扩展数据变量以保存扩展数据信息
    
13.     Dim xdataType As Variant
    
14.     Dim xdata     As Variant
    
15.     Dim xd        As Variant
    
16.     '定义索引计数器
    
17.     Dim xdi       As Integer
    
18.     xdi = 0
    
19.     ' 遍历选择集中的对象
    
20.     ' 并检索对象的扩展数据
    
21.     Dim msgstr     As String
    
22.     Dim strAppName As String
    
23.     Dim ent        As AcadEntity
    
24.     strAppName = ""
    
25.     For Each ent In sset
    
26.         msgstr = ""
    
27.         xdi = 0
    
28.         ' 检索 appName 扩展数据类型和值
    
29.         ent.GetXData strAppName, xdataType, xdata
    
30.         ' 如果未初始化 xdataType 变量，
    
31.         ' 则没有可供该图元检索的 appName 扩展数据
    
32.         If VarType(xdataType) <> vbEmpty Then
    
33.             For Each xd In xdata
    
34.                
    
35.                 If VarType(xd) And vbArray Then
    
36.                     msgstr = msgstr & vbCrLf & xdataType(xdi) & ": " & CStr(xd(0)) & "," & CStr(xd(1)) & "," & CStr(xd(2))
    
37.                 Else
    
38.                     msgstr = msgstr & vbCrLf & xdataType(xdi) & ": " & CStr(xd) 'xd如果是数组或其他对象类型就会出错
    
39.                 End If
    
40.                 xdi = xdi + 1
    
41.             Next xd
    
42.         End If
    
43.         ' 如果 msgstr 变量为 NULL，则没有扩展数据
    
44.         If msgstr = "" Then msgstr = vbCrLf & "NONE"
    
45.         'MsgBox strAPPNAME & " xdata on " & ent.ObjectName & _
    
46. ":      " & vbCrLf & msgstr
    
47.         ThisDrawing.Utility.Prompt strAppName & " XData on " & ent.ObjectName & ":" & _
    
48.         vbCrLf & msgstr & vbCrLf
    
49.         'ThisDrawing.SendCommand Chr$(vbKeyCancel)
    
50.     Next ent
    
51. End Sub

Public Sub ViewXData()                                         ' 查找上例中创建的选择集<br /> '   On Error Resume Next<br />     Dim sset As AcadSelectionSet<br />     For Each sset In ThisDrawing.SelectionSets<br />         If sset.Name = "SS1" Then<br />             ThisDrawing.SelectionSets.Item("SS1").Delete<br />             Exit For<br />         End If<br />     Next<br />     Set sset = ThisDrawing.SelectionSets.Add("SS1")<br />     sset.SelectOnScreen<br />     ' 定义扩展数据变量以保存扩展数据信息<br />     Dim xdataType As Variant<br />     Dim xdata     As Variant<br />     Dim xd        As Variant<br />     '定义索引计数器<br />     Dim xdi       As Integer<br />     xdi = 0<br />     ' 遍历选择集中的对象<br />     ' 并检索对象的扩展数据<br />     Dim msgstr     As String<br />     Dim strAppName As String<br />     Dim ent        As AcadEntity<br />     strAppName = ""<br />     For Each ent In sset<br />         msgstr = ""<br />         xdi = 0<br />         ' 检索 appName 扩展数据类型和值<br />         ent.GetXData strAppName, xdataType, xdata<br />         ' 如果未初始化 xdataType 变量，<br />         ' 则没有可供该图元检索的 appName 扩展数据<br />         If VarType(xdataType) <> vbEmpty Then<br />             For Each xd In xdata<br />                 <br />                 If VarType(xd) And vbArray Then<br />                     msgstr = msgstr & vbCrLf & xdataType(xdi) & ": " & CStr(xd(0)) & "," & CStr(xd(1)) & "," & CStr(xd(2))<br />                 Else<br />                     msgstr = msgstr & vbCrLf & xdataType(xdi) & ": " & CStr(xd) 'xd如果是数组或其他对象类型就会出错<br />                 End If<br />                 xdi = xdi + 1<br />             Next xd<br />         End If<br />         ' 如果 msgstr 变量为 NULL，则没有扩展数据<br />         If msgstr = "" Then msgstr = vbCrLf & "NONE"<br />         'MsgBox strAPPNAME & " xdata on " & ent.ObjectName & _<br /> ":      " & vbCrLf & msgstr<br />         ThisDrawing.Utility.Prompt strAppName & " XData on " & ent.ObjectName & ":" & _<br />         vbCrLf & msgstr & vbCrLf<br />         'ThisDrawing.SendCommand Chr$(vbKeyCancel)<br />     Next ent<br /> End Sub

yaokui25

谢谢您的好代码

cuyongping

谢谢了！收藏了！

yefei812678

谢谢了！谢谢了！谢谢了！谢谢了！