在VBA中应用ucs小结,深入学习AUTOCAD二次开发第九章.

Sub Example_UserCoordinateSystems()
    ' This example finds the current UserCoordinateSystems collection and
    ' adds a new UCS to that collection.
    Dim pp(2) As Double
    Dim UCSColl As AcadUCSs
    Set UCSColl = ThisDrawing.UserCoordinateSystems
    
    ' Create a UCS named "TEST" in the current drawing
    Dim ucsObj As AcadUCS
    Dim origin(0 To 2) As Double
    Dim xAxisPnt(0 To 2) As Double
    Dim yAxisPnt(0 To 2) As Double
    Dim pp1(2) As Double
    pp1(1) = 20
    ' Define the UCS
    origin(0) = 0#: origin(1) = 0#: origin(2) = 0#
    xAxisPnt(0) = 0: xAxisPnt(1) = 1#: xAxisPnt(2) = 0
    yAxisPnt(0) = 0: yAxisPnt(1) = 0#: yAxisPnt(2) = 1
    Set objLine = ThisDrawing.ModelSpace.AddLine(xAxisPnt, yAxisPnt)
       objLine.color = 3
    ' Add the UCS to the UserCoordinatesSystems collection
    Dim objCircle As AcadCircle
    Set ucsObj = UCSColl.Add(origin, xAxisPnt, yAxisPnt, "TEST")
    ThisDrawing.ActiveUCS = ucsObj
    Set objCircle = ThisDrawing.ModelSpace.AddCircle(pp, 20)
    Set objCircle = ThisDrawing.ModelSpace.AddCircle(pp1, 0.5)
    Set objArc = ThisDrawing.ModelSpace.AddArc(pp, 3, 0, 1.5)
    'Set objcy = ThisDrawing.ModelSpace.AddCylinder(pp, 5, 20)
    objAng = (Atn(1) * 4 / 180) * 360
     objC = objCircle.ArrayPolar(6, objAng, pp)
    'MsgBox "A new UCS called " & ucsObj.Name & " has been added to the UserCoordinateSystems collection.", vbInformation, "UserCoordinateSystems 示例"
End Sub

Sub LLL()
  Dim UUS As AcadUCSs
  Dim UU As AcadUCS
  Set UU = ThisDrawing.UserCoordinateSystems.Item("aa")
  ThisDrawing.ActiveUCS = UU
  transMatrix = UU.GetUCSMatrix()
  Dim objLine As AcadLine, objCircle As AcadCircle
  Set objCircle = ThisDrawing.HandleToObject("8E")
  objCircle.TransformBy (transMatrix)
End Sub

Sub test_AddOrgUCS()
    '原点UCS调用示例
    Dim myUCS As AcadUCS, NewOrgPt As Variant
    NewOrgPt = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入新原点：")
    Set myUCS = AddOrgUCS(NewOrgPt, "abc")
    ThisDrawing.ActiveUCS = myUCS
End Sub
Sub test_AddXAngUCS()
    'X轴旋转UCS调用示例
    Dim myUCS As AcadUCS, Ang As Double
    Ang = ThisDrawing.Utility.GetAngle(, vbCrLf & "请指定绕 X 轴的旋转角度:")
    Set myUCS = AddXAngUCS(Ang, "abc")
    ThisDrawing.ActiveUCS = myUCS
End Sub
Sub test_AddYAngUCS()
    'Y轴旋转UCS调用示例
    Dim myUCS As AcadUCS, Ang As Double
    Ang = ThisDrawing.Utility.GetAngle(, vbCrLf & "请指定绕 Y 轴的旋转角度:")
    Set myUCS = AddYAngUCS(Ang, "abc")
    ThisDrawing.ActiveUCS = myUCS
End Sub
Sub test_AddZAngUCS()
    'Z轴旋转UCS调用示例
    Dim myUCS As AcadUCS, Ang As Double
    Ang = ThisDrawing.Utility.GetAngle(, vbCrLf & "请指定绕 Z 轴的旋转角度:")
    Set myUCS = AddZAngUCS(Ang, "abc")
    ThisDrawing.ActiveUCS = myUCS
End Sub
' 移动原点创建UCS
' ptOriginWcs：新UCS的原点在WCS中的坐标
Public Function AddOrgUCS(ptOriginWcs As Variant, strUcsName As String) As AcadUCS
    ' 获得新UCS原点在当前UCS中的坐标
    Dim ptOriginUcs As Variant
    ptOriginUcs = PtWcs2Ucs(ptOriginWcs)
    'Debug.Print ptOriginWcs(0)
    ' 获得X、Y正半轴上任一点的UCS坐标
    Dim ptXUcs(0 To 2) As Double, ptYUcs(0 To 2) As Double
    ptXUcs(0) = ptOriginUcs(0) + 1
    ptXUcs(1) = ptOriginUcs(1)
    ptXUcs(2) = ptOriginUcs(2)
    ptYUcs(0) = ptOriginUcs(0)
    ptYUcs(1) = ptOriginUcs(1) + 1
    ptYUcs(2) = ptOriginUcs(2)
    
    ' 获得X、Y正半轴上任一点的WCS坐标
    Dim ptXWcs As Variant, ptYWcs As Variant
    ptOriginWcs = PtUcs2Wcs(ptOriginUcs)
    ptXWcs = PtUcs2Wcs(ptXUcs)
    ptYWcs = PtUcs2Wcs(ptYUcs)
    'Debug.Print ptOriginWcs(0)
    ' 创建UCS
    Set AddOrgUCS = ThisDrawing.UserCoordinateSystems.Add(ptOriginWcs, ptXWcs, ptYWcs, strUcsName)
