Author Topic: Howto join adjacent LWpolylines with VBA?  (Read 11046 times)

0 Members and 1 Guest are viewing this topic.

havano

  • Guest
Howto join adjacent LWpolylines with VBA?
« on: May 25, 2006, 04:28:37 AM »
Having been awake for some 30 hours now, getting on slower and slower with my project. I think i'll "hit the sack" before too long. I hope to wake up this evening and find a solution for the following problem.

On a layer are a bunch of open LWpolylines. Visually, they form a closed contour, because their endpoints are all adjacent. There's nothing else on that layer but this collection of LWpolylines.

I need to know the enclosed area of this contour.

A normal Autocad user would choose Modify - Join, select one polyline and then pick the others with a fence, or freeze all other layers and then select all (Ctrl-A) that's left to pick. Et voilá, all the polylines are now one giant closed polyline, of which the area can be found in the properties window.

I could mimic such a normal Autocad user by using sendcommands in VBA, but to be honest I resent that, they bite you when you least expect it. I could also use arithmatic. The shape is a by-product of a bunch of parametric modeling routines that's a part of my program I finished before, so I could perhaps collect the necessary info by "backtracking" those routines.

But I am sure that one of you has a simple solution using clean VB(A), so I'll have something to look forward to when I wake up, and will be able to finish the d*** project, at least the challenging part, some time this weekend.

It's now 10.30 am and I start seeing those little movements in the corner of my eyes again. Bedtime! Before the voices start....  :ugly:

Jürg Menzi

  • Swamp Rat
  • Posts: 599
  • Oberegg, Switzerland
Re: Howto join adjacent LWpolylines with VBA?
« Reply #1 on: May 25, 2006, 06:45:43 AM »
Sleep well... :-)
meanwhile a possible solution (you've to call this function each with each of them):
Code: [Select]
Public Function MeJoinPline(FstPol As AcadLWPolyline, NxtPol As AcadLWPolyline, _
                            FuzVal As Double) As Boolean

  Dim FstArr() As Double
  Dim NxtArr() As Double
  Dim TmpPnt(0 To 1) As Double
  Dim FstLen As Long
  Dim NxtLen As Long
  Dim VtxCnt As Long
  Dim FstCnt As Long
  Dim NxtCnt As Long
  Dim RevFlg As Boolean
  Dim RetVal As Boolean
 
  With FstPol
    FstArr = .Coordinates
    NxtArr = NxtPol.Coordinates
    FstLen = UBound(FstArr)
    NxtLen = UBound(NxtArr)
    '<-Fst<-Nxt
    If MePointsEqual(FstArr, 1, NxtArr, NxtLen, FuzVal) Then
      MeReversePline FstPol
      FstArr = .Coordinates
      MeReversePline NxtPol
      NxtArr = NxtPol.Coordinates
      RevFlg = True
      RetVal = True
    '<-FstNxt->
    ElseIf MePointsEqual(FstArr, 1, NxtArr, 1, FuzVal) Then
      MeReversePline FstPol
      FstArr = .Coordinates
      RevFlg = True
      RetVal = True
    'Fst-><-Nxt
    ElseIf MePointsEqual(FstArr, FstLen, NxtArr, NxtLen, FuzVal) Then
      MeReversePline NxtPol
      NxtArr = NxtPol.Coordinates
      RevFlg = False
      RetVal = True
    'Fst->Nxt->
    ElseIf MePointsEqual(FstArr, FstLen, NxtArr, 1, FuzVal) Then
      RevFlg = False
      RetVal = True
    Else
      RetVal = False
    End If
   
    If RetVal Then
      FstCnt = (FstLen - 1) / 2
      NxtCnt = 0
      .SetBulge FstCnt, NxtPol.GetBulge(NxtCnt)
      For VtxCnt = 2 To NxtLen Step 2
        FstCnt = FstCnt + 1
        NxtCnt = NxtCnt + 1
        TmpPnt(0) = NxtArr(VtxCnt)
        TmpPnt(1) = NxtArr(VtxCnt + 1)
        .AddVertex FstCnt, TmpPnt
        .SetBulge FstCnt, NxtPol.GetBulge(NxtCnt)
      Next VtxCnt
      .Update
      NxtPol.Delete
      If RevFlg Then MeReversePline FstPol
    End If
  End With
 
  MeJoinPline = RetVal

End Function

' -----
Public Function MeReversePline(PolObj As AcadLWPolyline)

  Dim NewArr() As Double
  Dim BlgArr() As Double
  Dim OldArr() As Double
  Dim SegCnt As Long
  Dim ArrCnt As Long
  Dim ArrLen As Long

  With PolObj
    OldArr = .Coordinates
    ArrLen = UBound(OldArr)
    SegCnt = (ArrLen - 1) / 2
    ReDim NewArr(0 To ArrLen)
    ReDim BlgArr(0 To SegCnt + 1)
 
    For ArrCnt = SegCnt To 0 Step -1
      BlgArr(ArrCnt) = .GetBulge(SegCnt - ArrCnt) * -1
    Next ArrCnt
    For ArrCnt = ArrLen To 0 Step -2
      NewArr(ArrLen - ArrCnt + 1) = OldArr(ArrCnt)
      NewArr(ArrLen - ArrCnt) = OldArr(ArrCnt - 1)
    Next ArrCnt
   
    .Coordinates = NewArr
    For ArrCnt = 0 To SegCnt
      .SetBulge ArrCnt, BlgArr(ArrCnt + 1)
    Next ArrCnt
    .Update
  End With
   
End Function

' -----
Public Function MePointsEqual(FstArr, FstPos As Long, NxtArr, NxtPos As Long, _
                              FuzVal As Double) As Boolean

  Dim XcoDst As Double
  Dim YcoDst As Double
 
  XcoDst = FstArr(FstPos - 1) - NxtArr(NxtPos - 1)
  YcoDst = FstArr(FstPos) - NxtArr(NxtPos)
  MePointsEqual = (Sqr(XcoDst ^ 2 + YcoDst ^ 2) < FuzVal)

End Function
A computer's human touch is its unscrupulousness!
MENZI ENGINEERING GmbH
Current A2k16... A2k24 - Start R2.18

Bob Wahr

  • Guest
Re: Howto join adjacent LWpolylines with VBA?
« Reply #2 on: May 25, 2006, 11:05:16 AM »
Nice functions Jürg

Jürg Menzi

  • Swamp Rat
  • Posts: 599
  • Oberegg, Switzerland
Re: Howto join adjacent LWpolylines with VBA?
« Reply #3 on: May 25, 2006, 01:32:39 PM »
Nice functions Jürg
Thank you for the flowers, Bob... :-)

This was basically written in LISP, then translated to VBA.
A computer's human touch is its unscrupulousness!
MENZI ENGINEERING GmbH
Current A2k16... A2k24 - Start R2.18

havano

  • Guest
