;;; TORVA LISP - Basement Wall Mark (torva.kr/lisp.html) ;;; WLS : label -> wall face points (Enter ends) -> side to draw on ;;; -> line offset by the wall thickness, 45 deg ends back to the face, broken at the longest run for the label ;;; S at the label prompt: text height / thickness (0 = auto) / gap beside the label. Values persist until the drawing closes ;;; Text = 3.5 x DIMSCALE (350 at 1:100), gap = 1.5 x DIMSCALE. Auto thickness = 0.4 x shortest run, up to 10 x DIMSCALE ;;; Layer BASEWALL, created if missing. Text uses the current text style (vl-load-com) (if (null *TV-WLS-TXT*) (setq *TV-WLS-TXT* "BW1")) (if (null *TV-WLS-DEP*) (setq *TV-WLS-DEP* 0.0)) (setq *TV-WLS-LAYER* "BASEWALL") (defun tv-wls-ds () (if (> (getvar "DIMSCALE") 0) (getvar "DIMSCALE") 1.0)) (defun tv-wls-h () (cond (*TV-WLS-H*) ((* 3.5 (tv-wls-ds))))) (defun tv-wls-pad () (cond (*TV-WLS-PAD*) ((* 1.5 (tv-wls-ds))))) ;; text width in the current style (defun tv-wls-tw (s h / bx) (setq bx (vl-catch-all-apply 'textbox (list (list (cons 1 s) (cons 7 (getvar "TEXTSTYLE")) (cons 40 h) (cons 41 1.0))))) (if (and bx (not (vl-catch-all-error-p bx))) (- (car (cadr bx)) (car (car bx))) (* (strlen s) h 0.7))) ;; WCS points -> LWPOLYLINE on BASEWALL (defun tv-wls-pline (pts z) (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 8 *TV-WLS-LAYER*) '(100 . "AcDbPolyline") (cons 90 (length pts)) '(70 . 0) (cons 38 z)) (mapcar '(lambda (p) (list 10 (car p) (cadr p))) pts)))) (defun c:WLS (/ *error* old os ce doc input v pts pt dir z H b_pl o_pl o_pts i p1 p2 max_L max_i m_pt gap pA pB L1 L2 ua rel ang s_ang fit q1 q2) (setq os (getvar "OSMODE") ce (getvar "CMDECHO") old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object))) (defun *error* (msg) (setvar "OSMODE" os) (setvar "CMDECHO" ce) (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 (null (tblsearch "LAYER" *TV-WLS-LAYER*)) (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (cons 2 *TV-WLS-LAYER*) '(70 . 0) '(62 . 7) '(6 . "Continuous")))) ;; label: Enter = last label, S = settings (setq input "S") (while (= (strcase input) "S") (setq input (getstring (strcat "\n표기 문자 [설정(S)] <" *TV-WLS-TXT* ", 높이 " (rtos (tv-wls-h) 2 0) ", 여백 " (rtos (tv-wls-pad) 2 0) ", " (if (> *TV-WLS-DEP* 0.0) (strcat "두께 " (rtos *TV-WLS-DEP* 2 0)) "두께 자동") ">: "))) (if (= (strcase input) "S") (progn (initget 6) (if (setq v (getdist (strcat "\n문자 높이 <" (rtos (tv-wls-h) 2 0) ">: "))) (setq *TV-WLS-H* v)) (initget 4) (if (setq v (getdist (strcat "\n벽 두께 (0 = 자동) <" (rtos *TV-WLS-DEP* 2 0) ">: "))) (setq *TV-WLS-DEP* v)) (initget 4) (if (setq v (getdist (strcat "\n문자 좌우 여백 <" (rtos (tv-wls-pad) 2 0) ">: "))) (setq *TV-WLS-PAD* v))))) (if (/= input "") (setq *TV-WLS-TXT* input)) (if (setq pt (getpoint "\n시작점: ")) (progn (setq pts (list pt)) (while (setq pt (getpoint (car pts) "\n다음 점 (엔터 = 끝): ")) (setq pts (cons pt pts))) ;; picked in UCS -> work in WCS from here (setq pts (mapcar '(lambda (p) (trans p 1 0)) (reverse pts)) z (caddr (car pts))) (if (>= (length pts) 2) (progn (setvar "OSMODE" 0) (setq dir (getpoint (trans (car pts) 0 1) "\n그릴 방향: ")) (setvar "OSMODE" os) (if dir (progn ;; thickness: user value, else 0.4 x shortest run capped at 10 x DIMSCALE (if (> *TV-WLS-DEP* 0.0) (setq H *TV-WLS-DEP*) (progn (setq H 1e99 i 0) (while (< i (1- (length pts))) (setq H (min H (distance (nth i pts) (nth (1+ i) pts))) i (1+ i))) (setq H (min (* 10.0 (tv-wls-ds)) (* 0.4 H))))) ;; temporary pline -> OFFSET toward the picked side (setq b_pl (tv-wls-pline pts z)) (setvar "OSMODE" 0) (command "_.OFFSET" "_E" "_N" "_L" "_S" H b_pl dir "") (setvar "OSMODE" os) (setq o_pl (entlast)) (if (not (equal b_pl o_pl)) (progn (setq o_pts nil) (foreach item (entget o_pl) (if (= (car item) 10) (setq o_pts (append o_pts (list (list (cadr item) (caddr item) z)))))) (entdel b_pl) (entdel o_pl) (if (> (distance (car o_pts) (car pts)) (distance (last o_pts) (car pts))) (setq o_pts (reverse o_pts))) ;; both ends pulled back along the wall by H -> 45 deg return to the face (setq p1 (polar (car o_pts) (angle (car pts) (cadr pts)) H) p2 (polar (last o_pts) (angle (last pts) (nth (- (length pts) 2) pts)) H)) (setq o_pts (cons p1 (cdr o_pts))) (setq o_pts (reverse (cons p2 (cdr (reverse o_pts))))) ;; longest run takes the label (setq max_L 0.0 max_i 0 i 0) (while (< i (1- (length o_pts))) (if (> (distance (nth i o_pts) (nth (1+ i) o_pts)) max_L) (setq max_L (distance (nth i o_pts) (nth (1+ i) o_pts)) max_i i)) (setq i (1+ i))) (setq p1 (nth max_i o_pts) p2 (nth (1+ max_i) o_pts) s_ang (angle p1 p2) m_pt (polar p1 s_ang (/ max_L 2.0)) gap (+ (/ (tv-wls-tw *TV-WLS-TXT* (tv-wls-h)) 2.0) (tv-wls-pad)) fit (< (* 2.0 gap) (* max_L 0.95)) pA (polar m_pt (angle p2 p1) gap) pB (polar m_pt s_ang gap)) ;; keep the label readable against the UCS X axis (setq ua (angle '(0 0 0) (trans '(1 0 0) 1 0 T)) rel (rem (+ (- s_ang ua) (* 4.0 pi)) (* 2.0 pi)) ang (if (and (> rel (/ pi 2.0)) (<= rel (* pi 1.5))) (- s_ang pi) s_ang)) (if fit (progn ;; line split in two around the label (setq L1 (list (car pts)) i 0) (while (<= i max_i) (setq L1 (append L1 (list (nth i o_pts))) i (1+ i))) (setq L1 (append L1 (list pA)) L2 (list pB) i (1+ max_i)) (while (< i (length o_pts)) (setq L2 (append L2 (list (nth i o_pts))) i (1+ i))) (setq L2 (append L2 (list (last pts))))) (progn ;; label wider than the run: one line, label outside the wall (setq L1 (append (list (car pts)) o_pts (list (last pts))) L2 nil) (setq q1 (polar m_pt (+ s_ang (/ pi 2.0)) (* (tv-wls-h) 0.9)) q2 (polar m_pt (- s_ang (/ pi 2.0)) (* (tv-wls-h) 0.9))) (setq m_pt (if (> (distance q1 (car pts)) (distance q2 (car pts))) q1 q2)) (princ "\nLabel wider than the run - placed outside the line"))) (tv-wls-pline L1 z) (if L2 (tv-wls-pline L2 z)) (entmake (list '(0 . "TEXT") (cons 8 *TV-WLS-LAYER*) (cons 7 (getvar "TEXTSTYLE")) (cons 10 m_pt) (cons 11 m_pt) (cons 40 (tv-wls-h)) (cons 1 *TV-WLS-TXT*) (cons 50 ang) '(72 . 1) '(73 . 2))) (princ (strcat "\nWall mark " *TV-WLS-TXT* " drawn (thickness " (rtos H 2 0) ", layer " *TV-WLS-LAYER* ")"))) (progn (entdel b_pl) (princ "\nOffset failed - runs too short or overlapping")))))) (princ "\nTwo or more points needed")))) (setvar "OSMODE" os) (setvar "CMDECHO" ce) (vla-EndUndoMark doc) (setq *error* old) (princ) ) (princ "\nTORVA Basement Wall Mark: WLS | 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 ----