;;; 부재 이름 - TORVA 무료 리습 (torva.kr/lisp.html)
;;; BN : 보 이름. 보(4점 폴리선 사각형, 선, 치수선)를 고르면 부재 방향을 따라 보 위에 이름을 쓴다
;;; CN : 기둥 이름. 기둥 외곽을 고르면 크기가 큰 것부터 C1, C2 ... 로 번호를 매겨 왼쪽 위에 쓴다
;;; 이름을 묻는 자리에서 H(글자 높이)를 바꿀 수 있다. 바꾼 값은 도면을 닫을 때까지 유지된다
;;; 글자 높이 기본값 = 3.5 x DIMSCALE (1:100 도면이면 350). 부재와 글자 사이 = 1 x DIMSCALE
;;; 레이어 MEMBER-NAME (없으면 만든다). 글꼴은 현재 문자 스타일
(vl-load-com)
(if (null *TV-MN-BEAM*) (setq *TV-MN-BEAM* "G1"))
(if (null *TV-MN-COL*) (setq *TV-MN-COL* "C"))
(setq *TV-MN-LAYER* "MEMBER-NAME")
(defun tv-mn-ds ()
(if (> (getvar "DIMSCALE") 0) (getvar "DIMSCALE") 1.0))
;; 글자 높이 - 직접 정한 값이 없으면 도면 축척에 맞춘다
(defun tv-mn-h ()
(cond (*TV-MN-H*) ((* 3.5 (tv-mn-ds)))))
(defun tv-mn-layer ()
(if (null (tblsearch "LAYER" *TV-MN-LAYER*))
(entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
(cons 2 *TV-MN-LAYER*) '(70 . 0) '(62 . 3) '(6 . "Continuous")))))
;; 이름 묻기 - H 만 입력하면 글자 높이를 바꾸고 다시 묻는다. 엔터면 기본값
(defun tv-mn-name (msg def / r v)
(setq r "H")
(while (= (strcase r) "H")
(setq r (getstring (strcat "\n" msg " [글자 높이(H)] <" def ", 높이 " (rtos (tv-mn-h) 2 0) ">: ")))
(if (= (strcase r) "H")
(if (setq v (getdist (strcat "\n글자 높이 <" (rtos (tv-mn-h) 2 0) ">: "))) (setq *TV-MN-H* v))))
(if (= r "") def r))
(defun tv-mn-text (pt h str ang h72)
(entmakex (list '(0 . "TEXT") '(100 . "AcDbEntity") (cons 8 *TV-MN-LAYER*) '(100 . "AcDbText")
(cons 10 pt) (cons 11 pt) (cons 40 h) (cons 1 str) (cons 50 ang)
(cons 7 (getvar "TEXTSTYLE")) (cons 72 h72) '(73 . 2))))
;; 잠긴 레이어면 T
(defun tv-mn-locked (en / d)
(setq d (tblsearch "LAYER" (cdr (assoc 8 (entget en)))))
(and d (= 4 (logand 4 (cdr (assoc 70 d))))))
(defun c:BN (/ *error* old ce ss i en ed typ pts p1 p2 p3 c ang bw h gap n name)
(setq ce (getvar "CMDECHO") old *error*)
(defun *error* (msg)
(setvar "CMDECHO" ce) (setq *error* old)
(if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\n오류: " msg)))
(princ))
(setvar "CMDECHO" 0)
(setq name (tv-mn-name "보 이름" *TV-MN-BEAM*) *TV-MN-BEAM* name)
(princ "\n이름을 붙일 보 선택 (사각 폴리선, 선, 치수선): ")
(if (setq ss (ssget '((-4 . "")
(0 . "LINE") (0 . "DIMENSION") (-4 . "OR>"))))
(progn
(tv-mn-layer)
(setq i 0 n 0 h (tv-mn-h) gap (tv-mn-ds))
(repeat (sslength ss)
(setq en (ssname ss i) ed (entget en) typ (cdr (assoc 0 ed)) i (1+ i))
(if (not (tv-mn-locked en))
(progn
(if (= typ "LWPOLYLINE")
(progn
;; 사각 보: 네 점 가운데, 긴 변 방향, 짧은 변이 보 폭
(setq pts nil)
(foreach x ed (if (= (car x) 10) (setq pts (append pts (list (cdr x))))))
(setq p1 (nth 0 pts) p2 (nth 1 pts) p3 (nth 2 pts))
(setq c (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p3))
(if (> (distance p1 p2) (distance p2 p3))
(setq ang (angle p1 p2) bw (distance p2 p3))
(setq ang (angle p2 p3) bw (distance p1 p2))))
(progn
;; 선·치수선: 폭 0
(if (= typ "DIMENSION")
(setq p1 (cdr (assoc 13 ed)) p2 (cdr (assoc 14 ed)))
(setq p1 (cdr (assoc 10 ed)) p2 (cdr (assoc 11 ed))))
(setq c (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2) ang (angle p1 p2) bw 0.0)))
;; 글자가 뒤집히지 않게 -90 ~ 90 도로
(while (>= ang pi) (setq ang (- ang pi)))
(if (> ang (/ pi 2.0)) (setq ang (- ang pi)))
(if (equal ang (/ pi -2.0) 0.001) (setq ang (/ pi 2.0)))
(tv-mn-text (polar (list (car c) (cadr c) 0.0) (+ ang (/ pi 2.0)) (+ (/ bw 2.0) gap (/ h 2.0))) h name ang 1)
(setq n (1+ n)))))
(princ (strcat "\n보 " (itoa n) "개에 " name))))
(setvar "CMDECHO" ce) (setq *error* old)
(princ))
(defun c:CN (/ *error* old ce doc ss i en obj mn mx a b big small pt all sizes k n h gap done dup pre)
(setq ce (getvar "CMDECHO") old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun *error* (msg)
(setvar "CMDECHO" ce) (setq *error* old) (vla-EndUndoMark doc)
(if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\n오류: " msg)))
(princ))
(vla-StartUndoMark doc)
(setvar "CMDECHO" 0)
(setq pre (tv-mn-name "기둥 이름 앞글자" *TV-MN-COL*) *TV-MN-COL* pre)
(princ "\n이름을 붙일 기둥 외곽 선택: ")
(if (setq ss (ssget))
(progn
(tv-mn-layer)
(setq i 0 h (tv-mn-h) gap (tv-mn-ds))
;; 1. 기둥마다 외곽 크기(긴 변, 짧은 변)와 글자 자리(왼쪽 위 바깥)
(repeat (sslength ss)
(setq en (ssname ss i) i (1+ i) obj (vlax-ename->vla-object en))
(if (and (not (tv-mn-locked en))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox (list obj 'mn 'mx)))))
(progn
(setq mn (vlax-safearray->list mn) mx (vlax-safearray->list mx))
(setq a (- (car mx) (car mn)) b (- (cadr mx) (cadr mn)))
(setq big (fix (+ (max a b) 0.5)) small (fix (+ (min a b) 0.5)))
(setq pt (list (- (car mn) gap) (+ (cadr mx) gap (/ h 2.0)) 0.0))
(setq all (cons (list big small pt) all))
(if (not (member (list big small) sizes)) (setq sizes (cons (list big small) sizes))))))
;; 2. 큰 것부터 번호: 긴 변, 같으면 짧은 변
(setq sizes (vl-sort sizes '(lambda (x y) (if (= (car x) (car y)) (> (cadr x) (cadr y)) (> (car x) (car y))))))
;; 3. 글자 쓰기. 같은 자리(글자 높이의 1/10 안)에 이미 썼으면 건너뛴다
(setq n 0)
(foreach e all
(setq dup nil)
(foreach p done (if (< (distance (caddr e) p) (* 0.1 h)) (setq dup T)))
(if (not dup)
(progn
(setq k (1+ (vl-position (list (car e) (cadr e)) sizes)))
(tv-mn-text (caddr e) h (strcat pre (itoa k)) 0.0 2)
(setq done (cons (caddr e) done) n (1+ n)))))
(princ (strcat "\n기둥 " (itoa n) "개, 크기 " (itoa (length sizes)) "종류"))))
(setvar "CMDECHO" ce) (setq *error* old) (vla-EndUndoMark doc)
(princ))
(princ "\n부재 이름: BN (보) / CN (기둥) / 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)