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

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

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

请高手帮忙解决，在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

wyj7485 发表于 2006-12-31 09:01:00

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

gzmkshjsh 发表于 2007-1-1 15:49:00

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

wyj7485 发表于 2007-1-9 08:25:00

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

查看完整版本: [求助]VBA中利用offset复制后如何填充