;;; TORVA LISP - Section Properties (torva.kr/lisp.html) ;;; SPR : closed shapes -> property table (A, w, centroid, Ix, Iy, Sx, Sy, rx, ry, Ip, J) ;;; Pipe / box: select outer and inner loop together, the inner loop is subtracted ;;; Options before the insert point: M material (auto / steel / RC, for unit weight only) ;;; U unit (cm / mm) A advanced (densities, text height, row gap, drawing unit) ;;; Text height 0 = auto (1/12 of the largest section). Drawing unit follows INSUNITS (mm / cm / m) ;;; Layer SECT-PROP (color 4), created if missing. Text uses the current text style ;;; Geometry only - no code checks (grade, slenderness, deflection) (vl-load-com) (defun tv-section-prop-std () (setq *TV-SECTION-PROP-MAT* "자동" ; auto / steel / RC *TV-SECTION-PROP-UNIT* "cm" *TV-SECTION-PROP-DENS* 7850.0 ; steel kg/m3 *TV-SECTION-PROP-DENC* 2400.0 ; RC kg/m3 *TV-SECTION-PROP-H* 0.0 ; text height, 0 = auto *TV-SECTION-PROP-GAP* 0.0 ; gap between tables, 0 = auto *TV-SECTION-PROP-UF* 0.0) ; 1 drawing unit = ? mm, 0 = from INSUNITS (princ)) (defun tv-section-prop-uf () (cond ((> *TV-SECTION-PROP-UF* 0.0) *TV-SECTION-PROP-UF*) ((= (getvar "INSUNITS") 5) 10.0) ((= (getvar "INSUNITS") 6) 1000.0) (1.0))) (defun tv-section-prop-adv (/ v) (setq v (getreal (strcat "\n강재 밀도 kg/m3 <" (rtos *TV-SECTION-PROP-DENS* 2 0) ">: "))) (if (and v (> v 0.0)) (setq *TV-SECTION-PROP-DENS* v)) (setq v (getreal (strcat "\nRC 밀도 kg/m3 <" (rtos *TV-SECTION-PROP-DENC* 2 0) ">: "))) (if (and v (> v 0.0)) (setq *TV-SECTION-PROP-DENC* v)) (setq v (getdist (strcat "\n글자 높이 (0 = 자동) <" (rtos *TV-SECTION-PROP-H* 2 0) ">: "))) (if v (setq *TV-SECTION-PROP-H* v)) (setq v (getdist (strcat "\n표 간격 (0 = 자동) <" (rtos *TV-SECTION-PROP-GAP* 2 0) ">: "))) (if v (setq *TV-SECTION-PROP-GAP* v)) (setq v (getreal (strcat "\n도면 1단위 = mm <" (rtos (tv-section-prop-uf) 2 2) ">: "))) (if (and v (> v 0.0)) (setq *TV-SECTION-PROP-UF* v)) (princ)) (defun tv-section-prop-fmt (v) (cond ((>= (abs v) 1000.0) (rtos v 2 0)) ((>= (abs v) 100.0) (rtos v 2 1)) (T (rtos v 2 2)))) (defun tv-section-prop-v2l (v) (if (= (type v) 'variant) (setq v (vlax-variant-value v))) (if (= (type v) 'safearray) (vlax-safearray->list v) v)) ;; layer: create, or thaw / unlock / turn on our own layer (defun tv-section-prop-layer (nm / el) (if (null (tblsearch "LAYER" nm)) (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (cons 2 nm) '(70 . 0) '(62 . 4) '(6 . "Continuous"))) (progn (setq el (entget (tblobjname "LAYER" nm))) (setq el (subst (cons 62 (abs (cdr (assoc 62 el)))) (assoc 62 el) el)) (setq el (subst (cons 70 (logand (cdr (assoc 70 el)) -6)) (assoc 70 el) el)) (entmod el))) nm) ;; (region . created-by-us) or nil (defun tv-section-prop-region (ent spc / arr res lst) (if (= "REGION" (cdr (assoc 0 (entget ent)))) (cons (vlax-ename->vla-object ent) nil) (progn (setq arr (vlax-make-safearray vlax-vbObject '(0 . 0))) (vlax-safearray-put-element arr 0 (vlax-ename->vla-object ent)) (setq res (vl-catch-all-apply 'vla-AddRegion (list spc arr))) (if (and (not (vl-catch-all-error-p res)) (setq lst (tv-section-prop-v2l res))) (cons (car lst) T))))) (defun tv-section-prop-mtext (pt hgt lay str / dxf pos) (setq dxf (list '(0 . "MTEXT") '(100 . "AcDbEntity") (cons 8 lay) '(100 . "AcDbMText") (cons 10 pt) (cons 40 hgt) '(41 . 0.0) '(71 . 1) (cons 7 (getvar "TEXTSTYLE")))) ;; long strings go in 250-char chunks (code 3), skipping a leading \P (while (setq pos (vl-string-search "\\P" str 1)) (setq dxf (append dxf (list (cons 3 (substr str 1 pos))))) (setq str (substr str (1+ pos)))) (entmake (append dxf (list (cons 1 str))))) ;; a inside b (bounding boxes) and smaller (defun tv-section-prop-in (a b) (and (> (nth 4 a) (nth 4 b)) (> (nth 5 a) (nth 5 b)) (< (nth 6 a) (nth 6 b)) (< (nth 7 a) (nth 7 b)) (< (nth 2 a) (nth 2 b)))) ;; thin-walled closed section torsion constant (Bredt) from outer / inner loop (defun tv-section-prop-bredt (po ph / ao ah a0 pm) (setq ao (nth 2 po) ah (nth 2 ph) a0 (/ (+ ao ah) 2.0) pm (/ (+ (nth 3 po) (nth 3 ph)) 2.0)) (if (or (<= pm 1e-9) (<= (- ao ah) 0.0)) 0.0 (/ (* 4.0 a0 a0 (/ (- ao ah) pm)) pm))) ;; solid rectangle torsion constant (defun tv-section-prop-jrect (aa bb / lg sh rr) (setq lg (max aa bb) sh (min aa bb)) (if (<= sh 1e-9) 0.0 (progn (setq rr (/ sh lg)) (* lg sh sh sh (- 0.333333 (* 0.21 rr (- 1.0 (/ (expt rr 4.0) 12.0)))))))) (defun c:SPR (/ *error* olderr oldos oldce oldcl doc spc ss lay loop n i obj p1 p2 mx hgt vgap pk u fa fi fs fr uf lst nn hol jl k m itm jv ent rg reg cnt fail tot cy jt x1 y1 x2 y2 ar cen moi xc yc ix iy a2 i4 j4 ct cb cx sx sy rx ry bw dd afil hasH circ rc wt ipv jstr txt) (if (null *TV-SECTION-PROP-MAT*) (tv-section-prop-std)) (setq olderr *error* oldos (getvar "OSMODE") oldce (getvar "CMDECHO") oldcl (getvar "CLAYER") doc (vla-get-ActiveDocument (vlax-get-acad-object))) (defun *error* (msg) (setvar "OSMODE" oldos) (setvar "CMDECHO" oldce) (setvar "CLAYER" oldcl) (vla-EndUndoMark doc) (setq *error* olderr) (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg))) (princ)) (setvar "CMDECHO" 0) (vla-StartUndoMark doc) (setq spc (if (= 1 (getvar "CVPORT")) (vla-get-PaperSpace doc) (vla-get-ModelSpace doc))) ;; 1. shapes: preselected, else ask (setq ss (ssget "_I" '((0 . "LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE,SPLINE,REGION")))) (if (not ss) (progn (princ "\n단면 선택 (강관은 외곽과 내곽 함께): ") (setq ss (ssget '((0 . "LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE,SPLINE,REGION")))))) (if ss (progn ;; 2. largest size -> auto text height (setq n (sslength ss) i 0 mx 0.0) (while (< i n) (vla-GetBoundingBox (vlax-ename->vla-object (ssname ss i)) 'p1 'p2) (setq p1 (tv-section-prop-v2l p1) p2 (tv-section-prop-v2l p2) mx (max mx (- (car p2) (car p1)) (- (cadr p2) (cadr p1))) i (1+ i))) (setvar "OSMODE" 0) ;; 3. insert point; keywords change settings (setq loop T) (while loop (initget "Material Unit Advanced") (setq pk (getpoint (strcat "\n표 삽입점 [재료(M)/단위(U)/상세(A)] <" *TV-SECTION-PROP-MAT* ", " *TV-SECTION-PROP-UNIT* ", " (itoa n) "개>: "))) (cond ((= pk "Material") (setq *TV-SECTION-PROP-MAT* (cond ((= *TV-SECTION-PROP-MAT* "자동") "강재") ((= *TV-SECTION-PROP-MAT* "강재") "RC") (T "자동")))) ((= pk "Unit") (setq *TV-SECTION-PROP-UNIT* (if (= *TV-SECTION-PROP-UNIT* "cm") "mm" "cm"))) ((= pk "Advanced") (tv-section-prop-adv)) (T (setq loop nil)))) (setq hgt (if (> *TV-SECTION-PROP-H* 0.0) *TV-SECTION-PROP-H* (/ mx 12.0))) (if (<= hgt 0.0) (setq hgt (* 2.5 (max 1.0 (getvar "DIMSCALE"))))) (setq vgap (if (> *TV-SECTION-PROP-GAP* 0.0) *TV-SECTION-PROP-GAP* (* hgt 1.5))) (if pk (progn (setq pk (trans pk 1 0) lay (tv-section-prop-layer "SECT-PROP")) (setvar "CLAYER" lay) (if (= *TV-SECTION-PROP-UNIT* "mm") (setq u "mm" fa 1.0 fi 1.0 fs 1.0 fr 1.0) (setq u "cm" fa 0.01 fi 0.0001 fs 0.001 fr 0.1)) (setq uf (tv-section-prop-uf)) (if (= 0 (getvar "WORLDUCS")) (princ "\nUCS is not World - check the Ix / Iy axes")) ;; 4. regions + area / perimeter / box (setq lst nil i 0 fail 0) (while (< i n) (setq ent (ssname ss i) rg (tv-section-prop-region ent spc)) (if (null rg) (setq fail (1+ fail)) (progn (setq reg (car rg)) (vla-GetBoundingBox (vlax-ename->vla-object ent) 'p1 'p2) (setq p1 (tv-section-prop-v2l p1) p2 (tv-section-prop-v2l p2)) (setq lst (cons (list reg (cdr rg) (vla-get-Area reg) (vla-get-Perimeter reg) (car p1) (cadr p1) (car p2) (cadr p2) (cdr (assoc 0 (entget ent)))) lst)))) (setq i (1+ i))) (setq lst (reverse lst) nn (length lst)) ;; 5. subtract inner loops (only when Boolean works) + closed-section J (setq hol nil jl nil k 0) (while (< k nn) (if (not (member k hol)) (progn (setq itm (nth k lst) jv 0.0 m 0) (while (< m nn) (if (and (/= m k) (not (member m hol)) (nth 1 itm) (nth 1 (nth m lst)) (tv-section-prop-in (nth m lst) itm)) (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-Boolean (list (nth 0 itm) 2 (nth 0 (nth m lst)))))) (setq jv (+ jv (tv-section-prop-bredt itm (nth m lst))) hol (cons m hol)) (princ "\nInner loop subtract failed - computed as separate shapes"))) (setq m (1+ m))) (setq jl (cons (cons k jv) jl)))) (setq k (1+ k))) (foreach m hol (vl-catch-all-apply 'vla-Delete (list (nth 0 (nth m lst))))) ;; 6. properties -> one MTEXT per section, stacked down from the insert point (setq k 0 cnt 0 tot 0.0 cy (cadr pk)) (while (< k nn) (if (not (member k hol)) (progn (setq itm (nth k lst) reg (nth 0 itm) jt (cdr (assoc k jl))) (if (null jt) (setq jt 0.0)) (setq x1 (nth 4 itm) y1 (nth 5 itm) x2 (nth 6 itm) y2 (nth 7 itm) ar (vla-get-Area reg) cen (tv-section-prop-v2l (vla-get-Centroid reg)) moi (tv-section-prop-v2l (vla-get-MomentOfInertia reg)) xc (car cen) yc (cadr cen) ix (- (car moi) (* ar yc yc)) iy (- (cadr moi) (* ar xc xc))) (if (nth 1 itm) (vl-catch-all-apply 'vla-Delete (list reg))) (if (or (<= ar 1e-9) (<= ix 1e-9) (<= iy 1e-9)) (setq fail (1+ fail)) (progn (setq a2 (* ar uf uf) i4 (* ix uf uf uf uf) j4 (* iy uf uf uf uf) ct (* (- y2 yc) uf) cb (* (- yc y1) uf) cx (max (* (- x2 xc) uf) (* (- xc x1) uf)) sx (/ i4 (max ct cb)) sy (/ j4 cx) rx (sqrt (/ i4 a2)) ry (sqrt (/ j4 a2)) bw (* (- x2 x1) uf) dd (* (- y2 y1) uf) afil (if (> (* bw dd) 1e-9) (/ a2 (* bw dd)) 0.0) hasH (> jt 1e-9) circ (or (= (nth 8 itm) "CIRCLE") (and (> afil 0.76) (< afil 0.81) (equal bw dd (* 0.02 bw))))) ;; material for unit weight: hollow -> steel, solid rectangle / circle -> RC, other -> steel (setq rc (cond ((= *TV-SECTION-PROP-MAT* "강재") nil) ((= *TV-SECTION-PROP-MAT* "RC") T) (hasH nil) ((> afil 0.95) T) (circ T) (T nil)) wt (/ (* a2 (if rc *TV-SECTION-PROP-DENC* *TV-SECTION-PROP-DENS*)) 1000000.0) tot (+ tot wt) ipv (+ i4 j4)) (setq jstr (cond (circ (strcat "J = " (tv-section-prop-fmt (* ipv fi)) " " u "4 (circle)")) (hasH (strcat "J = " (tv-section-prop-fmt (* jt uf uf uf uf fi)) " " u "4 (closed)")) ((> afil 0.99) (strcat "J = " (tv-section-prop-fmt (* (tv-section-prop-jrect bw dd) fi)) " " u "4 (solid rect)")) (T "J = - (open section)"))) (setq txt (strcat (if rc "RC B x D = " "Steel H x B = ") (if rc (strcat (rtos bw 2 1) " x " (rtos dd 2 1)) (strcat (rtos dd 2 1) " x " (rtos bw 2 1))) " mm" "\\PA = " (tv-section-prop-fmt (* a2 fa)) " " u "2 / w = " (rtos wt 2 1) " kg/m" "\\Pxc = " (tv-section-prop-fmt (* (- xc x1) uf fr)) " / yc = " (tv-section-prop-fmt (* (- yc y1) uf fr)) " " u " (from lower left)" "\\PIx = " (tv-section-prop-fmt (* i4 fi)) " " u "4 / Iy = " (tv-section-prop-fmt (* j4 fi)) " " u "4" "\\PSx = " (tv-section-prop-fmt (* sx fs)) " " u "3 / Sy = " (tv-section-prop-fmt (* sy fs)) " " u "3" "\\Prx = " (tv-section-prop-fmt (* rx fr)) " " u " / ry = " (tv-section-prop-fmt (* ry fr)) " " u "\\PIp = " (tv-section-prop-fmt (* ipv fi)) " " u "4 / " jstr)) (tv-section-prop-mtext (list (car pk) cy (caddr pk)) hgt lay txt) (setq cy (- cy (+ (* 7 hgt 1.7) vgap)) cnt (1+ cnt)))))) (setq k (1+ k))) (princ (strcat "\n" (itoa cnt) " sections, layer " lay)) (if hol (princ (strcat ", inner loops subtracted " (itoa (length hol))))) (if (> cnt 0) (princ (strcat ", total " (rtos tot 2 1) " kg/m"))) (if (> fail 0) (princ (strcat "\n" (itoa fail) " failed: not closed or self-intersecting"))))))) (setvar "OSMODE" oldos) (setvar "CMDECHO" oldce) (setvar "CLAYER" oldcl) (vla-EndUndoMark doc) (setq *error* olderr) (princ)) (princ "\nTORVA Section Properties: SPR | 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 ----