偏移折线

'frmMain
Option Explicit
' form scope variables
' the offset (thickness of the shape)
Private dOffset As Double
' Insertion Point
Private Ipt(0 To 2) As Double
' Viewport scale
Private ViewScale As Double
' how many breaks
Private Breaks As Integer
' the blank length
Private brkLength As Double
' break calculation modifier
Private dblModifier As Double
Private Sub Go()
    Dim varCoords As Variant
    Dim NewCoords() As Double
    ' the three points necessary to build an angular dimension
    Dim pt1(0 To 2) As Double
    Dim pt2(0 To 2) As Double
    Dim pt3(0 To 2) As Double
    Dim varRet As Variant
    Dim varStPt As Variant
    Dim ObjEntity As AcadLWPolyline
    Dim objNewEntity As AcadLWPolyline
    Dim angle1 As Double
    Dim angle2 As Double
    Dim angle3 As Double
    Dim Dir1 As Double
    Dim Dir2 As Double
    Dim DistTemp As Double
    Dim Dist1 As Double
    Dim Dist2 As Double
    Dim Plus As Boolean
    Dim aPlus As Boolean
    Dim I As Integer
    Dim J As Integer
    Dim count As Integer
    Dim NewCount As Integer
    Dim currentY As Integer
    Dim currentOppY As Integer
    Dim ProjectExist As Boolean
    Dim CurrSegCount As Integer
    Dim CurrOppSegCount As Integer
    Dim BulgeArray() As Integer
    Dim AngleArray() As Double
    Const x = 0
    Const y = 1
    
    ' get the ployline
    Set ObjEntity = Get_Poly
    
    ' if it's a closed polyline then it's going to look funky
    If ObjEntity.Closed Then
        MsgBox "This is a closed polyline, Hmmm..." & vbCr & _
               "I REALLY Don't think you want to do that.. I quit"
        End
    End If
    
    varCoords = ObjEntity.Coordinates
    ' if there are less than 5 points then you can't
    ' get an angle
    If UBound(varCoords)  9.3 Or Height > 6.5 Then
        ThisDrawing.SetVariable "Dimscale", 2
        ViewScale = 0.5
    Else
        ThisDrawing.SetVariable "Dimscale", 1
        ViewScale = 1
    End If
    
    ' dimension the original one
    Call DoDims(varCoords, ObjEntity)
    
End Sub
' takes a vector and a direction from the vector and returns
' whether or not the offset side perpendicular would be an addition
' of ninety degrees or a subtraction of ninety degrees from the
' original vector direction
Private Function isPlus(Vector As Double, Side As Double) As Boolean
    Dim angle1 As Double
    Dim angle2 As Double
    angle1 = Vector
    angle2 = Vector + dtr(180)
    If angle2 > dtr(360) Then angle2 = angle2 - dtr(360)
    If angle2 > angle1 Then ' angle 2 is the large one
        If Side > angle1 And Side  angle2 And Side  Vector2 Then
        SmallAngle = Vector1 - Vector2
    Else
        SmallAngle = Vector2 - Vector1
    End If
    If SmallAngle > dtr(180) Then SmallAngle = dtr(360) - SmallAngle
End Function
Private Sub cmdGo_Click()
    ' get the aluminum thickness and select the
    ' modifier and the thickness
    Select Case listType.ListIndex
        Case 0
            dblModifier = 0.076
            dOffset = 0.05
        Case 1
            dblModifier = 0.095
            dOffset = 0.0625
        Case 2
            dblModifier = 0.1425
            dOffset = 0.09
        Case 3
            dblModifier = 0.19
            dOffset = 0.125
        Case 4
            dblModifier = 0.285
            dOffset = 0.1875
        Case Else
        ' this should never happen so inform the user and exit
            MsgBox "Something is wrong, see the programmer: "
            Exit Sub
    End Select
    Me.Hide
    Call Go
    Call MakeLayout
