使用孵化创建块

RICVBA · 发表于 2017-11-15 19:25:16

我正在尝试帮助一位朋友使用此代码。他们可以使用2个拾取的点绘制得克萨斯州国旗，但希望将结果进行一个块。我想不出来。


Option Explicit
Public Sub DrawTexasFlagOp()
Dim PT1 As Variant
Dim PT2 As Variant
Dim pntLL(0 To 2) As Double
Dim pntLR(0 To 2) As Double
Dim pntUL(0 To 2) As Double
Dim pntUR(0 To 2) As Double
Dim pntLRBlue(0 To 2) As Double
Dim pntURBlue(0 To 2) As Double
Dim vertDist As Double
Dim horzDist As Double
Dim pntRW_Left(0 To 2) As Double
Dim pntRW_Right(0 To 2) As Double
Dim circleDiameter As Double
Dim cntPnt(0 To 2) As Double
Dim cir As AcadCircle
Dim starTopPoint(0 To 2) As Double
' star leg length @ unit circle of 1 = .7265
' starlegLength is variable
Dim starLegLen As Double
Dim starLegStart As Variant
Dim starLegEnd As Variant
PT1 = ThisDrawing.Utility.GetPoint(, "Pick lower left corner of Flag")
vertDist = ThisDrawing.Utility.GetDistance(PT1, vbCr & "Pick distance for vertical")
horzDist = (vertDist / 2) * 3
pntLL(0) = PT1(0) 'X value
pntLL(1) = PT1(1) 'Y value
pntUL(0) = PT1(0)
pntUL(1) = PT1(1) + vertDist
pntLR(0) = PT1(0) + horzDist
pntLR(1) = PT1(1)
pntUR(0) = PT1(0) + horzDist
pntUR(1) = PT1(1) + vertDist
pntLRBlue(0) = pntLL(0) + (horzDist / 3)
pntLRBlue(1) = pntLL(1)
pntURBlue(0) = pntLL(0) + (horzDist / 3)
pntURBlue(1) = pntLL(1) + vertDist
pntRW_Left(0) = pntLRBlue(0)
pntRW_Left(1) = pntLRBlue(1) + (vertDist / 2)
pntRW_Right(0) = pntLR(0)
pntRW_Right(1) = pntRW_Left(1)
circleDiameter = (horzDist / 3) * 0.75
cntPnt(0) = pntLL(0) + horzDist / 6
cntPnt(1) = pntLL(1) + vertDist / 2
starTopPoint(0) = cntPnt(0)
starTopPoint(1) = cntPnt(1) + (circleDiameter / 2)
starLegLen = 0.7265 * (circleDiameter / 2)
Dim plineObjStar As AcadLWPolyline
Dim pointsStar(0 To 21) As Double
starLegStart = starTopPoint
starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(288), starLegLen)
pointsStar(0) = starTopPoint(0)
pointsStar(1) = starTopPoint(1)
pointsStar(2) = starLegEnd(0)
pointsStar(3) = starLegEnd(1)
starLegStart = starLegEnd
starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(0), starLegLen)
pointsStar(4) = starLegEnd(0)
pointsStar(5) = starLegEnd(1)
starLegStart = starLegEnd
starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(216), starLegLen)
pointsStar(6) = starLegEnd(0)
pointsStar(7) = starLegEnd(1)
starLegStart = starLegEnd
starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(288), starLegLen)
pointsStar(8) = starLegEnd(0)
pointsStar(9) = starLegEnd(1)
starLegStart = starLegEnd
starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(144), starLegLen)
pointsStar(10) = starLegEnd(0)
pointsStar(11) = starLegEnd(1)
starLegStart = starLegEnd
starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(216), starLegLen)
pointsStar(12) = starLegEnd(0)
pointsStar(13) = starLegEnd(1)
starLegStart = starLegEnd
starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(72), starLegLen)
pointsStar(14) = starLegEnd(0)
pointsStar(15) = starLegEnd(1)
starLegStart = starLegEnd
starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(144), starLegLen)
pointsStar(16) = starLegEnd(0)
pointsStar(17) = starLegEnd(1)
starLegStart = starLegEnd
starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(0), starLegLen)
pointsStar(18) = starLegEnd(0)
pointsStar(19) = starLegEnd(1)
pointsStar(20) = starTopPoint(0)
pointsStar(21) = starTopPoint(1)
Dim mylayer As AcadLayer
Set mylayer = ThisDrawing.Layers.Add("RED")
mylayer.color = acRed
Set mylayer = ThisDrawing.Layers.Add("WHITE")
mylayer.color = acWhite
Set mylayer = ThisDrawing.Layers.Add("BLUE")
mylayer.color = acBlue
Set mylayer = ThisDrawing.Layers.Item("RED")
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item("0")
Dim hatchObj As AcadHatch
Dim hatchObj2 As AcadHatch
Dim hatchObj3 As AcadHatch ' blue
Dim hatchobj4 As AcadHatch
  Dim patternName As String
  Dim PatternType As Long
  Dim bAssociativity As Boolean
  ' Define the hatch
  patternName = "SOLID"
  PatternType = 0
  bAssociativity = True
  Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
