Ok, here is the contents of this module.
Option Explicit
Private CoordLength As Double
Private PolyVertIndex() As Double
Private MainCntr As Integer
Sub RevBubble()
Dim KeyWdList As String
Dim Opt As String
Dim OptText As String
Dim PreOpt As String
SaveSetting "RevisionCloud", "Value", "SystemCoordLenght", ThisDrawing.GetVariable("DIMSCALE") / 3
CoordLength = ThisDrawing.GetVariable("DIMSCALE") / 3
StartOver:
On Error GoTo EscKeyPressed:
KeyWdList = "? Options Rectangle Polygon"
ThisDrawing.Utility.InitializeUserInput 128, KeyWdList
OptText = "Enter A Selection [?/Options/Rectangle/Polygon <"
If Opt = "" Then
OptText = Chr$(10) & Chr$(10) & Chr(10) & OptText & "Rectangle" & ">: "
Opt = ThisDrawing.Utility.GetKeyword(OptText)
If Opt = "" Then
Opt = "Rectangle"
End If
Else
OptText = Chr$(10) & Chr$(10) & Chr$(10) & OptText & Opt & ">:"
PreOpt = Opt
Opt = ThisDrawing.Utility.GetKeyword(OptText)
If Opt = "" Then
Opt = PreOpt
End If
End If
Select Case Opt
Case "Options"
Call Rev_Options
DoEvents
Opt = "Rectangle"
GoTo StartOver:
Case "Rectangle"
Call Rev_Rectangle
Case "Polygon"
Call Rev_Polygon
Case "?"
ThisDrawing.Utility.Prompt "Stand up, walk yourself back to Ben's desk, ask him your question." & Chr$(10)
End Select
EscKeyPressed:
End
End Sub
Private Sub Rev_Rectangle()
Dim SecondPoint(0 To 2) As Double
Dim FourthPoint(0 To 2) As Double
Dim LaterBeginPoint(0 To 2) As Double
Dim LaterSecondPoint(0 To 2) As Double
Dim LaterThirdPoint(0 To 2) As Double
Dim LaterFourthPoint(0 To 2) As Double
Dim FirstPoint As Variant
Dim ThirdPoint As Variant
FirstPoint = ThisDrawing.Utility.GetPoint(, Chr$(10) & "Select first corner point :")
ThirdPoint = ThisDrawing.Utility.GetCorner(FirstPoint, Chr$(10) & "Select second corner point :")
'This part works fine, the points get converted correctly.
FirstPoint = ThisDrawing.Utility.TranslateCoordinates(FirstPoint, acWorld, acUCS, False)
ThirdPoint = ThisDrawing.Utility.TranslateCoordinates(ThirdPoint, acWorld, acUCS, False)
SecondPoint(0) = ThirdPoint(0): SecondPoint(1) = FirstPoint(1): SecondPoint(2) = FirstPoint(2)
FourthPoint(0) = FirstPoint(0): FourthPoint(1) = ThirdPoint(1): FourthPoint(2) = FirstPoint(2)
'These next lines were added because of a similar issue happening to my points. While it was working through ThirdPoint, it was also changing FirstPoint.
LaterBeginPoint(0) = FirstPoint(0): LaterBeginPoint(1) = FirstPoint(1): LaterBeginPoint(2) = FirstPoint(2)
LaterSecondPoint(0) = SecondPoint(0): LaterSecondPoint(1) = SecondPoint(1): LaterSecondPoint(2) = SecondPoint(2)
LaterThirdPoint(0) = ThirdPoint(0): LaterThirdPoint(1) = ThirdPoint(1): LaterThirdPoint(2) = ThirdPoint(2)
LaterFourthPoint(0) = FourthPoint(0): LaterFourthPoint(1) = FourthPoint(1): LaterFourthPoint(2) = FourthPoint(2):
Call Rev_Draw(FirstPoint, SecondPoint)
Call Rev_Draw(LaterSecondPoint, ThirdPoint)
Call Rev_Draw(ThirdPoint, FourthPoint)
Call Rev_Draw(LaterFourthPoint, LaterBeginPoint)
Call Rev_Draw_Cloud
ThisDrawing.Utility.Prompt "Rectangle Cloud was Created Successfully :" & Chr(10)
Erase FirstPoint
Erase ThirdPoint
End Sub
Private Sub Rev_Polygon()
Dim Cont As Boolean
Dim PtStart() As Double
Dim StartPoint(0 To 2) As Double
Dim PtNext() As Double
Dim PtLast(0 To 2) As Double
Dim Cntr As Integer
Dim CurrLin() As Object
Cont = True
PtStart = ThisDrawing.Utility.GetPoint(, Chr$(10) & "Select point")
StartPoint(0) = PtStart(0): StartPoint(1) = PtStart(1): StartPoint(2) = PtStart(2)
PtNext = ThisDrawing.Utility.GetPoint(PtStart, Chr$(10) & "Select next point")
ReDim CurrLin(0 To Cntr)
Set CurrLin(Cntr) = ThisDrawing.ModelSpace.AddLine(PtStart, PtNext)
AutoCAD.Update
Cntr = 0
If IsEmpty(PtNext) <> True Then
Call Rev_Draw(PtStart, PtNext)
End If
Do While Cont = True
On Error GoTo FinishedPolygon:
If IsEmpty(PtNext) <> True Then
PtLast(0) = PtNext(0): PtLast(1) = PtNext(1): PtLast(2) = PtNext(2)
PtNext = ThisDrawing.Utility.GetPoint(PtLast, Chr$(10) & "Select next point")
Cont = True
Cntr = Cntr + 1
ReDim Preserve CurrLin(0 To Cntr)
Set CurrLin(Cntr) = ThisDrawing.ModelSpace.AddLine(PtLast, PtNext)
AutoCAD.Update
If IsEmpty(PtNext) <> True Then
Call Rev_Draw(PtLast, PtNext)
End If
If PtNext(0) = PtLast(0) And PtNext(1) = PtStart(1) And PtNext(2) = PtStart(2) Then
Cont = False
End If
Else
FinishedPolygon:
Cont = False
End If
Loop
If StartPoint(0) <> PtLast(0) Or StartPoint(1) <> PtLast(1) Or StartPoint(2) <> PtLast(2) Then
Call Rev_Draw(PtLast, StartPoint)
End If
Call Rev_Draw_Cloud
For Cntr = 0 To UBound(CurrLin)
CurrLin(Cntr).Delete
Next Cntr
Debug.Print Chr$(10) & "Polygon Cloud was Created Successfully :"
Erase CurrLin
End Sub
Private Sub Rev_Draw(Point1 As Variant, Point2 As Variant)
Dim TempLine As AcadLine
Dim Dist As Double
Dim Angl As Double
Dim NewCoordLength As Double
Dim VertPoints() As Double
Dim Arcs As Integer
Dim Counter As Integer
Dim Cntr As Integer
Dim Cntr2 As Integer
Dim Increm As Integer
Dim Point3 As Variant
CoordLength = GetSetting("RevisionCloud", "Value", "SystemCoordLenght")
'Here is where the fun part occurs.
Point1 = ThisDrawing.Utility.TranslateCoordinates(Point1, acUCS, acWorld, False)
Point2 = ThisDrawing.Utility.TranslateCoordinates(Point2, acUCS, acWorld, False)
Set TempLine = ThisDrawing.ModelSpace.AddLine(Point1, Point2)
Dist = TempLine.Length
Angl = TempLine.Angle
TempLine.Delete
Set TempLine = Nothing
Arcs = (Fix(Dist) / CoordLength) + 1
NewCoordLength = Dist / Arcs
Counter = 0
Increm = 2
ReDim VertPoints(0 To 1)
VertPoints(0) = Point1(0): VertPoints(1) = Point1(1)
Do While Counter < Arcs
ReDim Preserve VertPoints(0 To Increm + 1)
Point3 = ThisDrawing.Utility.PolarPoint(Point1, Angl, NewCoordLength)
VertPoints(Increm) = Point3(0): VertPoints(Increm + 1) = Point3(1)
Increm = Increm + 2
Counter = Counter + 1
Point1(0) = Point3(0): Point1(1) = Point3(1): Point1(2) = Point3(2)
Loop
On Error GoTo NewVariable
Cntr2 = UBound(PolyVertIndex) + 1
MainCntr = MainCntr + UBound(VertPoints) + 1
GoTo ContinueAlong
NewVariable:
Cntr2 = 0
MainCntr = MainCntr + UBound(VertPoints)
ContinueAlong:
ReDim Preserve PolyVertIndex(0 To MainCntr)
For Cntr = 0 To UBound(VertPoints)
PolyVertIndex(Cntr2) = VertPoints(Cntr)
Cntr2 = Cntr2 + 1
Next Cntr
Erase VertPoints
Erase Point3
End Sub
Private Sub Rev_Draw_Cloud()
Dim FinalLine As AcadLWPolyline
Dim BulgeH As Double
Dim VertCount As Integer
Dim Cntr As Integer
Dim CloudStart(0 To 2) As Double
CloudStart(0) = PolyVertIndex(0): CloudStart(1) = PolyVertIndex(1): CloudStart(2) = 0
VertCount = ((UBound(PolyVertIndex) + 1) / 2) - 1
Set FinalLine = ThisDrawing.ModelSpace.AddLightWeightPolyline(PolyVertIndex)
'FinalLine.Rotate
BulgeH = GetBulge(CoordLength) * -1
For Cntr = 0 To VertCount
FinalLine.SetBulge Cntr, BulgeH
Next Cntr
Set FinalLine = Nothing
End Sub
Private Sub Rev_Options()
Rev_Cloud_Options.Show
End Sub
Private Function GetBulge(LOChord As Double) As Double
Dim Tri1Len As Double
Dim BulgeHeight As Double
Dim ChordEndAng As Double
Dim ChordHeightAng As Double
Dim AngleIncluded As Double
Const PI = 3.1415926
BulgeHeight = LOChord / 1.125
Tri1Len = LOChord / 2
ChordEndAng = Atn(Tri1Len / BulgeHeight)
ChordEndAng = ChordEndAng * (180 / PI)
ChordHeightAng = 180 - (ChordEndAng + 90)
AngleIncluded = ((ChordHeightAng * 2) * (PI / 180))
GetBulge = Tan(AngleIncluded / 4)
End Function
Let me add that this worked fine, until I started wanting it to work regardless of the current UCS, and added in all of the translate coordinates stuff.
Any help would be appreciated.
