【AutoCAD二次开发】第九节 扩展数据

'第九节 扩展数据
Public Function HasXData(ent As AcadEntity, strAppName As String) As Boolean '检查实体是否存在扩展数据
  Dim dataType As Variant
  Dim Data As Variant
  ent.GetXData strAppName, dataType, Data
  HasXData = True
  If IsEmpty(dataType) Then
     HasXData = False
  End If
End Function
Public Function GetCode(objEnt As AcadEntity, strAppName As String) As Variant '获取实体的扩展数据
  Dim dType As Variant, dData As Variant, i As Integer
  If HasXData(objEnt, strAppName) = False Then
     GetCode = ""
  Else
     objEnt.GetXData strAppName, dType, dData
     For i = LBound(dType) To UBound(dType)
         If dType(i) = 1000 Then
            GetCode = dData(i)
            Exit For
         End If
     Next i
  End If
End Function
Public Sub GETP() '读取CASS实体编码
  Dim objEnt As AcadEntity
  Dim pnt As Variant
xGoTo:
  On Error Resume Next
  ThisDrawing.Application.ActiveDocument.Utility.GetEntity objEnt, pnt, vbCr & "VBA程序-选择图形实体<直接回车退出>"
  If Err Then Exit Sub
  MsgBox "实体编码：" & GetCode(objEnt, "south"), , "AutoCAD信息"
  GoTo xGoTo
End Sub
Public Function SetCode(ent As AcadEntity, str As String, strAppName As String) '设置CASS实体编码
    Dim dType(0 To 1) As Integer
    Dim mData(0 To 1) As Variant
    dType(0) = 1001: mData(0) = strAppName
    dType(1) = 1000: mData(1) = str
    ent.SetXData dType, mData
End Function