[VBA函数]：清除CAD对象的扩展实体数据

efan2000

2. 
   
3.   [FONT=courier new]
   
4. Direct from AcadX.com
   
5. 
   
6. Public Sub ClearXData(Obj As AcadObject, Optional RegApp As String = "")
   
7.     Const regAppKey As Integer = 1001
   
8.     Const acadApp As String = "ACAD"
   
9. 
   
10.     Dim XDType As Variant
    
11.     Dim XDData As Variant
    
12.     Dim NewType(0) As Integer
    
13.     Dim NewData(0) As Variant
    
14.     Dim i As Integer
    
15. 
    
16.     Obj.GetXData AppName:=RegApp, XDataType:=XDType, XDataValue:=XDData
    
17. 
    
18.     If Not IsEmpty(XDType) Then
    
19.         For i = LBound(XDType) To UBound(XDType)
    
20.             If XDType(i) = regAppKey Then
    
21.                 If Not XDData(i) Like acadApp Then '对CAD内部的扩展实体数据不清除
    
22.                     NewType(0) = regAppKey
    
23.                     NewData(0) = XDData(i)
    
24.                     Obj.setXdata XDataType:=NewType, XDataValue:=NewData
    
25.                 End If
    
26.             End If
    
27.         Next i
    
28.     End If
    
29. End Sub
    
30. 
    
31. 目的
    
32. 删除扩展实体数据。扩展实体数据是附着于CAD对象上，如果应用程序名称没有指定，所有的扩展实体数据将删除。
    
33. 
    
34. 参数
    
35. 一个AcadObject对象和可选的应用程序名称。
    
36. 
    
37. 示例
    
38. Call ClearXData (myAcadObject, "ACADX")
    
39. 
    
40. 注意
    
41. ClearXData() 不会删除AutoCAD内部保存的扩展实体数据。
    
42. --
    
43. Bobby C. Jones
    
44. [url]www.AcadX.com[/url]
    
45. 
    
46.   [/FONT]
    

<br />   [FONT=courier new]<br /> Direct from AcadX.com<br /> <br /> Public Sub ClearXData(Obj As AcadObject, Optional RegApp As String = "")<br />     Const regAppKey As Integer = 1001<br />     Const acadApp As String = "ACAD"<br /> <br />     Dim XDType As Variant<br />     Dim XDData As Variant<br />     Dim NewType(0) As Integer<br />     Dim NewData(0) As Variant<br />     Dim i As Integer<br /> <br />     Obj.GetXData AppName:=RegApp, XDataType:=XDType, XDataValue:=XDData<br /> <br />     If Not IsEmpty(XDType) Then<br />         For i = LBound(XDType) To UBound(XDType)<br />             If XDType(i) = regAppKey Then<br />                 If Not XDData(i) Like acadApp Then '对CAD内部的扩展实体数据不清除<br />                     NewType(0) = regAppKey<br />                     NewData(0) = XDData(i)<br />                     Obj.setXdata XDataType:=NewType, XDataValue:=NewData<br />                 End If<br />             End If<br />         Next i<br />     End If<br /> End Sub<br /> <br /> 目的<br /> 删除扩展实体数据。扩展实体数据是附着于CAD对象上，如果应用程序名称没有指定，所有的扩展实体数据将删除。<br /> <br /> 参数<br /> 一个AcadObject对象和可选的应用程序名称。<br /> <br /> 示例<br /> Call ClearXData (myAcadObject, "ACADX")<br /> <br /> 注意<br /> ClearXData() 不会删除AutoCAD内部保存的扩展实体数据。<br /> --<br /> Bobby C. Jones<br /> [url]www.AcadX.com[/url]<br /> <br />   [/FONT]<br />