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

兰州人

Sub A()
    Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
    Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double
    With ThisDrawing
        '下面4个点用于定义二维填充(solid)对象
        P1(0) = 0: P1(1) = 0: P1(2) = 0
        '下面3个点用于定义新的UCS
        Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点
        Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向
        Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向
        '新建UCS
        Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")
        '新UCS置为当前
        .ActiveUCS = UCS
        '创建二维填充
        Set objCircle = .ModelSpace.AddCircle(P1, 10)

    End With
End Sub

Xp(0)=1:Yp(2)=1 相当于执行UCS命令--- UCS →X →90

Xp(0)=1:Yp(2)=-1 相当于执行UCS命令--- UCS →X →-90

Xp(2)=1:Yp(1)=1 相当于执行UCS命令--- UCS →X →-90

希望有兴趣的大侠共同整理,谢谢.

兰州人

下面程序是将VBA示例程序,填加了circle,arc和arraypolar命令,便于各位大侠理解.

2. Sub Example_UserCoordinateSystems()
3.     ' This example finds the current UserCoordinateSystems collection and
4.     ' adds a new UCS to that collection.
5.     Dim pp(2) As Double
6.     Dim UCSColl As AcadUCSs
7.     Set UCSColl = ThisDrawing.UserCoordinateSystems
8.    
9.     ' Create a UCS named "TEST" in the current drawing
10.     Dim ucsObj As AcadUCS
11.     Dim origin(0 To 2) As Double
12.     Dim xAxisPnt(0 To 2) As Double
13.     Dim yAxisPnt(0 To 2) As Double
14.     Dim pp1(2) As Double
15.     pp1(1) = 20
16.     ' Define the UCS
17.     origin(0) = 0#: origin(1) = 0#: origin(2) = 0#
18.     xAxisPnt(0) = 0: xAxisPnt(1) = 1#: xAxisPnt(2) = 0
19.     yAxisPnt(0) = 0: yAxisPnt(1) = 0#: yAxisPnt(2) = 1
20.     Set objLine = ThisDrawing.ModelSpace.AddLine(xAxisPnt, yAxisPnt)
21.        objLine.color = 3
22.     ' Add the UCS to the UserCoordinatesSystems collection
23.     Dim objCircle As AcadCircle
24.     Set ucsObj = UCSColl.Add(origin, xAxisPnt, yAxisPnt, "TEST")
25.     ThisDrawing.ActiveUCS = ucsObj
26.     Set objCircle = ThisDrawing.ModelSpace.AddCircle(pp, 20)
27.     Set objCircle = ThisDrawing.ModelSpace.AddCircle(pp1, 0.5)
28.     Set objArc = ThisDrawing.ModelSpace.AddArc(pp, 3, 0, 1.5)
29.     'Set objcy = ThisDrawing.ModelSpace.AddCylinder(pp, 5, 20)
30.     objAng = (Atn(1) * 4 / 180) * 360
31.      objC = objCircle.ArrayPolar(6, objAng, pp)
32.     'MsgBox "A new UCS called " & ucsObj.Name & " has been added to the UserCoordinateSystems collection.", vbInformation, "UserCoordinateSystems 示例"
33. End Sub

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

ningyong58

在UCS中有一个已经定义好的UCS为"aa"
采用UserCoordianteSystems.Item方法.
用UserCoordinateSystems.Item("aa")

2. Sub LLL()
3.   Dim UUS As AcadUCSs
4.   Dim UU As AcadUCS
5.   Set UU = ThisDrawing.UserCoordinateSystems.Item("aa")
6.   ThisDrawing.ActiveUCS = UU
7.   transMatrix = UU.GetUCSMatrix()
8.   Dim objLine As AcadLine, objCircle As AcadCircle
9.   Set objCircle = ThisDrawing.HandleToObject("8E")
10.   objCircle.TransformBy (transMatrix)
11. 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

兰州人

重新体会AutoCAD二次开发第九章的9.1到9.2
上面所述全在下面程序中解决.

