[编程交流] 线型手柄

(defun c:pps  (/ mm_lay pi2 2pi 3pi2 les i pltlr pltud clt plt
                obj info ac0 dr40 pt10 starc edarc pt11 pt10s p10
                n alist alist1 alist2 lft rht upt dnt cor1 cor2 cor3
                cor4 pcenter locat key xcor1 xcor2 xcor3 xcor4 plistn
                loc1 loc2 locat2 locn1 locn2 lcline0 clocat clocat2
                lcline1 lcline2 celine0 celine1 celine2 pt1 pt2
                oldline pt1 pt2 pt3 pt0 *error* erases mvs vxs)
                
(defun erases (ss / i) 
(setq i -1)
(repeat (sslength ss)
        (entdel (ssname ss (setq i (1+ i))))
)
)
(defun mvs (lst / a lst2)  
(while (setq a (car lst) lst2 (cons a lst2) lst (vl-remove a lst)))
(reverse lst2)
)
(defun vxs (e / i v lst)
(setq i -1)
(while
        (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
        (setq lst (cons v lst))
)
(reverse lst)
)
(defun *error*(s)  
(setvar 'cmdecho 0)
(command "_.undo" "e")
(setvar 'cmdecho 1)
(redraw)
)
(if (null (tblsearch "layer" "03centreline"))
        (progn (setq mm_lay (getvar "CLAYER"))
                (setvar "cmdecho" 0)
                (command "_layer" "m" "03centreline" "c" "1" "" "l" "center" "" "lw" "0.18" "03centreline" "")
                (setvar "cmdecho" 1)
                (setvar "clayer" mm_lay)
        )
)
        
(if (null (tblsearch "layer" "04dashed"))
                (progn (setq mm_lay (getvar "CLAYER"))
                        (setvar "cmdecho" 0)
                        (command "_layer" "m" "04dashed" "c" "2" "" "l" "DASHED" "" "lw" "0.18" "04dashed" "")
                        (setvar "cmdecho" 1)
                        (setvar "clayer" mm_lay)
                )
)
(setq pi2 (/ pi 2))
(setq 2pi (* pi 2))
(setq 3pi2 (/ (* 3 pi) 2))
(setq les (ssget '((0 . "LINE,CIRCLE,ARC,LWPOLYLINE")
                                (-4 . "<NOT")
                                (8 . "*03centreline*")
                                (-4 . "NOT>")
                                )
                )
)
(setq i 0)
(repeat (sslength les)
        (setq obj (ssname les i))
        (setq info (entget obj))
        (setq ac0 (cdr (assoc 0 info)))
        (cond
                ((= ac0 "CIRCLE")
                (progn
                        (setq dr40 (cdr (assoc 40 info)))
                        (setq pt10 (cdr (assoc 10 info)))
                        (setq clt (cons pt10 clt))
                        (setq pltlr (cons (polar pt10 0 dr40)
                                                        (cons (polar pt10 pi dr40) pltlr)
                                                )
                        )
                        (setq pltud (cons (polar pt10 pi2 dr40)
                                                        (cons (polar pt10 3pi2 dr40) pltud)
                                                )
                        )
                );end_progn
                )
                ((= ac0 "ARC")
                                (setq dr40 (cdr (assoc 40 info)))
                                (setq pt10 (cdr (assoc 10 info)))
                                ;; (setq clt (cons pt10 clt))
                                (setq starc (cdr (assoc 50 info)))
                                (setq edarc (cdr (assoc 51 info)))
                                (if
                                        (or
                                                (and (= starc 0) (= edarc pi))
                                                (and (= starc pi) (= edarc 0))
                                                (and (= starc pi2) (= edarc 3pi2))
                                                (and (= starc 3pi2) (= edarc pi2))
                                        )
                                        (setq clt (cons pt10 clt))
                                )
                                        (cond
                                                ((or
                                                        
                                                        (and (<= starc pi2) (<= pi2 edarc) (< edarc 3pi2))
                                                        (and (<= pi2 edarc) (< edarc 3pi2 starc))
                                                )
                                                (setq pltud (cons (polar pt10 pi2 dr40) pltud))
                                                )
                                                ((or
                                                        (and (<= starc pi2) (>= edarc 3pi2))
                                                        (and (<= starc pi2) (< edarc pi2))
                                                        (and (> starc 3pi2) (>= edarc 3pi2))
                                                )
                                                (setq        pltud (cons (polar pt10 pi2 dr40)
                                                                                        (cons (polar pt10 3pi2 dr40) pltud)
                                                                                        )
                                                )
                                                )
                                                ((<= pi2 edarc starc 3pi2)
                                                        (setq        pltud (cons (polar pt10 pi2 dr40)
                                                                                                (cons (polar pt10 3pi2 dr40) pltud)
                                                                                          )
                                                        )
                                                )
                                                ((and
                                                        (> starc pi2)
                                                        (<= starc 3pi2)
                                                        (or (>= edarc 3pi2) (and (>= edarc 0) (< edarc pi2)))
                                                  )
                                                (setq pltud (cons (polar pt10 3pi2 dr40) pltud))
                                                )
                                        )
                                        (cond
                                                ((and (<= starc pi edarc) (> starc 0))
                                                                (setq pltlr (cons (polar pt10 pi dr40) pltlr))
                                                )
                                                ((<= pi edarc starc)
                                                        (setq        pltlr (cons (polar pt10 0 dr40)
                                                                                                (cons (polar pt10 pi dr40) pltlr)
                                                                                                )
                                                        )
                                                )
                                                ((>= pi starc edarc)
                                                        (setq        pltlr (cons (polar pt10 0 dr40)
                                                                                                (cons (polar pt10 pi dr40) pltlr)
                                                                                                )
                                                        )
                                                )
                                                ((< edarc pi starc)
                                                        (setq pltlr (cons (polar pt10 0 dr40) pltlr))
                                                )
                                        )
                )
                                
                                ((= ac0 "LINE")
                                        (setq pt10 (cdr (assoc 10 info)))
                                        (setq pt11 (cdr (assoc 11 info)))
                                        (setq plt (cons pt10 (cons pt11 plt)))
                                )
                                ((= ac0 "LWPOLYLINE")
                                        (setq pt10s (vxs obj))
                                        (setq plt (append pt10s plt))
                                )
        );end_cond
                        (setq i (1+ i))
);end_repeat
(setq alist (append plt pltlr pltud))
(setq
        alist1
        (vl-sort alist
                (function (lambda (e1 e2) (< (car e1) (car e2))))
        )
)
(setq lft (car alist1))
(setq rht (car (reverse alist1)))
(setq        alist2
                        (vl-sort alist
                                (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))
                        )
)
(setq upt (car alist2))
(setq dnt (car (reverse alist2)))
(setq alist1 (mvs alist1))
(setq alist2 (mvs alist2))
(setq cor1 (mapcar '+
                        (mapcar '* lft '(1 0 1))
                        (mapcar '* upt '(0 1 1))
                        )
)
(setq cor2 (mapcar '+
                        (mapcar '* lft '(1 0 1))
                        (mapcar '* dnt '(0 1 1))
                        )
)
(setq cor3 (mapcar '+
                        (mapcar '* rht '(1 0 1))
                        (mapcar '* upt '(0 1 1))
                )
)
(setq cor4 (mapcar '+
                        (mapcar '* rht '(1 0 1))
                        (mapcar '* dnt '(0 1 1))
                )
)
                
(setq pcenter (inters cor1 cor4 cor3 cor2 nil))
                
(setq locat (getpoint pcenter "\nProjection position:"))
                
(if (> (abs (- (car locat) (car pcenter)))
                        (abs (- (cadr locat) (cadr pcenter)))
        )
(setq key 0)
;;;x dir
(setq key 1)
;;;y dir
)
                
(cond
        ((= key 0)
        (setq
                xcor1 (mapcar '+ cor1 '(99999 0 0))
                xcor2 (mapcar '+ cor2 '(99999 0 0))
                xcor3 (mapcar '+ cor3 '(-99999 0 0))
                xcor4 (mapcar '+ cor4 '(-99999 0 0))
        )
        (grdraw xcor1 xcor3 1 1)
        (grdraw xcor2 xcor4 1 1)
        )
        ((= key 1)
                (setq
                        xcor1 (mapcar '+ cor1 '(0 99999 0))
                        xcor2 (mapcar '+ cor2 '(0 -99999 0))
                        xcor3 (mapcar '+ cor3 '(0 99999 0))
                        xcor4 (mapcar '+ cor4 '(0 -99999 0))
                )
                (grdraw xcor1 xcor2 1 1)
                (grdraw xcor3 xcor4 1 1)
        )
);end_cond
                
(cond
        ((= key 0)
        (setq plistn (append plt pltud))
        (setq loc1  (mapcar        '+
                                (mapcar '* locat '(1 0 1))
                                (mapcar '* upt '(0 1 1))
                                )
        )
        (setq loc2        (mapcar        '+
        (mapcar '* locat '(1 0 1))
        (mapcar '* dnt '(0 1 1))
                                        )
        )
        )
        ((= key 1)
                (setq plistn (append plt pltlr))
                        (setq loc1 (mapcar        '+
                       (mapcar '* locat '(0 1 1))
                       (mapcar '* lft '(1 0 1))
                                                )
                        )
                        (setq loc2 (mapcar        '+
                                                (mapcar '* locat '(0 1 1))
                                                (mapcar '* rht '(1 0 1))
                                                )
                        )
        )
);end_cond
(grdraw loc1 loc1 1 1)
                
(setq locat2 (getpoint locat "\nWidth:"))
                (cond
                        ((= key 0)
                                (setq locn1 (mapcar '+
                                        (mapcar '* locat2 '(1 0 1))
                                        (mapcar '* upt '(0 1 1))
                                                        )
                                )
                                (setq locn2 (mapcar '+
                                        (mapcar '* locat2 '(1 0 1))
                                        (mapcar '* dnt '(0 1 1))
                                                        )                
                                )
                                (setq lcline0 (mapcar '(lambda (x) (mapcar '* x '(0 1 1))) plistn))
                                (if (> (car locat) (car locat2))
                                        (setq clocat  locat
                                                clocat2 locat2
                                        )
                                        (setq clocat  locat2
                                                clocat2 locat
                                        )
                                )
                                (setq lcline1
                                        (mapcar
                                                '(lambda (x) (mapcar '+ x (mapcar '* locat '(1 0 1))))
                                                lcline0
                                        )
                                )
                                (setq lcline2
                                        (mapcar
                                                '(lambda (x) (mapcar '+ x (mapcar '* locat2 '(1 0 1))))
                                                lcline0
                                        )
                                )
                                (setq celine0 (mapcar '(lambda (x) (mapcar '* x '(0 1 1))) clt))
                                (setq celine1
                                        (mapcar
                                                '(lambda (x)
                                                        (mapcar '+ x '(10 0 0) (mapcar '* clocat '(1 0 1)))
                                                )
                                                celine0
                                        )
                                )
                                (setq
                                        celine2 (mapcar '(lambda        (x)
                                                (mapcar '+
                                                        x
                                                        '(-10 0 0)
                                                        (mapcar '* clocat2 '(1 0 1))
                                                )
                                        )
                                        celine0
                                        )
                                )
                        )
                        ((= key 1)
                                (setq locn1 (mapcar '+
                                        (mapcar '* locat2 '(0 1 1))
                                        (mapcar '* lft '(1 0 1))
                                )
                                )
                                (setq locn2 (mapcar '+
                                        (mapcar '* locat2 '(0 1 1))
                                        (mapcar '* rht '(1 0 1))
                                )
                                )
                                (setq
                                lcline0 (mapcar '(lambda (x) (mapcar '* x '(1 0 1))) plistn))
                                (if (> (cadr locat) (cadr locat2))
                                        (setq clocat  locat
                                                clocat2 locat2
                                        )
                                        (setq clocat  locat2
                                                clocat2 locat
                                        )
                                )
                                (setq lcline1
                                        (mapcar
                                                '(lambda (x) (mapcar '+ x (mapcar '* locat '(0 1 1))))
                                                lcline0
                                        )
                                )
                                (setq lcline2
                                        (mapcar
                                                '(lambda (x) (mapcar '+ x (mapcar '* locat2 '(0 1 1))))
                                                lcline0
                                        )
                                )
                                (setq celine0 (mapcar '(lambda (x) (mapcar '* x '(1 0 1))) clt))
                                (setq celine1
                                        (mapcar
                                                '(lambda (x)
                                                        (mapcar '+ x '(0 10 0) (mapcar '* clocat '(0 1 1)))
                                                )
                                                celine0
                                        )
                                )
                                (setq
                                        celine2 (mapcar '(lambda        (x)
                                                (mapcar '+
                                                        x
                                                        '(0 -10 0)
                                                        (mapcar '* clocat2 '(0 1 1))
                                                )
                                        )
                                        celine0
                                        )
                                )
                        )
                )
                (grdraw locn1 locn1 1 1)
                
                (setvar "cmdecho" 0)
                (command "_.undo" "be")
                (entmake (list '(0 . "line")
                        '(8 . "0")
                        (cons 10 loc1)
                        (cons 11 loc2)
                )
                )
                (entmake (list '(0 . "line")
                        '(8 . "0")
                        (cons 10 locn1)
                        (cons 11 locn2)
                )
                )
                
                (repeat
                        (length plistn)
                        (setq pt1 (car lcline1))
                        (setq lcline1 (cdr lcline1))
                        (setq pt2 (car lcline2))
                        (setq lcline2 (cdr lcline2))
                        (setq oldline (ssget "_w" pt1 pt2))
                        
                        (if (and (/= oldline nil) (/= (sslength oldline) 0))
                                (erases oldline)
                        )
                        
                        (entmake (list '(0 . "line")
                   '(8 . "04dashed")
                   (cons 10 pt1)
                   (cons 11 pt2)
                        )
                        )
                )
                
                (repeat (length clt)
                        (setq pt1 (car celine1))
                        (setq celine1 (cdr celine1))
                        (setq pt2 (car celine2))
                        (setq celine2 (cdr celine2))
                        (setq oldline (ssget "_w" pt1 pt2))
                        
                        (if        (and (/= oldline nil) (/= (sslength oldline) 0))
                                (erases oldline)
                        )
                        
                        (entmake (list '(0 . "line")
                                '(8 . "03centreline")
                                (cons 10 pt1)
                                (cons 11 pt2)
                        )
                        )
                )
                (setq oldline (ssget "_w" loc1 locn1))
                
                (if (and (/= oldline nil) (/= (sslength oldline) 0))
                        (erases oldline)
                )
                
                (entmake (list '(0 . "line")
                        '(8 . "0")
                        (cons 10 loc1)
                        (cons 11 locn1)
                )
                )
                (setq oldline (ssget "_w" loc2 locn2))
                
                (if (and (/= oldline nil) (/= (sslength oldline) 0))
                        (erases oldline)
                )
                
                (entmake (list '(0 . "line")
                        '(8 . "0")
                        (cons 10 loc2)
                        (cons 11 locn2)
                )
                )
                (command "_.undo" "e")
                (setvar "cmdecho" 0)
                (prin1)
)