;;; 구름마크 - TORVA 무료 리습 (torva.kr/lisp.html)
;;; CC : 두 점으로 사각 구름마크
;;; CCT : 구름마크 + 목표 지점까지 지시선 (스페이스바를 누르면 선 없이 끝)
;;; 시작점을 찍기 전에 A(호 크기) S(선 두께) D(색상 바꾸기)로 설정을 바꾼다. 바꾼 값은 도면을 닫을 때까지 유지된다
;;; 호 크기 기본값 = 10 x DIMSCALE (1:100 도면이면 1000). 레이어는 REV (없으면 만든다)
(vl-load-com)
(if (null *TV-CLOUD-WIDTH*) (setq *TV-CLOUD-WIDTH* 0.0))
(if (null *TV-CLOUD-COLOR*) (setq *TV-CLOUD-COLOR* 6))
(setq *TV-CLOUD-LAYER* "REV")
;; 호 크기 - 직접 정한 값이 없으면 도면 축척에 맞춘다
(defun tv-cloud-arc ()
(cond (*TV-CLOUD-ARC*)
((> (getvar "DIMSCALE") 0) (* 10.0 (getvar "DIMSCALE")))
(10.0)))
;; 시작점 받기 - A S D 로 설정을 바꾸고, 점을 찍으면 돌려준다. 엔터 = nil
(defun tv-cloud-start (/ p v colors)
(setq p "A")
(while (= (type p) 'STR)
(initget "A S D")
(setq p (getpoint (strcat "\n시작점 [호 크기(A)/선 두께(S)/색상(D)] <호 " (rtos (tv-cloud-arc) 2 0)
", 두께 " (rtos *TV-CLOUD-WIDTH* 2 1) ", 색 " (itoa *TV-CLOUD-COLOR*) ">: ")))
(cond
((= p "A") (if (setq v (getdist (strcat "\n호 크기 <" (rtos (tv-cloud-arc) 2 0) ">: "))) (setq *TV-CLOUD-ARC* v)))
((= p "S") (if (setq v (getdist (strcat "\n선 두께 <" (rtos *TV-CLOUD-WIDTH* 2 1) ">: "))) (setq *TV-CLOUD-WIDTH* v)))
((= p "D")
(setq colors '(1 2 3 4 6 30 40 50 90 130 140 200 210))
(setq *TV-CLOUD-COLOR* (nth (rem (abs (getvar "MILLISECS")) (length colors)) colors))
(princ (strcat "\n색상 " (itoa *TV-CLOUD-COLOR*))))
)
)
p
)
;; 공통 본체 - leader 가 T 면 지시선까지
(defun tv-cloud-run (leader / *error* old osm lay pa p1 p2 cloud tgt best d ln)
(setq osm (getvar "OSMODE") lay (getvar "CLAYER") pa (getvar "PEDITACCEPT") old *error*)
(defun *error* (msg)
(setvar "OSMODE" osm) (setvar "CLAYER" lay) (setvar "PEDITACCEPT" pa) (setvar "CMDECHO" 1)
(setq *error* old)
(if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\n오류: " msg)))
(princ))
(setvar "CMDECHO" 0)
(if (and (setq p1 (tv-cloud-start))
(setq p2 (getcorner p1 "\n반대편 구석: ")))
(progn
(if (null (tblsearch "LAYER" *TV-CLOUD-LAYER*))
(entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
(cons 2 *TV-CLOUD-LAYER*) '(70 . 0) '(62 . 6) '(6 . "Continuous"))))
(setvar "CLAYER" *TV-CLOUD-LAYER*)
(setvar "OSMODE" 0)
(command "_.RECTANG" p1 p2)
(command "_.REVCLOUD" "_A" (tv-cloud-arc) (tv-cloud-arc) "_O" (entlast) "_N")
(setq cloud (entlast))
(setvar "OSMODE" osm)
(if (and leader (setq tgt (getpoint "\n지시선 목표 지점 (스페이스바 = 선 없음): ")))
(progn
;; 목표에 가장 가까운 모서리 -> 구름 위에서 그 모서리에 가장 가까운 점에서 출발
(foreach c (list p1 p2 (list (car p1) (cadr p2)) (list (car p2) (cadr p1)))
(if (or (null best) (< (distance c tgt) d)) (setq best c d (distance c tgt))))
(setq best (vlax-curve-getClosestPointTo (vlax-ename->vla-object cloud) (list (car best) (cadr best) 0.0)))
(setvar "OSMODE" 0)
(command "_.PLINE" best tgt "")
(setq ln (entlast))))
(setvar "PEDITACCEPT" 1)
(if ln
(progn (command "_.PEDIT" "_M" cloud ln "" "_W" *TV-CLOUD-WIDTH* "")
(command "_.CHPROP" cloud ln "" "_C" *TV-CLOUD-COLOR* ""))
(progn (command "_.PEDIT" cloud "_W" *TV-CLOUD-WIDTH* "")
(command "_.CHPROP" cloud "" "_C" *TV-CLOUD-COLOR* "")))
)
)
(setvar "OSMODE" osm) (setvar "CLAYER" lay) (setvar "PEDITACCEPT" pa) (setvar "CMDECHO" 1)
(setq *error* old)
(princ)
)
(defun c:CC () (tv-cloud-run nil))
(defun c:CCT () (tv-cloud-run T))
(princ "\n구름마크: CC (구름마크) / CCT (구름마크 + 지시선) / 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)