[编程交流] 车门Lisp程序

(defun C:test ;| credits to: Lee Mac |; ( / *error* cm SelBname bn p Blk ll ur msg SS cen Grrr mc )
(defun *error* (m) (redraw)(and cm (setvar 'cmdecho cm)) (and m (print m)) (princ))
(defun SelBname ( / e bn )
        (setvar 'errno 0)
        (while (/= 52 (getvar 'errno))
                (setq e (car (entsel "\nSelect block to reinsert <exit>: ")))
                (cond
                        ( (= 7 (getvar 'errno)) (princ "\nMissed, try again.") (setvar 'errno 0) )
                        ( (and (= 'ENAME (type e)) (/= (cdr (assoc 0 (entget e))) "INSERT")) 
                                (princ "\nThis is not a block.") (setq e nil)
                        )
                        ( (and e (not (alert "Visit lee-mac.com")) (setq bn (vla-get-EffectiveName (vlax-ename->vla-object e))) (setvar 'errno 52)) )
                ); cond
        ); while
        bn
); defun SelBname
(redraw) (setq bn (SelBname))
(while
        (and
                (setq cm (getvar 'cmdecho)) (setvar 'cmdecho 0)
                bn
                (last (setq p (list (getpoint "\nSpecify insertion point <exit>: "))))
                (last (setq p (append p (list (getpoint (last p) "\nSpecify second point <exit>: ")))))
                (not (apply 'grdraw (append p (list 1 7))))
                (setq Blk
                        (vla-InsertBlock
                                (vlax-get-property 
                                        (vla-get-ActiveDocument (vlax-get-acad-object)) 
                                        (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)
                                ) ; AcSpc
                                (vlax-3D-point (car p)) bn 1. 1. 1. 0. 
                        )        
                )
        )
        (progn
                (vla-GetBoundingBox Blk 'll 'ur)
                (vla-ScaleEntity Blk (vlax-3D-point (car p))
                        (/ (apply 'distance p) (abs (apply '- (mapcar 'car (mapcar 'vlax-safearray->list (list ll ur))))) ) 
                )
                (vla-put-Rotation Blk (apply 'angle p))
                (setq msg "\nPress [TAB] to change orientation, [ENTER] to exit: ")
                (and msg (princ msg)) (setvar 'errno 0)
                (setq SS (ssadd))
                (ssadd (handent (vla-get-Handle Blk)) SS)
                (setq cen (apply 'mapcar (cons '(lambda (a b) (/ (+ a b) 2.)) p)))
                (while (/= 52 (getvar 'errno))
                        (setq Grrr (grread T))
                        (cond
                                ((= (car Grrr) 2)
                                        (cond
                                                ((= (cadr Grrr) (ascii "\t"))
                                                        (and msg (princ msg))
                                                        (and (not mc) (setq mc 0))
                                                        (setq mc (rem (+ mc 1) 4))
                                                        (cond
                                                                ( (or (= mc 1) (= mc 3) )
                                                                        (command "_.MIRROR" SS "" "_non" cen "_non" (polar cen (+ (apply 'angle p) (/ PI 2.)) (apply 'distance p)) "_Y")
                                                                )
                                                                ( (or (= mc 2) (= mc 0) )
                                                                        (command "_.MIRROR" SS "" "_non" cen "_non" (polar cen (apply 'angle p) (apply 'distance p)) "_Y")
                                                                )
                                                        )
                                                )
                                                ((= (cadr Grrr) (ascii "\r"))
                                                        (princ "\nExiting.") (redraw) (setvar 'errno 52)
                                                )
                                        ); cond
                                )
                                ((= (car Grrr) 25)
                                        (princ "\nExiting.") (redraw) (setvar 'errno 52)
                                )
                        ); cond
                ); while
        ); progn
); while/if
(and cm (setvar 'cmdecho cm))
(princ)
);| defun |; (vl-load-com) (princ)