标签： VB

‘绑定 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 oBlockDef As Object
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
Set oBlockDef = oDraw.Blocks.Add(insertionPnt, “TestBlock”)

‘ 块内添加圆
Dim oCircle As Object
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 0: center(1) = 0: center(2) = 0
radius = 12
Set oCircle = oBlockDef.AddCircle(center, radius)
Debug.Print “Entity Name: ” & oCircle.EntityName
Debug.Print oCircle.Handle

‘ 块内添加单行文字
Dim startPoint(0 To 2) As Double
Dim height As Double
Dim textString As String
Dim oText As Object
startPoint(0) = 15
startPoint(1) = 5
startPoint(2) = 0
height = 6
textString = “A block demo.”
Set oText = oBlockDef.AddText(textString, startPoint, height)
Debug.Print “Entity Name: ” & oText.EntityName
Debug.Print oText.Handle

‘ 插入块(块的实例化)
Dim oBlockRef As Object
insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0
Set oBlockRef = oDraw.ModelSpace.InsertBlock(insertionPnt, “TestBlock”, 1#, 1#, 1#, 0)

‘ 缩放块实例
Dim basePoint(0 To 2) As Double
Dim scaleFactor As Double
basePoint(0) = 0#
basePoint(1) = 0#
basePoint(2) = 0#
scaleFactor = 10#
Call oBlockRef.ScaleEntity(basePoint, scaleFactor)

‘ 旋转块实例
Dim rotationAngle As Double
basePoint(0) = 0#
basePoint(1) = 0#
basePoint(2) = 0#
rotationAngle = 1.57 ‘弧度
Call oBlockRef.Rotate(basePoint, rotationAngle)

‘ 分解块实例
Dim oSet As Variant
oSet = oBlockRef.Explode()
For I = LBound(oSet) To UBound(oSet)
Debug.Print “Entity Name: ” & oSet(I).EntityName
Debug.Print oSet(I).Handle
Next

‘ 执行 AutoCAD 命令 Zoomextents
oAutoCAD.Zoomextents

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

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