[求助]VBA中利用offset复制后如何填充

gzmkshjsh · 发表于 2006-12-21 16:31:00

请高手帮忙解决，在VBA开发的程序中，如何对用offset复制的封闭的多边形进行图案填充！

mccad · 发表于 2006-12-21 21:40:00

OFFSET后的对象是可以取得的，只要能够取得，就可以对其操作。

兰州人 · 发表于 2006-12-24 16:07:00

Dim circObj As AcadCircle
Dim currCenterPt(0 To 2) As Double
Dim newCenterPt(0 To 2) As Double
Dim radius As Double
currCenterPt(0) = 20: currCenterPt(1) = 30: currCenterPt(2) = 0
radius = 3
Set circObj = ThisDrawing.ModelSpace.AddCircle(currCenterPt, radius)
Dim offsetObj As Variant
offsetObj = circObj.Offset(5) '经过offset处理的图元

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

' Define the hatch
patternName = "ANSI31"
PatternType = 0
bAssociativity = True
Dim hatchObj As AcadHatch
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
Dim outerLoop(0 To 0) As AcadEntity
Set outerLoop(0) = offsetObj(0)

hatchObj.AppendInnerLoop (outerLoop)'填充offset图元的填充线
hatchObj.Evaluate
ThisDrawing.Regen True
注:要是充填circObj和offsetObj所包含的填充部分, hatchObj.AppendInnerLoop (outerLoop)和 hatchObj.AppendInnerLoop (innerLoop)两次处理

gzmkshjsh · 发表于 2006-12-25 12:07:00

谢谢明总和兰州人版主，回去试试

gzmkshjsh · 发表于 2006-12-28 09:43:00

回去试了上面的程序，并利用其它形状的封闭图进行试验都成功了，但是我利用offset命令组成的封闭图形去无法填充，程序如下，请明总和兰州人版主给予指导！
Sub Example_offset1()
Dim lineObj1 As AcadLine, lineObj2 As AcadLine
Dim sPt1(0 To 2) As Double, ePt1(0 To 2) As Double
Dim sPt2(0 To 2) As Double, ePt2(0 To 2) As Double

' 定义第一条直线起点和终点
sPt1(0) = 100#: sPt1(1) = 100#
ePt1(0) = 500#: ePt1(1) = 100#
'创建第一条直线
Set lineObj1 = ThisDrawing.ModelSpace.AddLine(sPt1, ePt1)

' 定义第二条直线起点和终点
sPt2(0) = 100#: sPt2(1) = 100#
ePt2(0) = 100#: ePt2(1) = 500#
'创建第二条直线
Set lineObj2 = ThisDrawing.ModelSpace.AddLine(sPt2, ePt2)

Dim offsetObj1 As Variant, offsetObj2 As Variant
'偏移第一条直线
offsetObj1 = lineObj1.Offset(400)
'偏移第二条直线
offsetObj2 = lineObj2.Offset(-400)

'创建图案填充
Dim hatchObj As AcadHatch
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean

patternName = "ANSI31"
PatternType = 0
bAssociativity = True
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)

Dim outerLoop(0 To 3) As AcadEntity
Set outerLoop(0) = lineObj1
Set outerLoop(1) = lineObj2
Set outerLoop(2) = offsetObj1 '运行到这里出现错误，无法执行下去
Set outerLoop(3) = offsetObj2
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.Evaluate
ThisDrawing.Regen True

ZoomAll
End Sub