2. Sub test_AddOrgUCS()
3.     '原点UCS调用示例
4.     Dim myUCS As AcadUCS, NewOrgPt As Variant
5.     NewOrgPt = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入新原点：")
6.     Set myUCS = AddOrgUCS(NewOrgPt, "abc")
7.     ThisDrawing.ActiveUCS = myUCS
8. End Sub
9. Sub test_AddXAngUCS()
10.     'X轴旋转UCS调用示例
11.     Dim myUCS As AcadUCS, Ang As Double
12.     Ang = ThisDrawing.Utility.GetAngle(, vbCrLf & "请指定绕 X 轴的旋转角度:")
13.     Set myUCS = AddXAngUCS(Ang, "abc")
14.     ThisDrawing.ActiveUCS = myUCS
15. End Sub
16. Sub test_AddYAngUCS()
17.     'Y轴旋转UCS调用示例
18.     Dim myUCS As AcadUCS, Ang As Double
19.     Ang = ThisDrawing.Utility.GetAngle(, vbCrLf & "请指定绕 Y 轴的旋转角度:")
20.     Set myUCS = AddYAngUCS(Ang, "abc")
21.     ThisDrawing.ActiveUCS = myUCS
22. End Sub
23. Sub test_AddZAngUCS()
24.     'Z轴旋转UCS调用示例
25.     Dim myUCS As AcadUCS, Ang As Double
26.     Ang = ThisDrawing.Utility.GetAngle(, vbCrLf & "请指定绕 Z 轴的旋转角度:")
27.     Set myUCS = AddZAngUCS(Ang, "abc")
28.     ThisDrawing.ActiveUCS = myUCS
29. End Sub
30. ' 移动原点创建UCS
31. ' ptOriginWcs：新UCS的原点在WCS中的坐标
32. Public Function AddOrgUCS(ptOriginWcs As Variant, strUcsName As String) As AcadUCS
33.     ' 获得新UCS原点在当前UCS中的坐标
34.     Dim ptOriginUcs As Variant
35.     ptOriginUcs = PtWcs2Ucs(ptOriginWcs)
36.     'Debug.Print ptOriginWcs(0)
37.     ' 获得X、Y正半轴上任一点的UCS坐标
38.     Dim ptXUcs(0 To 2) As Double, ptYUcs(0 To 2) As Double
39.     ptXUcs(0) = ptOriginUcs(0) + 1
40.     ptXUcs(1) = ptOriginUcs(1)
41.     ptXUcs(2) = ptOriginUcs(2)
42.     ptYUcs(0) = ptOriginUcs(0)
43.     ptYUcs(1) = ptOriginUcs(1) + 1
44.     ptYUcs(2) = ptOriginUcs(2)
45.    
46.     ' 获得X、Y正半轴上任一点的WCS坐标
47.     Dim ptXWcs As Variant, ptYWcs As Variant
48.     ptOriginWcs = PtUcs2Wcs(ptOriginUcs)
49.     ptXWcs = PtUcs2Wcs(ptXUcs)
50.     ptYWcs = PtUcs2Wcs(ptYUcs)
51.     'Debug.Print ptOriginWcs(0)
52.     ' 创建UCS
53.     Set AddOrgUCS = ThisDrawing.UserCoordinateSystems.Add(ptOriginWcs, ptXWcs, ptYWcs, strUcsName)
54. End Function
55. ' 旋转X轴创建新的UCS
56. ' angle：弧度值，绕X轴旋转的角度（旋转方向由右手定则决定）
57. Public Function AddXAngUCS(angle As Double, strUcsName As String) As AcadUCS
58.     ' 定义新UCS原点的三维WCS坐标
59.     Dim ptOriginUcs(0 To 2) As Double
60.     ptOriginUcs(0) = 0: ptOriginUcs(1) = 0: ptOriginUcs(2) = 0
61.     Dim ptOriginWcs As Variant
62.     ptOriginWcs = PtUcs2Wcs(ptOriginUcs)
63.    
64.     ' 定义新UCS在X轴正方向上一个点的三维WCS坐标
65.     Dim ptXUcs(0 To 2) As Double
66.     ptXUcs(0) = 1: ptXUcs(1) = 0: ptXUcs(2) = 0
67.     Dim ptXWcs As Variant
68.     ptXWcs = PtUcs2Wcs(ptXUcs)
69.    
70.     ' 定义新UCS在Y轴正方向上一个点的三维WCS坐标
71.     Dim ptYUcs(0 To 2) As Double
72.     ptYUcs(0) = 0: ptYUcs(1) = Cos(angle): ptYUcs(2) = Sin(angle)
73.     Dim ptYWcs As Variant
74.     ptYWcs = PtUcs2Wcs(ptYUcs)
75.    
76.     Set AddXAngUCS = ThisDrawing.UserCoordinateSystems.Add(ptOriginWcs, ptXWcs, ptYWcs, strUcsName)
77. End Function
78. ' 旋转Y轴创建新的UCS
79. ' angle:弧度值，绕Y轴旋转的角度（旋转方向由右手定则决定）
80. Public Function AddYAngUCS(angle As Double, strUcsName As String) As AcadUCS
81.     ' 定义新UCS原点的三维WCS坐标
82.     Dim ptOriginUcs(0 To 2) As Double
83.     ptOriginUcs(0) = 0: ptOriginUcs(1) = 0: ptOriginUcs(2) = 0
84.     Dim ptOriginWcs As Variant
85.     ptOriginWcs = PtUcs2Wcs(ptOriginUcs)
86.    
87.     ' 定义新UCS在X轴正方向上一个点的三维WCS坐标
88.     Dim ptXUcs(0 To 2) As Double
89.     ptXUcs(0) = Cos(angle): ptXUcs(1) = 0: ptXUcs(2) = -Sin(angle)
90.     Dim ptXWcs As Variant
91.     ptXWcs = PtUcs2Wcs(ptXUcs)
92.    
93.     ' 定义新UCS在Y轴正方向上一个点的三维WCS坐标
94.     Dim ptYUcs(0 To 2) As Double
95.     ptYUcs(0) = 0: ptYUcs(1) = 1: ptYUcs(2) = 0
96.     Dim ptYWcs As Variant
97.     ptYWcs = PtUcs2Wcs(ptYUcs)
98.    
99.     Set AddYAngUCS = ThisDrawing.UserCoordinateSystems.Add(ptOriginWcs, ptXWcs, ptYWcs, strUcsName)
100. End Function
101. ' 旋转Z轴创建新的UCS
102. ' angle:弧度值，绕Z轴旋转的角度（旋转方向由右手定则决定）
103. Public Function AddZAngUCS(angle As Double, strUcsName As String) As AcadUCS
104.     ' 定义新UCS原点的三维WCS坐标
105.     Dim ptOriginUcs(0 To 2) As Double
106.     ptOriginUcs(0) = 0: ptOriginUcs(1) = 0: ptOriginUcs(2) = 0
107.     Dim ptOriginWcs As Variant
108.     ptOriginWcs = PtUcs2Wcs(ptOriginUcs)
109.    
110.     ' 定义新UCS在X轴正方向上一个点的三维WCS坐标
111.     Dim ptXUcs(0 To 2) As Double
112.     ptXUcs(0) = Cos(angle): ptXUcs(1) = Sin(angle): ptXUcs(2) = 0
113.     Dim ptXWcs As Variant
114.     ptXWcs = PtUcs2Wcs(ptXUcs)
115.    
116.     ' 定义新UCS在Y轴正方向上一个点的三维WCS坐标
117.     Dim ptYUcs(0 To 2) As Double
118.     ptYUcs(0) = -Sin(angle): ptYUcs(1) = Cos(angle): ptYUcs(2) = 0
119.     Dim ptYWcs As Variant
120.     ptYWcs = PtUcs2Wcs(ptYUcs)
121.    
122.     Set AddZAngUCS = ThisDrawing.UserCoordinateSystems.Add(ptOriginWcs, ptXWcs, ptYWcs, strUcsName)
123. End Function
124. ' 将点的UCS坐标转化到WCS坐标
125. Private Function PtUcs2Wcs(ptUcs As Variant) As Variant
126.     PtUcs2Wcs = ThisDrawing.Utility.TranslateCoordinates(ptUcs, acUCS, acWorld, False)
127. End Function
128. ' 将点的WCS坐标转化到UCS坐标
129. Private Function PtWcs2Ucs(ptWcs As Variant) As Variant
130.     PtWcs2Ucs = ThisDrawing.Utility.TranslateCoordinates(ptWcs, acWorld, acUCS, False)
131. End Function

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

wangjianchunmo

兰州人 发表于 2009-7-22 08:46
重新体会AutoCAD二次开发第九章的9.1到9.2
上面所述全在下面程序中解决.

非常感谢楼主

3xxx

感谢版主。