AutoCAD二次开发教程（7）-通过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
MsgBox "运行的是： " + acadApp.Name + " 版本：" + acadApp.Version


' 连接至 AutoCAD 图形
Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument
acadApp.Visible = True

'程序最大化
acadDoc.Application.WindowState = acMax

'文档最大化
acadDoc.WindowState = acMax

 Dim solidObj As AcadSolid
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
Dim point3(0 To 2) As Double
Dim point4(0 To 2) As Double

' 定义实体
point1(0) = 0#: point1(1) = 0#: point1(2) = 0#
point2(0) = 5#: point2(1) = 0#: point2(2) = 0#
point3(0) = 5#: point3(1) = 8#: point3(2) = 0#
point4(0) = 0#: point4(1) = 8#: point4(2) = 0#
' 在模型空间中创建实体对象
Set solidObj = acadDoc.ModelSpace.AddSolid(point1, point2, point3, point4)
ZoomAll

绘制顺序也会有点关系，把point3与point4顺序兑换，运行后效果如下：

如下图：

2：创建Hatch填充

代码如下：

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
MsgBox "运行的是： " + acadApp.Name + " 版本：" + acadApp.Version


' 连接至 AutoCAD 图形
Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument
acadApp.Visible = True

'程序最大化
acadDoc.Application.WindowState = acMax

'文档最大化
acadDoc.WindowState = acMax

Dim hatchObj As AcadHatch
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean

' 定义图案填充
patternName = "ANSI31"
PatternType = 0
bAssociativity = True

' 创建关联的 Hatch 对象
Set hatchObj = acadDoc.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)

' 创建图案填充的外边界。（一个圆）
Dim outerLoop(0 To 0) As AcadEntity
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 3: center(1) = 3: center(2) = 0
radius = 100
Set outerLoop(0) = acadDoc.ModelSpace.AddCircle(center, radius)

' 向 Hatch 对象附加外边界，并显示图案填充
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.Evaluate
acadDoc.Regen True

ZoomAll

在圆填充，图案名称ANSI31