[LISP程序]：多图档文件克隆实体

lsjjm

下面程序点击当前图形中的圆, 自动在其他所有图形文件中生成相同圆心半径的圆:
[php]
(defun c:test ()
  (vl-load-com)
  (setq doc (vla-get-Documents (vlax-get-acad-object)))
  (setq cir (car (entsel "\nSelect Circle: ")))
  (setq  pc (cdr (assoc 10 (entget cir))))
  (setq   r (cdr (assoc 40 (entget cir))))
  (vlax-for i doc
    (setq ms (vla-get-modelspace i))
    (vla-addcircle ms (vlax-3d-point pc) r)
  )
  (princ)
)
[/php]

fylinwater

这好像不是克隆， 只是绘制  以为实现 跨文档的copy命令 呢

aidraft

Copyobjects才是深度克隆

雪山飞狐(lzh)

同意

2. 
   
3. (defun c:test ()
   
4.   (vl-load-com)
   
5.   (setq acadobj (vlax-get-acad-object)
   
6.         docs (vla-get-Documents acadobj)
   
7.         doc (vla-get-activedocument acadobj)
   
8.         ss (ssget)
   
9.         i -1
   
10.         count (sslength ss)
    
11.         objs (vlax-make-safearray vlax-vbObject (cons 0 (1- count)))
    
12.   )
    
13.   (repeat count
    
14.     (setq obj (vlax-ename->vla-object (ssname ss (setq i (1+ i)))))
    
15.     (vlax-safearray-put-element objs i obj)
    
16.   )
    
17.   (vlax-for j docs
    
18.     (if (not (= (vla-get-hwnd doc) (vla-get-hwnd j)))
    
19.       (vla-copyobjects doc objs (vla-get-modelspace j))
    
20.     )
    
21.   )
    
22.   (princ)
    
23. )
    

<br /> (defun c:test () <br />   (vl-load-com) <br />   (setq acadobj (vlax-get-acad-object)<br />         docs (vla-get-Documents acadobj)<br />         doc (vla-get-activedocument acadobj)<br />         ss (ssget)<br />         i -1 <br />         count (sslength ss)<br />         objs (vlax-make-safearray vlax-vbObject (cons 0 (1- count)))<br />   )<br />   (repeat count<br />     (setq obj (vlax-ename->vla-object (ssname ss (setq i (1+ i)))))<br />     (vlax-safearray-put-element objs i obj)<br />   )<br />   (vlax-for j docs<br />     (if (not (= (vla-get-hwnd doc) (vla-get-hwnd j)))<br />       (vla-copyobjects doc objs (vla-get-modelspace j))<br />     )<br />   )<br />   (princ) <br /> )<br />

lsjjm

2楼3楼4楼:
如果copyobjects我就说拷贝了. 我说的是:...自动在其他所有图形文件中生成相同...

雪山飞狐(lzh)

是麽，要是圆就AddCircle，要是直线就AddLine，。。。。。。
这样你要写多少代码呀，

梦断江南

仅仅用add方法不能有效的保持实体的扩展数据，如果有的话

lzh，谢谢你昨天的指点，不过我下面的代码还是有问题，你帮看看

2. 
   
3. Sub clone()
   
4.    ThisDrawing.SendCommand "(command ""_.copyclip"" (ssget) """") " '这一句还没完成就进入循环了.
   
5.    Dim drawing As AcadDocument
   
6.     For Each drawing In ThisDrawing.Application.Documents
   
7.        drawing.Activate
   
8.        ThisDrawing.SendCommand "_.pasteorig" & vbCr
   
9.     Next drawing
   
10. End Sub
    

<br /> Sub clone()<br />    ThisDrawing.SendCommand "(command ""_.copyclip"" (ssget) """") " '这一句还没完成就进入循环了.<br />    Dim drawing As AcadDocument<br />     For Each drawing In ThisDrawing.Application.Documents<br />        drawing.Activate<br />        ThisDrawing.SendCommand "_.pasteorig" & vbCr<br />     Next drawing<br /> End Sub<br />

雪山飞狐(lzh)

VBA的SendCommand是最头疼的，一般少用，调用CopyObjects方法吧

可以试试
Sub clone()
On Error Resume Next
    Dim ss As AcadSelectionSet
    ThisDrawing.SelectionSets("*Test*").Delete
    Set ss = ThisDrawing.SelectionSets.Add("*Test*")
    ss.SelectOnScreen
    If ss.Count = 0 Then GoTo ErrHandle
    ThisDrawing.SendCommand "_.copyclip" & vbCr & "p" & vbCr & vbCr   
    Dim drawing As AcadDocument
    For Each drawing In ThisDrawing.Application.Documents
        If ThisDrawing.hwnd <> drawing.hwnd Then
            drawing.Activate
            ThisDrawing.SendCommand "_.pasteorig" & vbCr
        End If
    Next drawing
ErrHandle:
End Sub

liuyj

感觉还是不很方便：第一，不能决定哪张图需要复制；第二，复制到图中时不能选择基点。还是用粘贴吧。

雪山飞狐(lzh)

就当是练手玩玩，没什么实用价值，：）