Topic: Offset a polyline

[Troy Williams]

Does anyone have a code sample that offsets a polyline similar to the offset command in AutoCAD?

[Draftek]

I kinda did that a few years ago using vba to take a polyline profile of one side of an extrusion to calculate some breakmetal bends. It is quite a lot of code. If you want to parse thru it to get what you want, I'll be glad to post.

[Troy Williams]

I kinda did that a few years ago using vba to take a polyline profile of one side of an extrusion to calculate some breakmetal bends. It is quite a lot of code. If you want to parse thru it to get what you want, I'll be glad to post.

Thanks for the offer, I appreciate it.

I have a good idea on what needs to be done but I can't seem to figure out the starting point. The way I see it is that a polyline can consist of hundreds of segments (I am only interested in straight segments, no fancy stuff like bulges) and can be opened or closed. The first step is to determine which side the offset is on (left, right, top, bottom, inside or outside). Each segment needs to be offset by a certain amount along a line that is perpendicular to the line segment. The perpendicular is the one that points in the correct offset direction (either positive or negative). Once I have the correct perpendicular line then I can easily create an offset of the line segment. Since all polylines are either clockwise or counter-clockwise I can pretty much use the first perpendicular as a reference to tell me wheather each of the segments use a positive or negative perpendicular offset. From there it is simply a matter of finding all the intersection points of the adjacent segments and constructing the offset entity.

I hope that made sense. I am having problems figuring out if the perpendicular offset should be negative or positive. I'd love to post a diagram, but I won't have access to a proper system till next week.

[Jeff_M]

Hi Troy,
I think you are looking too deep into this. Wouldn't be easier to just offset the pline instead of the individual segments? Plines are offset with a positive value being to the right, and negative to the left, in relation to the direction they were drawn. So that leaves just finding the side that is selected when the offset is a given distance, and finding the perpendicular distance at the specified point for a "Through" distance.

Does that make it any simpler? 

[Troy Williams]

Hi Troy,
I think you are looking too deep into this. Wouldn't be easier to just offset the pline instead of the individual segments? Plines are offset with a positive value being to the right, and negative to the left, in relation to the direction they were drawn. So that leaves just finding the side that is selected when the offset is a given distance, and finding the perpendicular distance at the specified point for a "Through" distance.

Does that make it any simpler? 

Jeff, that does make it simpler! I'll see if I can work out the math today. Thanks!

[Draftek]

Well, if you can do that then this may be overkill but here it is anyway. There will be way more here than you are interested in and I'm sorry for bad coding techniques but this is a few years old. Of course you will not be interested in the buldges but I needed them to show the sheetmetal bends.

here is the form code:

Code: [Select]

