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

gzmkshjsh

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

mccad

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

兰州人

  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

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

gzmkshjsh

回去试了上面的程序，并利用其它形状的封闭图进行试验都成功了，但是我利用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

wyj7485

offsetObj1 ，offsetObj2改为   是对象数组，改为offsetObj1 （0），offsetObj2（0）

gzmkshjsh

试过了，成功了，又学到一点知识，非常感谢wyj7485版主。再请问wyj7485版主，利用VBA程序对图形填充，如何利用程序设定填充比例不受图形大小限制？

wyj7485

gzmkshjsh发表于2007-1-1 15:49:00利用VBA程序对图形填充，如何利用程序设定填充比例不受图形大小限制？

恐怕不好实现，线型比例是个麻烦的事，不同大小图形看是不同的