加载中…
VB6+AutoCAD图元扩展数据
(2018-06-07 09:17:55)
标签：
autocad扩展数据 |
分类： AutoCAD二次开发 |
'检查实体是否存在扩展数据
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
Public Function HasXData(objEnt As AcadEntity, strAppName As String) As Boolean
End Function
'读取扩展数据
Public Function GetCode(objEnt As AcadEntity, strAppName As String) As Variant
End Function
'设置扩展数据
Public Function SetCode(objEnt As AcadEntity, strAppName As String, strDataValue As String)
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 = "")
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
Public Sub ListXData(ByVal AcadApp As Object)