[编程交流] 预览m周围的矩形

(defun C:test ( / mysc GetISOpsizes shiftL msgf _getrec LWPoly *error* psL scL orn s g k r rec )
 '(87 114 105 116 116 101 110 32 98 121 32 71 114 114 114)
 (setq mysc 0.1) ; scale factor for the units, to readjust the rectangle's size of (_getrec) and the console prompts, can be leaved nil.
 
 ; ("A4" "210.00" "297.00")
 (defun GetISOpsizes ( / L r )
   (defun splitstr (s d / p L) (while (setq p (vl-string-search d s)) (setq L (cons (substr s 1 p) L)) (setq s (substr s (+ p 2)))) (reverse (cons s L)))
   (defun GetCanonicalMediaNames ( / acDoc layObj )
     (setq layObj (vla-get-ActiveLayout (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))))
     (vla-put-ConfigName layObj "DWG To PDF.pc3")
     (vla-RefreshPlotDeviceInfo layObj)
     (vlax-invoke (vla-item (vla-get-layouts acDoc) "Model") 'GetCanonicalMediaNames)
   )
   (and
     (setq L (apply 'append (mapcar ''((x)(if (wcmatch x "ISO_*") (list (splitstr x "_")))) (GetCanonicalMediaNames))))
     (setq L (vl-remove-if-not ''((x) (= 6 (length x))) L))
     (setq L (mapcar ''((x) (apply ''((a b c d e f) (list b (vl-string-left-trim "(" c) e)) x)) L))
     (setq r L)
   ); and
   r
 ); defun GetISOpsizes
 
 ; _$ (shiftL '(a b c d e) t) -> (B C D E A)
 ; _$ (shiftL '(a b c d e) nil) -> (E A B C D)
 (setq shiftL '(( L f ) (if f (append (cdr L) (list (car L))) (cons (last L) (reverse (cdr (reverse L)))))))
 
 (setq msgf
   '((x psL scL orn / ps sc ori )
     ((eval x) 
       (strcat "\n"
         "[A/D] Paper size: " (apply '(lambda (a b c) (strcat a " " b "x" c)) (setq ps (car psL))) " | "
         "[-/+] Scale: " (strcat "1:" (setq sc (car scL))) " | "
         "[TAB] Orientation: " (setq ori (car orn))
       ); strcat
     ); x
     (list ps sc ori)
   )
 ); setq msgf
 
 (setq _getrec
   (lambda ( c sc / tmp tmpr )
     (redraw)
     (setq tmp (mapcar 'atof (cdar r)))
     (if (/= "Landscape" (car orn)) (setq tmp (reverse tmp)))
     (setq tmp (mapcar ''((x) (* (cond (sc) (1.)) (read (cadr r)) (/ x 2.))) tmp))
     
     (apply ''((a b c d) (grdraw a b 2 1) (grdraw b c 2 1) (grdraw c d 2 1) (grdraw d a 2 1))
       (setq tmpr 
         (list
           (mapcar '+ c tmp)
           (mapcar '+ c (list (- (car tmp)) (cadr tmp)))
           (mapcar '+ c (mapcar '- tmp))
           (mapcar '+ c (list (car tmp) (- (cadr tmp))))
         ); list
       ); setq tmpr
     ); mapcar
     tmpr
   )
 ); setq _getrec
 
 (defun LWPoly (lst cls) ; Lee Mac
   (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst)))
 )
 
 (defun *error* ( m )
   (redraw)
   (and m (princ m)) (princ)
 ); defun *error*
 
 (setq psL ((lambda (L / nL) (foreach x L (cond ( (assoc (car x) nL) ) ( (setq nL (cons x nL)) ) )) (reverse nL)) (GetISOpsizes)))
 (setq scL (apply 'append (mapcar ''((a) (mapcar ''((b)(strcat (itoa b) a)) '(1 2 5))) '("" "0" "00" "000"))))
 (setq orn '("Landscape" "Portrait"))
 
 (setq r (msgf 'princ psL scL orn))
 (while (not s) (setq g (grread t))
   (and (or (equal g '(2 13)) (= (car g) 25)) (setq s T))
   (cond
     ( 
       (and (= (car g) 2)
         (cond 
           ( (member g '((2 97)(2 65))) (setq psL (shiftL psL nil)) )
           ( (member g '((2 100)(2 68))) (setq psL (shiftL psL t)) )
           ( (equal g '(2 45)) (setq scL (shiftL scL nil)) )
           ( (equal g '(2 43)) (setq scL (shiftL scL t)) )
           ( (member g '((2 9)(2 32))) (setq orn (reverse orn)) )
         ); cond
         (setq r (msgf 'princ psL scL orn))
       )
     )
     ( (= (car g) 5) (_getrec (cadr g) mysc) )
     ( (= (car g) 3) (setq rec (_getrec (cadr g) mysc)) (setq s t) )
   ); cond        
 ); while 
 ; (apply 'msgf (cons 'alert (mapcar 'list r)))
 (and rec (LWPoly rec 1))
 (*error* nil) (princ)
); defun

(setq mysc 0.1)
(setq mysc nil)
(setq mysc 10.)