;;; 면적 평수 - TORVA 무료 리습 (torva.kr/lisp.html)
;;; PY : 닫힌 객체 하나를 고르면 면적(m2)과 평수(py)를 글자로 쓴다. 사각형·삼각형은 가로·세로(밑변·높이)도 함께
;;; 삽입점을 찍기 전에 S(글자 높이) U(도면 단위 mm/m)로 설정을 바꾼다. 바꾼 값은 도면을 닫을 때까지 유지된다
;;; 글자 높이 기본값 = 3.5 x DIMSCALE (1:100 도면이면 350). 도면 단위 기본값 mm. 글꼴은 현재 글꼴 스타일
(vl-load-com)
(if (null *TV-AREA-MM*) (setq *TV-AREA-MM* T)) ; T = 도면 단위 mm, nil = m
;; 글자 높이 - 직접 정한 값이 없으면 도면 축척에 맞춘다
(defun tv-area-h ()
(cond (*TV-AREA-H*)
((> (getvar "DIMSCALE") 0) (* 3.5 (getvar "DIMSCALE")))
(3.5)))
;; 길이를 m 로
(defun tv-area-m (d) (if *TV-AREA-MM* (/ d 1000.0) d))
(defun c:PY (/ *error* doc space ss ent obj area pts n l1 l2 l3 base w h dx dy lines txt inspt mt v s)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(defun *error* (msg)
(vla-EndUndoMark doc)
(if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\n오류: " msg)))
(princ))
(vla-StartUndoMark doc)
(setq space (if (= (vla-get-activespace doc) 1) (vla-get-modelspace doc) (vla-get-paperspace doc)))
;; 먼저 골라 둔 객체가 있으면 그것을 쓴다
(if (setq ss (ssget "_I"))
(setq ent (ssname ss 0))
(if (setq ent (entsel "\n객체 선택: ")) (setq ent (car ent))))
(cond
((null ent) (princ "\n선택한 객체가 없습니다."))
((vl-catch-all-error-p (setq area (vl-catch-all-apply 'vla-get-area (list (setq obj (vlax-ename->vla-object ent))))))
(princ "\n면적을 구할 수 없는 객체입니다."))
(T
;; 꼭짓점 (폴리선) - 처음과 끝이 같으면 하나로
(foreach x (entget ent) (if (= (car x) 10) (setq pts (cons (cdr x) pts))))
(setq pts (reverse pts))
(if (and (> (length pts) 1) (equal (car pts) (last pts) 1e-4)) (setq pts (cdr pts)))
(setq n (length pts))
;; 삽입점 - S U 로 설정을 바꾸고, 점을 찍으면 쓴다. 엔터 = 쓰지 않음
(setq inspt "S")
(while (= (type inspt) 'STR)
(initget "S U")
(setq inspt (getpoint (strcat "\n글자 삽입점 [글자 높이(S)/도면 단위(U)] <높이 " (rtos (tv-area-h) 2 0)
", 단위 " (if *TV-AREA-MM* "mm" "m") ">: ")))
(cond
((= inspt "S") (if (setq v (getdist (strcat "\n글자 높이 <" (rtos (tv-area-h) 2 0) ">: "))) (setq *TV-AREA-H* v)))
((= inspt "U") (setq *TV-AREA-MM* (not *TV-AREA-MM*)))))
(if inspt
(progn
(setq area (if *TV-AREA-MM* (/ area 1000000.0) area))
(cond
((= n 3)
(setq l1 (distance (nth 0 pts) (nth 1 pts)) l2 (distance (nth 1 pts) (nth 2 pts)) l3 (distance (nth 2 pts) (nth 0 pts))
base (tv-area-m (max l1 l2 l3)))
(setq lines (list (strcat "W: " (rtos base 2 2) "m / H: " (rtos (/ (* 2.0 area) base) 2 2) "m"))))
((= n 4)
(setq l1 (distance (nth 0 pts) (nth 1 pts)) l2 (distance (nth 1 pts) (nth 2 pts))
dx (abs (- (car (nth 1 pts)) (car (nth 0 pts)))) dy (abs (- (cadr (nth 1 pts)) (cadr (nth 0 pts)))))
(if (> dx dy) (setq w l1 h l2) (setq w l2 h l1))
(setq lines (list (strcat "W: " (rtos (tv-area-m w) 2 2) "m / H: " (rtos (tv-area-m h) 2 2) "m")))))
(setq lines (append lines (list (strcat (rtos area 2 2) " m\\U+00B2") (strcat (rtos (* area 0.3025) 2 2) " py"))))
(setq txt (car lines))
(foreach s (cdr lines) (setq txt (strcat txt "\\P" s)))
(setq mt (vla-AddMText space (vlax-3d-point (trans inspt 1 0)) 0.0 txt))
(vla-put-Height mt (tv-area-h))
(vla-put-AttachmentPoint mt acAttachmentPointTopLeft)
(vla-put-InsertionPoint mt (vlax-3d-point (trans inspt 1 0)))
(princ (strcat "\n" (rtos area 2 2) " m2 / " (rtos (* area 0.3025) 2 2) " 평"))))))
(vla-EndUndoMark doc)
(princ)
)
(princ "\n면적 평수: PY / 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)