[VBA程序]： 用vba实现连续旋转加复制功能

min_zxm

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

程序清单：

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

coverne

也来试试看