明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1976|回复: 4

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

[复制链接]
发表于 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

 楼主| 发表于 2005-9-16 12:42:00 | 显示全部楼层

没人顶啊!

发表于 2005-9-16 15:03:00 | 显示全部楼层

你的程序很好呀。

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

 While icount < 1000

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

个人观点。不要见怪。

发表于 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



 

 楼主| 发表于 2005-9-16 19:20:00 | 显示全部楼层
强啊,太谢谢各位了!真是太厉害了,以后要多多学习
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-27 10:45 , Processed in 0.165394 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表