1:绘制构造线
代码如下:
On Error Resume Next ' 连接至 AutoCAD 应用程序 Dim acadApp As AcadApplication Dim docObj As AcadDocument Set acadApp = GetObject(, "AutoCAD.Application.17.1") Set docObj = acadApp.Application.Documents.Add If Err Then Err.Clear Set acadApp = CreateObject("AutoCAD.Application.17.1") Set docObj = acadApp.Application.Documents.Add If Err Then MsgBox ("无法运行AutoCAD2008,请检查是否安装了AutoCAD2008") Exit Sub End If End If ' 连接至 AutoCAD 图形 Dim acadDoc As AcadDocument Set acadDoc = acadApp.ActiveDocument acadApp.Visible = True '程序最大化 acadDoc.Application.WindowState = acMax '文档最大化 acadDoc.WindowState = acMax Dim xlineObj As AcadXline Dim basePoint(0 To 2) As Double Dim directionVec(0 To 2) As Double ' 定义构造线 basePoint(0) = 2#: basePoint(1) = 2#: basePoint(2) = 0# directionVec(0) = 1#: directionVec(1) = 1#: directionVec(2) = 0# ' 在模型空间中创建构造线 Set xlineObj = acadDoc.ModelSpace.AddXline(basePoint, directionVec) acadApp.ZoomAll
通过两点 (5, 0, 0) 和 (1, 1, 0) 创建构造线,效果如下:
2:绘制射线
代码如下:
On Error Resume Next ' 连接至 AutoCAD 应用程序 Dim acadApp As AcadApplication Dim docObj As AcadDocument Set acadApp = GetObject(, "AutoCAD.Application.17.1") Set docObj = acadApp.Application.Documents.Add If Err Then Err.Clear Set acadApp = CreateObject("AutoCAD.Application.17.1") Set docObj = acadApp.Application.Documents.Add If Err Then MsgBox ("无法运行AutoCAD2008,请检查是否安装了AutoCAD2008") Exit Sub End If End If ' 连接至 AutoCAD 图形 Dim acadDoc As AcadDocument Set acadDoc = acadApp.ActiveDocument acadApp.Visible = True acadDoc.WindowState = acMax Dim rayObj As AcadRay Dim basePoint(0 To 2) As Double Dim secondPoint(0 To 2) As Double ' 定义射线 basePoint(0) = 3 basePoint(1) = 3 basePoint(2) = 0 secondPoint(0) = 4 secondPoint(1) = 4 secondPoint(2) = 0 ' 在模型空间中创建 Ray 对象 Set rayObj = acadDoc.ModelSpace.AddRay(basePoint, secondPoint) ZoomAll
通过两点 (3, 3, 0) 和 (4, 4, 0) 创建一条射线,效果如下: