[求助]如何自定义UCS坐标的表达方式？

hzh2000

如何建立自定义表达方式的UCS. 例如，想建立这样一个UCS, 原点在WCS的原点上，Y、Z方向按WCS表述，X方向按肋位号表示。如：肋位为0-100，每档肋位间距500mm,这样，相对于WCS的点（6000，1200，3000）按此UCS方法表示就是（FR12,1200,3000).

我的问题就是能否建立上述坐标系，可以自定义坐标的表达方式。如在画直线命令时，以（FR12,1200,3000)的形式输入点坐标，而不是（6000，1200，3000）。不知道能否实现。望达者解惑，等待...

兰州人

学习AUTOCAD二次开发第九章

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

hzh2000

楼上的应该没有明白我的意思，我是想在坐标的输入方式上有所更改，用（FR12,1200,3000)代替（6000，1200，3000）。

兰州人

hzh2000发表于2009-7-27 11:10:00楼上的应该没有明白我的意思，我是想在坐标的输入方式上有所更改，用（FR12,1200,3000)代替（6000，1200，3000）。

在VBA中（FR12,1200,3000),（6000，1200，3000）需要在在VBA的UCS中,点坐标转换.

Set myUCS = AddOrgUCS(NewOrgPt, "abc")

式中的NewOrgPt是dim NewOrgPT(0 to 2) as double.

FR12是你自己定义,在VBA中没有,这应属VB字符替换知识.

hzh2000

FR12代替6000，12与6000的关系是12*500，同理FR15就是15*500=7500，不可能每个字符都定义，所以有很大差距