求拷贝物体使两物体中心点重合的程序？

cj52000

各位好：

            现比如说有两组图元，多个同心圆或圆弧，和一个距形，我想让它们的中心重合，圆的中心就是圆，距形的中心就是对角线交点，然后选择欲复制的图元，确认，然后再选择目的图元，这样，第一选择的图元就和第二选择的图元中心重合，第一选择的图元还在原处，只是复制，选择时最好是框选，因为工作中经常会做到这样的动作，所以请大家帮帮忙，谢谢大家！

Andyhon

2. 
   
3. 
   
4. ;;; For test only ...
   
5. (Defun C:test ()
   
6.    (princ "\框选同心圆或圆弧: ")
   
7.    (setq ss1 (ssget '((0 . "ARC,CIRCLE")))
   
8.           po (cdr (assoc 10 (entget (ssname ss1 0))))
   
9.    )
   
10.    (princ "\选矩形框: ")
    
11.    (setq ss2 (ssget ":S:E" '((0 . "LWPOLYLINE")))
    
12.           e2 (ssname ss2 0)
    
13.          dat (entget e2)
    
14.          dat (member (assoc 10 dat) dat)
    
15.          pt1 (cdar dat)
    
16.          dat (nth 8 dat)
    
17.          pt2 (cdr dat)
    
18.          Pt5 (mapcar (function (lambda (a b) (/ (+ a b) 2)))  pt1 pt2)
    
19.   )      
    
20.   ;; (command "Move" ss1 "" "none" po "none" Pt5)
    
21.   (command "Copy" ss1 "" "none" po "none" Pt5)   ; 依 zhynt 的提示订正
    
22. )
    

<br /> <br /> ;;; For test only ...<br /> (Defun C:test ()<br />    (princ "\框选同心圆或圆弧: ")<br />    (setq ss1 (ssget '((0 . "ARC,CIRCLE")))<br />           po (cdr (assoc 10 (entget (ssname ss1 0))))<br />    )<br />    (princ "\选矩形框: ")<br />    (setq ss2 (ssget ":S:E" '((0 . "LWPOLYLINE")))<br />           e2 (ssname ss2 0)<br />          dat (entget e2)<br />          dat (member (assoc 10 dat) dat)<br />          pt1 (cdar dat)<br />          dat (nth 8 dat)<br />          pt2 (cdr dat)<br />          Pt5 (mapcar (function (lambda (a b) (/ (+ a b) 2)))  pt1 pt2)<br />   )       <br />   ;; (command "Move" ss1 "" "none" po "none" Pt5)<br />   (command "Copy" ss1 "" "none" po "none" Pt5)   ; 依 zhynt 的提示订正<br /> )<br />

zhynt

我做了一些修改，应该比较符合题意。

2. 
   
3. ;;; For test only ...
   
4. (Defun C:test ()
   
5.   (princ "\框选同心圆或圆弧: ")
   
6.   (setq ss1 (ssget '((0 . "ARC,CIRCLE"))))
   
7.   (command "copy" ss1 "" "@" "@")
   
8.   (setq ss1 (ssget "P"))
   
9.   (setq po (cdr (assoc 10 (entget (ssname ss1 0)))))
   
10.   (princ "\选矩形框: ")
    
11.   (setq        ss2 (ssget ":S:E" '((0 . "LWPOLYLINE")))
    
12.         e2  (ssname ss2 0)
    
13.         dat (entget e2)
    
14.         dat (member (assoc 10 dat) dat)
    
15.         pt1 (cdar dat)
    
16.         dat (nth 10 dat);;;不知是不是机器的问题，我这里应该是10，不是8
    
17.         pt2 (cdr dat)
    
18.         Pt5 (mapcar (function (lambda (a b) (/ (+ a b) 2))) pt1 pt2)
    
19.   )
    
20.   (setq        n (sslength ss1)
    
21.         m 0
    
22.   )
    
23.   (while (/= n m)
    
24.     (setq ent (entget (ssname ss1 m)))
    
25.     (setq ent (subst (cons 10 pt5) (assoc 10 ent) ent))
    
26.     (entmod ent)
    
27.     (setq m (1+ m))
    
28.   )
    
29.   ;;(command "Move" ss1 "" "none" po "none" Pt5)
    
30. )
    

<br /> ;;; For test only ...<br /> (Defun C:test ()<br />   (princ "\框选同心圆或圆弧: ")<br />   (setq ss1 (ssget '((0 . "ARC,CIRCLE"))))<br />   (command "copy" ss1 "" "@" "@")<br />   (setq ss1 (ssget "P"))<br />   (setq po (cdr (assoc 10 (entget (ssname ss1 0)))))<br />   (princ "\选矩形框: ")<br />   (setq        ss2 (ssget ":S:E" '((0 . "LWPOLYLINE")))<br />         e2  (ssname ss2 0)<br />         dat (entget e2)<br />         dat (member (assoc 10 dat) dat)<br />         pt1 (cdar dat)<br />         dat (nth 10 dat);;;不知是不是机器的问题，我这里应该是10，不是8<br />         pt2 (cdr dat)<br />         Pt5 (mapcar (function (lambda (a b) (/ (+ a b) 2))) pt1 pt2)<br />   )<br />   (setq        n (sslength ss1)<br />         m 0<br />   )<br />   (while (/= n m)<br />     (setq ent (entget (ssname ss1 m)))<br />     (setq ent (subst (cons 10 pt5) (assoc 10 ent) ent))<br />     (entmod ent)<br />     (setq m (1+ m))<br />   )<br />   ;;(command "Move" ss1 "" "none" po "none" Pt5)<br /> )<br />

Andyhon

...不知是不是机器的问题，我这里应该是10，不是8 ...
您用的版次较新啦

cj52000

太感谢Andyhon 和zhynt 了，昨天发的贴子，今天就得到回复了，激动~~
我用的是10的，Andyhon长老的程序提示; 错误: 参数类型错误: listp 0.0，可能是版本的问题
zhynt长老修改过的程序正是我想要的，还有就是还想大胆的提点要求，呵呵~~就是框选同心圆或圆弧时，能否改成任何图元的中心，包括同心圆或圆弧，距形，多边形等，这样就完美了，多谢！！！

lincctw_ccl

不錯的程式!!
先簽到