标签： 编程

‘本例演示判断两个图元是否交叉？有几个交点？交点坐标分别是什么？

‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)

‘打开并绑定文件 D:/Test.dwg
Dim oDraw As Object ‘AutoCAD 多文档之一
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)

‘建立选择集
Dim oSelset As Object, oItem As Object
Dim TempName As String
TempName = SelName(8)
If SetExist(oDraw, TempName) Then oDraw.SelectionSets.Item(TempName).Delete
Set oSelset = oDraw.SelectionSets.Add(TempName)
oDraw.Activate

‘屏幕选择多个图元填入选择集，列出前两个图元之间交点的坐标
Dim IntersectPoint As Variant
oSelset.SelectOnScreen
‘Debug.Print “oSelSet.Count” & Space$(1) &”=” & Space$(1) & oSelSet.Count
If oSelset.Count > 1 Then ‘最少两个,但只认前两个
‘ Find the intersection points between the oSelSet(0) and the oSelSet(1)
IntersectPoint = oSelset(0).IntersectWith(oSelset(1), 0)
‘ acExtendNone Does not extend either object.
‘ acExtendThisEntity Extends the base object.
‘ acExtendOtherEntity Extends the object passed as an argument.
‘ acExtendBoth Extends both objects.
‘ Print all the intersection points
If VarType(IntersectPoint) <> vbEmpty Then
For I = LBound(IntersectPoint) To UBound(IntersectPoint) Step 3
Debug.Print “Intersection[” & (I + 3) / 3 & “/” & (UBound(IntersectPoint) – LBound(IntersectPoint) + 1) / 3 & “]:” & Space$(1) & _
IntersectPoint(I) & “,” & IntersectPoint(I + 1) & “,” & IntersectPoint(I + 2)
Next I
Else
Debug.Print “No intersection points.”
End If
End If

‘解除绑定,释放资源
oSelset.Delete
Set oSelset = Nothing
Set oItem = Nothing

‘本例演示分多次绘制图形,而每次所绘图元与当前进程所绘一般无二,即,可以对其进行任何操作, 绘制图元的数据存储于 Dictionarys,下次从 Dictionarys 中读出数据加以利用

‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)
Dim oDraw As Object ‘AutoCAD 多文档之一

‘打开并绑定文件 D:/Test.dwg
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)

Dim oLine() As Object
Dim LineCount As Integer
Public vPickPoint As Variant
Dim dStartPoint(0 To 2) As Double
Dim dEndPoint(0 To 2) As Double

‘在 Dictionarys 中查找 “Line”，并读取”Handle” App 的 “1000” 位码的值
Dim sTemp As String
sTemp = GetDicString(oDraw, “Line”, “Handle”)
sTemp = PurgeTerminal(sTemp, “|”)

‘确定起点
Set oUtility = oDraw.Utility
If sTemp = “” Then ‘第一次
LineCount = 0
vPickPoint = oUtility.GetPoint(, “选取线段起点!”)
dStartPoint(0) = vPickPoint(0)
dStartPoint(1) = vPickPoint(1)
dStartPoint(2) = vPickPoint(2)
Else ‘Dictionary 有数据则唤醒对象
Dim TempArray As Variant
TempArray = Split(sTemp, “|”, -1, vbTextCompare)
For I = LBound(TempArray) To UBound(TempArray)
LineCount = LineCount + 1
ReDim Preserve oLine(1 To LineCount)
Set oLine(LineCount) = oDraw.HandleToObject(TempArray(I))
Next I
Dim vStart As Variant, vEnd As Variant
vStart = oLine(LineCount).StartPoint
vEnd = oLine(LineCount).EndPoint ‘AutoCAD 特别之处
dStartPoint(0) = vEnd(0)
dStartPoint(1) = vEnd(1)
dStartPoint(2) = vEnd(2)
End If

‘绘制(或增加)线段
vPickPoint = oUtility.GetPoint(dStartPoint, “选取线段终点!”)
dEndPoint(0) = vPickPoint(0)
dEndPoint(1) = vPickPoint(1)
dEndPoint(2) = vPickPoint(2)
LineCount = LineCount + 1
ReDim Preserve oLine(1 To LineCount)
Set oLine(LineCount) = oDraw.ModelSpace.AddLine(dStartPoint, dEndPoint)

‘在 Dictionarys 中生成新的(或更新) Dictionary，建立 App 并为 “1000” 位码赋值
Dim lRet As Long
Dim sDic As String
Dim sApp As String
Dim sValue As String
sDic = “Line”
sApp = “Handle”
For I = 1 To LineCount
sValue = sValue & “|” & oLine(I).Handle
Next I
sTemp = PurgeTerminal(sValue, “|”)
lRet = SetDicString(oDraw, sDic, sApp, sValue)

‘测试一:统计长度
Dim dLength As Double
For I = 1 To LineCount
dLength = dLength + oLine(I).Length
Next I
Debug.Print “线段根数:” & CStr(LineCount)
Debug.Print “线段总长:” & CStr(dLength)

‘测试二:部分线段左移,部分线段右移
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = 0: point1(1) = 0: point1(2) = 0
point2(0) = 200: point2(1) = 0: point2(2) = 0
For I = 1 To LineCount Step 2
If I <= LineCount Then oLine(I).Move point1, point2 ‘1, 3, 5, 7
If I + 1 <= LineCount Then oLine(I + 1).Move point2, point1 ‘2, 4, 6, 8
Next I