'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) < 5 Then ' inform and insult the user
        MsgBox "This polyline has less than 2 sides you dork"
        Exit Sub
    End If
    ' set the new coordinates boundaries
    count = UBound(varCoords)
    ReDim NewCoords(count * 3)
    NewCount = UBound(NewCoords)
    ' get the first vector of the polyline and the direction from point1 to point2
    pt1(x) = varCoords(0): pt1(y) = varCoords(1)
    pt2(x) = varCoords(2): pt2(y) = varCoords(3)
    Dir1 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
   
    ' get the middle point so we can get a direction
    Dist1 = Distance(pt1, pt2)
    varStPt = ThisDrawing.Utility.PolarPoint(pt1, Dir1, 0.5 * Dist1)
    angle1 = ThisDrawing.Utility.GetAngle(varStPt, "Pick Side To Offset: ")
   
    ' do we add 90 along the path or subtract 90 for the offset direction
    Plus = isPlus(Dir1, angle1)
   
    ' and the array of the buldges
    ReDim BulgeArray(CInt((count - 3) / 2) - 1)
    ReDim AngleArray(UBound(BulgeArray))
    ' set the breaks to this number plus one
    Breaks = UBound(BulgeArray) + 1
    Dim TmpCount As Integer
    ' calculate the total segment count
    TmpCount = CInt((count - 1) / 2)
    TmpCount = (TmpCount * 2) + TmpCount
    'initialize the j counter and the segment counters
    J = 0
    CurrSegCount = 0
    CurrOppSegCount = TmpCount
    ' loop thru the points and process the polyline
    For I = 5 To count 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)
        ' get the distances
        Dist1 = Distance(pt1, pt2)
        Dist2 = Distance(pt2, pt3)
        ' get the directions
        Dir1 = ThisDrawing.Utility.AngleFromXAxis(pt2, pt1)
        Dir2 = ThisDrawing.Utility.AngleFromXAxis(pt2, pt3)
        ' set the small angle
        angle1 = SmallAngle(Dir1, Dir2)
        ' reverse the direction of the first vector to follow the polyline path
        Dir1 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
        ' set the angle perpendicular to the current vector
        If Plus Then
            angle2 = Dir1 + dtr(90)
        Else
            angle2 = Dir1 - dtr(90)
        End If
        ' is the current angle in the plus direction or not
        aPlus = isPlus(Dir1, Dir2)
        ' first we sould test to see whether this is the first angle
        ' if it is then do the square corner stuff
        If I = 5 Then ' first segment
            ' set the first and last points of the new polyline
            ' First Point
            NewCoords(x) = varCoords(x): NewCoords(y) = varCoords(y)
            ' last point
            NewCoords(NewCount - 1) = varCoords(x): NewCoords(NewCount) = varCoords(y)
            ' second to last point - move over the offset distance
            varRet = ThisDrawing.Utility.PolarPoint(pt1, angle2, dOffset)
            ' set the coordinates
            NewCoords(NewCount - 3) = varRet(x): NewCoords(NewCount - 2) = varRet(y)
            ' set the current y place and the opposite y place
            currentY = 1
            currentOppY = NewCount - 2
            ' segment index for the buldge calculation
            CurrSegCount = 1
            CurrOppSegCount = CurrOppSegCount - 2
        End If
        ' do we project the bulge points on the existing line or the projected line
        If Plus Then
            If aPlus Then
                ProjectExist = True
            Else
                ProjectExist = False
            End If
        Else
            If aPlus Then
                ProjectExist = False
            Else
                ProjectExist = True
            End If
        End If
        ' now calculate offset distance
        If angle1 = 0 Then angle1 = dtr(360)
        DistTemp = (dOffset / (Tan(0.5 * angle1)))
        If angle1 = dtr(360) Then angle1 = 0
        If ProjectExist Then ' project the buldge on the existing line
            ' go back dir1
            varRet = ThisDrawing.Utility.PolarPoint(pt2, Dir1 - dtr(180), DistTemp)
            NewCoords(currentY + 1) = varRet(x): NewCoords(currentY + 2) = varRet(y)
            ' now set the opposite corner
            varRet = ThisDrawing.Utility.PolarPoint(varRet, angle2, dOffset)
            NewCoords(currentOppY - 3) = varRet(x): NewCoords(currentOppY - 2) = varRet(y)
            ' now go up dir2
            varRet = ThisDrawing.Utility.PolarPoint(pt2, Dir2, DistTemp)
            NewCoords(currentY + 3) = varRet(x): NewCoords(currentY + 4) = varRet(y)
            ' reset currenty and opposite y
            currentY = currentY + 4
            currentOppY = currentOppY - 2
            ' set the buldge and move the counters
            BulgeArray(J) = CurrSegCount
            AngleArray(J) = Tan((dtr(180) - angle1) / 4)
            CurrSegCount = CurrSegCount + 2
            CurrOppSegCount = CurrOppSegCount - 1
        Else ' project the buldge on the new line
            ' set angle3 to the perpendicular of the second line
            If Plus Then
                angle3 = Dir2 + dtr(90)
            Else
                angle3 = Dir2 - dtr(90)
            End If
            ' set the existing
            NewCoords(currentY + 1) = pt2(x): NewCoords(currentY + 2) = pt2(y)
            ' do the opposite
            varRet = ThisDrawing.Utility.PolarPoint(pt2, angle2, dOffset)
            NewCoords(currentOppY - 3) = varRet(x): NewCoords(currentOppY - 2) = varRet(y)
            varRet = ThisDrawing.Utility.PolarPoint(pt2, angle3, dOffset)
            NewCoords(currentOppY - 5) = varRet(x): NewCoords(currentOppY - 4) = varRet(y)
            ' reset the running counts of y placeholders
            currentY = currentY + 2
            currentOppY = currentOppY - 4
            ' set the buldge and move the counters
            BulgeArray(J) = CurrOppSegCount
            AngleArray(J) = Tan((dtr(180) - angle1) / 4)
            CurrOppSegCount = CurrOppSegCount - 2
            CurrSegCount = CurrSegCount + 1
        End If
        ' If it's the last one then do the last stuff
        If I = count Then ' the last one
            ' reset the offset angle to match
            If Plus Then
                angle2 = Dir2 + dtr(90)
            Else
                angle2 = Dir2 - dtr(90)
            End If
            NewCoords(currentY + 1) = varCoords(count - 1): NewCoords(currentY + 2) = varCoords(count)
            ' get the point we need
            varRet = ThisDrawing.Utility.PolarPoint(pt3, angle2, dOffset)
            ' set the coordinates
            NewCoords(currentY + 3) = varRet(x): NewCoords(currentY + 4) = varRet(y)
        End If
        ' increment the buldge counter
        J = J + 1
    Next I
    ' make the polyline
    Set objNewEntity = ThisDrawing.ModelSpace.AddLightWeightPolyline(NewCoords)
    ' do the bulges
    Dim tmpDir As Double
    For J = 0 To UBound(BulgeArray)
        ' which direction
        If Plus Then
            tmpDir = AngleArray(J)
        Else
            tmpDir = -AngleArray(J)
        End If
        objNewEntity.SetBulge BulgeArray(J), tmpDir
    Next J
   
    objNewEntity.Closed = True
   
    ' update the pline
    objNewEntity.Update
   
    ' find the size of the object drawn so we can calculate the viewport
    ' and determine the scale factor
    Dim varMin As Variant
    Dim varMax As Variant
    Dim Width As Double
    Dim Height As Double
    objNewEntity.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)
   
    ' get the height and width
    Width = varMax(0) - varMin(0) + dOffset
    Height = varMax(1) - varMin(1) + dOffset
   
    If Width > 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 Then
            isPlus = True
        Else
            isPlus = False
        End If
    Else ' angle 1 is the large one
        If Side > angle2 And Side < angle1 Then
            isPlus = False
        Else
            isPlus = True
        End If
    End If
