用vba实现连续旋转加复制功能

min_zxm 发表于 2005-9-14 18:38:00

程序清单：
Sub copyAndRotate()
Dim ssetObj As AcadSelectionSet Dim ent As AcadEntity Dim i As Integer Dim n As Integer

'新建选择集 On Error Resume Next     ThisDrawing.SelectionSets("New_SelectionSet").Delete     Set ssetObj = ThisDrawing.SelectionSets.Add("New_SelectionSet")
 '检查选择集是否为空，是则退出程序     ssetObj.SelectOnScreen     n = ThisDrawing.SelectionSets("New_SelectionSet").Count     If n = 0 Then         Exit Sub     End If
 '确定目标点 Dim p1 As Variant Dim p2 As Variant Dim k As Double Dim angle1 As Double Dim angle2 As Double Dim angle As Double  p1 = ThisDrawing.Utility.GetPoint(, "请选择旋转中心:")  p2 = ThisDrawing.Utility.GetPoint(p1, "请选择基点:")  k = (p2(1) - p1(1)) / (p2(0) - p1(0))  'MsgBox "k=" & k '除数为零，k＝无穷大  If Err = 11 Then      If p2(1) < p1(1) Then      angle1 = 1.5 * 3.14159265358979      Else          angle1 = 0.5 * 3.14159265358979      End If  End If  angle1 = Atn(k) 'p2在第二、三象限  If p2(0) < p1(0) Then      angle1 = angle1 + 3.14159265358979  End If  
Dim icount As Integer
  While incount < 1000 '如果异常发生，退出程序   If Err <> 0 Then       Exit Sub   Else     p2 = ThisDrawing.Utility.GetPoint(p1, "请选择目标点:")     k = (p2(1) - p1(1)) / (p2(0) - p1(0))     '除数为零，k＝无穷大  If Err = 11 Then      If p2(1) < p1(1) Then      angle2 = 1.5 * 3.14159265358979      Else          angle2 = 0.5 * 3.14159265358979      End If   End If  angle2 = Atn(k) 'p2在第二、三象限  If p2(0) < p1(0) Then      angle2 = angle2 + 3.14159265358979  End If         angle = angle2 - angle1         For i = 0 To n - 1           Set ent = ssetObj.Item(i).Copy           ent.Rotate p1, angle      Next        End If      Wend  
End Sub

min_zxm 发表于 2005-9-16 12:42:00

没人顶啊!

MJTD_7777 发表于 2005-9-16 15:03:00

你的程序很好呀。
我改了一个地方应该是输入问题吧。
 While icount < 1000
不过你的循环可以用错误处理来代替。因为icount 这个变量的使用。并没有体现出While的真正功能。
个人观点。不要见怪。

MJTD_7777 发表于 2005-9-16 15:33:00

我修改的程序：（旨在抛砖引玉，没有剽窃原创的意思)
 Sub copyAndRotate()
Dim ssetObj As AcadSelectionSet Dim ent As AcadEntity Dim i As Integer
Dim Osmode As Integer ThisDrawing.StartUndoMark Osmode = ThisDrawing.GetVariable("osmode") ThisDrawing.SetVariable "osmode", 37 '设成什么看自己习惯了
'新建选择集 On Error Resume Next ThisDrawing.SelectionSets("New_SelectionSet").Delete Set ssetObj = ThisDrawing.SelectionSets.Add("New_SelectionSet")
 '检查选择集是否为空，是则退出程序 ssetObj.SelectOnScreen If ssetObj.Count = 0 Then GoTo ExitSub
'确定目标点 Dim P1 As Variant Dim Angle1 As Double Dim Angle2 As Double Dim Angle As Double P1 = ThisDrawing.Utility.GetPoint(, "请选择旋转中心:") P1 = ThisDrawing.Utility.TranslateCoordinates(P1, acWorld, acUCS, False) '因为用户当前坐标系可能不是世界坐标系 If Err Then GoTo ExitSub Angle1 = ThisDrawing.Utility.GetAngle(P1, "请选择基点:") If Err Then GoTo ExitSub Angle2 = ThisDrawing.Utility.GetAngle(P1, "请选择目标点:") If Err Then GoTo ExitSub
Do While Err.Number = 0     For i = 0 To ssetObj.Count - 1           Set ent = ssetObj.Item(i).Copy           Angle = Angle2 - Angle1           ent.Rotate ThisDrawing.Utility.TranslateCoordinates(P1, acUCS, acWorld, False), Angle     Next     Angle2 = ThisDrawing.Utility.GetAngle(P1, "请选择目标点:") Loop
ExitSub: ThisDrawing.SetVariable "osmode", Osmode ThisDrawing.EndUndoMark End Sub

min_zxm 发表于 2005-9-16 19:20:00

强啊，太谢谢各位了！真是太厉害了，以后要多多学习

页: [1]

明经CAD社区's Archiver

用vba实现连续旋转加复制功能