【大鹏测绘】图元扩展属性

'检查实体是否存在扩展数据
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 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