End Function
' 旋转X轴创建新的UCS
' angle：弧度值，绕X轴旋转的角度（旋转方向由右手定则决定）
Public Function AddXAngUCS(angle As Double, strUcsName As String) As AcadUCS
    ' 定义新UCS原点的三维WCS坐标
    Dim ptOriginUcs(0 To 2) As Double
    ptOriginUcs(0) = 0: ptOriginUcs(1) = 0: ptOriginUcs(2) = 0
    Dim ptOriginWcs As Variant
    ptOriginWcs = PtUcs2Wcs(ptOriginUcs)
    
    ' 定义新UCS在X轴正方向上一个点的三维WCS坐标
    Dim ptXUcs(0 To 2) As Double
    ptXUcs(0) = 1: ptXUcs(1) = 0: ptXUcs(2) = 0
    Dim ptXWcs As Variant
    ptXWcs = PtUcs2Wcs(ptXUcs)
    
    ' 定义新UCS在Y轴正方向上一个点的三维WCS坐标
    Dim ptYUcs(0 To 2) As Double
    ptYUcs(0) = 0: ptYUcs(1) = Cos(angle): ptYUcs(2) = Sin(angle)
    Dim ptYWcs As Variant
    ptYWcs = PtUcs2Wcs(ptYUcs)
    
    Set AddXAngUCS = ThisDrawing.UserCoordinateSystems.Add(ptOriginWcs, ptXWcs, ptYWcs, strUcsName)
End Function
' 旋转Y轴创建新的UCS
' angle:弧度值，绕Y轴旋转的角度（旋转方向由右手定则决定）
Public Function AddYAngUCS(angle As Double, strUcsName As String) As AcadUCS
    ' 定义新UCS原点的三维WCS坐标
    Dim ptOriginUcs(0 To 2) As Double
    ptOriginUcs(0) = 0: ptOriginUcs(1) = 0: ptOriginUcs(2) = 0
    Dim ptOriginWcs As Variant
    ptOriginWcs = PtUcs2Wcs(ptOriginUcs)
    
    ' 定义新UCS在X轴正方向上一个点的三维WCS坐标
    Dim ptXUcs(0 To 2) As Double
    ptXUcs(0) = Cos(angle): ptXUcs(1) = 0: ptXUcs(2) = -Sin(angle)
    Dim ptXWcs As Variant
    ptXWcs = PtUcs2Wcs(ptXUcs)
    
    ' 定义新UCS在Y轴正方向上一个点的三维WCS坐标
    Dim ptYUcs(0 To 2) As Double
    ptYUcs(0) = 0: ptYUcs(1) = 1: ptYUcs(2) = 0
    Dim ptYWcs As Variant
    ptYWcs = PtUcs2Wcs(ptYUcs)
    
    Set AddYAngUCS = ThisDrawing.UserCoordinateSystems.Add(ptOriginWcs, ptXWcs, ptYWcs, strUcsName)
End Function
' 旋转Z轴创建新的UCS
' angle:弧度值，绕Z轴旋转的角度（旋转方向由右手定则决定）
Public Function AddZAngUCS(angle As Double, strUcsName As String) As AcadUCS
    ' 定义新UCS原点的三维WCS坐标
    Dim ptOriginUcs(0 To 2) As Double
    ptOriginUcs(0) = 0: ptOriginUcs(1) = 0: ptOriginUcs(2) = 0
    Dim ptOriginWcs As Variant
    ptOriginWcs = PtUcs2Wcs(ptOriginUcs)
    
    ' 定义新UCS在X轴正方向上一个点的三维WCS坐标
    Dim ptXUcs(0 To 2) As Double
    ptXUcs(0) = Cos(angle): ptXUcs(1) = Sin(angle): ptXUcs(2) = 0
    Dim ptXWcs As Variant
    ptXWcs = PtUcs2Wcs(ptXUcs)
    
    ' 定义新UCS在Y轴正方向上一个点的三维WCS坐标
    Dim ptYUcs(0 To 2) As Double
    ptYUcs(0) = -Sin(angle): ptYUcs(1) = Cos(angle): ptYUcs(2) = 0
    Dim ptYWcs As Variant
    ptYWcs = PtUcs2Wcs(ptYUcs)
    
    Set AddZAngUCS = ThisDrawing.UserCoordinateSystems.Add(ptOriginWcs, ptXWcs, ptYWcs, strUcsName)
End Function
' 将点的UCS坐标转化到WCS坐标
Private Function PtUcs2Wcs(ptUcs As Variant) As Variant
    PtUcs2Wcs = ThisDrawing.Utility.TranslateCoordinates(ptUcs, acUCS, acWorld, False)
End Function
' 将点的WCS坐标转化到UCS坐标
Private Function PtWcs2Ucs(ptWcs As Variant) As Variant
    PtWcs2Ucs = ThisDrawing.Utility.TranslateCoordinates(ptWcs, acWorld, acUCS, False)
End Function