;;; TORVA LISP - Leader Text (torva.kr/lisp.html) ;;; LDT : marker point -> two more points (ortho) -> text at the end. Leader, marker and text become one group ;;; Options at the text prompt: 1 text height / 2 marker shape (filled dot, ring, arrow, X) / 3 marker size ;;; Text = 3.5 x DIMSCALE (350 at 1:100), marker = 1.5 x DIMSCALE. Values persist until the drawing closes ;;; Layer LEADER, created if missing. Text uses the current text style (vl-load-com) (if (null *TV-LDT-TYPE*) (setq *TV-LDT-TYPE* 1)) (setq *TV-LDT-LAYER* "LEADER") (defun tv-ldt-ds () (if (> (getvar "DIMSCALE") 0) (getvar "DIMSCALE") 1.0)) (defun tv-ldt-h () (cond (*TV-LDT-H*) ((* 3.5 (tv-ldt-ds))))) (defun tv-ldt-m () (cond (*TV-LDT-M*) ((* 1.5 (tv-ldt-ds))))) (defun tv-ldt-name () (nth (1- *TV-LDT-TYPE*) '("점" "원" "화살표" "X"))) (defun tv-ldt-layer () (if (null (tblsearch "LAYER" *TV-LDT-LAYER*)) (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (cons 2 *TV-LDT-LAYER*) '(70 . 0) '(62 . 7) '(6 . "Continuous"))))) (defun tv-ldt-line (a b) (entmakex (list '(0 . "LINE") (cons 8 *TV-LDT-LAYER*) (cons 10 a) (cons 11 b)))) ;; leader + marker from WCS points; returns the new entities (defun tv-ldt-build (pts / p1 p2 ang m s off out a b) (setq p1 (car pts) p2 (cadr pts) ang (angle p1 p2) m (tv-ldt-m) s (/ m 2.0) off (if (member *TV-LDT-TYPE* '(2 4)) s 0.0)) ;; hollow markers: the line starts at the marker edge (setq out (list (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 8 *TV-LDT-LAYER*) '(100 . "AcDbPolyline") (cons 90 (length pts)) '(70 . 0)) (mapcar '(lambda (p) (cons 10 (list (car p) (cadr p)))) (cons (polar p1 ang off) (cdr pts))))))) (cond ((= *TV-LDT-TYPE* 1) ; filled dot = closed pline, two half arcs, width = radius (setq a (polar p1 pi (/ m 4.0)) b (polar p1 0.0 (/ m 4.0))) (setq out (cons (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 8 *TV-LDT-LAYER*) '(100 . "AcDbPolyline") '(90 . 2) '(70 . 1) (cons 43 s) (cons 10 (list (car a) (cadr a))) '(42 . 1.0) (cons 10 (list (car b) (cadr b))) '(42 . 1.0))) out))) ((= *TV-LDT-TYPE* 2) (setq out (cons (entmakex (list '(0 . "CIRCLE") (cons 8 *TV-LDT-LAYER*) (cons 10 p1) (cons 40 s))) out))) ((= *TV-LDT-TYPE* 3) ; arrow head = SOLID, 15 deg each side (setq a (polar p1 (+ ang (/ pi 12)) m) b (polar p1 (- ang (/ pi 12)) m)) (setq out (cons (entmakex (list '(0 . "SOLID") (cons 8 *TV-LDT-LAYER*) (cons 10 p1) (cons 11 a) (cons 12 b) (cons 13 b))) out))) (T (setq out (cons (tv-ldt-line (polar p1 (+ ang (* pi 0.75)) s) (polar p1 (+ ang (* pi 1.75)) s)) out)) (setq out (cons (tv-ldt-line (polar p1 (+ ang (* pi 0.25)) s) (polar p1 (+ ang (* pi 1.25)) s)) out)))) out ) (defun c:LDT (/ *error* old ce orth doc p1 pl pts elev ents txt v k u2 u3 h gap rot ins al ss) (setq ce (getvar "CMDECHO") orth (getvar "ORTHOMODE") old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object))) (defun *error* (msg) (setvar "CMDECHO" ce) (setvar "ORTHOMODE" orth) (vla-EndUndoMark doc) (setq *error* old) (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg))) (princ)) (setvar "CMDECHO" 0) (vla-StartUndoMark doc) (if (setq p1 (getpoint "\n마커 위치: ")) (progn (tv-ldt-layer) (setvar "ORTHOMODE" 1) (setq pl (entlast)) (command "_.PLINE" p1 pause pause "") (setvar "ORTHOMODE" orth) (if (not (eq pl (entlast))) (progn ;; read the drawn vertices (WCS for a WCS-normal pline), then rebuild it with the marker (setq pl (entlast) elev (cond ((cdr (assoc 38 (entget pl)))) (0.0)) pts (mapcar '(lambda (x) (list (cadr x) (caddr x) elev)) (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget pl)))) (entdel pl) (if (< (length pts) 2) (setq pts (list (car pts) (car pts)))) (setq ents (tv-ldt-build pts) txt "") (while (member txt '("" "1" "2" "3")) (princ (strcat "\n글자 " (rtos (tv-ldt-h) 2 0) " / 마커 " (tv-ldt-name) " " (rtos (tv-ldt-m) 2 0))) (setq txt (getstring T "\n내용 [1 글자 크기 / 2 마커 모양 / 3 마커 크기]: ")) (cond ((= txt "") (setq txt nil)) ((= txt "1") (if (setq v (getdist (strcat "\n글자 높이 <" (rtos (tv-ldt-h) 2 0) ">: "))) (setq *TV-LDT-H* v))) ((member txt '("2" "3")) (if (= txt "2") (progn (initget "1 2 3 4") (if (setq k (getkword "\n마커 [1 점 / 2 원 / 3 화살표 / 4 X]: ")) (setq *TV-LDT-TYPE* (atoi k)))) (if (setq v (getdist (strcat "\n마커 크기 <" (rtos (tv-ldt-m) 2 0) ">: "))) (setq *TV-LDT-M* v))) (foreach e ents (entdel e)) (setq ents (tv-ldt-build pts))))) (if txt (progn ;; text beside the last point, on the side the shelf points to (UCS X) (setq u2 (trans (nth (- (length pts) 2) pts) 0 1) u3 (trans (last pts) 0 1) h (tv-ldt-h) gap (* h 0.3) rot (angle '(0 0 0) (trans '(1 0 0) 1 0 T)) al (if (>= (car u3) (car u2)) 0 2) ins (trans (list (if (= al 0) (+ (car u3) gap) (- (car u3) gap)) (+ (cadr u3) (/ h 10.0)) (caddr u3)) 1 0)) (setq ents (cons (entmakex (list '(0 . "TEXT") (cons 8 *TV-LDT-LAYER*) (cons 7 (getvar "TEXTSTYLE")) (cons 10 ins) (cons 11 ins) (cons 40 h) (cons 1 txt) (cons 50 rot) (cons 72 al) '(73 . 2))) ents)))) (setq ss (ssadd)) (foreach e ents (if e (ssadd e ss))) (command "_.-GROUP" "_C" "*" "" ss "") (princ (strcat "\nLeader drawn (layer " *TV-LDT-LAYER* ")")))))) (setvar "CMDECHO" ce) (setvar "ORTHOMODE" orth) (vla-EndUndoMark doc) (setq *error* old) (princ) ) (princ "\nTORVA Leader Text: LDT | 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 ----