[求助]：请教用vba实现坐标转换的问题

ibluesky

如何用vba把wcs中的坐标转换到ucs中呢？

ibluesky

是不是translatecoordinates函数？怎么用？

lsjjm

试试这个子程序:
sub pointtranslate ()
dim pointwcs as variant
pointwcs = thisdrawing.utility.getpoint(,"input point:")
dim pointucs as variant
pointucs = thisdrawing.utility.translatecoordinates(pointwcs,acworld,acucs,false)
msgbox "coordinates: " & vbcrlf & "wcs:" & pointwcs(0) & "," &_
pointwcs(1) & "," & pointwcs (2) & vbcrlf & "ucs:" & pointucs(0) &_
"," & pointucs(1) & "," & pointucs(2)
end sub

ibluesky

谢谢
but

compile error
can not assign to array
好像是不能给数组分配

hgqhq

translatecoordinates将点从一个坐标系统转换为另外一个坐标系统
语法
RetVal = object.TranslateCoordinates(OriginalPoint, From, To, Disp[, OCSNormal])
Object：使用该方法的对象。
OriginalPoint：Variant[变体] (三元素双精度数组); 仅用于输入
From：AcCoordinateSystem 常数; 仅用于输入(acWorld  acUCS  acOCS acDisplayDCS  acPaperSpaceDCS )
To：AcCoordinateSystem 常数; 仅用于输入(acWorld  acUCS  acOCS acDisplayDCS acPaperSpaceDCS )
Disp：Integer[整数]; 仅用于输入
FALSE: OriginalPoint is treated as a point.
OCSNormal：Variant[变体] (三元素双精度数组); 仅用于输入;可选项
RetVal：Variant[变体] (三元素双精度数组)

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 of the point
    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

ibluesky

Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS")


这一段不懂

ibluesky

Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS")



而且系统报错说x,y 轴不正交，不懂

efan2000

这一句是创建一个用户坐标系。构成用户坐标系的X轴和Y轴必须是垂直相交的，否则不能创建。

liujianzhong88

大神们还在吗？我也遇到同样的问题是用了上面的代码，但是坐标转换不了，转换后 坐标没有变化，求指导