Dim plineObj As AcadLWPolyline
  Dim points(0 To 9) As Double
    points(0) = pntRW_Left(0)
    points(1) = pntRW_Left(1)
    points(2) = pntRW_Right(0)
    points(3) = pntRW_Right(1)
    points(4) = pntUR(0)
    points(5) = pntUR(1)
    points(6) = pntURBlue(0)
    points(7) = pntURBlue(1)
    points(8) = pntRW_Left(0)
    points(9) = pntRW_Left(1)
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
plineObj.Closed = False
Dim outerLoop As Variant
Dim outerLoopArray(0) As Object
Set outerLoopArray(0) = plineObj
outerLoop = outerLoopArray
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.Layer = "WHITE"
hatchObj.Evaluate
plineObj.Delete  ' white hatch polyline
ThisDrawing.Regen True
'create red hatch pline
    points(0) = pntRW_Left(0)
    points(1) = pntRW_Left(1)
    points(2) = pntRW_Right(0)
    points(3) = pntRW_Right(1)
    points(4) = pntLR(0)
    points(5) = pntLR(1)
    points(6) = pntLRBlue(0)
    points(7) = pntLRBlue(1)
    points(8) = pntRW_Left(0)
    points(9) = pntRW_Left(1)
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
plineObj.Closed = False
Set outerLoopArray(0) = plineObj
outerLoop = outerLoopArray
Set hatchObj2 = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
hatchObj2.AppendOuterLoop (outerLoop)
hatchObj2.Layer = "red"
hatchObj2.Evaluate
plineObj.Delete  ' red hatch polyline
points(0) = pntLL(0)
    points(1) = pntLL(1)
    points(2) = pntUL(0)
    points(3) = pntUL(1)
    points(4) = pntURBlue(0)
    points(5) = pntURBlue(1)
    points(6) = pntLRBlue(0)
    points(7) = pntLRBlue(1)
    points(8) = pntLL(0)
    points(9) = pntLL(1)
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
plineObj.Closed = False
Set plineObjStar = ThisDrawing.ModelSpace.AddLightWeightPolyline(pointsStar)
Dim innerLoop As Variant
Dim innerLoopArray(0) As Object
Set innerLoopArray(0) = plineObjStar
innerLoop = innerLoopArray
Set outerLoopArray(0) = plineObj
outerLoop = outerLoopArray
Set hatchObj3 = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
hatchObj3.AppendOuterLoop (outerLoop)
hatchObj3.AppendInnerLoop (innerLoop)
hatchObj3.Layer = "blue"
hatchObj3.Evaluate
plineObj.Delete  ' red hatch polyline
Set hatchobj4 = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
hatchobj4.AppendOuterLoop (innerLoop)
hatchobj4.Layer = "white"
hatchobj4.Evaluate
plineObjStar.Delete
ThisDrawing.Regen True
End Sub
Private Function rtod(r As Double)
rtod = (r * 180) / 3.14159265358979
End Function
Private Function dtor(d As Double)
dtor = (d * 3.14159265358979) / 180
End Function

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

RICVBA · 发表于 2017-11-16 06:22:09

您必须：
1）插入一个新的块对象
2）“添加”所有图形元素（图案填充、LwPoly）到此新创建的块，而不是图形模型空间
3）在图形模型空间中插入新块的块引用
以使代码的更改最小，如以下注释所述：

copy