End Sub
Private Sub DoDims(varCoords As Variant, ObjEntity As AcadEntity)
    Dim txtHeight As Double
    Dim DimOffset As Double
    ' the three points necessary to build an angular dimension
    Dim pt1(0 To 2) As Double
    Dim pt2(0 To 2) As Double
    Dim pt3(0 To 2) As Double
    ' running blank and total length
    Dim dblLength As Double
    Dim dblTotalLength As Double
    ' included angle for calculations
    Dim dblAngle As Double
    ' distance between the 2 end points for calculating
    ' the dimension text location
    Dim dblDist As Double
    ' use x for x and y for y, z for z if needed
    Const x = 0: Const y = 1: Const z = 2
    ' integer counter
    Dim I As Integer
    ' left and right points for the dimensions
    Dim lpt As Variant
    Dim rpt As Variant
    ' get the drawing scale and set the text height and dimension var's
    DwgScale = ThisDrawing.GetVariable("dimscale")
    txtHeight = DwgScale * 0.125
    DimOffset = DwgScale * 1
    ' point for the angular text location (temporary)
    Dim varPT As Variant
    ' dimension object (temporary)
    Dim objDim As AcadDimAngular
    ' set the initial length to zero
    dblLength = 0
    dblTotalLength = 0
        
    ' loop thru the polyline, extract the vertexes
    ' and calculate the angles, length and break distances
    For I = 5 To UBound(varCoords) Step 2
        ' points 1 thru 3
        pt1(x) = varCoords(I - 5)
        pt1(y) = varCoords(I - 4)
        pt2(x) = varCoords(I - 3)
        pt2(y) = varCoords(I - 2)
        pt3(x) = varCoords(I - 1)
        pt3(y) = varCoords(I)
        ' add linear dimensions
        lpt = pt1
        rpt = pt2
        ' get the angle of the first line so we can draw the dimension
        dblAngle = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
        ' draw the dimension
        Call DrawDim(lpt, rpt, DimOffset, dblAngle, "STD1")
        ' test for the last line segment and if it is then draw the dimension
        If I = UBound(varCoords) Then
            lpt = pt2
            rpt = pt3
            dblAngle = ThisDrawing.Utility.AngleFromXAxis(pt2, pt3)
            Call DrawDim(lpt, rpt, DimOffset, dblAngle, "STD1")
        End If
        ' add the length of point 1 and 2
        dblLength = dblLength + Distance(pt1, pt2)
        dblTotalLength = dblTotalLength + Distance(pt1, pt2)
        ' get the distance of the 2 outer end points
        dblDist = Distance(pt1, pt3)
        ' get the angle so we can get the halfway point
        dblAngle = ThisDrawing.Utility.AngleFromXAxis(pt1, pt3)
        ' get the halfway point , we will use this to give us
        ' a text location for the temporary dimension
        varPT = ThisDrawing.Utility.PolarPoint _
                    (pt1, dblAngle, 0.5 * dblDist)
        ' draw the dimension
        Set objDim = ThisDrawing.ModelSpace.AddDimAngular _
                    (pt2, pt1, pt3, varPT)
        ' get the angle between the two segments
        dblAngle = rtd(objDim.Measurement)
        ' if more than ninety then use the excluded angle
        If dblAngle > 90 Then
            dblAngle = 180 - dblAngle
        End If
        ' subtract the break length calculated
        dblLength = dblLength - ((dblAngle / 90) * dblModifier)
        ' if this is the last one then add the last chord
        If I = UBound(varCoords) Then
            dblLength = dblLength + Distance(pt2, pt3)
            dblTotalLength = dblTotalLength + Distance(pt2, pt3)
        End If
    Next I
    ' show the user what the length is
    ' now it's time to get the text location
    ' get the bounding box coordinates
    Dim varMin As Variant
    Dim varMax As Variant
    ObjEntity.GetBoundingBox varMin, varMax
    
    ' set the center point to be used by the viewport code
    Ipt(0) = ((varMax(0) - varMin(0)) / 2) + varMin(0)
    Ipt(1) = ((varMax(1) - varMin(1)) / 2) + varMin(1)
    
    ' set the break length variable to be used in the title block
    brkLength = dblLength
    ' delete the original polyline because we don't need it anymore
    ObjEntity.Delete
    ' now, let's zoom extents so you can see it all, baby
    ThisDrawing.Application.ZoomCenter Ipt, 1
    
End Sub