End Function

' get's the smallest angle of two vectors
Private Function SmallAngle(Vector1 As Double, Vector2 As Double) As Double
    ' subtract the smaller angle from the smaller one
    If Vector1 > 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



[Draftek]

I had to break it up because it was too long

second part of the frmMain code

Code: [Select]

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


Code: [Select]

[Draftek]

here is the code from the main module with some helper functions which I cannot take credit for a couple of them:

Code: [Select]

'' 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

hope this helps...

[Troy Williams]

Draftek, thank you for posting the code! I will take a look at it and see how it works.


Thanks again!

[Kerry]

hmmmmmm .. wonder what hatch is doing these days ?

[gilseorin]

Thank you Draftek!
I do need this, but it returns error message.
Could you repair it available and upload it.
Helping me,much much ...... appreciated.

[DaveW]

I deal with closed polyines, so you may have to adjust the code and make it deal with one more vertex.

This code offsets a polyline. The returned area if bigger or smaller tells you the direction of the verticies too.

Code: [Select]

Public Function DirPolSante(polyEnt As AcadEntity) As String
Dim OffsetObj As Variant
Dim AreaObj As Double
Dim AreaOffset As Double

AreaObj = polyEnt.Area

OffsetObj = polyEnt.Offset(0.01)
AreaOffset = OffsetObj(0).Area
OffsetObj(0).Delete

If AreaOffset < AreaObj Then
VertDir = "Clockwise"
Else
VertDir = "CounterClockwise"
End If

End Function
this finds the area if needed:

Code: [Select]

