‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object ‘AutoCAD Application 本身
Call BindAutoCAD(True)
Dim oDraw As Object ‘AutoCAD 多文档之一
‘打开并绑定文件 D:/Test.dwg
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)
‘绑定 Microsoft Excel
Dim oExcel As Object ‘Microsoft Excel Application 本身
Call BindExcel(True)
Dim oBook As Object ‘Microsoft Excel 多工作薄之一
Dim oSheet As Object ‘工作薄的工作表之一
‘打开并绑定文件 D:/Test.xls
Set oBook = oExcel.Application.WorkBooks.Open(“D:/Test.xls”)
‘绑定已有工作表 Sheet1
Set oSheet = oBook.Sheets(“Sheet1”)
‘屏幕选择图元
Dim PointPicked As Variant
Dim oEntity As Object
oDraw.Activate
oDraw.Utility.GetEntity oEntity, PointPicked
‘指向 TargetRow 行第一列
Dim TargetRow As Integer
TargetRow = MaxRow(oSheet) ‘有文字的最大行
oSheet.Cells(TargetRow, 1).Select
‘添加扩展数据
For J = MinColumn(oSheet) To MaxColumn(oSheet)
If IsInteger(oSheet.Cells(1, J)) And _
IsInRange(oSheet.Cells(1, J), 1000, 1071, True) And _
Not oSheet.Cells(TargetRow, J) = “” Then ‘允许等于上下界
Dim iCount As Integer
iCount = iCount + 1
ReDim Preserve iTypeArray(0 To iCount – 1)
ReDim Preserve sValueArray(0 To iCount – 1)
iTypeArray(iCount – 1) = oSheet.Cells(1, J)
sValueArray(iCount – 1) = oSheet.Cells(TargetRow, J) ‘新数据行位于最后
End If
Next J
‘Debug.Print IsEmptyArray(iTypeArray)
‘Debug.Print IsEmptyArray(sValueArray)
If AttachXData(oEntity, iTypeArray(), sValueArray()) Then
Debug.Print “Attached.”
Else
Debug.Print “Not attached.”
End If
Public Function AttachXData(ByVal oEntity As Object, ByRef iType() As Integer, ByRef sValue() As String) As Boolean
Dim I As Integer, J As Integer
AttachXData = False
If Not IsObject(oEntity) Then Exit Function
If Not IsArray(iType) Then Exit Function
If Not IsArray(sValue) Then Exit Function
If Not LBound(iType) = LBound(sValue) Then Exit Function
If Not UBound(iType) = UBound(sValue) Then Exit Function
If Not IsInArray(“1001”, iType) Then Exit Function
If Not iType(LBound(iType)) = “1001” Then Exit Function
For J = LBound(iType) To UBound(iType)
If Not IsInteger(iType(J)) Then Exit Function
If Trim(sValue(J)) = “” Then Exit Function
Select Case iType(J)
Case 1001 ‘排第一
If CountStr(False, sValue(J), “|”) > 0 Then Exit Function ‘Only one appname is allowed when attaching.
Case 1000, 1002, 1003, 1004, 1005 ‘1002/1004 数据特殊
‘Nothing
Case 1010, 1011, 1012, 1013 ‘三维
For I = 1 To CountStr(False, sValue(J), “|”) + 1
If Not CountStr(False, ExtractDivide(“|”, sValue(J), I), “,”) = 2 Then Exit Function ‘The data format is as nnn,nnn,nnn.
If Not IsNumeric(ExtractDivide(“,”, ExtractDivide(“|”, sValue(J), I), 1)) Then Exit Function
If Not IsNumeric(ExtractDivide(“,”, ExtractDivide(“|”, sValue(J), I), 2)) Then Exit Function
If Not IsNumeric(ExtractDivide(“,”, ExtractDivide(“|”, sValue(J), I), 3)) Then Exit Function
Next I
Case 1040, 1041, 1042
For I = 1 To CountStr(False, sValue(J), “|”) + 1
If Not IsNumeric(ExtractDivide(“|”, sValue(J), I)) Then Exit Function
Next I
Case 1070, 1071
For I = 1 To CountStr(False, sValue(J), “|”) + 1
If Not IsInteger(ExtractDivide(“|”, sValue(J), I)) Then Exit Function
Next I
Case Else
‘Nothing
End Select
Next J
‘DXF 组码值 扩展数据内容
‘1000 字符串, 扩展数据中的字符串可长达 255 字节（第 256 字节是为空字符保留的）
‘1001 应用程序名, 应用名称可长达 31 字节（第 32 字节是为空字符保留的），而且必须符合符号表的名称规则（如图层名称）。应用名称可包含字母、数字、专用字符 $（美元符号）、-（连字符）以及 _（下划线），但不能包含空格
‘1002 控制字符串, 扩展数据的控制字符串可以是”{“或”}”。这些大括号使应用可以通过将扩展数据细分为表来组织它们。左括号开始一个表，右括号结束最新的表。表是可以嵌套的
‘1003 图层名, 与扩展数据相关联的图层名称, 须是已有层
‘1004 二进制数据, 二进制数据被组织为可变长度的数据块，它可在有 ads_binary 结构的 ObjectARX 中处理。数据块的最大长度为 127 字节
‘1005 数据库对象句柄, 图形数据库中的图元句柄
‘1010 三维点（X, Y, Z）, 一个点中的三个实数值
‘1011 三维空间位置, 与简单的三维点不同，其 WCS 坐标随扩展数据所属的父图元移动、比例缩放、旋转和镜像。当对父图元使用 STRETCH 命令并且此点位于选择窗口中时，该 WCS 的位置也会被拉伸
‘1012 三维空间距离, 一个随着父图元比例缩放、旋转或镜像的三维点，但不可拉伸或移动
‘1013 三维空间方向, 一个随着父图元旋转或镜像的三维点，但不可比例缩放、拉伸或移动。其 WCS 方向是一个单位长度的规格化向量
‘1040 浮点数, 一个实数值
‘1041 距离值, 一个随着父图元比例缩放的实数值
‘1042 比例系数, 一个随着父图元比例缩放的实数值
‘1070 整数, 一个 16 位整数（带符号或不带符号）
‘1071 长整数, 一个 32 位带符号的（长）整数。如果 1071 组码中出现短整数或实数值，则被转换为一个长整数；如果组码值非法（例如一个字符串），则将被转换为长整数形式的零 (0L)
Dim iCount As Integer
For J = LBound(iType) To UBound(iType)
iCount = iCount + 1
iCount = iCount + CountStr(False, sValue(J), “|”)
Next J
If iCount = 0 Then Exit Function
‘ Initialize all the xdata values. Note that first data in the list should be application name and first datatype code should be 1001
ReDim DataType(0 To iCount – 1) As Integer
ReDim DataValue(0 To iCount – 1) As Variant
iCount = 0 ‘重置
Dim ThreeDim(0 To 2) As Double
For J = LBound(iType) To UBound(iType)
For I = 1 To CountStr(False, sValue(J), “|”) + 1
iCount = iCount + 1
DataType(iCount – 1) = iType(J)
‘Debug.Print DataType(iCount – 1)
If iType(J) = 1010 Or iType(J) = 1011 Or iType(J) = 1012 Or iType(J) = 1013 Then ‘三维
ThreeDim(0) = ExtractDivide(“,”, ExtractDivide(“|”, sValue(J), I), 1)
ThreeDim(1) = ExtractDivide(“,”, ExtractDivide(“|”, sValue(J), I), 2)
ThreeDim(2) = ExtractDivide(“,”, ExtractDivide(“|”, sValue(J), I), 3)
‘Debug.Print ThreeDim(0)
‘Debug.Print ThreeDim(1)
‘Debug.Print ThreeDim(2)
DataValue(iCount – 1) = ThreeDim
Else
DataValue(iCount – 1) = ExtractDivide(“|”, sValue(J), I)
‘Debug.Print DataValue(iCount – 1)
End If
Next I
Next J
‘ Attach the xdata to the entity
oEntity.SetXData DataType, DataValue
AttachXData = True
End Function