;;; TORVA LISP - Beam Draw (torva.kr/lisp.html)
;;; BMD : click a centre line (LINE or XLINE) -> closed rectangle of the beam width, half each side of the line
;;; Each end stops at the nearest column or wall face on that side of the pick point. Repeats until Enter
;;; Options at the prompt:
;;; W width of the current kind (default 400, kept until the drawing closes)
;;; G girder -> layer BEAM (color 3, Continuous)
;;; B sub beam -> layer BEAM-SUB (color 4, HIDDEN). Sub beams also stop at girders (layer BEAM)
;;; C column layers: pick columns and walls once, their layers become the stops.
;;; Asked on the first run, kept for later sessions (setenv TV-BMD-STOP). The picked line's own layer never stops
;;; Layers are created if missing. U undoes one whole BMD run. Works in any UCS
(vl-load-com)
(if (null *TV-BMD-KIND*) (setq *TV-BMD-KIND* "G"))
(if (null *TV-BMD-WG*) (setq *TV-BMD-WG* 400.0))
(if (null *TV-BMD-WB*) (setq *TV-BMD-WB* 400.0))
;; kind -> (layer color linetype label)
(defun tv-bmd-kind ()
(if (= *TV-BMD-KIND* "B")
'("BEAM-SUB" 4 "HIDDEN" "Sub beam")
'("BEAM" 3 "Continuous" "Girder")))
(defun tv-bmd-width () (if (= *TV-BMD-KIND* "B") *TV-BMD-WB* *TV-BMD-WG*))
(defun tv-bmd-label () (if (= *TV-BMD-KIND* "B") "작은보" "큰보"))
;; escape wcmatch wildcards so a layer name matches only itself
(defun tv-bmd-esc (s / out)
(setq out "")
(foreach c (vl-string->list s)
(if (member c '(35 64 46 42 63 126 91 93 45 44 96)) (setq out (strcat out "`")))
(setq out (strcat out (chr c))))
out)
;; "A;B" -> ("A" "B")
(defun tv-bmd-split (s / i out)
(while (setq i (vl-string-search ";" s))
(if (> i 0) (setq out (cons (substr s 1 i) out)))
(setq s (substr s (+ i 2))))
(if (/= s "") (setq out (cons s out)))
(reverse out))
;; stop layers: this session, else the saved list
(defun tv-bmd-stops (/ v)
(cond (*TV-BMD-STOP*)
((and (setq v (vl-catch-all-apply 'getenv '("TV-BMD-STOP")))
(= (type v) 'STR) (/= v ""))
(setq *TV-BMD-STOP* (tv-bmd-split v)))))
;; pick columns/walls -> their layers become the stops (our own beam layers excluded)
(defun tv-bmd-pick-stops (/ ss i lay out)
(princ "\n기둥·벽체 선택 (엔터 = 없음): ")
(if (setq ss (ssget '((0 . "LWPOLYLINE,POLYLINE,CIRCLE,ARC,ELLIPSE,LINE,SPLINE,INSERT,REGION"))))
(progn
(setq i 0)
(repeat (sslength ss)
(setq lay (cdr (assoc 8 (entget (ssname ss i)))) i (1+ i))
(if (not (or (member lay out) (member (strcase lay) '("BEAM" "BEAM-SUB"))))
(setq out (cons lay out))))
(setq *TV-BMD-STOP* (reverse out))
(vl-catch-all-apply 'setenv
(list "TV-BMD-STOP" (apply 'strcat (mapcar '(lambda (x) (strcat x ";")) *TV-BMD-STOP*)))))
(progn (setq *TV-BMD-STOP* nil) (vl-catch-all-apply 'setenv '("TV-BMD-STOP" ""))))
(setq *TV-BMD-ASKED* T)
(princ (if *TV-BMD-STOP*
(strcat "\nStop layers: " (apply 'strcat (cdr (apply 'append (mapcar '(lambda (x) (list "," x)) *TV-BMD-STOP*)))))
"\nNo stop layers - beams run the full line length"))
(princ))
;; T if the layer exists and is locked
(defun tv-bmd-locked (lay / d)
(setq d (tblsearch "LAYER" lay))
(and d (= 4 (logand 4 (cdr (assoc 70 d))))))
;; create the layer if missing; linetype from acad(iso).lin, Continuous if it will not load
(defun tv-bmd-layer (doc spec / name lt)
(setq name (car spec) lt (caddr spec))
(if (null (tblsearch "LAYER" name))
(progn
(if (and (/= (strcase lt) "CONTINUOUS") (null (tblsearch "LTYPE" lt)))
(vl-catch-all-apply 'vla-Load
(list (vla-get-Linetypes doc) lt (if (= 1 (getvar "MEASUREMENT")) "acadiso.lin" "acad.lin"))))
(if (null (tblsearch "LTYPE" lt)) (setq lt "Continuous"))
(entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
(cons 2 name) '(70 . 0) (cons 62 (cadr spec)) (cons 6 lt))))))
;; temporary edge lines, removed again on exit or error
(defun tv-bmd-clean ()
(foreach e *TV-BMD-TMP* (if (entget e) (entdel e)))
(setq *TV-BMD-TMP* nil))
(defun tv-bmd-dot (a b) (+ (* (car a) (car b)) (* (cadr a) (cadr b))))
;; edge from a to b (WCS 2D); returns (start end) cut back to the nearest stop on each side of station tc
;; (start/end stay nil when that side has no stop)
(defun tv-bmd-cut (a b ss tc lay / e u q st lo hi plo phi i r)
(setq e (entmakex (list '(0 . "LINE") (cons 8 lay) (cons 10 a) (cons 11 b)))
*TV-BMD-TMP* (cons e *TV-BMD-TMP*)
u (list (cos (angle a b)) (sin (angle a b))) lo -1e300 hi 1e300 i 0)
(if ss
(repeat (sslength ss)
(setq r (vl-catch-all-apply 'vlax-invoke
(list (vlax-ename->vla-object e) 'IntersectWith (vlax-ename->vla-object (ssname ss i)) acExtendNone))
i (1+ i))
(if (not (vl-catch-all-error-p r))
(while r
(setq q (list (car r) (cadr r)) r (cdddr r)
st (tv-bmd-dot (mapcar '- q a) u))
(cond ((and (< st tc) (> st lo)) (setq lo st plo q))
((and (> st tc) (< st hi)) (setq hi st phi q)))))))
(entdel e)
(setq *TV-BMD-TMP* (vl-remove e *TV-BMD-TMP*))
(list plo phi))
;; one beam from the centre line ent picked at UCS point pick; returns a result message
(defun tv-bmd-make (ent pick / ed typ spec lay hw cp p1 p2 dir ang n stops flt ss tc c1 c2 a1 b1 a2 b2)
(setq ed (entget ent) typ (cdr (assoc 0 ed)) spec (tv-bmd-kind) lay (car spec) hw (/ (tv-bmd-width) 2.0))
(cond
((not (member typ '("LINE" "XLINE"))) "\nPick a LINE or XLINE")
((tv-bmd-locked lay) (strcat "\nLayer " lay " is locked, skipped"))
(T
;; all geometry in WCS 2D; the pick comes in the current UCS
(setq cp (vlax-curve-getClosestPointTo ent (trans pick 1 0)) cp (list (car cp) (cadr cp)))
(if (= typ "LINE")
(setq p1 (cdr (assoc 10 ed)) p2 (cdr (assoc 11 ed)))
(setq dir (cdr (assoc 11 ed))
p1 (mapcar '(lambda (c d) (- c (* 1e7 d))) cp dir)
p2 (mapcar '(lambda (c d) (+ c (* 1e7 d))) cp dir)))
(setq p1 (list (car p1) (cadr p1)) p2 (list (car p2) (cadr p2))
ang (angle p1 p2) n (/ pi 2.0)
tc (tv-bmd-dot (mapcar '- cp p1) (list (cos ang) (sin ang))))
;; stops: picked column layers (+ girders for sub beams), never the centre line's own layer
(setq stops (append (tv-bmd-stops) (if (= *TV-BMD-KIND* "B") '("BEAM")))
stops (vl-remove-if '(lambda (x) (= (strcase x) (strcase (cdr (assoc 8 ed))))) stops))
(if stops
(setq flt (apply 'strcat (cdr (apply 'append (mapcar '(lambda (x) (list "," (tv-bmd-esc x))) stops))))
ss (ssget "_X" (list (cons 8 flt) (cons 410 (if (= 1 (getvar "CVPORT")) (getvar "CTAB") "Model"))))))
(tv-bmd-layer (vla-get-ActiveDocument (vlax-get-acad-object)) spec)
(setq c1 (tv-bmd-cut (polar p1 (+ ang n) hw) (polar p2 (+ ang n) hw) ss tc lay)
c2 (tv-bmd-cut (polar p1 (- ang n) hw) (polar p2 (- ang n) hw) ss tc lay))
(if (and (= typ "XLINE") (not (and (car c1) (cadr c1) (car c2) (cadr c2))))
"\nNo column on one side of the XLINE, skipped"
(progn
(setq a1 (cond ((car c1)) ((polar p1 (+ ang n) hw))) b1 (cond ((cadr c1)) ((polar p2 (+ ang n) hw)))
a2 (cond ((car c2)) ((polar p1 (- ang n) hw))) b2 (cond ((cadr c2)) ((polar p2 (- ang n) hw))))
(entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 8 lay)
'(100 . "AcDbPolyline") '(90 . 4) '(70 . 1)
(cons 10 a1) (cons 10 b1) (cons 10 b2) (cons 10 a2)))
(setq *TV-BMD-N* (1+ *TV-BMD-N*))
(strcat "\n" (cadddr spec) " " (rtos (tv-bmd-width) 2 0) " drawn"))))))
(defun c:BMD (/ *error* old doc pk v loop)
(setq old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object)) *TV-BMD-N* 0)
(defun *error* (msg)
(tv-bmd-clean) (vla-EndUndoMark doc) (setq *error* old)
(if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
(princ))
(vla-StartUndoMark doc)
(if (and (null (tv-bmd-stops)) (null *TV-BMD-ASKED*)) (tv-bmd-pick-stops))
(setq loop T)
(while loop
(setvar "ERRNO" 0)
(initget "W G B C")
(setq pk (entsel (strcat "\n중심선 클릭 [폭(W)/큰보(G)/작은보(B)/기둥 레이어(C)] <"
(tv-bmd-label) " " (rtos (tv-bmd-width) 2 0) ">: ")))
(cond
((= pk "W")
(if (and (setq v (getdist (strcat (if (= *TV-BMD-KIND* "B") "\n작은보 폭 <" "\n큰보 폭 <")(rtos (tv-bmd-width) 2 0) ">: "))) (> v 0))
(if (= *TV-BMD-KIND* "B") (setq *TV-BMD-WB* v) (setq *TV-BMD-WG* v))))
((member pk '("G" "B")) (setq *TV-BMD-KIND* pk))
((= pk "C") (tv-bmd-pick-stops))
((listp pk)
(if pk
(princ (tv-bmd-make (car pk) (cadr pk)))
(if (= 7 (getvar "ERRNO")) (princ "\nNothing picked") (setq loop nil))))))
(princ (strcat "\nDone: " (itoa *TV-BMD-N*) " beams"))
(vla-EndUndoMark doc) (setq *error* old)
(princ))
(princ "\nTORVA Beam Draw: BMD | 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 ----