[VBA程序]：如何改坐标系方向?

xiaokai

如何改坐标系方向?
也就是把x方向和y方向交换,使x方向成为y方向,y方向成为x方向.
谢谢!

雪山飞狐(lzh)

使用用户坐标系

xiaokai

斑竹
那用vba怎么编?

雪山飞狐(lzh)

由用户指定三维空间中X，Y和Z轴方向而自定义的坐标系 。

VBA 类名:
AcadUCS

创建方法:
UCSs.Add

访问途径:
UCSs.Item
Document.ActiveUCS


修改 (0, 0, 0)原点的位置和XY平面及Z轴的方向定义一个UCS。可以在三维空间中的任何地方定位或确定一个UCS，也可以根据需要定义多个UCS。

ActiveX 自动模型中的所有坐标系都基于世界坐标系(WCS)。使用 GetUCSMatrix 方法返回给定的UCS的变换矩阵。使用这一变换矩阵可得到WCS坐标系下的坐标值。

使用 UCSIconOn 属性设置UCS图标在给定视图中是否打开。

激活UCS，使用Document(文档)对象的 ActiveUCS 属性。若修改了活动的UCS，新的UCS对象必须复位，以显示活动的UCS的改变。复位活动的UCS，只需要再次调用ActiveUCS属性即可更新UCS对象。

要在图形中添加UCS，可使用UCSs对象集合的 Add 方法。要编辑或查询已存在的UCS，可使用下列方法和属性： 方法

Delete

GetExtensionDictionary

GetUCSMatrix

GetXData

SetXData
属性  

Application

Document

Handle

HasExtensionDictionary

Name

ObjectID

ObjectName

Origin

OwnerID

XVector

YVector  
事件  

Modified

xiaokai

斑竹,讲了这么多,都是理论的,有点晕了
举个例子好吧
把x方向和y方向互换
把程序写出来吧
谢谢了!!

ahlzl

[php]Sub test_XY_UCS()
    '程序只在WCS中成立！
    Dim myUCS As AcadUCS, P0(2) As Double, P1(2) As Double, P2(2) As Double
    P1(1) = 1: P2(0) = 1
    Set myUCS = ThisDrawing.UserCoordinateSystems.Add(P0, P1, P2, "abc")
    ThisDrawing.ActiveUCS = myUCS
End Sub[/php]

xiaokai

Dim myUCS As AcadUCS, P0(2) As Double, P1(2) As Double, P2(2) As Double
    P1(1) = 1: P2(0) = 1
    Set myUCS = ThisDrawing.UserCoordinateSystems.Add(P0, P1, P2, "abc")
    ThisDrawing.ActiveUCS = myUCS

     Dim objLine1 As AcadLine
     Set objLine1 = ThisDrawing.ModelSpace.addline(P0, P1)
我用上面这条语句进行测试,目的是为了画一条(0,0,0)起点,(0,1,0)终点的水平直线,但结果是画成了一条(0,0,0)起点,(1,0,0)终点的垂直直线,也就是画图的结果和没改变坐标系的一样,但用手工用直线命令在新坐标系下输入(0,0,0)起点,(0,1,0)终点,确能正确画出我想要的那条水平直线来.
如果修改Set objLine1 ....语句行的终点坐标为(1,0,0)应该可以实现这种结果,但程序中很多这种语句,而且这样做不太好.请问,该怎么修改这个程序?
谢谢!

ahlzl

[php]Sub test_XY_UCS()
       '程序只在WCS中成立！
    Dim myUCS As AcadUCS, P0(2) As Double, P1(2) As Double, P2(2) As Double
    P1(1) = 1: P2(0) = 1
    Set myUCS = ThisDrawing.UserCoordinateSystems.Add(P0, P1, P2, "abc")
    ThisDrawing.ActiveUCS = myUCS
   
    Dim LineObj As AcadLine
    Dim pt1(2) As Double, pt2(2) As Double
    pt2(1) = 1
   
    Dim ucspt1, ucspt2 As Variant
    ucspt1 = ThisDrawing.Utility.TranslateCoordinates(pt1, acUCS, acWorld, False)
    ucspt2 = ThisDrawing.Utility.TranslateCoordinates(pt2, acUCS, acWorld, False)
    Set LineObj = ThisDrawing.ModelSpace.AddLine(ucspt1, ucspt2)
End Sub[/php]

xiaokai

又出现新问题了
我用...ThisDrawing.ModelSpace.AddText(......方法在新的坐标系中添加文本,比如想显示"晓东cad",但却反向显示成了"dac东晓",并且我用.roate...旋转文本,不管后面的角度选择多少,文本总是旋转成垂直,请问该怎么做?
谢谢!

ahlzl

最初由 xiaokai 发布
[B]又出现新问题了
我用...ThisDrawing.ModelSpace.AddText(......方法在新的坐标系中添加文本,比如想显示"晓东cad",但却反向显示成了"dac东晓",并且我用.roate...旋转文本,不管后面的角度选择多少,文本总是旋转成垂直... [/B]

你要什么结果，贴张图上来！

xiaokai

Sub test_XY_UCS()
       '程序只在WCS中成立！
    Dim myUCS As AcadUCS, P0(2) As Double, P1(2) As Double, P2(2) As Double
    P1(1) = 1: P2(0) = 1
    Set myUCS = ThisDrawing.UserCoordinateSystems.Add(P0, P1, P2, "abc")
    ThisDrawing.ActiveUCS = myUCS
     
    Dim LineObj As AcadLine
    Dim pt1(2) As Double, pt2(2) As Double
    pt2(1) = 1
     
    Dim ucspt1, ucspt2 As Variant
    ucspt1 = ThisDrawing.Utility.TranslateCoordinates(pt1, acUCS, acWorld, False)
    ucspt2 = ThisDrawing.Utility.TranslateCoordinates(pt2, acUCS, acWorld, False)
    Set LineObj = ThisDrawing.ModelSpace.AddLine(ucspt1, ucspt2)

    dim aaa as acadtext
    set  aaa=ThisDrawing.ModelSpace.addtext(p1,"晓东cad",5)
End Sub

以上程序,想在p1点上插入"晓东cad"文本,但得出来的确是"dac东晓",文本被反向了,版主可以运行下这程序,看看就更明白了.
请问该怎么解决?谢谢!

ahlzl

先插入文本，再调UCS吧……