hzh2000 发表于 2009-7-21 20:01:00

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

<div style="MARGIN-TOP: 10px; FONT-SIZE: 12pt; MIN-HEIGHT: 200px; WORD-BREAK: break-all; TEXT-INDENT: 0px; LINE-HEIGHT: normal; WORD-WRAP: break-word;"><p>如何建立自定义表达方式的UCS. 例如，想建立这样一个UCS, 原点在WCS的原点上，Y、Z方向按WCS表述，X方向按肋位号表示。如：肋位为0-100，每档肋位间距500mm,这样，相对于WCS的点（6000，1200，3000）按此UCS方法表示就是（FR12,1200,3000).</p><p>我的问题就是能否建立上述坐标系，可以自定义坐标的表达方式。如在画直线命令时，以（FR12,1200,3000)的形式输入点坐标，而不是（6000，1200，3000）。不知道能否实现。望达者解惑，等待...</p></div>

兰州人 发表于 2009-7-24 12:54:00

学习AUTOCAD二次开发第九章
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 发表于 2009-7-27 11:10:00

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

兰州人 发表于 2009-7-27 12:18:00

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

<p></p><p>在VBA中（FR12,1200,3000),（6000，1200，3000）需要在在VBA的UCS中,点坐标转换.</p><p>Set myUCS <font color="#0000ff">=</font> AddOrgUCS<font color="#ff0000">(</font>NewOrgPt, <font color="#880000">"abc"</font><font color="#ff0000">)</font></p><p>式中的NewOrgPt是dim NewOrgPT(0 to 2) as double.</p><p>FR12是你自己定义,在VBA中没有,这应属VB字符替换知识.</p><p></p><p></p>

hzh2000 发表于 2009-7-27 23:07:00

<p>FR12代替6000，12与6000的关系是12*500，同理FR15就是15*500=7500，不可能每个字符都定义，所以有很大差距</p>
页: [1]
查看完整版本: [求助]如何自定义UCS坐标的表达方式？