Option Explicit
Public Sub DrawTexasFlagOp()
       
    Dim PT1 As Variant
    Dim PT2 As Variant
    
    
    Dim pntLL(0 To 2) As Double
    Dim pntLR(0 To 2) As Double
    Dim pntUL(0 To 2) As Double
    Dim pntUR(0 To 2) As Double
    Dim pntLRBlue(0 To 2) As Double
    Dim pntURBlue(0 To 2) As Double
    Dim vertDist As Double
    Dim horzDist As Double
    Dim pntRW_Left(0 To 2) As Double
    Dim pntRW_Right(0 To 2) As Double
    Dim circleDiameter As Double
    Dim cntPnt(0 To 2) As Double
    Dim cir As AcadCircle
    Dim starTopPoint(0 To 2) As Double
    ' star leg length @ unit circle of 1 = .7265
    ' starlegLength is variable
    Dim starLegLen As Double
    Dim starLegStart As Variant
    Dim starLegEnd As Variant
    
    
    PT1 = ThisDrawing.Utility.GetPoint(, "Pick lower left corner of Flag")
    vertDist = ThisDrawing.Utility.GetDistance(PT1, vbCr & "Pick distance for vertical")
    horzDist = (vertDist / 2) * 3
    pntLL(0) = PT1(0) 'X value
    pntLL(1) = PT1(1) 'Y value
    
    
    pntUL(0) = PT1(0)
    pntUL(1) = PT1(1) + vertDist
    
    
    pntLR(0) = PT1(0) + horzDist
    pntLR(1) = PT1(1)
    
    
    pntUR(0) = PT1(0) + horzDist
    pntUR(1) = PT1(1) + vertDist
    
    
    pntLRBlue(0) = pntLL(0) + (horzDist / 3)
    pntLRBlue(1) = pntLL(1)
    
    
    pntURBlue(0) = pntLL(0) + (horzDist / 3)
    pntURBlue(1) = pntLL(1) + vertDist
    
    
    pntRW_Left(0) = pntLRBlue(0)
    pntRW_Left(1) = pntLRBlue(1) + (vertDist / 2)
    pntRW_Right(0) = pntLR(0)
    pntRW_Right(1) = pntRW_Left(1)
    
    
    circleDiameter = (horzDist / 3) * 0.75
    
    
    cntPnt(0) = pntLL(0) + horzDist / 6
    cntPnt(1) = pntLL(1) + vertDist / 2
    
    
    starTopPoint(0) = cntPnt(0)
    starTopPoint(1) = cntPnt(1) + (circleDiameter / 2)
    starLegLen = 0.7265 * (circleDiameter / 2)
    
    
    Dim plineObjStar As AcadLWPolyline
    Dim pointsStar(0 To 21) As Double
    
    
    starLegStart = starTopPoint
    starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(288), starLegLen)
    
    
    pointsStar(0) = starTopPoint(0)
    pointsStar(1) = starTopPoint(1)
    pointsStar(2) = starLegEnd(0)
    pointsStar(3) = starLegEnd(1)
    
    
    starLegStart = starLegEnd
    
    
    starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(0), starLegLen)
    pointsStar(4) = starLegEnd(0)
    pointsStar(5) = starLegEnd(1)
    
    
    starLegStart = starLegEnd
    starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(216), starLegLen)
    pointsStar(6) = starLegEnd(0)
    pointsStar(7) = starLegEnd(1)
    
    
    starLegStart = starLegEnd
    starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(288), starLegLen)
    pointsStar(8) = starLegEnd(0)
    pointsStar(9) = starLegEnd(1)
    
    
    starLegStart = starLegEnd
    starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(144), starLegLen)
    pointsStar(10) = starLegEnd(0)
    pointsStar(11) = starLegEnd(1)
    
    
    starLegStart = starLegEnd
    starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(216), starLegLen)
    pointsStar(12) = starLegEnd(0)
    pointsStar(13) = starLegEnd(1)
    
    
    starLegStart = starLegEnd
    starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(72), starLegLen)
    pointsStar(14) = starLegEnd(0)
    pointsStar(15) = starLegEnd(1)
    
    
    starLegStart = starLegEnd
    starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(144), starLegLen)
    pointsStar(16) = starLegEnd(0)
    pointsStar(17) = starLegEnd(1)
    
    
    starLegStart = starLegEnd
    starLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(0), starLegLen)
    pointsStar(18) = starLegEnd(0)
    pointsStar(19) = starLegEnd(1)
    pointsStar(20) = starTopPoint(0)
    pointsStar(21) = starTopPoint(1)
    
    
    Dim mylayer As AcadLayer
    Set mylayer = ThisDrawing.Layers.Add("RED")
    mylayer.color = acRed
    Set mylayer = ThisDrawing.Layers.Add("WHITE")
    mylayer.color = acWhite
    Set mylayer = ThisDrawing.Layers.Add("BLUE")
    mylayer.color = acBlue
    Set mylayer = ThisDrawing.Layers.Item("RED")
    
    
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item("0")
    
    
    Dim hatchObj As AcadHatch
    Dim hatchObj2 As AcadHatch
    Dim hatchObj3 As AcadHatch ' blue
    Dim hatchobj4 As AcadHatch
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
    '------------------------------------------------------------
    ' Define the block
    Dim flagBlock As AcadBlock
    Set flagBlock = ThisDrawing.Blocks.Add(PT1, "FlagBlock")
    '------------------------------------------------------------
    
    With flagBlock '<--| reference the new block for all subsequent "Add" methods
    
        ' Define the hatch
        patternName = "SOLID"
        PatternType = 0
        bAssociativity = True
        Set hatchObj = .AddHatch(PatternType, patternName, bAssociativity) '<--| .AddHatch will add a hatch to the referenced block, instead of to the drawing modelspace
        
        
        Dim plineObj As AcadLWPolyline
        Dim points(0 To 9) As Double
        points(0) = pntRW_Left(0)
        points(1) = pntRW_Left(1)
        points(2) = pntRW_Right(0)
        points(3) = pntRW_Right(1)
        points(4) = pntUR(0)
        points(5) = pntUR(1)
        points(6) = pntURBlue(0)
        points(7) = pntURBlue(1)
        points(8) = pntRW_Left(0)
        points(9) = pntRW_Left(1)
        Set plineObj = .AddLightWeightPolyline(points) '<--| .AddLightWeightPolyline will add a LWPoly to the referenced block, instead of to the drawing modelspace
        plineObj.Closed = False
        
        
        Dim outerLoop As Variant
        Dim outerLoopArray(0) As Object
        Set outerLoopArray(0) = plineObj
        outerLoop = outerLoopArray
        hatchObj.AppendOuterLoop (outerLoop)
        
        
        hatchObj.Layer = "WHITE"
        hatchObj.Evaluate
        plineObj.Delete  ' white hatch polyline
        ThisDrawing.Regen True
        'create red hatch pline
        points(0) = pntRW_Left(0)
        points(1) = pntRW_Left(1)
        points(2) = pntRW_Right(0)
        points(3) = pntRW_Right(1)
        points(4) = pntLR(0)
        points(5) = pntLR(1)
        points(6) = pntLRBlue(0)
        points(7) = pntLRBlue(1)
        points(8) = pntRW_Left(0)
        points(9) = pntRW_Left(1)
        Set plineObj = .AddLightWeightPolyline(points) '<--| see above comments
        plineObj.Closed = False
        Set outerLoopArray(0) = plineObj
        outerLoop = outerLoopArray
        
        
        Set hatchObj2 = .AddHatch(PatternType, patternName, bAssociativity) '<--| see above comments
        hatchObj2.AppendOuterLoop (outerLoop)
        
        
        hatchObj2.Layer = "red"
        hatchObj2.Evaluate
        plineObj.Delete  ' red hatch polyline
        
        
        points(0) = pntLL(0)
        points(1) = pntLL(1)
        points(2) = pntUL(0)
        points(3) = pntUL(1)
        points(4) = pntURBlue(0)
        points(5) = pntURBlue(1)
        points(6) = pntLRBlue(0)
        points(7) = pntLRBlue(1)
        points(8) = pntLL(0)
        points(9) = pntLL(1)
        Set plineObj = .AddLightWeightPolyline(points) '<--| see above comments
        plineObj.Closed = False
        
        
        Set plineObjStar = .AddLightWeightPolyline(pointsStar) '<--| see above comments
        Dim innerLoop As Variant
        Dim innerLoopArray(0) As Object
        Set innerLoopArray(0) = plineObjStar
        innerLoop = innerLoopArray
        
        
        Set outerLoopArray(0) = plineObj
        outerLoop = outerLoopArray
        Set hatchObj3 = .AddHatch(PatternType, patternName, bAssociativity) '<--| see above comments
        hatchObj3.AppendOuterLoop (outerLoop)
        hatchObj3.AppendInnerLoop (innerLoop)
        hatchObj3.Layer = "blue"
        hatchObj3.Evaluate
        plineObj.Delete  ' red hatch polyline
        
        
        Set hatchobj4 = .AddHatch(PatternType, patternName, bAssociativity) '<--| see above comments
        hatchobj4.AppendOuterLoop (innerLoop)
        hatchobj4.Layer = "white"
        hatchobj4.Evaluate
        plineObjStar.Delete
    End With
    
    '------------------------------------------------------------
    ' Insert the block
    Dim blockRefObj As AcadBlockReference
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(PT1, "FlagBlock", 1#, 1#, 1#, 0)
    '------------------------------------------------------------
    ThisDrawing.Regen True
    ZoomAll
End Sub
Private Function rtod(r As Double)
    rtod = (r * 180) / 3.14159265358979
End Function
Private Function dtor(d As Double)
    dtor = (d * 3.14159265358979) / 180
End Function