AutoCAD二次开发教程(7)-通过VB6创建填充

发布于 / VB / 0 条评论

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

通过坐标 (0,0,0)、(5,0,0)、(5,8,0) 和 (0,8,0) 在模型空间中创建四边形实体,效果如下:

绘制顺序也会有点关系,把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

转载原创文章请注明,转载自: 胡伟明 » AutoCAD二次开发教程(7)-通过VB6创建填充
暂无评论