;;; 글자 크기·글꼴 일괄 변경 - TORVA 무료 리습 (torva.kr/lisp.html)
;;; TXH  : 고른 글자(TEXT, MTEXT)의 높이를 한 번에 바꾼다. 글자 가운데를 기준으로 커지고 줄어 제자리를 지킨다
;;; TXST : 고른 글자의 문자 스타일을 한 번에 바꾼다. 기준 글자를 찍거나 스타일 이름을 입력한다. 엔터를 누르면 도면 전체
;;; 높이 기본값 = 3.5 x DIMSCALE (1:100 도면이면 350). 바꾼 값은 도면을 닫을 때까지 유지된다
;;; 잠긴 레이어의 글자는 건드리지 않는다

(vl-load-com)

(defun tv-tb-height ()
  (cond (*TV-TB-HEIGHT*)
        ((> (getvar "DIMSCALE") 0) (* 3.5 (getvar "DIMSCALE")))
        (3.5)))

;; 글자 외곽 상자의 가운데
(defun tv-tb-center (o / a b)
  (vla-getboundingbox o 'a 'b)
  (mapcar '(lambda (x y) (/ (+ x y) 2.0)) (vlax-safearray->list a) (vlax-safearray->list b)))

;; 미리 고른 것이 있으면 그것, 없으면 새로 고른다 (잠긴 레이어 제외)
(defun tv-tb-pick (msg)
  (cond ((ssget "_I" '((0 . "TEXT,MTEXT"))))
        (T (prompt msg) (ssget ":L" '((0 . "TEXT,MTEXT"))))))

(defun c:TXH (/ *error* old ss v h i o c0 c1 n lay)
  (setq old *error*)
  (defun *error* (msg)
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\n오류: " msg)))
    (princ))
  (setq ss (tv-tb-pick "\n높이를 바꿀 글자 선택: "))
  (sssetfirst nil nil)
  (if ss
    (progn
      (if (setq v (getdist (strcat "\n글자 높이 <" (rtos (tv-tb-height) 2 1) ">: "))) (setq *TV-TB-HEIGHT* v))
      (setq h (tv-tb-height) n 0 i 0)
      (repeat (sslength ss)
        (setq o (vlax-ename->vla-object (ssname ss i)) i (1+ i)
              lay (tblsearch "LAYER" (vla-get-layer o)))
        (if (= 0 (logand 4 (cdr (assoc 70 lay))))
          (progn
            (setq c0 (tv-tb-center o))
            (vla-put-height o h)
            (setq c1 (tv-tb-center o))
            (vla-move o (vlax-3d-point c1) (vlax-3d-point c0))
            (setq n (1+ n)))))
      (princ (strcat "\n글자 " (itoa n) "개 높이 " (rtos h 2 1)))))
  (setq *error* old)
  (princ)
)

;; 스타일 정하기 - 기준 글자를 찍거나 N 으로 이름 입력. 없는 이름이면 글꼴 파일을 물어 새로 만든다
(defun tv-tb-style (/ e st f)
  (initget "N")
  (setq e (entsel (strcat "\n기준 글자 선택 또는 [이름 입력(N)] <" (getvar "TEXTSTYLE") ">: ")))
  (cond
    ((= e "N")
     (setq st (getstring T (strcat "\n문자 스타일 이름 <" (getvar "TEXTSTYLE") ">: ")))
     (if (= st "") (setq st (getvar "TEXTSTYLE")))
     (if (not (tblsearch "STYLE" st))
       (progn
         (setq f (getstring (strcat "\n" st " 스타일이 없습니다. 쓸 글꼴 파일 <malgun.ttf>: ")))
         (if (= f "") (setq f "malgun.ttf"))
         (command "_.-STYLE" st f 0 1 0 "_N" "_N")))
     st)
    ((and e (wcmatch (cdr (assoc 0 (entget (car e)))) "TEXT,MTEXT"))
     (cdr (assoc 7 (entget (car e)))))
    (e (princ "\n글자가 아닙니다. 현재 스타일을 씁니다.") (getvar "TEXTSTYLE"))
    (T (getvar "TEXTSTYLE")))
)

(defun c:TXST (/ *error* old doc st ss i o n all)
  (setq old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (defun *error* (msg)
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\n오류: " msg)))
    (princ))
  (setq ss (ssget "_I" '((0 . "TEXT,MTEXT"))) n 0)   ; 미리 고른 것은 기준 글자를 찍기 전에 잡아 둔다
  (sssetfirst nil nil)
  (setq st (tv-tb-style))
  (if (not ss)
    (progn (prompt (strcat "\n" st " 스타일로 바꿀 글자 선택 (엔터 = 도면 전체): "))
           (setq ss (ssget ":L" '((0 . "TEXT,MTEXT"))))))
  (if ss
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (setq o (vlax-ename->vla-object (ssname ss i)) i (1+ i))
        (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-stylename (list o st)))) (setq n (1+ n)))))
    (progn
      (initget "Y N")
      (if (= "Y" (getkword (strcat "\n도면 전체 글자(블록 안 포함)를 " st " 스타일로 바꿀까요? [예(Y)/아니오(N)] <N>: ")))
        (vlax-for blk (vla-get-Blocks doc)
          (if (= :vlax-false (vla-get-isxref blk))
            (vlax-for o blk
              (if (wcmatch (vla-get-ObjectName o) "AcDbText,AcDbMText")
                (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-stylename (list o st)))) (setq n (1+ n))))))))))
  (if (> n 0)
    (progn (setvar "TEXTSTYLE" st)
           (vla-Regen doc acAllViewports)
           (princ (strcat "\n글자 " (itoa n) "개를 " st " 스타일로 바꿈"))))
  (setq *error* old)
  (princ)
)

(princ "\n글자 일괄 변경: TXH (높이) / TXST (스타일) / torva.kr")
(princ)

;;; ---- 단축키 바꾸기 (TVKEY) - TORVA 리습 공통, torva.kr/lisp-guide.html ----
;;; TVKEY -> 명령 -> 새 단축키. 원래 명령어도 그대로 쓴다
;;; 정한 단축키는 이 PC 에 TORVA-KEYS 로 저장되고, 리습을 불러올 때마다 되살아난다
;;; (TORVA 리습 파일마다 같은 코드가 들어 있다. 여러 개를 불러와도 같은 정의를 덮어쓸 뿐이다)

;; "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))))

;; 불러온 리습 명령인가
(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))))

;; 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)

;; 쓸 수 없는 단축키면 까닭을, 쓸 수 있으면 nil
(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) "AutoCAD 단축키(acad.pgp)와 같은 이름입니다")
    ((and (tv-key-cmd-p key) (not (assoc key lst))) "이미 있는 리습 명령입니다")))

(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 "\n정한 단축키가 없습니다")))
    ((not (tv-key-cmd-p cmd)) (princ (strcat "\n" cmd " 는 불러온 리습 명령이 아닙니다")))
    (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 "\n" cmd " 의 단축키를 지웠습니다")))
       ((= 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 " 로도 " cmd " 가 실행됩니다"))))))
  (princ))

;; 불러올 때 - 저장된 단축키 중 명령이 불러와져 있는 것을 되살린다
(foreach p (tv-key-list)
  (if (tv-key-cmd-p (cdr p)) (tv-key-def (car p) (cdr p))))
(princ "\n단축키 바꾸기: TVKEY")
(princ)