偏移多段线

'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

'' breakmetal.dvb
'' 5/2/01
'' runs inside autocad to extract vertexes and lengths from
'' lightweightpolylines drawn by the user to calculate the
'' break length of sheetmetal
''
'' calculations are dependant upon the included angle of the
'' vertex and the thickness of the aluminum used
''
'' if the included angle is greater than 90 then the opposite
'' angle is used - for some reason for more than 90 degrees the
'' amount adjusted is equal to the opposite side angle
''
'' Vba only lets me get the array of points in x and y values
'' since I had to get lengths and angles I used to following techniques:
'' For lengths I created a function call "Distance" using trig
'' For the angles I created an angular dimension using the endpoints and
'' the vertex along with a text location I calculated from a point halfway
'' of an imaginary line between the two end points - pt1, and pt3
'' I then extracted the measurement in radians and converted to degrees
'' for the calculation and then delete the dimension
' public variables
' the drawing scale factor
Public DwgScale As Double
' main sub
Public Sub Main()
    frmMain.Show
End Sub
' get lwpolyline sub
Public Function Get_Poly() As AcadLWPolyline
    Dim ObjEntity As AcadLWPolyline
    Dim varPoint As Variant
    On Error GoTo PickError:
    ThisDrawing.Utility.GetEntity _
                ObjEntity, varPoint, "Please Pick a PolyLine: "
    Set Get_Poly = ObjEntity
    Exit Function
PickError:
    Dim Answer As Integer
    ' display a message in case the user picked something
    ' other than a lightweightpolyline or did not pick
    ' anything at all
    Answer = MsgBox("You did not pick a polyline!" _
                & vbLf & "Try Again?", 52, "Break Metal")
    ' if the answer is not "OK" then end the program
    If Answer  6 Then
        End
    End If
    ' if the answer is "OK" then try again
    Resume
End Function
' obtain distance function from 2 points
Function Distance(sp As Variant, ep As Variant)
    Dim x As Double
    Dim y As Double
    Dim z As Double
    x = sp(0) - ep(0)
    y = sp(1) - ep(1)
    z = sp(2) - ep(2)
    Distance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function
' radians to degress function
Function rtd(rad As Double) As Double
    rtd = (rad / PI) * 180
End Function
' degrees to rad
Public Function dtr(a As Double) As Double
 dtr = (a / 180) * PI()
End Function
' the pi forumula for the dtr and rdt functions
Public Function PI() As Double
 PI = Atn(1) * 4
End Function
' draws a rotated dimension
Sub DrawDim(lpt As Variant, rpt As Variant, Offset As Double, _
                DimDir As Double, Dimtype As String)
    Dim NewDimStyle As AcadDimStyle
    Dim DimObj As AcadDimRotated
    Dim LdimPt(0 To 2) As Double
    Dim RdimPt(0 To 2) As Double
    Dim DimLoc(0 To 2) As Double
    Dim TempVar As Variant
    Dim DimDir90 As Double
    On Error GoTo BlkError
    ' set the current dimension style to the Dimtype parameter
    ' passed to the program
    Set NewDimStyle = ThisDrawing.DimStyles.Item(Dimtype)
    ThisDrawing.ActiveDimStyle = NewDimStyle
    ThisDrawing.SetVariable "Dimscale", DwgScale
    ThisDrawing.ActiveDimStyle.CopyFrom ThisDrawing
    ' left and right dimension points
    LdimPt(0) = lpt(0): LdimPt(1) = lpt(1)
    RdimPt(0) = rpt(0): RdimPt(1) = rpt(1)
    TempVar = lpt
    ' 90degrees from dimension direction
    DimDir90 = dtr(90) + DimDir
    ' get the dimension location
    TempVar = ThisDrawing.Utility.PolarPoint(TempVar, DimDir90, Offset)
    DimLoc(0) = TempVar(0): DimLoc(1) = TempVar(1)
    ' create the dimension object
    Set DimObj = ThisDrawing.ModelSpace.AddDimRotated(LdimPt, RdimPt, DimLoc, DimDir)
    Exit Sub
BlkError:
    Select Case Err.Number
        Case -2145386476 ' dimstyle does not exist
            Resume Next
        Case Else
            Exit Sub
    End Select
End Sub
' checks to see if a number is even or NOT
Public Function isEven(iNum As Integer) As Boolean
    Dim Answer As Boolean
    If iNum Mod 2 = 0 Then
        Answer = True
    Else
        Answer = False
    End If
    isEven = Answer
End Function