AutoCAD二次开发教程（6）-通过VB6绘制辅助线

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