;;; TORVA LISP - Sheet Scale (torva.kr/lisp.html)
;;; DSC : select objects -> scale them in place so the title block (sheet frame) fits a drawing scale 1/N
;;; scale mode : type N (e.g. 100), pick the left and right ends of the frame -> frame width becomes paper width x N
;;; the left end is the base point, so the frame stays where it is
;;; reference mode: pick two points of a current length, then two points of the length it should become
;;; Enter at the first prompt = the last scale N
;;; Settings: Paper = frame width at 1/1 (A3 420, A2 594, A1 841, A0 1189). For a drawing in meters type 0.42
;;; scale N and paper width persist until the drawing closes
;;; Objects on locked layers are not selected. One U undoes the whole run
(vl-load-com)
(if (null *TV-DSC-SCALE*) (setq *TV-DSC-SCALE* 100.0))
(if (null *TV-DSC-PAPER*) (setq *TV-DSC-PAPER* 420.0))
(defun tv-dsc-scale (ss bp f)
(command "_.SCALE" ss "" "_non" bp f)
(princ (strcat "\nScaled x" (rtos f 2 4))))
(defun c:DSC (/ *error* old doc ce ss in n g p1 p2 p3 p4 w d1 d2 done)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)) ce (getvar "CMDECHO") old *error*)
(defun *error* (msg)
(vla-EndUndoMark doc)
(setvar "CMDECHO" ce)
(setq *error* old)
(if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
(princ))
(setvar "CMDECHO" 0)
(princ "\n축척을 맞출 객체: ")
(if (setq ss (ssget "_:L"))
(while (not done)
(initget 128 "Paper")
(setq in (getpoint (strcat "\n축척 1/N 또는 현재 길이 첫 점 [용지(P)] <" (rtos *TV-DSC-SCALE* 2 0) ">: ")))
(cond
((= in "Paper")
(if (setq g (getdist (strcat "\n용지 폭 <" (rtos *TV-DSC-PAPER* 2 2) ">: ")))
(if (> g 0) (setq *TV-DSC-PAPER* g))))
((= (type in) 'LIST)
(setq done T p1 in)
(if (and (setq p2 (getpoint p1 "\n현재 길이 끝점: "))
(setq p3 (getpoint "\n맞출 길이 첫 점: "))
(setq p4 (getpoint p3 "\n맞출 길이 끝점: ")))
(if (and (> (setq d1 (distance p1 p2)) 0) (> (setq d2 (distance p3 p4)) 0))
(progn
(vla-StartUndoMark doc)
(tv-dsc-scale ss p1 (/ d2 d1))
(vla-EndUndoMark doc))
(princ "\nLength is zero"))))
((and in (not (and (setq n (distof in)) (> n 0))))
(princ "\nScale must be a positive number"))
(T
(setq done T)
(if n (setq *TV-DSC-SCALE* n))
(princ (strcat "\nFrame width 1/" (rtos *TV-DSC-SCALE* 2 0) " = " (rtos (* *TV-DSC-PAPER* *TV-DSC-SCALE*) 2 2)))
(if (and (setq p1 (getpoint "\n도곽 왼쪽 끝: "))
(setq p2 (getpoint p1 "\n도곽 오른쪽 끝: ")))
(progn
(setq w (abs (- (car p2) (car p1))))
(if (equal w 0.0 1e-8) (setq w (distance p1 p2)))
(if (> w 0)
(progn
(vla-StartUndoMark doc)
(tv-dsc-scale ss p1 (/ (* *TV-DSC-PAPER* *TV-DSC-SCALE*) w))
(vla-EndUndoMark doc)
(princ (strcat " -> 1/" (rtos *TV-DSC-SCALE* 2 0))))
(princ "\nLength is zero"))))))
(setq n nil)))
(setvar "CMDECHO" ce)
(setq *error* old)
(princ)
)
(princ "\nTORVA Sheet Scale: DSC | torva.kr")
(princ)
;;; ---- TVKEY: change a shortcut - shared by every TORVA LISP (torva.kr/lisp.html) ----
;;; TVKEY -> command -> new shortcut. The original command keeps working
;;; Shortcuts are saved on this PC as TORVA-KEYS and restored whenever a TORVA LISP loads
;;; (Every TORVA LISP carries this block; loading several just redefines the same functions)
;; "A1=PY;B2=CN;" -> (("A1" . "PY") ("B2" . "CN"))
(defun tv-key-list (/ s i out)
(setq s (cond ((getenv "TORVA-KEYS")) ("")) out nil)
(while (setq i (vl-string-search ";" s))
(setq out (cons (substr s 1 i) out) s (substr s (+ i 2))))
(if (/= s "") (setq out (cons s out)))
(vl-remove nil
(mapcar '(lambda (x / j) (if (setq j (vl-string-search "=" x)) (cons (substr x 1 j) (substr x (+ j 2)))))
(reverse out))))
(defun tv-key-save (lst)
(setenv "TORVA-KEYS" (apply 'strcat (mapcar '(lambda (p) (strcat (car p) "=" (cdr p) ";")) lst))))
;; is cmd a loaded LISP command
(defun tv-key-cmd-p (cmd)
(member (type (eval (read (strcat "C:" cmd)))) '(SUBR USUBR EXRXSUBR)))
(defun tv-key-def (key cmd)
(eval (list 'defun (read (strcat "C:" key)) '() (list (read (strcat "C:" cmd))) '(princ))))
;; is key an alias in acad.pgp ("L, *LINE")
(defun tv-key-pgp-p (key / f h l hit)
(if (setq f (findfile "acad.pgp"))
(progn
(setq h (open f "r"))
(while (and (not hit) (setq l (read-line h)))
(if (and (not (wcmatch l ";*")) (wcmatch (strcase l) (strcat key ",*"))) (setq hit T)))
(close h)))
hit)
;; reason the key cannot be used, nil if fine
(defun tv-key-bad (key lst)
(cond
((not (vl-every '(lambda (c) (or (<= 48 c 57) (<= 65 c 90))) (vl-string->list key))) "영문·숫자만")
((getcname key) "AutoCAD 명령 이름")
((tv-key-pgp-p key) "acad.pgp 별칭과 같음")
((and (tv-key-cmd-p key) (not (assoc key lst))) "이미 있는 리습 명령")))
;; "My shortcuts" lines at the end of the file: (tv-my-key "A1" "BN"). Bad key -> reason only
(defun tv-my-key (key cmd / why)
(setq key (strcase key) cmd (strcase cmd))
(cond ((not (tv-key-cmd-p cmd)))
((setq why (tv-key-bad key (list (cons key cmd)))) (princ (strcat "\nShortcut " key ": " why)))
(T (tv-key-def key cmd))))
(defun c:TVKEY (/ cmd key lst why)
(setq lst (tv-key-list)
cmd (strcase (getstring "\n단축키를 붙일 명령 [목록(?)]: ")))
(cond
((= cmd ""))
((= cmd "?")
(if lst
(foreach p lst (princ (strcat "\n " (car p) " = " (cdr p))))
(princ "\nNo shortcuts set")))
((not (tv-key-cmd-p cmd)) (princ (strcat "\n" cmd " is not a loaded LISP command")))
(T
(setq key (strcase (getstring (strcat "\n" cmd " 의 새 단축키 [지우기(-)]: "))))
(cond
((= key ""))
((= key "-")
(foreach p lst
(if (= (cdr p) cmd) (set (read (strcat "C:" (car p))) nil)))
(tv-key-save (vl-remove-if '(lambda (p) (= (cdr p) cmd)) lst))
(princ (strcat "\nShortcut for " cmd " removed")))
((= key cmd))
((setq why (tv-key-bad key lst)) (princ (strcat "\n" key ": " why)))
(T
(tv-key-save (cons (cons key cmd) (vl-remove-if '(lambda (p) (= (car p) key)) lst)))
(tv-key-def key cmd)
(princ (strcat "\n" key " now runs " cmd))))))
(princ))
;; on load: restore saved shortcuts whose command is loaded
(foreach p (tv-key-list)
(if (tv-key-cmd-p (cdr p)) (tv-key-def (car p) (cdr p))))
(princ "\nTVKEY: change a shortcut | torva.kr")
(princ)
;;; ---- My shortcuts: lines set at torva.kr download land below. Edit or add lines to change them ----