Private Sub MakeLayout()
    Dim strTitleBlock As String
    Dim strFile
    Dim I As Long
    Dim objLayout As AcadLayout
    Dim objViewPort As AcadPViewport
    Dim objObject As AcadObject
    Dim BlkRef As AcadBlockReference
    Dim Ipt1(0 To 2) As Double
    On Error GoTo err_Handler
    strTitleBlock = "TitleBlock"
    ' NOTE: The drawing 'BKML.dwg' must be in the support path
    strFile = "BKMTL.dwg"
    ' first, let's add the layout
    Set objLayout = ThisDrawing.Layouts.Add(strTitleBlock)
    ' zoom the drawint
    Application.ZoomCenter Ipt, ViewScale
    ' make the layout and go to paper space
    ThisDrawing.ActiveLayout = ThisDrawing.Layouts(strTitleBlock)
    ThisDrawing.ActiveSpace = acPaperSpace
    ' set the insertion point to 0,0
    Ipt1(0) = 0: Ipt1(1) = 0
    ' insert the title block
    Set BlkRef = ThisDrawing.PaperSpace.InsertBlock(Ipt1, strFile, 1, 1, 1, 0)
    ThisDrawing.Application.ZoomCenter Ipt, ViewScale
    ' set the middle of the viewport
    Ipt1(0) = 4.9375: Ipt1(1) = 5#
    Set objViewPort = ThisDrawing.PaperSpace.AddPViewport(Ipt1, 9.375, 6.625)
    ThisDrawing.ActiveSpace = acModelSpace
    ' zoom the viewport
    ThisDrawing.Application.ZoomCenter Ipt, ViewScale
    ' go back to paper space
    ThisDrawing.ActiveSpace = acPaperSpace
    objViewPort.Visible = True
    objViewPort.Display True
    objViewPort.StandardScale = acVpCustomScale
    objViewPort.CustomScale = ViewScale
    objViewPort.DisplayLocked = True
    ThisDrawing.Regen acAllViewports
    ThisDrawing.Application.ZoomExtents
    
    ' now, delete all of the layouts
    Set objLayout = Nothing
    For Each objLayout In ThisDrawing.Layouts
        If objLayout.Name = "Layout1" Then
            objLayout.Delete
        ElseIf objLayout.Name = "Layout2" Then
            objLayout.Delete
        End If
    Next objLayout
    ' now let's insert the Title Info and fill in the data
    Dim varAttrib As Variant
    Dim attribObj As AcadAttributeReference
    ' the block name
    strFile = "BrkInfo"
    ' set the insertion point
    Ipt1(0) = 0.25: Ipt1(1) = 1.1875
    ' round the blank length to 3 spaces
    brkLength = RoundExt(brkLength, 3)
    Set BlkRef = ThisDrawing.PaperSpace.InsertBlock(Ipt1, strFile, 1, 1, 1, 0)
        varAttrib = BlkRef.GetAttributes
    ' fix the attributes text strings
    For I = LBound(varAttrib) To UBound(varAttrib)
        Set attribObj = varAttrib(I)
        Select Case attribObj.TagString
            Case "QUANTITY"
                attribObj.TextString = "1"
            Case "MARK"
                attribObj.TextString = "A"
            Case "DESC"
                attribObj.TextString = "Description"
            Case "LENGTH"
                attribObj.TextString = "1"
            Case "BLANK"
                attribObj.TextString = CStr(brkLength)
            Case "BREAKS"
                attribObj.TextString = CStr(Breaks)
            Case "BAYMARK"
                attribObj.TextString = "Bay"
            Case "REMARKS"
                attribObj.TextString = "Remarks"
            Case Else
        End Select
    Next I
    ' update the blkreference
    BlkRef.Update
    ' Finished - Yeah
    Exit Sub
err_Handler:
    Select Case Err.Number
        Case -2145386475 ' Title block layout already exists
            Err.Clear
            MsgBox "You already have a Title Block Layout " & vbCr & _
                    "Make sure You aren't duplicating Title BLocks"
            Resume Next
        Case Else
            MsgBox Err.Number & " " & Err.Description
    End Select
End Sub
Private Sub UserForm_Initialize()
' fill the aluminum thickenss text box
    listType.AddItem "0.05"
    listType.AddItem "0.0625"
    listType.AddItem "0.09"
    listType.AddItem "0.125"
    listType.AddItem "0.1875"
    ' set the initial index to the first one
    listType.ListIndex = 0
End Sub

Public Function polyentconvert(polyEnt As Object) As AcadPolyline
Dim entity As AcadDocument
Set entity = AutoCAD_Application.ActiveDocument
 Dim I As Integer, j As Integer, K As Integer
 If polyEnt.EntityName = "AcDbPolyline" Then
  Dim Coords As Variant
  Coords = polyEnt.Coordinates
  I = Fix((UBound(Coords) + 1) * 1.5) - 1
  ReDim Coords2(I) As Double
  j = 0
  Dim X As Double, y As Double, z As Double
  For I = LBound(Coords) To UBound(Coords) Step 2
    X = Coords(I): y = Coords(I + 1): z = 0#
    Coords2(j) = X:
    Coords2(j + 1) = y:
    Coords2(j + 2) = z:
    j = j + 3
  Next I
  Dim Coords2V As Variant
  Coords2V = Coords2
  Dim EN2 As AcadPolyline
  Set EN2 = entity.ModelSpace.AddPolyline(Coords2V)
  EN2.Closed = polyEnt.Closed
  EN2.Color = polyEnt.Color
  EN2.Linetype = polyEnt.Linetype
  EN2.Thickness = polyEnt.Thickness
    EN2.Layer = polyEnt.Layer
  Dim b As Double, w As Double, W2 As Double
  For I = 0 To UBound(Coords) Step 2
    j = I / 2
    b = polyEnt.GetBulge(j)
    polyEnt.GetWidth j, w, W2
    EN2.SetBulge j, b
    EN2.SetWidth j, w, W2
  Next I
  Dim polyentx As AcadPolyline
  Set polyentx = EN2
  polyEnt.Delete
 End If
End Function