Author Topic: Create block using hatch  (Read 33 times)

0 Members and 1 Guest are viewing this topic.

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4038
Create block using hatch
« on: November 15, 2017, 07:25:16 pm »
I am trying to help a friend with this code.  They can draw the Texas flag using 2 picked points, but would like to make a block out of the result.  I cant figure it out.


Code: [Select]

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
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's pretty close

RICVBA

  • Newt
  • Posts: 53
Re: Create block using hatch
« Reply #1 on: November 16, 2017, 06:22:09 am »
you have to:

1) insert a new Block object

2) "Add" all graphic elements (hatches, LWPolys) to this newly created block, instead of to the drawing modelspace

3) insert a block reference of the new block in the drawing modelspace

so the changes to your code are minimal, as outlined by comments in the following:

Code: [Select]
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

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4038
Re: Create block using hatch
« Reply #2 on: November 16, 2017, 08:06:21 am »
Thanks.  I could not figure that one out.  It's been to long since I programmed AutoCAD
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's pretty close

RICVBA

  • Newt
  • Posts: 53
Re: Create block using hatch
« Reply #3 on: November 16, 2017, 09:11:14 am »
you are welcome