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