Public Function HasXData(objEnt As AcadEntity, strAppName As String) As Boolean
Dim DataType As Variant, DataValue As Variant
objEnt.GetXData strAppName, DataType, DataValue
If IsEmpty(DataType) Then
HasXData = False
Else
HasXData = True
End If
End Function
'读取扩展数据
Public Function GetCode(objEnt As AcadEntity, strAppName As String) As Variant
Dim DataType As Variant, DataVaue As Variant, i As Integer
If HasXData(objEnt, strAppName) = False Then
GetCode = ""
Else
objEnt.GetXData strAppName, DataType, DataValue
For i = LBound(DataType) To UBound(DataType)
If DataType(i) = 1000 Then GetCode = DataValue(i): Exit For
Next i
End If
End Function
'设置扩展数据
Public Function SetCode(objEnt As AcadEntity, strAppName As String, strDataValue As String)
Dim DataType(0 To 1) As Integer
Dim DataValue(0 To 1) As Variant
DataType(0) = 1001: DataValue(0) = strAppName
DataType(1) = 1000: DataValue(1) = strDataValue
objEnt.SetXData DataType, DataValue
End Function
'删除绑定图元的扩展数据
Public Sub ClearXData(Obj As AcadObject, Optional RegApp As String = "")
Const regAppKey As Integer = 1001
Const acadApp As String = "ACAD"
Dim XDType As Variant
Dim XDData As Variant
Dim NewType(0) As Integer
Dim NewData(0) As Variant
Dim i As Integer
Obj.GetXData AppName:=RegApp, XDataType:=XDType, XDataValue:=XDData
If Not IsEmpty(XDType) Then
For i = LBound(XDType) To UBound(XDType)
If XDType(i) = regAppKey Then
If Not XDData(i) Like acadApp Then
NewType(0) = regAppKey
NewData(0) = XDData(i)
Obj.setXdata XDataType:=NewType, XDataValue:=NewData
End If
End If
Next i
End If
End Sub
Public Sub ClearXData(Obj As AcadObject, Optional RegApp As String = "")
Const regAppKey As Integer = 1001
Const acadApp As String = "ACAD"
Dim XDType As Variant
Dim XDData As Variant
Dim NewType(0) As Integer
Dim NewData(0) As Variant
Dim i As Integer
Obj.GetXData AppName:=RegApp, XDataType:=XDType, XDataValue:=XDData
If Not IsEmpty(XDType) Then
For i = LBound(XDType) To UBound(XDType)
If XDType(i) = regAppKey Then
If Not XDData(i) Like acadApp Then
NewType(0) = regAppKey
NewData(0) = XDData(i)
Obj.setXdata XDataType:=NewType, XDataValue:=NewData
End If
End If
Next i
End If
End Sub
'显示选定图元的扩展属性
Public Sub ListXData(ByVal AcadApp As Object)
Dim ent As Object
Dim XDType As Variant, XDData As Variant
Dim i As Integer, pnt(2) As Double, strPrint As String, strInfo As String, strEnd As String
On Error Resume Next
AcadApp.Application.ActiveDocument.Utility.GetEntity ent, pnt, vbCr & vbCr & "选择实体："
If Err Then Err.Clear: Exit Sub
ent.GetXData "", XDType, XDData
If Not IsEmpty(XDType) Then
For i = LBound(XDType) To UBound(XDType)
DoEvents
If XDType(i) = 1001 Then
If Not XDData(i) Like "ACAD" Then
If strPrint = "" Then
strPrint = "[" & XDData(i) & "]=" & GetCode(ent, CStr(XDData(i)))
Else
strPrint = strPrint & Space(2) & "[" & XDData(i) & "]=" & GetCode(ent, CStr(XDData(i)))
End If
End If
End If
Next i
End If
strInfo = "----------实体 " & ent.Handle & " 扩展属性----------"
If strPrint = "" Then
strPrint = strInfo & vbCrLf & "NULL"
Else
strPrint = strInfo & vbCrLf & strPrint
End If
For i = 1 To Len(strInfo) + 6
strEnd = strEnd & "-"
Next i
strPrint = strPrint & vbCrLf & strEnd
AcadApp.Application.ActiveDocument.Utility.Prompt vbCr & vbCr & strPrint
End Sub
Public Sub ListXData(ByVal AcadApp As Object)
Dim ent As Object
Dim XDType As Variant, XDData As Variant
Dim i As Integer, pnt(2) As Double, strPrint As String, strInfo As String, strEnd As String
On Error Resume Next
AcadApp.Application.ActiveDocument.Utility.GetEntity ent, pnt, vbCr & vbCr & "选择实体："
If Err Then Err.Clear: Exit Sub
ent.GetXData "", XDType, XDData
If Not IsEmpty(XDType) Then
For i = LBound(XDType) To UBound(XDType)
DoEvents
If XDType(i) = 1001 Then
If Not XDData(i) Like "ACAD" Then
If strPrint = "" Then
strPrint = "[" & XDData(i) & "]=" & GetCode(ent, CStr(XDData(i)))
Else
strPrint = strPrint & Space(2) & "[" & XDData(i) & "]=" & GetCode(ent, CStr(XDData(i)))
End If
End If
End If
Next i
End If
strInfo = "----------实体 " & ent.Handle & " 扩展属性----------"
If strPrint = "" Then
strPrint = strInfo & vbCrLf & "NULL"
Else
strPrint = strInfo & vbCrLf & strPrint
End If
For i = 1 To Len(strInfo) + 6
strEnd = strEnd & "-"
Next i
strPrint = strPrint & vbCrLf & strEnd
AcadApp.Application.ActiveDocument.Utility.Prompt vbCr & vbCr & strPrint
End Sub
全部评论