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

min_zxm

程序清单：

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

没人顶啊!

MJTD_7777

你的程序很好呀。

我改了一个地方应该是输入问题吧。

 While icount < 1000

不过你的循环可以用错误处理来代替。因为icount 这个变量的使用。并没有体现出While的真正功能。

个人观点。不要见怪。

MJTD_7777

我修改的程序：（旨在抛砖引玉，没有剽窃原创的意思)

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

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