|
|
完整代码：
Option Explicit
Private Sub Command1_Click()
Dim acadApp As AcadApplication
Set acadApp = GetObject(, ".Application")
Dim hatchObj As AcadHatch
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
'定义填充
PatternType = 0
patternName = "SOLID"
bAssociativity = True '填充图案与边界相关联
'创建填充对象
Set hatchObj = acadApp.ActiveDocument.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
'创建两个同心圆作为填充边界
Dim OuterLoop(0 To 0) As AcadEntity
Dim InnerLoop(0 To 0) As AcadEntity
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 1: center(1) = 2: center(2) = 0
radius = 20
Set OuterLoop(0) = acadApp.ActiveDocument.ModelSpace.AddCircle(center, radius)
Set InnerLoop(0) = acadApp.ActiveDocument.ModelSpace.AddCircle(center, radius / 2)
'向填充对象添加填充边界
hatchObj.AppendOuterLoop (OuterLoop)
hatchObj.AppendInnerLoop (InnerLoop)
'用Evaluate方法进行求值并显示填充
hatchObj.Evaluate
acadApp.ActiveDocument.Regen True
'输出填充的边界数
Print (hatchObj.NumberOfLoops)
'判断边界的类型
Dim loopNum As Integer
loopNum = hatchObj.NumberOfLoops
Print (loopNum)
Dim num As Integer
num = 0
Dim loopObjs As Variant
Dim hatLoop As Object
'hatLoop = Nothing
Do While num < loopNum
Set hatLoop = hatchObj.GetLoopAt(num, loopObjs)
num = num + 1
If hatLoop.IsPolyline Then
Print (111)
Else
Print (222)
End If
Loop
ZoomExtents
End Sub
其中Set hatLoop = hatchObj.GetLoopAt(num, loopObjs)这句一直报缺少函数或变量的错 不知道为什么 |
|
置顶卡