Re: Howto join adjacent LWpolylines with VBA?
« Reply #4 on: May 25, 2006, 03:39:17 PM »
(Oops, I posted my reply before I finished it! Here's the final version.)

I always envy those musicians who can "hear" the music just by reading the notes. Also with VBA, I may never reach that level of brillance. So it took me some time to "hear the music" of your code. In my simple words, what I found out it does is:

Check if two polylines you present it, can be joined. If so, add the vertices etc. of the second one to the first one, delete the second one and report back "Mission accomplished! I joined two polylines".

So, now, all it takes is an embedding routine that:

Creates a selection set of polylines to be investigated
- Compares/joins the first one in the set with all the others (using your function)
- After all are compared to, and if possible joined with the first one, refreshes the selectionset
- Does a new run, and another (or uses recursion, or nested loops) until only one polyline is left or no further joins can be made
Then closes this polyline and gets the area value I need. (Apart from that, the drawing has been cleaned up some, but the ignorant viewer won't see the difference.)

Thanks Jurg! Meanwhile I found a simpler solution for my -much simpler- problem (this morning I was too drowsy to see it) but I think many other readers could well take advantage of your masterpiece!
« Last Edit: May 25, 2006, 05:36:42 PM by havano »

Bob Wahr

  • Guest
Re: Howto join adjacent LWpolylines with VBA?
« Reply #5 on: May 25, 2006, 04:21:25 PM »
Something like this should work
Code: [Select]
Sub JoininJoininJoinin()
'Get them plines joinin'
'This song is quite anoyin'
'raw code
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim intGroup(0 To 1) As Integer
Dim varData(0 To 1) As Variant
Dim intcnt As Integer
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
  If objSelSet.Name = "PolyJoin" Then
    objSelSets.Item(objSelSet.Name).Delete
    Exit For
  End If
Next objSelSet
intGroup(0) = 0: varData(0) = "LWPolyline": intGroup(1) = 8: varData(1) = "LayerName"
Set objSelSet = objSelSets.Add("PolyJoin")
objSelSet.Select acSelectionSetAll, , , intGroup, varData
For intcnt = 1 To objSelSet.Count - 1
  MeJoinPline objSelSet.Item(0), objSelSet.Item(intcnt), 0.01
Next intcnt
End Sub

Bob Wahr

  • Guest
Re: Howto join adjacent LWpolylines with VBA?
« Reply #6 on: May 25, 2006, 04:44:06 PM »
thinking on it, that would only work as is if they were all in order in the selection set if theiy're not, which is likely, it won't join everything.  You could break the selectionset out to a function, populate it, run through the join function, repopulate the selection set and loop until the selection set count = 1.  Put in a check though because if any of them fall outside your fuzz factor and can't join, you will loop forever.

Bryco

  • Water Moccasin
  • Posts: 1882
Re: Howto join adjacent LWpolylines with VBA?
« Reply #7 on: May 25, 2006, 08:38:10 PM »
I've been working on this for 2 years and its 99.5%, some of the 3d is a bit tricky. I draw a lot for cnc so I don't want extra verticies or lines. This is supposed to delete the baddies. As far as would should be joined to what, you have to make decisions. Whether I should have made all the lines into polys first I don't know. I'm pretty sure I could eliminate some of the steps here but it gets harder and harder to see the forrest for the trees.
 
Code: [Select]
Option Explicit

Declare Function GetCursor Lib "user32" () As Long

Public Declare Function GetAsyncKeyState Lib "user32" _
        (ByVal vKey As Long) As Integer
Public Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" _
    (dest As Any, source As Any, ByVal Length As Long) 'AlmostEqual
Private DeleteCol As Collection
Private StartEndCol As Collection
Private SlopeCol As Collection
Private CoordList As Collection
Private Const PolyClosedFudge As Double = 0.005
'If the first coordinate and last coordinate are within this distance
'The poly will be closed.
Const Pi As Double = 3.14159265358979


Public Property Get CurrentSpace() As AcadBlock
  If ThisDrawing.GetVariable("CVPORT") = 1 Then
    Set CurrentSpace = ThisDrawing.PaperSpace
  Else
    Set CurrentSpace = ThisDrawing.ModelSpace
  End If
End Property



'Aims
'1) To select a group of lines,arcs and polys
'and create clean polys w/ no double ups
'or double points.
'2) Delete unnecessary geometry
'Some will want to add a layer control here.
'3) Note 2d and 3dpolys are not included
'4) I have used line formulas rather than polar angles
'hoping that it will be faster.


Sub VBAPLJoin()
    'On Error GoTo Err_Control

    Dim oLine As AcadLine
    Dim LineCol As New Collection
    Dim oPline As AcadLWPolyline
    Dim CoordsCt As Integer
    Dim oArc As AcadArc
    Dim oSSets As AcadSelectionSets
    Dim ss As AcadSelectionSet
    Dim FilterType(6) As Integer
    Dim FilterData(6) As Variant
    Dim i As Integer, j As Integer, k As Integer
    Dim intNotParallel As Integer
    Dim PtsCount As Integer, Count As Integer
    Dim StartPt As Variant, EndPt As Variant
    Dim StartP(2) As Double, EndP(2) As Double
    Dim Pt As Variant
    Dim pts() As Double
    Dim SE(4) As Variant
    Dim obj(0) As AcadEntity
    Dim M As Double, OrigY As Double
    Dim UcsNormal As Variant, N As Variant
    Dim blnRemove As Boolean
    Dim dblElev As Double
    Dim strlayer As String
    Dim util As AcadUtility

    PtsCount = 1
    Set util = ThisDrawing.Utility
    Set StartEndCol = New Collection
       
    'Stage 1  Create the selectionset
    Set oSSets = ThisDrawing.SelectionSets
    For Each ss In oSSets
        If ss.Name = "SS" Then
            ss.Delete
            Exit For
        End If
    Next
    Set ss = oSSets.Add("SS")
   
   
    FilterType(0) = 0: FilterData(0) = "Line,Arc,LWPolyline"
    FilterType(1) = -4: FilterData(1) = "<NOT"
    FilterType(2) = -4: FilterData(2) = "<XOR"
    FilterType(3) = 70: FilterData(3) = 1       'exclude Closed polys
    FilterType(4) = 70: FilterData(4) = 129       'exclude Closed polys w/ linetype generation enabled
    FilterType(5) = -4: FilterData(5) = "XOR>"
    FilterType(6) = -4: FilterData(6) = "NOT>"
   
     Do ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ss.SelectOnScreen FilterType:=FilterType, FilterData:=FilterData
    Loop Until GetCursor = 0
   
    If ss.Count > 500 Then
        MsgBox "You have selected " & ss.Count & " objects. Please select less :"
        Exit Sub
    End If
    If ss.Count = 0 Then
        Set ss = Nothing
        ''''''''''''MsgBox "Nothing selected."
        Exit Sub
    End If
    If ss.Count = 1 Then
        If TypeOf ss(0) Is AcadLWPolyline Then
            Set oPline = ss(0)
            If UBound(oPline.Coordinates) = 3 Then
                Exit Sub
            End If
        End If
    End If
    UcsNormal = CurrentUcsNormal
    'We're using the SS set index to keep track of the objects
    'So first pass is just to clean up the set
    'From then on the order wont change
   
    'Stage 2- delete zero length ents, remove non applicable ents
     For i = ss.Count - 1 To 0 Step -1
        If TypeOf ss(i) Is AcadLine Then
            Set oLine = ss(i)
            If oLine.Length < 0.0000000001 Then
                Set obj(0) = ss(i)
                ss.RemoveItems obj
                oLine.Delete
                GoTo skip
            End If
            'Debug.Print ToUcs(oLine.Endpoint)(2), ToUcs(oLine.Startpoint)(2)
            If Not Rd(ToUcs(oLine.Endpoint)(2), ToUcs(oLine.Startpoint)(2)) Then
                intNotParallel = intNotParallel + 1
                blnRemove = True
            Else
                N = oLine.Normal
                If Not EqualPts(N, UcsNormal) Then
                    oLine.Normal = UcsNormal
                End If                                 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            End If

            GoTo skip
        End If
        If TypeOf ss(i) Is AcadArc Then
            Set oArc = ss(i)
            If oArc.ArcLength < 0.0000000001 Then
                Set obj(0) = ss(i)
                ss.RemoveItems obj
                oArc.Delete
                GoTo skip
            End If
           
            If Not Rd(ToUcs(oArc.Endpoint)(2), ToUcs(oArc.Startpoint)(2)) Or _
                Not Rd(ToUcs(oArc.Endpoint)(2), ToUcs(oArc.Center)(2)) Then
                intNotParallel = intNotParallel + 1
                blnRemove = True
            End If
            GoTo skip
        End If
        If TypeOf ss(i) Is AcadLWPolyline Then
            Set oPline = ss(i)
            If Not PolyVertexCheck(oPline, i) Then    'This sub checks each poly for clean verticies
                GoTo skip
            End If
            CoordsCt = UBound(oPline.Coordinates)
           
            If CoordsCt = 3 Then
                'use this to delete small plines
                'If Length(oPline.Coordinate(0), oPline.Coordinate(1)) = PolyClosedFudge Then
                If Length(oPline.Coordinate(0), oPline.Coordinate(1)) = 0 Then
                    Set obj(0) = ss(i)
                    ss.RemoveItems obj
                    oPline.Delete
                    GoTo skip
                End If
            End If
            'Else
                'If oPline.Area = 0 Then
                    'Set obj(0) = SS(i)
                    'SS.RemoveItems obj
                    'oPline.Delete
                    'GoTo skip
                'End If
            'End If
            If Not EqualPts(oPline.Normal, UcsNormal) Then
                intNotParallel = intNotParallel + 1
                blnRemove = True
            End If
            If ss.Count = 1 Then Exit Sub
        End If
skip:
        If blnRemove Then
            Set obj(0) = ss(i)
            ss.RemoveItems obj
            blnRemove = False
        End If
    Next i
   
   'Stage 3
    'Now we sort the ents start and end points into collections
   
    For i = ss.Count - 1 To 0 Step -1
        If TypeOf ss(i) Is AcadLine Then
            Set oLine = ss(i)
            StartPt = oLine.Startpoint
            EndPt = oLine.Endpoint
            'Put the points in order
            SortStartEnd StartPt, EndPt
            GetSlope oLine.Delta(0), oLine.Delta(1), StartPt, M, OrigY
                   
            SE(0) = StartPt
            SE(1) = EndPt
            SE(2) = i
            SE(3) = M
            SE(4) = OrigY
            StartEndCol.Add SE
            LineCol.Add SE
            GoTo Skip2
        End If
       
        If TypeOf ss(i) Is AcadArc Then
            Set oArc = ss(i)
            StartPt = oArc.Startpoint
            EndPt = oArc.Endpoint
            SortStartEnd StartPt, EndPt
            SE(0) = StartPt
            SE(1) = EndPt
            SE(2) = i
            SE(3) = oArc.Center
            SE(4) = oArc.radius
            StartEndCol.Add SE
            GoTo Skip2
        End If
        If TypeOf ss(i) Is AcadLWPolyline Then
            Set oPline = ss(i)
            For j = 0 To 1
                StartP(j) = oPline.Coordinates(j)
            Next j
            StartP(2) = oPline.Elevation
            StartPt = util.TranslateCoordinates(StartP, acOCS, acWorld, 1, oPline.Normal)
            CoordsCt = UBound(oPline.Coordinates)
            EndP(0) = oPline.Coordinates(CoordsCt - 1)
            EndP(1) = oPline.Coordinates(CoordsCt)
            EndP(2) = oPline.Elevation
            EndPt = util.TranslateCoordinates(EndP, acOCS, acWorld, 1, oPline.Normal)
            SortStartEnd StartPt, EndPt
            SE(0) = StartPt
            SE(1) = EndPt
            SE(2) = i
            If CoordsCt = 3 Then
                GetSlope (EndP(0) - StartP(0)), (EndP(1) - StartP(1)), StartPt, M, OrigY
                If oPline.GetBulge(0) = 0 Then
                    SE(3) = M
                    SE(4) = OrigY
                    LineCol.Add SE 'Treat a single segment poly like a line
                End If
            End If
            StartEndCol.Add SE
        End If
Skip2:
    Next i
   
    'Stage 4
    'Sub checks for equal, overlapping lines, deletes unnecessary lines.
    If LineCol.Count > 0 Then
        CheckLines LineCol 'Sub checks for equal, overlapping lines
    End If

    If ss.Count = 0 Then 'items may have been removed
        Exit Sub
    End If
    If intNotParallel = 1 Then
        MsgBox intNotParallel & " object was not parallel to the current UCS."
    ElseIf intNotParallel > 1 Then
        MsgBox intNotParallel & " objects were not parallel to the current UCS."
    End If
   
    'Stage 5
    'This function sorts the start and end points into order
    If StartEndCol.Count > 1 Then
        SortPts
    End If
   
    Dim blnClosed As Boolean, blnNewLine As Boolean
    Dim BulgeCol() As Double, PolyBulgeCol() As Double
    Dim MPt(2) As Double, Seg As Double, Ht As Double
    Dim sPt, ePt
    ReDim pts(1)
AddNewLine:
   
    Count = StartEndCol.Count
    j = 0
    If Count > 1 Then
        For i = 1 To Count
            If StartEndCol(i)(2) = "NewLine" Then
                j = i - 1
                Exit For
            End If
        Next
        If j = 0 Then j = Count
        If EqualPts(StartEndCol(1)(0), StartEndCol(j)(1)) Then
            blnClosed = True
        End If
    End If
   
    N = ss(StartEndCol(1)(2)).Normal
    dblElev = ElevationFromPt(StartEndCol(1)(0), N) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    strlayer = ss(StartEndCol(1)(2)).Layer
    'Stage 6
    'Draw a pline for each set of continuous points
    'NewLine signifies there are no more points to add
    'to the last poly so a new poly is reqd.
   
   
    sPt = StartEndCol(1)(0)
    sPt = util.TranslateCoordinates(sPt, acWorld, acOCS, 1, N)
    pts(0) = sPt(0)
    pts(1) = sPt(1)
    PtsCount = 1
    For i = 1 To StartEndCol.Count
        If StartEndCol(i)(2) = "NewLine" Then
            StartEndCol.Remove i
            blnNewLine = True
            Exit For
        End If
       
        If TypeOf ss(StartEndCol(i)(2)) Is AcadArc Then
            Set oArc = ss(StartEndCol(i)(2))
            ePt = StartEndCol(i)(1)
            ePt = util.TranslateCoordinates(ePt, acWorld, acOCS, 1, N)
                       
            ReDim Preserve pts(PtsCount + 2)
            pts(PtsCount + 1) = ePt(0)
            pts(PtsCount + 2) = ePt(1)
            'Now get the bulge
            sPt = ToUcs(oArc.Startpoint): ePt = ToUcs(oArc.Endpoint)
            Dim CPt As Variant
            CPt = ToUcs(oArc.Center)
            MPt(0) = sPt(0) + ((ePt(0) - sPt(0)) / 2)
            MPt(1) = sPt(1) + ((ePt(1) - sPt(1)) / 2)
            MPt(2) = sPt(2)
            Seg = (Length(sPt, ePt)) / 2
            If oArc.TotalAngle > Pi Then
                Ht = (2 * oArc.radius) - (oArc.radius - Length(CPt, MPt))
            Else
                Ht = oArc.radius - Length(CPt, MPt)
            End If
            ReDim Preserve BulgeCol((PtsCount - 1) / 2)
             If EqualPts(oArc.Startpoint, StartEndCol(i)(0)) Then
           
                BulgeCol((PtsCount - 1) / 2) = Ht / Seg 'Bulge
            Else
                BulgeCol((PtsCount - 1) / 2) = -Ht / Seg
                           
            End If
            PtsCount = PtsCount + 2
            StartEndCol.Remove i
            i = i - 1
            GoTo Skip3
        End If
        If TypeOf ss(StartEndCol(i)(2)) Is AcadLine Then
PlineLine:
            ePt = StartEndCol(i)(1)
            ePt = util.TranslateCoordinates(ePt, acWorld, acOCS, 1, N)
            'addpt EPt, , 2
            ReDim Preserve pts(PtsCount + 2)
            pts(PtsCount + 1) = ePt(0)
            pts(PtsCount + 2) = ePt(1)
            ReDim Preserve BulgeCol((PtsCount - 1) / 2)
            BulgeCol((PtsCount - 1) / 2) = 0
            PtsCount = PtsCount + 2
            StartEndCol.Remove i
            i = i - 1
            GoTo Skip3
        End If
        If TypeOf ss(StartEndCol(i)(2)) Is AcadLWPolyline Then
            Set oPline = ss(StartEndCol(i)(2))
            CoordsCt = (UBound(oPline.Coordinates) - 1) / 2
            If CoordsCt = 1 Then
                If oPline.GetBulge(0) = 0 Then
                    GoTo PlineLine
                End If
            End If
            Dim Coord, coords()
            ReDim coords(CoordsCt)
            ReDim PolyBulgeCol(CoordsCt - 1)
            For j = 0 To 1
                StartPt(j) = oPline.Coordinates(j)
            Next j
            StartPt(2) = oPline.Elevation
            Pt = util.TranslateCoordinates(StartPt, acOCS, acWorld, 1, oPline.Normal)
            If Not EqualPts(Pt, StartEndCol(i)(0)) Then 'swap''''''''''''''''''
                k = 0
                For j = CoordsCt To 0 Step -1
                    coords(k) = oPline.Coordinate(j)
                    k = k + 1
                Next
                k = 0
                For j = CoordsCt - 1 To 0 Step -1
                    PolyBulgeCol(k) = -oPline.GetBulge(j)
                    k = k + 1
                Next
            Else
                For j = 0 To CoordsCt
                    coords(j) = oPline.Coordinate(j)
                Next
                For j = 0 To CoordsCt - 1
                    PolyBulgeCol(j) = oPline.GetBulge(j)
                Next
               
            End If
            ReDim Preserve pts(PtsCount + (CoordsCt * 2))
            For j = 1 To CoordsCt 'We already have the first pair
           
                pts(PtsCount + 1) = coords(j)(0)
                pts(PtsCount + 2) = coords(j)(1)
                ReDim Preserve BulgeCol((PtsCount - 1) / 2)
                BulgeCol((PtsCount - 1) / 2) = PolyBulgeCol(j - 1)
                PtsCount = PtsCount + 2
            Next
            StartEndCol.Remove i
            i = i - 1
            GoTo Skip3
        End If
Skip3:
        If StartEndCol.Count = 0 Then
            Exit For
        End If
    Next i
   
   
    If blnClosed Then
        ReDim Preserve pts(PtsCount - 2)
    End If
   
    Set oPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pts)
    oPline.Elevation = dblElev
    'oPline.Normal = N ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'oPline.Color = acMagenta
    oPline.Layer = strlayer
    For i = 0 To UBound(BulgeCol)
        oPline.SetBulge i, BulgeCol(i)
    Next
    If blnClosed Then
        oPline.Closed = True
    Else
        PolyVertexCheck oPline ''''''''''''''''''''''''''''''''''
    End If
   
   
    If blnNewLine Then
        blnNewLine = False
        blnClosed = False
        If StartEndCol.Count > 0 Then
            GoTo AddNewLine
        End If
    End If
   
    ss.Erase 'Delete the selection set leaving us w/ nice new polys
    ss.Delete


Exit_Here:
    Exit Sub
Err_Control:
    Select Case Err.Number
    'Add your Case selections here
        Case Else
        MsgBox Err.Description
        Err.Clear
        Resume Exit_Here
    End Select
End Sub








Bryco

  • Water Moccasin
  • Posts: 1882
Re: Howto join adjacent LWpolylines with VBA?
« Reply #8 on: May 25, 2006, 08:42:04 PM »
some functions
Code: [Select]
Function GetSlope(DeltaX, DeltaY, StartPt As Variant, _
                M As Double, OrigY As Double) As Integer
    DeltaX = CDbl(DeltaX)
    DeltaY = CDbl(DeltaY)
    If Rd(DeltaY, 0) Then   'Line is horizontal
        M = 0
        OrigY = StartPt(1)
        GetSlope = 0
    ElseIf Rd(DeltaX, 0) Then  'Line is vertical
        M = StartPt(0)
        OrigY = 0
        GetSlope = 1
    Else
        M = DeltaY / DeltaX
        OrigY = StartPt(1) - (M * StartPt(0))
        GetSlope = 2
    End If

End Function







Private Function SortPts()
   
    Dim A As Variant, b As Variant
    Dim StartPt As Variant, EndPt As Variant
    Dim NextStartPt As Variant, NextEndPt As Variant
    Dim NewStartEndCol As New Collection
    Dim blnRemoved As Boolean
    Dim intBefore As Integer
    Dim i As Integer
   
    intBefore = 1
    A = StartEndCol(1)
    StartPt = A(0): EndPt = A(1)
    NewStartEndCol.Add A
    StartEndCol.Remove 1
    Do While StartEndCol.Count > 0
Removed:
        blnRemoved = False
        For i = StartEndCol.Count To 1 Step -1
           
            NextStartPt = StartEndCol(i)(0)
            NextEndPt = StartEndCol(i)(1)
           
            If EqualPts(StartPt, NextStartPt) Then
                StartPt = NextEndPt
                A = StartEndCol(i)
                'swap start and end points
                A(0) = NextEndPt
                A(1) = NextStartPt
                NewStartEndCol.Add A, , intBefore
                blnRemoved = True
                GoTo skip
            End If
            If EqualPts(StartPt, NextEndPt) Then
                StartPt = NextStartPt
                A = StartEndCol(i)
                NewStartEndCol.Add A, , intBefore
                blnRemoved = True
                GoTo skip
            End If
            If EqualPts(EndPt, NextStartPt) Then
                EndPt = NextEndPt
                A = StartEndCol(i)
                NewStartEndCol.Add A
                blnRemoved = True
                GoTo skip
            End If
            If EqualPts(EndPt, NextEndPt) Then
                    EndPt = NextStartPt
                    A = StartEndCol(i)
                    'swap start and end points
                    A(0) = NextEndPt
                    A(1) = NextStartPt
                    NewStartEndCol.Add A
                    blnRemoved = True
                    GoTo skip
            End If
           
skip:
            If blnRemoved Then
                StartEndCol.Remove i
                GoTo Removed
            End If
        Next
       
        If blnRemoved = False Then
            If StartEndCol.Count > 0 Then
                A(2) = "NewLine"
                NewStartEndCol.Add A
                A = StartEndCol(1)
                StartPt = A(0): EndPt = A(1)
                NewStartEndCol.Add A
                intBefore = NewStartEndCol.Count
                StartEndCol.Remove 1
            End If
         End If
    Loop
       
   
    For i = 1 To NewStartEndCol.Count
        StartEndCol.Add NewStartEndCol(i)
    Next

End Function

















'Rules used
'1)identical-
'   delete one
'2)line within line-and no arms off the smaller-delete smaller
        'if within has arm and the larger doesn't-remove the larger
        'intWithin 1=start equal,2=end equal,3=neither
'3)Overlapping
    'if no arms off the inside pts then delete both, add one long line
    'intWithin=4


Private Sub CheckLines(LineCol As Collection)

    Dim oLine As AcadLine
    Dim Si  As Variant, Sj  As Variant, varSE  As Variant
    Dim blnSti As Boolean, blnStj As Boolean
    Dim blnEndi As Boolean, blnEndj As Boolean
    Dim Starti As Variant, Endi As Variant
    Dim Startj As Variant, Endj As Variant
    Dim i As Integer, j As Integer, k As Integer
    Dim intWithin As Integer '1=start equal,2=end equal,3=neither
    Dim blnRemoved As Boolean
    Dim intVertical As Integer
   
    For i = LineCol.Count To 1 Step -1 'allows removal from set
        Si = LineCol(i)
        Starti = Si(0): Endi = Si(1)
        'now do the expensive point checks we will need to
        'check if a line has an arm coming off it
        'we only want to do this once
        blnSti = PtCheck(Starti, i)
        blnEndi = PtCheck(Endi, i)
        For j = LineCol.Count To 1 Step -1
            blnRemoved = False
            If Not j = i Then
                If Rd(LineCol(j)(4), LineCol(i)(4)) Then 'Check origY values
                    If Rd(LineCol(j)(3), LineCol(i)(3)) Then  'Check slope values
                    'Check z values''''''''''''''''''''''''''''''''
                        Sj = LineCol(j)
                        Startj = Sj(0): Endj = Sj(1)
           
                        'now we dont have to factor in Line direction
                        'Make i the most left or the lowest
                        If Startj(0) < Starti(0) Or Startj(1) < Starti(1) Then
                            GoTo skip 'Get it the next time
                        End If
                       
                        If Startj(0) > Endi(0) Or Startj(1) > Endi(1) Then
                            GoTo skip 'Get it the next time
                        End If
                     
                        'Check for identical
                        If Rd(Startj(0), Starti(0)) And Rd(Endj(0), Endi(0)) Then   'Could be vertical
                            If Rd(Startj(1), Starti(1)) Then
                                If Rd(Endj(1), Endi(1)) Then   'identical
                                    DeleteIt LineCol, j
                                    blnRemoved = True
                                    'i = i - 1
                                    GoTo skip
                                 End If
                            End If
                        End If
       
                        intWithin = 0
                        intVertical = 0
                        'Check for within or overlapping
                        'Do the verticals first
                        If Rd(Startj(0), Starti(0)) And Rd(Endj(0), Endi(0)) Then  'vertical now
                            intVertical = 1
                            If Rd(Startj(1), Starti(1)) Then
                                intWithin = 1
                            End If
                            If Startj(1) > Starti(1) Then
                                If Endj(1) < Endi(1) Then
                                    intWithin = 3
                                ElseIf Rd(Endj(1), Endi(1)) Then
                                    intWithin = 2
                                Else
                                    intWithin = 4
                                    If Rd(Endi(1), Startj(1)) Then
                                        If Not blnEndi Then
                                            Si = LineCol(i)
                                            Si(1) = Endj
                                            DeleteIt LineCol, i
                                            blnRemoved = True
                                            If j > i Then ''''''''''''''''
                                                j = j - 1
                                            End If
                                            DeleteIt LineCol, j
                                            LineCol.Add Si
                                            StartEndCol.Add Si
                                            'i = i - 1
                                            GoTo skip
                                        End If
                                    End If
                                End If
                            End If
                            GoTo BranchControl
                        End If
                               
                        'Now horiz. lines and the rest
                        If Rd(Startj(0), Starti(0)) Then
                            intWithin = 1
                            GoTo BranchControl
                        End If
                       
                        If Startj(0) > Starti(0) Then
                            If Endj(0) < Endi(0) Then
                                intWithin = 3
                            ElseIf Rd(Endj(0), Endi(0)) Then
                                intWithin = 2
                                GoTo BranchControl
                            Else
                                intWithin = 4
                                If Rd(Endi(0), Startj(0)) Then
                                    If Not blnEndi Then
                                        Si = LineCol(i)
                                        Si(1) = Endj
                                        DeleteIt LineCol, i
                                        blnRemoved = True
                                        If j > i Then
                                            j = j - 1
                                        End If
                                        DeleteIt LineCol, j
                                        LineCol.Add Si
                                        StartEndCol.Add Si
                                        'i = i - 1
                                        GoTo skip
                                    End If
                                End If
                            End If
                        End If
                       
                        If intWithin = 0 Then GoTo skip
               
BranchControl:
                        'now do the expensive point checks we will need to
                        'check if a line has an arm coming off it
                        'we only want to do this once
                        blnStj = PtCheck(Startj, j)
                        blnEndj = PtCheck(Endj, j)
   
                        If intWithin = 4 Then 'overlapping
                            If Not blnStj And Not blnEndi Then 'make one line
                                Si = LineCol(i)
                                Si(1) = Endj
                                DeleteIt LineCol, i
                                blnRemoved = True
                                If j > i Then ''''''''''''''''
                                    j = j - 1
                                End If
                                DeleteIt LineCol, j
                                LineCol.Add Si
                                StartEndCol.Add Si
                                'i = i - 1
                                GoTo skip
                            End If
                        End If
                       
                        If intWithin = 1 Then
                            If Endj(intVertical) < Endi(intVertical) Then
                                If Not blnEndj Then
                                    DeleteIt LineCol, j
                                    blnRemoved = True
                                End If
                            Else
                                If Not blnEndi Then
                                    DeleteIt LineCol, i
                                    blnRemoved = True
                                End If
                            End If
                            GoTo skip
                        End If
                       
                        If intWithin = 2 Then
                            If Not blnStj Then
                                DeleteIt LineCol, j
                                blnRemoved = True
                            End If
                            GoTo skip
                        End If
                       
                        If intWithin = 3 Then
                            If Not blnStj Or Not blnEndj Then
                                DeleteIt LineCol, j
                                blnRemoved = True
                            End If
                            GoTo skip
                        End If
                       
                   
                    End If
                End If
            End If
skip:
        If blnRemoved Then
            If j > i Then
                j = j - 1
            End If
            If i > j Then
                i = i - 1
            End If
        End If
        Next j
    Next i

 
End Sub


Private Sub DeleteIt(COL As Collection, i As Integer)
    'Add layermanagement here if you need it.
    Dim k As Integer
    For k = 1 To StartEndCol.Count
        If StartEndCol(k)(2) = COL(i)(2) Then
            StartEndCol.Remove k
            Exit For
        End If
    Next
    COL.Remove i
End Sub



Function SortStartEnd(StartPt, EndPt)
    Dim varPt As Variant
    If EndPt(0) - StartPt(0) > 0.00000001 Then
    'If StartPt(0) < EndPt(0) Then
        Exit Function
    Else
        If Rd(StartPt(0), EndPt(0)) Then  'Vertical
            If StartPt(1) > EndPt(1) Then
                 varPt = StartPt
                 StartPt = EndPt
                 EndPt = varPt
            Else
                Exit Function
            End If
        Else
            varPt = StartPt
            StartPt = EndPt
            EndPt = varPt
        End If
    End If
End Function



Function CurrentUcsNormal() As Variant

    Dim UcsX, UcsY, UcsZ(2) As Double
    UcsX = ThisDrawing.GetVariable("Ucsxdir")
    UcsY = ThisDrawing.GetVariable("Ucsydir")
    'get CrossProduct
    UcsZ(0) = UcsX(1) * UcsY(2) - UcsX(2) * UcsY(1)
    UcsZ(1) = UcsX(2) * UcsY(0) - UcsX(0) * UcsY(2)
    UcsZ(2) = UcsX(0) * UcsY(1) - UcsX(1) * UcsY(0)
    CurrentUcsNormal = UcsZ
    'Debug.Print UcsZ(0), UcsZ(1), UcsZ(2)

End Function



Function ToUcs(Pt As Variant) As Variant
    ToUcs = ThisDrawing.Utility.TranslateCoordinates(Pt, acWorld, acUCS, False)
End Function
Function ToWcs(Pt As Variant) As Variant
    ToWcs = ThisDrawing.Utility.TranslateCoordinates(Pt, acUCS, acWorld, False)
End Function
Function Rd(num1 As Variant, num2 As Variant) As Boolean
    Dim dRet As Double
    dRet = num1 - num2
    If Abs(dRet) < 0.00000001 Then Rd = True
End Function





Function EqualPts(P1 As Variant, P2 As Variant) As Boolean

    'On Error GoTo errControl
    Dim i As Integer
    If IsEmpty(P1) Or IsEmpty(P2) Then
        GoTo errControl
    End If
    i = UBound(P1)
    If i > 2 Or i < 1 Then GoTo errControl
    If Not UBound(P2) = i Then GoTo errControl
   
    If Abs(P1(0) - P2(0)) < 0.00000001 Then
        If Abs(P1(1) - P2(1)) < 0.00000001 Then
            If i = 1 Then
                EqualPts = True
                Exit Function
            Else
                If Abs(P1(2) - P2(2)) < 0.00000001 Then
                    EqualPts = True
                    Exit Function
                End If
            End If
        End If
    End If
    Exit Function
errControl:
Err.Raise 5
End Function









Public Function Length(Startpoint As Variant, Endpoint As Variant) As Double

    Dim Stx As Double, Sty As Double, Stz As Double
    Dim Enx As Double, Eny As Double, Enz As Double
    Dim dX As Double, dY As Double, dZ As Double
    Dim i As Integer
    If IsEmpty(Startpoint) Then Err.Raise 13
    i = UBound(Startpoint)
    If UBound(Endpoint) = i Then
        If i > 0 Then
            Stx = Startpoint(0): Sty = Startpoint(1)
            Enx = Endpoint(0): Eny = Endpoint(1)
            dX = Stx - Enx
            dY = Sty - Eny
            If i = 1 Then
                Length = Sqr(dX * dX + dY * dY)
            Else
                Stz = Startpoint(2): Enz = Endpoint(2)
                dZ = Stz - Enz
                Length = Sqr((dX * dX) + (dY * dY) + (dZ * dZ))
            End If
        Else
            Exit Function
        End If
    Else
        Exit Function
    End If

End Function



Function ElevationFromPt(Pt As Variant, varNormal As Variant) As Double
    'Ax+ By + Cz + d = 0 formula for a plane where d=-oLWP.Elevation
    'ElevationFromPt = Pt(0) * UcsNormal(0) + Pt(1) * UcsNormal(1) + Pt(2) * UcsNormal(2)
    ElevationFromPt = (Pt(0) * varNormal(0)) + (Pt(1) * varNormal(1)) + (Pt(2) * varNormal(2))
End Function


Bryco

  • Water Moccasin
  • Posts: 1882
Re: Howto join adjacent LWpolylines with VBA?
« Reply #9 on: May 25, 2006, 08:44:09 PM »
This one is the tricky one
Code: [Select]
Function PolyVertexCheck(oPline As AcadLWPolyline, Optional j As Integer = -1) As Boolean
    'Checks for duplicate verticies
    'Should be closed.
    'Some Double backs
    Dim cCount As Integer
    Dim Dist As Double
    Dim NewCoordList As New Collection
    Dim i As Integer, k As Integer
    Dim Coord As Variant, PrevCoord As Variant, coord2 As Variant
    Dim Coord3 As Variant, Coord4 As Variant
    Dim SlopeCol As New Collection
    Dim BulgeCol As New Collection
    Dim DeltaX As Double, DeltaY As Double
    Dim StartPt As Variant
    Dim M As Double, OrigY As Double
    Dim Slopes(3) As Double
    Dim intXY As Integer
    Dim Rem1 As Integer, Rem2 As Integer
    Dim intSlope As Integer
    Dim obj(0) As AcadEntity
    Dim ss As AcadSelectionSet
    Dim blnBeginning As Boolean
    Dim blnRemoved As Boolean
   
    cCount = (UBound(oPline.Coordinates) - 1) / 2
   
    NewCoordList.Add (0)
    For i = 1 To cCount
        Coord = oPline.Coordinate(i): PrevCoord = oPline.Coordinate(i - 1)
        'Here we check for two equal verticies. Dont add them if they are equal.
        If Rd(Coord(0), PrevCoord(0)) And Rd(Coord(1), PrevCoord(1)) Then GoTo skip
           
        DeltaX = Coord(0) - PrevCoord(0): DeltaY = Coord(1) - PrevCoord(1)
        Slopes(2) = GetSlope(DeltaX, DeltaY, PrevCoord, M, OrigY)
        Slopes(0) = M: Slopes(1) = OrigY
        Slopes(3) = oPline.GetBulge(i - 1)
        SlopeCol.Add Slopes
        k = i
        NewCoordList.Add (k)
skip:
    Next
       
    cCount = NewCoordList.Count
    Debug.Print cCount
    If cCount = 1 Then 'zero length pline
        Set ss = ThisDrawing.SelectionSets("SS")
        If j > -1 Then
            Set obj(0) = ss(j)
            ss.RemoveItems obj
        End If
        oPline.Delete
        PolyVertexCheck = False
        Exit Function '''''
    End If
BeginCheck:
     If cCount > 2 Then
        If SlopeCol.Count = 2 Then
        'check for unneeded middle point in a straigth line
            If SlopeCol(1)(3) <> 0 Then GoTo Skip2
            If SlopeCol(2)(3) <> 0 Then GoTo Skip2
            If Rd(SlopeCol(1)(0), SlopeCol(2)(0)) Then
                If Rd(SlopeCol(1)(1), SlopeCol(2)(1)) Then
                    Coord = oPline.Coordinate(0)
                    coord2 = oPline.Coordinate(1)
                    Coord3 = oPline.Coordinate(2)
                    If EqualPts(Coord, Coord3) Then
                        NewCoordList.Remove cCount
                        GoTo Skip2
                    End If
                    intSlope = SlopeCol(1)(2)
                    If intSlope = 1 Then
                        intXY = 1  'vertical
                    Else
                        intXY = 0
                    End If
                   
                    If Coord(intXY) > coord2(intXY) Then
                        If coord2(intXY) > Coord3(intXY) Then
                            NewCoordList.Remove 2
                        Else
                            If Coord(intXY) > Coord3(intXY) Then
                                NewCoordList.Remove 3
                            Else
                                NewCoordList.Remove 1
                            End If
                        End If
                    Else
                        If Coord(intXY) > Coord3(intXY) Then
                                NewCoordList.Remove 1
                        Else
                            If Coord3(intXY) > coord2(intXY) Then
                                NewCoordList.Remove 2
                            Else
                                NewCoordList.Remove 3
                            End If
                        End If
                    End If
                End If
            End If
        Else

            For i = cCount To 3 Step -1
                'check for unneeded middle point in a straigth line
                If oPline.GetBulge(i - 1) <> 0 Then GoTo Skipi
                If oPline.GetBulge(i - 2) <> 0 Then GoTo Skipi
                If Rd(SlopeCol(i - 1)(0), SlopeCol(i - 2)(0)) Then
                    If Rd(SlopeCol(i - 1)(1), SlopeCol(i - 2)(1)) Then
                        Coord = oPline.Coordinate(NewCoordList(i))
                        coord2 = oPline.Coordinate(NewCoordList(i - 1))
                        Coord3 = oPline.Coordinate(NewCoordList(i - 2))
                        If Rd(Coord(0), coord2(0)) Then 'vertical
                            intXY = 1
                        Else
                            intXY = 0
                        End If
         
   
                         If i = cCount Then 'Double back at end
                            If Coord(intXY) > Coord3(intXY) Then
                                If Coord(intXY) < coord2(intXY) Then
                                    NewCoordList.Remove (i)
                                    SlopeCol.Remove i - 1
                                    blnRemoved = True
                                    GoTo Skipi ''''''''''''''''''
                                End If
                            Else
                                If Coord(intXY) > coord2(intXY) Then
                                    NewCoordList.Remove (i)
                                    SlopeCol.Remove i - 1
                                    blnRemoved = True
                                    GoTo Skipi ''''''''''''''''''
                                End If
                            End If
                        End If
                       
                        If i - 3 = 0 Then 'Double back at beginning
                            If Coord(intXY) > coord2(intXY) Then
                                If Coord(intXY) > Coord3(intXY) Then
                                    If Coord3(intXY) > coord2(intXY) Then
                                        NewCoordList.Remove (1)
                                        SlopeCol.Remove 1
                                        blnBeginning = True
                                        blnRemoved = True
                                        GoTo Skipi ''''''''''''''''''
                                    End If
                                End If
                            Else
                                If Coord(intXY) < Coord3(intXY) Then
                                    If Coord3(intXY) < coord2(intXY) Then
                                        NewCoordList.Remove 1
                                        SlopeCol.Remove 1
                                        blnBeginning = True
                                        blnRemoved = True
                                        GoTo Skipi ''''''''''''''''''
                                    End If
                                End If
                            End If
                        End If
                                         
                       
                        If Coord(intXY) > coord2(intXY) Then
                            If coord2(intXY) > Coord3(intXY) Then
                                NewCoordList.Remove (i - 1)
                                SlopeCol.Remove i - 2
                                blnRemoved = True
                                GoTo Skipi ''''''''''''''''''
                            End If
                        Else
                            If coord2(intXY) < Coord3(intXY) Then
                                NewCoordList.Remove (i - 1)
                                SlopeCol.Remove i - 2
                                blnRemoved = True
                                GoTo Skipi ''''''''''''''''''
                            End If
                        End If

                    End If
                End If
               
Skipi:
                If blnRemoved = True Then
                    i = i - 1
                    blnRemoved = False
                End If
                       
            Next i
            If blnBeginning = True Then
                blnBeginning = False
                cCount = NewCoordList.Count
                GoTo BeginCheck
            End If
             'check for double backs
            If SlopeCol.Count > 2 Then
                cCount = NewCoordList.Count
                For i = cCount To 4 Step -1
                    If oPline.GetBulge(i - 1) <> 0 Then GoTo Skip2i
                    If oPline.GetBulge(i - 2) <> 0 Then GoTo Skip2i
                    If oPline.GetBulge(i - 3) <> 0 Then GoTo Skip2i
                    If oPline.GetBulge(i - 4) <> 0 Then GoTo Skip2i
                    'Not checking for arc double backs as they are so rare.
                    intSlope = SlopeCol(i - 1)(2)
                    If Not intSlope = SlopeCol(i - 2)(2) Then GoTo Skip2i
                    If Not intSlope = SlopeCol(i - 3)(2) Then GoTo Skip2i
                    If intSlope = 0 Then intXY = 0  'horiz
                    If intSlope = 1 Then intXY = 1  'vertical
                    If intSlope = 2 Then
                        intXY = 2 ''''''''''''''''''''''2-15
                        If Rd(SlopeCol(i - 1)(0), SlopeCol(i - 2)(0)) Then
                            If Rd(SlopeCol(i - 2)(0), SlopeCol(i - 3)(0)) Then
                                If Rd(SlopeCol(i - 1)(1), SlopeCol(i - 2)(1)) Then
                                    If Rd(SlopeCol(i - 2)(1), SlopeCol(i - 3)(1)) Then
                                        intXY = 0
                                    'Else: GoTo Skip2i ''''''''''''''''''''''''''
                                    End If
                                End If
                            End If
                        End If
                    End If
                   
                    If intXY > 1 Then GoTo Skip2i
                                   
   
                    Coord = oPline.Coordinate(NewCoordList(i - 3))
                    coord2 = oPline.Coordinate(NewCoordList(i - 2))
                    Coord3 = oPline.Coordinate(NewCoordList(i - 1))
                    Coord4 = oPline.Coordinate(NewCoordList(i))
                    If Rd(Coord(0), coord2(0)) Then 'vertical
                        intXY = 1
                    Else
                        intXY = 0
                    End If
                    Rem1 = -1: Rem2 = -1
                    'code for double backs''''''''''''''''''''''''''''''
                    If Coord(intXY) < coord2(intXY) Then
                        If coord2(intXY) < Coord4(intXY) Then
                            If Coord3(intXY) < coord2(intXY) Then
                                If Coord3(intXY) > Coord(intXY) Then
                                    Rem1 = i - 1: Rem2 = i - 2
                                Else
                                    Rem1 = i - 2: Rem2 = i - 3
                                End If
                            End If
                        Else
                            If Coord3(intXY) > Coord(intXY) Then
                                Rem1 = i: Rem2 = i - 1
                            Else
                                Rem1 = i: Rem2 = i - 3
                            End If
                        End If
                    Else
                        If coord2(intXY) > Coord4(intXY) Then
                            If Coord3(intXY) > coord2(intXY) Then
                                If Coord3(intXY) < Coord(intXY) Then
                                    Rem1 = i - 1: Rem2 = i - 2
                                Else
                                    Rem1 = i - 2: Rem2 = i - 3
                                End If
                            End If
                        Else
                            If Coord3(intXY) < Coord(intXY) Then
                                Rem1 = i - 2: Rem2 = i - 3
                            Else
                                Rem1 = i: Rem2 = i - 3
                            End If
                        End If
                    End If
                   
                    If Rem1 > -1 Then
                        NewCoordList.Remove Rem1
                        SlopeCol.Remove Rem1 - 1
                        i = i - 1
                    End If
                    If Rem2 > -1 Then
                        NewCoordList.Remove Rem2
                        'i = i - 1
                        If Rem2 > 1 Then
                            SlopeCol.Remove Rem2 - 1
                        Else
                            SlopeCol.Remove Rem2
                        End If
                    End If
           
                     
Skip2i:
            Next i
        End If
    End If
 End If
Skip2:
   
   
   
    Dim NewPline As AcadLWPolyline
    Dim Cwidth As Double
    Dim blnNonConstantWidth As Boolean
   
    On Error Resume Next
    Cwidth = oPline.ConstantWidth
    If Err.Description = "Invalid input" Then
        blnNonConstantWidth = True
        Err.Clear
    End If
    On Error GoTo 0
   
    'check for should be closed
    If oPline.Closed = False Then
       Dim X1 As Double, Y1 As Double
       Dim X2 As Double, Y2 As Double
       Dim blnClosed As Boolean
       X1 = oPline.Coordinate(NewCoordList(1))(0)
       Y1 = oPline.Coordinate(NewCoordList(1))(1)
       X2 = oPline.Coordinate(NewCoordList(NewCoordList.Count))(0)
       Y2 = oPline.Coordinate(NewCoordList(NewCoordList.Count))(1)
       If Fuzzed(X1, X2, PolyClosedFudge) Then
           If Fuzzed(Y1, Y2, PolyClosedFudge) Then
               NewCoordList.Remove (NewCoordList.Count)
               blnClosed = True
           End If
       End If
    End If



    If Not NewCoordList.Count - 1 = (UBound(oPline.Coordinates) - 1) / 2 Then
        Dim PtsCount As Integer
        PtsCount = (NewCoordList.Count * 2) - 1
        Dim pts() As Double
        ReDim pts(PtsCount) As Double
        cCount = NewCoordList.Count
        For i = 1 To cCount
            k = (i - 1) * 2
            pts(k) = oPline.Coordinate(NewCoordList(i))(0)
            pts(k + 1) = oPline.Coordinate(NewCoordList(i))(1)
        Next
       
       
        Set NewPline = CurrentSpace.AddLightWeightPolyline(pts)
        If oPline.Closed = True Then
            NewPline.Closed = True
        End If
        With NewPline
            .Color = oPline.Color
            .Elevation = oPline.Elevation
            .Layer = oPline.Layer
            .LineType = oPline.LineType
            .LinetypeGeneration = oPline.LinetypeGeneration
            .LineWeight = oPline.LineWeight
            .Normal = oPline.Normal
            .Thickness = oPline.Thickness
            If Cwidth > 0 Then
                .ConstantWidth = Cwidth
            End If
            On Error GoTo 0
           
        End With
        'For i = 1 To NewCoordList.Count
        For i = 1 To SlopeCol.Count
            k = i - 1
            NewPline.SetBulge k, SlopeCol(i)(3)
            If blnNonConstantWidth Then
                Dim StartWidth As Double, endWidth As Double
                oPline.GetWidth NewCoordList(i), StartWidth, endWidth
                NewPline.SetWidth k, StartWidth, endWidth
            End If
        Next
       
        If j = -1 Then
            oPline.Delete
            Set oPline = NewPline
        Else
            Set ss = ThisDrawing.SelectionSets("SS")
            Set obj(0) = ss(j)
            ss.RemoveItems obj
            oPline.Delete
            Set oPline = NewPline
            If blnClosed = True Then
                oPline.Closed = True
            Else
                Set obj(0) = oPline
                ss.AddItems obj
            End If
        End If
        oPline.Update
    End If
   PolyVertexCheck = True
End Function

Bryco

  • Water Moccasin
  • Posts: 1882
Re: Howto join adjacent LWpolylines with VBA?
« Reply #10 on: May 25, 2006, 08:46:35 PM »
Oh they look to long, everone will be asleep before getting to here.

Jeff_M

  • King Gator
  • Posts: 4087
  • C3D user & customizer
Re: Howto join adjacent LWpolylines with VBA?
« Reply #11 on: May 25, 2006, 09:49:45 PM »
Oh they look to long, everone will be asleep before getting to here.
LOL, I scrolled through to see who made it this far. :-)

Seriously, looks like a lot of thought went into these. Can't wait to check it out when I have ACAD available.

Bryco

  • Water Moccasin
  • Posts: 1882
Re: Howto join adjacent LWpolylines with VBA?
« Reply #12 on: May 25, 2006, 10:01:14 PM »
I'ld appreciate your critique.

LE

  • Guest
Re: Howto join adjacent LWpolylines with VBA?
« Reply #13 on: May 25, 2006, 10:24:58 PM »
Do you have an image showing a sample of what you code does?

Thanks.

Bryco

  • Water Moccasin
  • Posts: 1882
Re: Howto join adjacent LWpolylines with VBA?
« Reply #14 on: May 25, 2006, 10:40:06 PM »
No need, use it like you would the express polylinejoin command. It does that and a little more. So you can have some arcs and lines and polys and join them.