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

0 Members and 1 Guest are viewing this topic.

David Hall

• Automatic Duh Generator
• King Gator
• Posts: 4043
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 ExplicitPublic Sub DrawTexasFlagOp()Dim PT1 As VariantDim PT2 As VariantDim pntLL(0 To 2) As DoubleDim pntLR(0 To 2) As DoubleDim pntUL(0 To 2) As DoubleDim pntUR(0 To 2) As DoubleDim pntLRBlue(0 To 2) As DoubleDim pntURBlue(0 To 2) As DoubleDim vertDist As DoubleDim horzDist As DoubleDim pntRW_Left(0 To 2) As DoubleDim pntRW_Right(0 To 2) As DoubleDim circleDiameter As DoubleDim cntPnt(0 To 2) As DoubleDim cir As AcadCircleDim starTopPoint(0 To 2) As Double' star leg length @ unit circle of 1 = .7265' starlegLength is variableDim starLegLen As DoubleDim starLegStart As VariantDim starLegEnd As VariantPT1 = ThisDrawing.Utility.GetPoint(, "Pick lower left corner of Flag")vertDist = ThisDrawing.Utility.GetDistance(PT1, vbCr & "Pick distance for vertical")horzDist = (vertDist / 2) * 3pntLL(0) = PT1(0) 'X valuepntLL(1) = PT1(1) 'Y valuepntUL(0) = PT1(0)pntUL(1) = PT1(1) + vertDistpntLR(0) = PT1(0) + horzDistpntLR(1) = PT1(1)pntUR(0) = PT1(0) + horzDistpntUR(1) = PT1(1) + vertDistpntLRBlue(0) = pntLL(0) + (horzDist / 3)pntLRBlue(1) = pntLL(1)pntURBlue(0) = pntLL(0) + (horzDist / 3)pntURBlue(1) = pntLL(1) + vertDistpntRW_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.75cntPnt(0) = pntLL(0) + horzDist / 6cntPnt(1) = pntLL(1) + vertDist / 2starTopPoint(0) = cntPnt(0)starTopPoint(1) = cntPnt(1) + (circleDiameter / 2)starLegLen = 0.7265 * (circleDiameter / 2)Dim plineObjStar As AcadLWPolylineDim pointsStar(0 To 21) As DoublestarLegStart = starTopPointstarLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(288), starLegLen)pointsStar(0) = starTopPoint(0)pointsStar(1) = starTopPoint(1)pointsStar(2) = starLegEnd(0)pointsStar(3) = starLegEnd(1)starLegStart = starLegEndstarLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(0), starLegLen)pointsStar(4) = starLegEnd(0)pointsStar(5) = starLegEnd(1)starLegStart = starLegEndstarLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(216), starLegLen)pointsStar(6) = starLegEnd(0)pointsStar(7) = starLegEnd(1)starLegStart = starLegEndstarLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(288), starLegLen)pointsStar(8) = starLegEnd(0)pointsStar(9) = starLegEnd(1)starLegStart = starLegEndstarLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(144), starLegLen)pointsStar(10) = starLegEnd(0)pointsStar(11) = starLegEnd(1)starLegStart = starLegEndstarLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(216), starLegLen)pointsStar(12) = starLegEnd(0)pointsStar(13) = starLegEnd(1)starLegStart = starLegEndstarLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(72), starLegLen)pointsStar(14) = starLegEnd(0)pointsStar(15) = starLegEnd(1)starLegStart = starLegEndstarLegEnd = ThisDrawing.Utility.PolarPoint(starLegStart, dtor(144), starLegLen)pointsStar(16) = starLegEnd(0)pointsStar(17) = starLegEnd(1)starLegStart = starLegEndstarLegEnd = 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 AcadLayerSet mylayer = ThisDrawing.Layers.Add("RED")mylayer.color = acRedSet mylayer = ThisDrawing.Layers.Add("WHITE")mylayer.color = acWhiteSet mylayer = ThisDrawing.Layers.Add("BLUE")mylayer.color = acBlueSet mylayer = ThisDrawing.Layers.Item("RED")ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item("0")Dim hatchObj As AcadHatchDim hatchObj2 As AcadHatchDim hatchObj3 As AcadHatch ' blueDim 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 = FalseDim outerLoop As VariantDim outerLoopArray(0) As ObjectSet outerLoopArray(0) = plineObjouterLoop = outerLoopArrayhatchObj.AppendOuterLoop (outerLoop)hatchObj.Layer = "WHITE"hatchObj.EvaluateplineObj.Delete  ' white hatch polylineThisDrawing.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 = FalseSet outerLoopArray(0) = plineObjouterLoop = outerLoopArraySet hatchObj2 = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)hatchObj2.AppendOuterLoop (outerLoop)hatchObj2.Layer = "red"hatchObj2.EvaluateplineObj.Delete  ' red hatch polylinepoints(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 = FalseSet plineObjStar = ThisDrawing.ModelSpace.AddLightWeightPolyline(pointsStar)Dim innerLoop As VariantDim innerLoopArray(0) As ObjectSet innerLoopArray(0) = plineObjStarinnerLoop = innerLoopArraySet outerLoopArray(0) = plineObjouterLoop = outerLoopArraySet hatchObj3 = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)hatchObj3.AppendOuterLoop (outerLoop)hatchObj3.AppendInnerLoop (innerLoop)hatchObj3.Layer = "blue"hatchObj3.EvaluateplineObj.Delete  ' red hatch polylineSet hatchobj4 = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)hatchobj4.AppendOuterLoop (innerLoop)hatchobj4.Layer = "white"hatchobj4.EvaluateplineObjStar.DeleteThisDrawing.Regen TrueEnd SubPrivate Function rtod(r As Double)rtod = (r * 180) / 3.14159265358979End FunctionPrivate Function dtor(d As Double)dtor = (d * 3.14159265358979) / 180End 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 a close second

RICVBA

• Newt
• Posts: 62
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 ExplicitPublic 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    ZoomAllEnd SubPrivate Function rtod(r As Double)    rtod = (r * 180) / 3.14159265358979End FunctionPrivate Function dtor(d As Double)    dtor = (d * 3.14159265358979) / 180End Function`

David Hall

• Automatic Duh Generator
• King Gator
• Posts: 4043
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 a close second

RICVBA

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