用entmakex实现对象拷贝

marting · 发表于 2017-5-8 20:18:51

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 marting 于 2017-5-8 20:20 编辑

适合的对象有点，曲线，（多行）文字，块

(defun C:TT (/ e etyp bp dp vec)
(and
(progn
(setvar 'errno 0)
(while (/= 52 (getvar 'errno))
(setq e (car (entsel "\nSelect entity to be copied <exit>: ")))
(cond
((= 7 (getvar 'errno))
(princ "\nMissed.")
(setvar 'errno 0)
)
((eq 'ENAME (type e))
(setvar 'errno 52)
)
)
)
e
)
(setq etyp (cdr (assoc 0 (entget e))))
(setq bp (getpoint "\nBase point: "))
(setq dp (getpoint bp "\nDestination point: "))
(setq vec (trans (mapcar
'-
dp
bp
) 1 (cond
((wcmatch etyp
"LWPOLYLINE,CIRCLE,ARC,TEXT,INSERT"
)
e
)
((wcmatch etyp "LINE,ELLIPSE,MTEXT,POINT")
0
)
(T
0
)
)
)
)
(entmakex (mapcar
'(lambda (x)
(cond
((= (car x) 10)
(cons 10 (mapcar
'+
(cdr x)
vec
)
)
)
((and
(= (car x) 11)
(not (wcmatch etyp "XLINE,ELLIPSE"))
)
(cons 11 (mapcar
'+
(cdr x)
vec
)
)
)
(T
x
)
)
)
(entget e)
)
)
)
)

(defun C:TT (/ e etyp bp dp vec) 
  (and 
    (progn 
      (setvar 'errno 0) 
      (while (/= 52 (getvar 'errno)) 
        (setq e (car (entsel "\nSelect entity to be copied <exit>: "))) 
        (cond 
          ((= 7 (getvar 'errno)) 
            (princ "\nMissed.") 
            (setvar 'errno 0) 
          ) 
          ((eq 'ENAME (type e)) 
            (setvar 'errno 52) 
          ) 
        )                               
      )                                        
      e 
    )                                        
    (setq etyp (cdr (assoc 0 (entget e)))) 
    (setq bp (getpoint "\nBase point: ")) 
    (setq dp (getpoint bp "\nDestination point: ")) 
    (setq vec (trans (mapcar 
                       '- 
                       dp 
                       bp 
                     ) 1 (cond 
                           ((wcmatch etyp 
                                     "LWPOLYLINE,CIRCLE,ARC,TEXT,INSERT" 
                            ) 
                             e 
                           ) 
                           ((wcmatch etyp "LINE,ELLIPSE,MTEXT,POINT") 
                             0 
                           ) 
                           (T 
                             0 
                           )                
                         )                
              ) 
    ) 
    (entmakex (mapcar 
                '(lambda (x) 
                   (cond 
                     ((= (car x) 10) 
                       (cons 10 (mapcar 
                                  '+ 
                                  (cdr x) 
                                  vec 
                                ) 
                       ) 
                     ) 
                     ((and 
                        (= (car x) 11) 
                        (not (wcmatch etyp "XLINE,ELLIPSE")) 
                      ) 
                       (cons 11 (mapcar 
                                  '+ 
                                  (cdr x) 
                                  vec 
                                ) 
                       ) 
                     ) 
                     (T 
                       x 
                     ) 
                   )                        
                 )                        
                (entget e) 
              )                               
    )                                        
  )                                        
)

另一个

; Vanilla copy/move excercise:
(defun C:test ( / e etyp bp dp vec vece vecw )
(and
(progn
(setvar 'errno 0)
(while (/= 52 (getvar 'errno))
(setq e (car (entsel "\nSelect entity to be copied <exit>: ")))
(cond
( (= 7 (getvar 'errno)) (princ "\nMissed.") (setvar 'errno 0) )
( (eq 'ENAME (type e)) (setvar 'errno 52) )
); cond
); while
e
); progn
(setq etyp (cdr (assoc 0 (entget e))))
(setq bp (getpoint "\nBase point: "))
(setq dp (getpoint bp "\nDestination point: "))
(setq vec (mapcar '- dp bp)) ;;; vector in UCS
(setq vece (mapcar '- (trans dp 1 e) (trans bp 1 e))) ;;; vector in OCS ;;; vece /= (trans vec 1 e) ;;; (mapcar '- (trans dp 1 e) (trans bp 1 e)) = (mapcar '- (trans vec 1 e) (trans '(0.0 0.0 0.0) 1 e)) /= (trans vec 1 e)
(setq vecw (mapcar '- (trans dp 1 0) (trans bp 1 0))) ;;; vector in WCS ;;; vecw /= (trans vec 1 0) ;;; (mapcar '- (trans dp 1 0) (trans bp 1 0)) = (mapcar '- (trans vec 1 0) (trans '(0.0 0.0 0.0) 1 0)) /= (trans vec 1 0)
;|
(setq vece (mapcar '- (trans vec 1 e) (trans '(0.0 0.0 0.0) 1 e)))
(setq vecw (mapcar '- (trans vec 1 0) (trans '(0.0 0.0 0.0) 1 0)))
|;
;;; either versions of vece and vecw are correct
(entmakex
(mapcar
'(lambda (x)
(cond
( (and (= (car x) 10) (wcmatch etyp "LWPOLYLINE,CIRCLE,ARC,TEXT,INSERT"))
(cons 10 (mapcar '+ (cdr x) vece))
)
( (and (= (car x) 10) (wcmatch etyp "LINE,MTEXT,POINT"))
(cons 10 (mapcar '+ (cdr x) vecw))
)
( (and (= (car x) 11) (wcmatch etyp "LINE"))
(cons 11 (mapcar '+ (cdr x) vecw))
)
(T x)
); cond
); lambda
(entget e)
); mapcar
); entmakex / entmod
); and
); defun

; Vanilla copy/move excercise: 
(defun C:test ( / e etyp bp dp vec vece vecw ) 
  (and 
    (progn 
      (setvar 'errno 0) 
      (while (/= 52 (getvar 'errno)) 
        (setq e (car (entsel "\nSelect entity to be copied <exit>: "))) 
        (cond 
          ( (= 7 (getvar 'errno)) (princ "\nMissed.") (setvar 'errno 0) ) 
          ( (eq 'ENAME (type e)) (setvar 'errno 52) ) 
        ); cond 
      ); while 
      e 
    ); progn 
    (setq etyp (cdr (assoc 0 (entget e)))) 
    (setq bp (getpoint "\nBase point: ")) 
    (setq dp (getpoint bp "\nDestination point: ")) 
    (setq vec (mapcar '- dp bp)) ;;; vector in UCS 
    (setq vece (mapcar '- (trans dp 1 e) (trans bp 1 e))) ;;; vector in OCS ;;; vece /= (trans vec 1 e) ;;; (mapcar '- (trans dp 1 e) (trans bp 1 e)) = (mapcar '- (trans vec 1 e) (trans '(0.0 0.0 0.0) 1 e)) /= (trans vec 1 e) 
    (setq vecw (mapcar '- (trans dp 1 0) (trans bp 1 0))) ;;; vector in WCS ;;; vecw /= (trans vec 1 0) ;;; (mapcar '- (trans dp 1 0) (trans bp 1 0)) = (mapcar '- (trans vec 1 0) (trans '(0.0 0.0 0.0) 1 0)) /= (trans vec 1 0) 
    ;| 
    (setq vece (mapcar '- (trans vec 1 e) (trans '(0.0 0.0 0.0) 1 e))) 
    (setq vecw (mapcar '- (trans vec 1 0) (trans '(0.0 0.0 0.0) 1 0))) 
    |; 
    ;;; either versions of vece and vecw are correct 
    (entmakex 
      (mapcar 
        '(lambda (x) 
          (cond 
            ( (and (= (car x) 10) (wcmatch etyp "LWPOLYLINE,CIRCLE,ARC,TEXT,INSERT")) 
              (cons 10 (mapcar '+ (cdr x) vece)) 
            ) 
            ( (and (= (car x) 10) (wcmatch etyp "LINE,MTEXT,POINT")) 
              (cons 10 (mapcar '+ (cdr x) vecw)) 
            ) 
            ( (and (= (car x) 11) (wcmatch etyp "LINE")) 
              (cons 11 (mapcar '+ (cdr x) vecw)) 
            ) 
            (T x) 
          ); cond 
        ); lambda 
        (entget e) 
      ); mapcar 
    ); entmakex / entmod 
  ); and 
); defun

sh_h · 发表于 2017-5-9 09:28:12

厉害了我的哥！！！

evayleung · 发表于 2017-6-22 16:23:47

值得学习，谢谢分享

xinxirong · 发表于 2017-6-22 16:32:29

中国人就应该写中文注释，搞得好像是国外哪个网站抄来似的。另外entmake不支持的对象太多，用来复制恐怕比不上command和vla-copy

qq1254582201 · 发表于 2017-6-22 21:31:00

好神奇的东西哦

kqqt6236 · 发表于 2017-6-23 01:08:51

这样都行？

账号		自动登录	找回密码
密码			立即注册

[每日一码] 用entmakex实现对象拷贝

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

浏览过的版块