TheSwamp
Code Red => VB(A) => Topic started by: havano 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:
-
Sleep well... :-)
meanwhile a possible solution (you've to call this function each with each of them):
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
-
Nice functions Jürg
-
Nice functions Jürg
Thank you for the flowers, Bob... :-)
This was basically written in LISP, then translated to VBA.
-
(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!
-
Something like this should work
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
-
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.
-
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.
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
-
some functions
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
-
This one is the tricky one
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
-
Oh they look to long, everone will be asleep before getting to here.
-
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.
-
I'ld appreciate your critique.
-
Do you have an image showing a sample of what you code does?
Thanks.
-
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.
-
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.
I see, thanks, I was in another radio station, then.
-
I hesitate to use your mighty solution for my simple problem (which I allready solved in a quick and dirty way that has nothing to do with VBA). I don't even possess any drawing that would help me judge your "beast" for its merits. Maybe if you made a drawing available that does, I would appreciate that very much....
The code looks very impressive anyway (to me, anyway).