从分解块挤出区域

Public Sub DrawWideFlangeSteel()
      Dim oCyl As Acad3DSolid, oCircle As AcadCircle, oLine As AcadLine, oLayer As AcadLayer
      Dim oBeam As Acad3DSolid, oReg As AcadRegion, oBlock As AcadBlockReference, oObject As AcadObject
      Dim varpick As Variant
      Dim Ent As AcadEntity
      Dim Inspt As Variant
      Dim RegEnt(0) As AcadEntity
      Dim V(2) As Double, Unit As Double, Vn(2) As Double, dblBusDia As Double
      Dim P1, P2
      Dim newPT1 As Variant
      Dim newPT2 As Variant
      Set oLayer = ThisDrawing.Layers.Add("3D-BUSS-STEEL")
      oLayer.color = 235
      
      Inspt = ThisDrawing.Utility.GetPoint(, "Pick Insertion Point: ")
      If ThisDrawing.ActiveSpace = acModelSpace Then
      Set oBlock = ThisDrawing.ModelSpace.InsertBlock(Inspt, "M:\MODEL-COMPONENTS\w8x24.dwg", 1#, 1#, 1#, 0)
      Else
      Set oBlock = ThisDrawing.PaperSpace.InsertBlock(Inspt, "M:\MODEL-COMPONENTS\w8x24.dwg", 1#, 1#, 1#, 0)
      End If
      ThisDrawing.Regen acActiveViewport
Set oObject = oBlock.Explode
'      ThisDrawing.Utility.GetEntity Ent, varpick
'      If Not TypeOf Ent Is AcadLine Then
'            MsgBox "That was not a Layout Line"
'            Exit Sub
'      End If
'      Set oLine = Ent
'      newPT1 = oLine.StartPoint
'      newPT2 = oLine.EndPoint
'      newPT1(2) = ConvertFeet(frmInsPart.cboBusHeight.Value)
'      newPT2(2) = ConvertFeet(frmInsPart.cboBusHeight.Value)
'      Set oLine = ThisDrawing.ModelSpace.AddLine(newPT1, newPT2)
'      oLine.Layer = "3D-BUSS-CALC"
'      P1 = oLine.StartPoint: P2 = oLine.EndPoint
'      V(0) = P2(0) - P1(0): V(1) = P2(1) - P1(1): V(2) = P2(2) - P1(2)
      'Normalise the vector(It's length=1)
'      Unit = Sqr(V(0) * V(0) + V(1) * V(1) + V(2) * V(2))
'      Vn(0) = V(0) / Unit: Vn(1) = V(1) / Unit: Vn(2) = V(2) / Unit
'      dblBusDia = CDbl(frmInsPart.cboBusSize.Value + 0.5) / 2
'      Set oCircle = ThisDrawing.ModelSpace.AddCircle(oLine.StartPoint, dblBusDia)
      ThisDrawing.Regen acActiveViewport
'      oCircle.Normal = Vn    ' Vn or V both work here.
'      ThisDrawing.Regen acActiveViewport
'      Set RegEnt(0) = oCircle
'      oReg = ThisDrawing.ModelSpace.AddRegion(RegEnt)
'      Set oCyl = ThisDrawing.ModelSpace.AddExtrudedSolid(oReg(0), oLine.Length, 0)
'      oCircle.Delete
'      oReg(0).Delete
End Sub

Public Sub AddDeadEnd(PhSpace As Double, PoleSp As Double, PoleHt As Double, BmHt As Double)
      Const VK_ESCAPE = &H1B
      Const VK_LBUTTON = &H1
      Const VK_SPACE = &H20
      Const VK_RETURN = &HD
      Const VK_LEFT = &H25
      On Err GoTo err_control
      Dim inspt As Variant, dblRotation As Double, dblTOC As Double, leftLeg As Variant, rightLeg As Variant
      Dim oCurrLayeR As AcadLayer, intAutoSnap As Integer, intOSMode As Integer, PI As Double, LL2 As Variant
      Dim oPline As AcadLWPolyline, oEntity(0) As AcadEntity, regent(0) As AcadEntity, obj3d As Acad3DSolid
      Dim objRegion
      Set oCurrLayeR = ThisDrawing.ActiveLayer
      'IsSetup
      dblTOC = CDbl(InputBox("What is T.O.C. elevation? ie 12 or 0 or -12"))
      ThisDrawing.SetVariable "ORTHOMODE", 1
      intAutoSnap = ThisDrawing.GetVariable("AUTOSNAP")
      ThisDrawing.SetVariable "AUTOSNAP", 0
      intOSMode = ThisDrawing.GetVariable("OSMODE")
      ThisDrawing.SetVariable "OSMODE", 32
      inspt = ThisDrawing.Utility.GetPoint(, "Select Deadend Insertion Point: ")
      ThisDrawing.SetVariable "OSMODE", 512
      dblRotation = ThisDrawing.Utility.GetAngle(inspt, "Pick Line Direction: ")
      PI = Atn(1) * 4
      ThisDrawing.SetVariable "OSMODE", 0
      inspt(2) = inspt(2) + dblTOC
      leftLeg = ThisDrawing.Utility.PolarPoint(inspt, dblRotation - ((PI * 90) / 180), PoleSp / 2)
      rightLeg = ThisDrawing.Utility.PolarPoint(inspt, dblRotation + ((PI * 90) / 180), PoleSp / 2)
      Call LayerSet("3D-STEL", 235)
      DrawDeadendPole leftLeg, PoleHt
      DrawDeadendPole rightLeg, PoleHt
      leftLeg(2) = leftLeg(2) + BmHt
      Set oPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(PolygonVexs(leftLeg, 8, 5))
      oPline.Closed = True
      oPline.Elevation = BmHt
      oPline.Update
      Set regent(0) = oPline
      objRegion = ThisDrawing.ModelSpace.AddRegion(regent)
      Set obj3d = ThisDrawing.ModelSpace.AddExtrudedSolid(objRegion(0), PoleSp, 0)
      regent(0).Delete
      objRegion(0).Delete
      
      LL2 = ThisDrawing.Utility.PolarPoint(leftLeg, dblRotation, 12)
      obj3d.Rotate3D leftLeg, LL2, ((PI * -90) / 180)
Exit_Here:
      ThisDrawing.ActiveLayer = oCurrLayeR
      ThisDrawing.SetVariable "AUTOSNAP", intAutoSnap
      ThisDrawing.SetVariable "OSMODE", intOSMode
      ThisDrawing.SetVariable "INSUNITS", 1
      Exit Sub
err_control:
      Select Case Err.Number
      Case -2147352567
      'Debug.Print Err.Number, Err.Description
            varcancel = ThisDrawing.GetVariable("LASTPROMPT")
            If InStr(1, varcancel, "*Cancel*")  0 Then
                  If GetAsyncKeyState(VK_ESCAPE) And 8000 > 0 Then
                        Err.Clear
                        Resume Exit_Here
                  ElseIf GetAsyncKeyState(VK_LBUTTON) > 0 Then
                        Err.Clear
                        Resume
                  End If
            Else
                  If GetAsyncKeyState(VK_SPACE) Then
                        Resume Exit_Here
                  End If
      'Missed the pick, send them back!
                  Err.Clear
                  Resume
            End If
      Case Else
            MsgBox Err.Description
            Resume Exit_Here
      End Select
End Sub

Private Sub DrawDeadendPole(insptpole As Variant, PoleHt As Double)
      Dim dblBase As Double, dblTop As Double, dblHeight As Double
      Dim obj3d As Acad3DSolid, regent(0) As AcadEntity
      Dim oPline As AcadLWPolyline
      Dim cenPt As Variant, iNum As Integer, intAutoSnap As Integer
      Dim dblAng As Double, dblRad As Double, dblAngle As Double
      Dim objRegion
      dblHeight = PoleHt
      dblTop = 18 / 2
      dblAngle = Atn((dblTop - dblBase) / dblHeight)
      iNum = 12
      cenPt = insptpole
      dblRad = 29 / 2
      Set oPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(PolygonVexs(cenPt, iNum, dblRad))
      oPline.ConstantWidth = 0
      oPline.Layer = "0"
      oPline.Closed = True
      oPline.Update
      Set regent(0) = oPline
      objRegion = ThisDrawing.ModelSpace.AddRegion(regent)
      Set obj3d = ThisDrawing.ModelSpace.AddExtrudedSolid(objRegion(0), dblHeight, dblAngle)
      regent(0).Delete
      objRegion(0).Delete
      ThisDrawing.Regen acActiveViewport
End Sub
Function PolygonVexs(cenPt As Variant, iNum As Integer, _
                     dblRad As Double, Optional mode As Integer = 0) As Variant
      Dim tmpPt As Variant
      Dim iCnt As Integer
      Dim vCnt As Integer
      Dim vxCnt As Integer
      Dim PI As Double
      PI = Atn(1) * 4
      Dim dltAng As Double
      Dim dblAng As Double
      Dim initAng As Double
      dltAng = 2 * PI / iNum
      initAng = dltAng / 2
      vxCnt = 2 * iNum - 1
      iCnt = 0
      vCnt = 0
      ReDim ptsarr(0 To vxCnt) As Double
      If mode = 0 Then dblRad = dblRad / Cos(dltAng / 2)
      While iCnt < iNum
            dblAng = initAng + dltAng * iCnt
            tmpPt = ThisDrawing.Utility.PolarPoint(cenPt, dblAng, dblRad)
            iCnt = iCnt + 1
            ptsarr(vCnt) = tmpPt(0): ptsarr(vCnt + 1) = tmpPt(1)
            vCnt = vCnt + 2
      Wend
      PolygonVexs = ptsarr
End Function