‘测试三:识别屏幕所选图元
‘在 Dictionarys 中查找 “Line”，并读取”Handle” App “1000” 位码的值
Dim oSelset As Object, oItem As Object
sTemp = GetDicString(oDraw, “Line”, “Handle”)
sTemp = PurgeTerminal(sTemp, “|”)
Dim TempArray As Variant
TempArray = Split(sTemp, “|”, -1, vbTextCompare)
Dim iIndex As Integer
Dim TempName As String
TempName = SelName(8)
If SetExist(oDraw, TempName) Then oDraw.SelectionSets.Item(TempName).Delete
Set oSelset = oDraw.SelectionSets.Add(TempName)
oDraw.Activate
oSelset.SelectOnScreen
‘Debug.Print “oSelSet.Count” & Space$(1) &”=” & Space$(1) & oSelSet.Count
If oSelset.Count <= 0 Then Exit Sub
For I = 0 To oSelset.Count – 1
iIndex = IndexInArray(oSelset.Item(I).Handle, TempArray)
If iIndex = -1 Then
Debug.Print “选择了集外图元.”
Else
Debug.Print “选择了” & CStr(iIndex + 1) & “号线段.”
End If
Next I
oSelset.Delete
Set oSelset = Nothing
Set oItem = Nothing

‘绑定 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”)

‘在 Dictionarys 中查找 “New Dic”，并读取”属性” App 的值
Dim sTemp As String
sTemp = GetDicString(oDraw, “New Dic”, “属性”)

Public Function GetDicString(ByVal vDraw As Variant, ByVal sDic As String, ByVal sApp As String) As String ‘在 Dictionarys 中查找 “New Dic”，并读取”属性” App “1000” 位码的值
GetDicString = “”
Dim I As Integer, J As Integer
Dim XTypeOut As Variant
Dim XValueOut As Variant
Dim oDic As Object
Set oDic = vDraw.Dictionaries.Item(sDic)
oDic.GetXData sApp, XTypeOut, XValueOut
If Not IsArray(XTypeOut) Or Not IsArray(XValueOut) Then Exit Function
For I = LBound(XTypeOut) To UBound(XTypeOut)
If XTypeOut(I) = 1000 Then GetDicString = XValueOut(I)
Next I
End Function

‘绑定 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”)

‘在 Dictionarys 中生成新的 Dictionary，建立 App 并赋值
Dim lRet As Long
Dim sDic As String
Dim sApp As String
Dim sValue As String
sDic = “New Dic”
sApp = “属性”
sValue = “467”
lRet = SetDicString(oDraw, sDic, sApp, sValue)

Public Function SetDicString(ByVal vDraw As Variant, ByVal sDic As String, ByVal sApp As String, ByVal sValue As String) As Long ‘在 Dictionarys 中生成新的 Dictionary 建立 App 并给 “1000” 位码赋值
Dim I As Integer, J As Integer
SetDicString = -1 ‘未执行
If Trim(sBase) = “” Then Exit Function
If Trim(sApp) = “” Then Exit Function
‘If Trim(sValue) = “” Then Exit Function
SetDicString = 0 ‘正常执行
Dim oDic As Object
Set oDic = vDraw.Dictionaries.Add(sDic)
Dim DataType(0 To 1) As Integer
Dim DataValue(0 To 1) As Variant
DataType(0) = 1001
DataValue(0) = sApp
DataType(1) = 1000
DataValue(1) = sValue
‘ Attach the xdata to the object
oDic.SetXData DataType, DataValue
End Function

Public Function SetExist(ByVal vDraw As Variant, ByVal sSet As String) As Boolean
Dim I As Integer, J As Integer
SetExist = False
If vDraw Is Nothing Then Exit Function
For I = 0 To vDraw.SelectionSets.Count – 1
If vDraw.SelectionSets.Item(I).Name = sSet Then SetExist = True
Next I
End Function

Public Function DictionaryExist(ByVal vDraw As Variant, ByVal sDict As String) As Boolean
Dim I As Integer, J As Integer
On Error GoTo ERR_NO_KEY
DictionaryExist = False
If vDraw Is Nothing Then Exit Function
Set oDictionary = vDraw.Dictionaries.Item(sDict) ‘试错
DictionaryExist = True
On Error GoTo 0
Exit Function
ERR_NO_KEY: ‘primary key
DictionaryExist = False
On Error GoTo 0
End Function

Public Function AppExist(ByVal vDraw As Variant, ByVal sApp As String, ByVal sDict As String) As Boolean
Dim I As Integer, J As Integer
AppExist = False
If vDraw Is Nothing Then Exit Function
If Not DictionaryExist(oDraw, sDict) Then Exit Function
Set oDictionary = vDraw.Dictionaries.Item(sDict)
Dim XTypeOut As Variant
Dim XValueOut As Variant
oDictionary.GetXData “”, XTypeOut, XValueOut
If Not IsArray(XTypeOut) Then Exit Function
If Not IsArray(XValueOut) Then Exit Function
For I = LBound(XTypeOut) To UBound(XTypeOut)
If XTypeOut(I) = 1001 And XValueOut(I) = sApp Then
AppExist = True
End If
Next I
End Function