在VBA中应用ucs小结,深入学习AUTOCAD二次开发第九章.

兰州人 发表于 2009-7-21 09:27:00

本帖最后由作者于 2009-7-22 8:43:21 编辑 Sub A()     Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double     Dim UCS As AcadUCS, Op(2) As Double, Xp(2) As Double, Yp(2) As Double     With ThisDrawing         '下面4个点用于定义二维填充(solid)对象         P1(0) = 0: P1(1) = 0: P1(2) = 0         '下面3个点用于定义新的UCS         Op(0) = 0: Op(1) = 0: Op(2) = 0 '新UCS的原点         Xp(0) = 1: Xp(1) = 0: Xp(2) = 0 '新UCS的X方向         Yp(0) = 0: Yp(1) = 0: Yp(2) = 1 '新UCS的Y方向         '新建UCS         Set UCS = .UserCoordinateSystems.Add(Op, Xp, Yp, "AAA")         '新UCS置为当前         .ActiveUCS = UCS         '创建二维填充         Set objCircle = .ModelSpace.AddCircle(P1, 10)    End With End SubXp(0)=1:Yp(2)=1 相当于执行UCS命令--- UCS →X →90Xp(0)=1:Yp(2)=-1 相当于执行UCS命令--- UCS →X →-90Xp(2)=1:Yp(1)=1 相当于执行UCS命令--- UCS →X →-90希望有兴趣的大侠共同整理,谢谢.

兰州人 发表于 2009-7-21 10:44:00

下面程序是将VBA示例程序,填加了circle,arc和arraypolar命令,便于各位大侠理解.
Sub Example_UserCoordinateSystems()
' This example finds the current UserCoordinateSystems collection and
' adds a new UCS to that collection.
Dim pp(2) As Double
Dim UCSColl As AcadUCSs
Set UCSColl = ThisDrawing.UserCoordinateSystems

' Create a UCS named "TEST" in the 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
Dim pp1(2) As Double
pp1(1) = 20
' Define the UCS
origin(0) = 0#: origin(1) = 0#: origin(2) = 0#
xAxisPnt(0) = 0: xAxisPnt(1) = 1#: xAxisPnt(2) = 0
yAxisPnt(0) = 0: yAxisPnt(1) = 0#: yAxisPnt(2) = 1
Set objLine = ThisDrawing.ModelSpace.AddLine(xAxisPnt, yAxisPnt)
objLine.color = 3
' Add the UCS to the UserCoordinatesSystems collection
Dim objCircle As AcadCircle
Set ucsObj = UCSColl.Add(origin, xAxisPnt, yAxisPnt, "TEST")
ThisDrawing.ActiveUCS = ucsObj
Set objCircle = ThisDrawing.ModelSpace.AddCircle(pp, 20)
Set objCircle = ThisDrawing.ModelSpace.AddCircle(pp1, 0.5)
Set objArc = ThisDrawing.ModelSpace.AddArc(pp, 3, 0, 1.5)
'Set objcy = ThisDrawing.ModelSpace.AddCylinder(pp, 5, 20)
objAng = (Atn(1) * 4 / 180) * 360
objC = objCircle.ArrayPolar(6, objAng, pp)
'MsgBox "A new UCS called " & ucsObj.Name & " has been added to the UserCoordinateSystems collection.", vbInformation, "UserCoordinateSystems 示例"
End Sub

ningyong58 发表于 2009-7-21 21:48:00

在UCS中有一个已经定义好的UCS为"aa"
采用UserCoordianteSystems.Item方法.
用UserCoordinateSystems.Item("aa")
Sub LLL()
Dim UUS As AcadUCSs
Dim UU As AcadUCS
Set UU = ThisDrawing.UserCoordinateSystems.Item("aa")
ThisDrawing.ActiveUCS = UU
transMatrix = UU.GetUCSMatrix()
Dim objLine As AcadLine, objCircle As AcadCircle
Set objCircle = ThisDrawing.HandleToObject("8E")
objCircle.TransformBy (transMatrix)
End Sub

兰州人 发表于 2009-7-22 08:46:00

重新体会AutoCAD二次开发第九章的9.1到9.2
上面所述全在下面程序中解决.
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

wangjianchunmo 发表于 2011-12-9 23:58:58

兰州人发表于 2009-7-22 08:46 static/image/common/back.gif
重新体会AutoCAD二次开发第九章的9.1到9.2
上面所述全在下面程序中解决.

非常感谢楼主

3xxx 发表于 2013-5-16 08:00:31

感谢版主。

页: [1]

明经CAD社区's Archiver

在VBA中应用ucs小结,深入学习AUTOCAD二次开发第九章.