[编程交流] 标题栏创建

(defun c:Captain_Ahap  ( / SizeList ScaleList size scale titleblockfolder titleblock)
 (vl-load-com)
 ; some shortcuts for titleblock / border sizes (without the full path)
 (setq SizeList  (list "A0" "A1" "A2" "A3" "A4-L" "A4-P")
ScaleList (list 1 10 50 100)
titleblockfolder "c:/temp/mytitleblockfolder/"
 )
 (if (and (setq size  (CycleList "Choose titleblock size" SizeList))
   (setq scale (CycleList "Choose titleblock scale" ScaleList)))
   (progn
     ; maybe translate size to filename first
     (cond ((eq size   "A0") (setq titleblock (strcat titleblockfolder "A0_horizondal_test.dwg")))
    ((eq size   "A1") (setq titleblock (strcat titleblockfolder "A1_horizondal_test.dwg")))
    ((eq size   "A2") (setq titleblock (strcat titleblockfolder "A2_horizondal_test.dwg")))
    ((eq size   "A3") (setq titleblock (strcat titleblockfolder "A3_horizondal_test.dwg")))
    ((eq size "A4-L") (setq titleblock (strcat titleblockfolder "A4_Landscape_test.dwg")))
    ((eq size "A4-P") (setq titleblock (strcat titleblockfolder "A4_Portrait_test.dwg")))
     )
     (if (and titleblock (findfile titleblock) (numberp scale))
(progn
  (setvar 'expert 2) (setvar 'cmdecho 0) (setvar 'attreq 0)
  (command "-insert" titleblock (list 0 0 0) scale scale 0)
  (command "_.explode" "_L")
  (command "-purge" "B" "YourBlockName" "N")
  (command "._zoom" "e")
)
(alert "Unable to insert titleblock")
     )
   )
 )
 (princ)
)
; example1 (setq choise (CycleList "Choose titleblock size" '("A0" "A1" "A2" "A3" "A4")))
; example2 (setq choise (CycleList "Choose titleblock scale" '(1 10 50 100)))
(defun CycleList (msg lst / inp loop rtn)
 (setq loop t)
 (while loop
   (princ "\nCycle list with tab or L-mouse / accept use enter,space or R-mouse / Esc or x for exit\n")
   (princ (strcat "\r" msg " <" (vl-princ-to-string (car lst)) "> : "))
   (setq inp (vl-catch-all-apply 'grread (list nil 8 0)))
   (if (vl-catch-all-error-p inp)
     (progn (princ "\nTitleblock insertion cancelled")(setq rtn nil loop nil))
     (progn
       (cond
         ;tab
         ((or (equal inp '(2 9))(= (car inp) 3))
          (setq lst (append (cdr lst)(list (car lst))))
          (princ (strcat "\r" msg " <" (vl-princ-to-string (car lst)) "> : ")))
         ;enter,space,r-mouse
         ((or (equal inp '(2 13)) (equal inp '(2 32))(= (car inp) 25))
          (setq rtn (car lst) loop nil))
         ;x or X
         ((member inp '((2 88)(2 120)))(setq rtn nil loop nil))
       )
     )
   )
 )
 (terpri)
 rtn
)
; start command with (c:Captain_Ahap)