summerfly2008 发表于 2006-4-22 19:27

用vba实现连续旋转复制

用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

sgxhao 发表于 2006-4-29 17:03

vba

真的不错啊:victory:

jiangyaolei 发表于 2008-6-30 09:35

听上去好象不错哦 ，呵呵 先下下来用用

zjloveqy1986 发表于 2008-6-30 13:24

我都还没明白这是什么哦。。我突然发现我就是井底之蛙

yangyongstu 发表于 2008-10-8 18:31

正好用到，学习一下，写的也不错，谢谢！

kent1968 发表于 2008-10-9 15:35

学习一下学习一下

xde888 发表于 2008-10-9 16:49

这个还不会用。学学。

zzw_06 发表于 2008-10-17 11:53

看上去不错哦
页: [1]
查看完整版本: 用vba实现连续旋转复制