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