使用孵化创建块
我正在尝试帮助一位朋友使用此代码。他们可以使用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
**** Hidden Message ***** 您必须：
1）插入一个新的块对象
2）“添加”所有图形元素（图案填充、LwPoly）到此新创建的块，而不是图形模型空间
3）在图形模型空间中插入新块的块引用
以使代码的更改最小，如以下注释所述：
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
谢了。我想不出那个。我编程AutoCAD已经很久了 不客气
页:
[1]