Public Function polyArea(arrPts() As Double) As Double
Dim intloop As Integer
Dim intLow As Integer
Dim intHigh As Integer
Dim dblArea As Double

intLow = LBound(arrPts)
intHigh = UBound(arrPts)
For intloop = intLow To intHigh - 3 Step 3
dblArea = dblArea + (arrPts(intloop) * arrPts(intloop + 4)) - (arrPts(intloop + 0) * arrPts(intloop + 1))
Next intloop
dblArea = dblArea + (arrPts(intHigh - 1 * arrPts(1))) - (arrPts(intHigh - 1) * arrPts(0))
polyArea = dblArea / 2
polyArea2 = polyArea
End Function
This reverses a open LWpolyline:

Code: [Select]

Private Sub revPline(polyEnt As AcadLWPolyline)

        Dim idx As Integer
        Dim numPts As Integer
        Dim numBulge As Integer
        Dim bulge As Double
'set an array to store the coordinates of the pline
        Dim newcoord() As Double
        numPts = UBound(polyEnt.Coordinates) - 1
        ReDim newcoord(numPts + 1)
'set an array to store the bludge factor for each segment
        Dim newbulge() As Double

        numBulge = ((numPts - 3) / 2)
       
        If ((UBound(polyEnt.Coordinates) + 1) / 2) Mod 2 = 0 Then
           GoTo myout
        Else
           numBulge = numBulge + 1
        End If
myout:
        ReDim newbulge(numBulge)
'loop through the vertices of the pline and save x,y in reverse order
        For idx = 0 To numPts Step 2
            newcoord(numPts - idx) = polyEnt.Coordinates(idx)
            newcoord(numPts - idx + 1) = polyEnt.Coordinates(idx + 1)
        Next idx
'loop through the bulge factors and save in reverse order
        For idx = 0 To numBulge
            newbulge(numBulge - idx) = polyEnt.GetBulge(idx) * -1
        Next idx
       
'reverse the original pline
        polyEnt.Coordinates = newcoord

       
        For idx = 0 To numBulge
            polyEnt.SetBulge idx, newbulge(idx)
        Next idx
       
        polyEnt.Update
End Sub
This reverses a closed LWpolyline:

Code: [Select]

Private Sub reverse_pline(polyEnt As AcadLWPolyline)

        Dim idx As Integer
        Dim numPts As Integer
        Dim numBulge As Integer
        Dim bulge As Double
'set an array to store the coordinates of the pline
        Dim newcoord() As Double
        numPts = UBound(polyEnt.Coordinates) - 1 'was -1
        ReDim newcoord(numPts + 1) 'was 1
'set an array to store the bludge factor for each segment
        Dim newbulge() As Double
        numBulge = (((numPts)) / 2)  'was -3)/2
        ReDim newbulge(numBulge)
'loop through the vertices of the pline and save x,y in reverse order
        For idx = 0 To numPts Step 2
            newcoord(numPts - idx) = polyEnt.Coordinates(idx)
            newcoord(numPts - idx + 1) = polyEnt.Coordinates(idx + 1) 'was +1 in 2 places
        Next idx
'loop through the bulge factors and save in reverse order
        For idx = 0 To numBulge
          If idx <> numBulge Then
            newbulge(numBulge - idx) = polyEnt.GetBulge(idx) * -1
           
            Else
           
            newbulge(0) = polyEnt.GetBulge(idx) * -1
           
          End If
        Next idx
       
'reverse the original pline
        polyEnt.Coordinates = newcoord

       
        For idx = 0 To numBulge
       
          If idx = 0 Then
            polyEnt.SetBulge (numBulge), newbulge(idx)
          Else
            polyEnt.SetBulge (idx - 1), newbulge(idx)
          End If
           
        Next idx
       
        polyEnt.Update

End Sub

This converts a LWpolyline toa  2D polyline. Great for older CNC programs when you have to have 2D poly a tthe end of your code. ACAD does a much better with Pedit on LW polylines (sendcommand):

Code: [Select]

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

Most of this code can be contributed to Malcom Fernadaz. His code delt with open polylines. I modified it to deal with closed ones

[gilseorin]

Thank you so much,Davew!