CAD-VBA创建填充圆

1、CAD VBA创建填充圆Sub Command1_Click()Dim center(0 To 2) As DoubleDim radius As DoubleDim entity As ObjectDim found As BooleanDim hatchObj As AcadHatchDim patternName As StringDim PatternType As LongDim bAssociativity As BooleanThisDrawing.ActiveLayer.color = 4 设置当前图层为青色patternName = SOLID 填充样式PatternType

2、 = 0bAssociativity = TrueDim circleobj(0 To 0) As AcadCircle 声明填充边界Set hatchObj = ThisDrawing.ModelSpace.AddHatch _(PatternType, patternName, bAssociativity) 创建填充center(0) = 0center(1) = 0center(2) = 0radius = 17 Set circleobj(0) = ThisDrawing.ModelSpace.AddCircle(center, radius) 创建需要填充的边界 hatchObj.

3、AppendOuterLoop (circleobj) 填充End SubDim entity As ObjectDim found As BooleanDim hatchObj As AcadHatchDim patternName As StringDim PatternType As LongDim bAssociativity As BooleanpatternName = SOLID 填充样式PatternType = 0bAssociativity = TrueDim circleobj(0 To 0) As AcadCircle 声明填充边界Set hatchObj = This

4、Drawing.ModelSpace.AddHatch _(PatternType, patternName, bAssociativity) 创建填充 For Each entity In ThisDrawing.ModelSpace With entity If (.EntityName = AcDbCircle) Then If (.Radius = 0.4) Then 若圆半径为0.4 Set circleobj(0) = ThisDrawing.ModelSpace.AddCircle(.Center, 1.28) 创建需要填充的边界 hatchObj.AppendOuterLoop (circleobj) 填充 found = True End If End If End With Set entity = Nothing 清空当前实体 Set circleobj(0) = Nothing 清空边界 Next entity 下一实体