WCS

Option Explicit


Sub test_Improved_UCS()
' by Jueergen Menzi
' Create a UCS named "New_UCS" in current drawing
     Dim ucsObj As AcadUCS
     Dim origin As Variant, xAxisPnt As Variant, yAxisPnt As Variant

     ' Define the UCS #1
     origin = ThisDrawing.Utility.GetPoint(, "Enter origin:")
     xAxisPnt = _
     ThisDrawing.Utility.GetPoint(ThisDrawing.Utility.TranslateCoordinates(origin _
                                                                           , acWorld, acUCS, False), "Enter x-Axis Point:")
     yAxisPnt = _
     ThisDrawing.Utility.GetPoint(ThisDrawing.Utility.TranslateCoordinates(origin _
                                                                           , acWorld, acUCS, False), "Enter point in X-Y Plane:")

     ' call the improved ADD function
     Set ucsObj = Add_UCS_improved(origin, xAxisPnt, yAxisPnt, "New_UCS")

     ThisDrawing.ActiveUCS = ucsObj

End Sub


Function Add_UCS_improved(origin As Variant, xAxisPnt _
                                             As Variant, yAxisPnt As Variant, ucsName As String) As AcadUCS
' origin, xAxisPnt, and yAxisPnt must all contain Doubles dimmed (0 to 2)

     Dim ucsObj As AcadUCS
     Dim xAxisVec(0 To 2) As Double
     Dim yAxisVec(0 To 2) As Double
     Dim perpYaxisPnt(0 To 2) As Double
     Dim xCy As Variant, perpYaxisVec As Variant

     xAxisVec(0) = xAxisPnt(0) - origin(0)
     xAxisVec(1) = xAxisPnt(1) - origin(1)
     xAxisVec(2) = xAxisPnt(2) - origin(2)
     yAxisVec(0) = yAxisPnt(0) - origin(0)
     yAxisVec(1) = yAxisPnt(1) - origin(1)
     yAxisVec(2) = yAxisPnt(2) - origin(2)

     xCy = Cross3D(xAxisVec, yAxisVec)
     perpYaxisVec = Cross3D(xCy, xAxisVec)

     perpYaxisPnt(0) = perpYaxisVec(0) + origin(0)
     perpYaxisPnt(1) = perpYaxisVec(1) + origin(1)
     perpYaxisPnt(2) = perpYaxisVec(2) + origin(2)

     Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, _
                                                        perpYaxisPnt, ucsName)
     Set Add_UCS_improved = ucsObj

End Function

Function Cross3D(A As Variant, B As Variant) As Variant
' A and B must be dimensioned Double(0 to 2)
     Dim C(0 To 2) As Double
     C(0) = A(1) * B(2) - A(2) * B(1)
     C(1) = -(A(0) * B(2) - A(2) * B(0))
     C(2) = A(0) * B(1) - A(1) * B(0)
     Cross3D = C
End Function