【转帖】在vba中求点的ucs坐标,嘿嘿,在工程中用处可大了 - 精华帖集合
 

在vba中求点的ucs坐标,嘿嘿,在工程中用处可大了 - 精华帖集合
www.dimcax.com
在vba中求点的ucs坐标,嘿嘿,在工程中用处可大了
'*感谢卢老师,感谢peter
'*已知点在wcs中的坐标,如何求在ucs中的坐标
sub example_translatecoordinates()
' this example creates a ucs with an origin at 2, 2, 2.
' next, a point is entered by the user. the wcs and ucs
' coordinates of that point are output in a msgbox.

' create a ucs named "new_ucs" in 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

' define the ucs
origin(0) = 2#: origin(1) = 2#: origin(2) = 2#
xaxispnt(0) = 5#: xaxispnt(1) = 2#: xaxispnt(2) = 2#
yaxispnt(0) = 2#: yaxispnt(1) = 6#: yaxispnt(2) = 2#

' add the ucs to the usercoordinatessystems collection
set ucsobj = thisdrawing.usercoordinatesystems.add(origin, xaxispnt, yaxispnt, "new_ucs")
thisdrawing.activeucs = ucsobj

' get the active viewport and make sure the ucs icon is on
dim viewportobj as acadviewport
set viewportobj = thisdrawing.activeviewport
viewportobj.ucsiconon = true
viewportobj.ucsiconatorigin = true
thisdrawing.activeviewport = viewportobj

' have the user enter a point
dim pointwcs as variant
pointwcs = thisdrawing.utility.getpoint(, "enter a point to translate:")

' translate the point into ucs coordinates
dim pointucs as variant
pointucs = thisdrawing.utility.translatecoordinates(pointwcs, acworld, acucs, false)

' display the coordinates
msgbox "the point has the following coordinates:" & vbcrlf & _
"wcs: " & pointwcs(0) & ", " & pointwcs(1) & ", " & pointwcs(2) & vbcrlf & _
"ucs: " & pointucs(0) & ", " & pointucs(1) & ", " & pointucs(2), , "translatecoordinates example"
end sub
来顶个啦
俺也来顶
如此高深的程序,怎能不顶!
坐标系转换时候会有一定的误差,在程式中就把它消灭掉最好了~
impossible is nothing
这个主要用在工程放样做模具的时候很有用