[VBA函数]：在autocad中实现连续复制（像2005一样）

min_zxm

Sub copy()

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
p1 = ThisDrawing.Utility.GetPoint(, "请选择基点:")
Dim icount As Integer
   
While incount < 1000
'如果异常发生，退出程序
  If Err <> 0 Then
      Exit Sub
  Else
    p2 = ThisDrawing.Utility.GetPoint(p1, "请选择目标点:")

'复制并移动对象
     For i = 0 To n - 1
          Set ent = ssetObj.Item(i).copy
          ent.Move p1, p2
     Next
  End If
   
Wend


End Sub

macula55

不错，但是程序逻辑不是很紧凑！

zxli2004

2004好象有这个功能，co 选择对象enter后，m就可以了。

雪山飞狐(lzh)

2002本身也可以：

命令: copy

选择对象: 找到 1 个

选择对象:
指定基点或位移，或者 [重复(M)]: m
指定基点: 指定位移的第二点或 <用第一点作位移>: 指定位移的第二点或
<用第一点作位移>: 指定位移的第二点或 <用第一点作位移>:

拖动在VBA里不好实现，Lisp处理命令是强项：）
另外试试这段Lisp

2. 
   
3. (defun c:mcopy()
   
4. (if (setq ss (ssget)) (command "_.copy" ss "" "m"))
   
5. )
   

<br /> (defun c:mcopy()<br /> (if (setq ss (ssget)) (command "_.copy" ss "" "m"))<br /> )<br />

hannibal329

类似的我也写过一个，就是undo不太好办，不知道有没有什么好办法，是不是应该记录下objectID

min_zxm

老大强悍啊,短短三行代码比我几十行还好用!

狂刀

这是cad的基本用法啊，老兄
别关顾着写程序，连cad本身提供的命令参赛都不知道用了