You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
560 lines
22 KiB
560 lines
22 KiB
(set-file-docstring "Fab drawing utility functions")
|
|
|
|
(psc-include
|
|
'(
|
|
"dialog/dialog.lsp"
|
|
"fab/handrail-return.lsp"
|
|
"fab/stair.lsp"
|
|
"fab/stair-rail.lsp"
|
|
"fab/laser-stringer.lsp"
|
|
"fab/closure-plate.lsp"
|
|
"fab/land-ship-loose.lsp"
|
|
"fab/land.lsp"
|
|
"fab/wall-rail.lsp"
|
|
))
|
|
|
|
(defun-q fab-get-types (/ defaults-file popup-keys dist-keys int-keys toggle-keys
|
|
plain-string-keys default-actions dialog-ties sub-dialogs extra-keys
|
|
tile-actions types)
|
|
"Gets a list of fab drawing types via dialog"
|
|
(setq toggle-keys '("stairs"
|
|
"lands"
|
|
"stair_rails"
|
|
"handrail_returns"
|
|
"wall_rails"
|
|
"laser_stringers"
|
|
"land_sl"
|
|
"close_pl")
|
|
types (dialog-init "fab/fab-types.dcl"
|
|
"fab_types"
|
|
'(("stairs" "0")
|
|
("lands" "0")
|
|
("stair_rails" "0")
|
|
("handrail_returns" "0")
|
|
("wall_rails" "0")
|
|
("laser_stringers" "0")
|
|
("land_sl" "0")
|
|
("close_pl" "0"))))
|
|
(mapcar 'car (remove types '(= (cadr x) "0"))))
|
|
(defun-r 'fab-get-types)
|
|
|
|
(defun-q make-fab-dwgs (types enames
|
|
/ stairno stairs-p lands-p stair-rails-p handrail-returns-p
|
|
wall-rails-p laser-stringers-p land-sl-p close-pl-p stairs
|
|
lands stair-rails stair-rail-dloops stair-datas wall-rails
|
|
laser-stringers data errors)
|
|
"Makes all the TYPES of fab drawings using data from ENAMES"
|
|
(setq job-info (get-job-info)
|
|
jobno (xd-value "number" job-info)
|
|
stairs-p (member "stairs" types)
|
|
lands-p (member "lands" types)
|
|
stair-rails-p (member "stair_rails" types)
|
|
handrail-returns-p (member "handrail_returns" types)
|
|
wall-rails-p (member "wall_rails" types)
|
|
laser-stringers-p (member "laser_stringers" types)
|
|
land-sl-p (member "land_sl" types)
|
|
close-pl-p (member "close_pl" types))
|
|
|
|
(foreach ename enames
|
|
(cond ((and (or stairs-p
|
|
stair-rails-p
|
|
wall-rails-p
|
|
handrail-returns-p
|
|
laser-stringers-p
|
|
close-pl-p)
|
|
(setq data (draw-xdata-migrate 'ename "Stair")))
|
|
(setq stairno (xd-value "number" data))
|
|
(add-to-list 'stairs
|
|
(cons (list "insx" (cadr (assoc 10 (entget ename))))
|
|
data)))
|
|
((and (or lands-p
|
|
land-sl-p)
|
|
(setq data (draw-xdata-migrate 'ename "Land")))
|
|
(setq stairno (xd-value "number" data))
|
|
(add-to-list 'lands data))))
|
|
|
|
(if stairs-p
|
|
(progn
|
|
(make-stair-fabs stairs)))
|
|
(if handrail-returns-p
|
|
(progn
|
|
(make-handrail-return-fabs stairs)))
|
|
(if stair-rails-p
|
|
(progn
|
|
(make-stair-rail-dloop-fabs stairs)
|
|
(make-stair-rail-fabs stairs)
|
|
;; TODO: (make-chopped-stair-rail-fabs stairs)
|
|
))
|
|
(if wall-rails-p
|
|
(progn
|
|
(make-wall-rail-fabs stairs)
|
|
;; TODO: (make-wall-rail-dloop-fabs wall-rail-dloops)
|
|
))
|
|
(if laser-stringers-p
|
|
(progn
|
|
(make-laser-stringer-files stairs)))
|
|
(if close-pl-p
|
|
(progn
|
|
(make-closure-plate-fabs stairs)))
|
|
(if land-sl-p
|
|
(progn
|
|
(make-land-sl-fabs lands)))
|
|
(if lands-p
|
|
(progn
|
|
(make-land-fabs lands)))
|
|
|
|
(if errors (alert (strcat "The following parts had errors:\n"
|
|
(strjoin errors "\n")))))
|
|
(defun-r 'make-fab-dwgs)
|
|
|
|
(defun-q make-generic-fab (data ent-type / path filename acadDoc oldAcadDoc modelSpace
|
|
dwgno template piece-mark obj assemblies clayer dwg-width
|
|
dwg-height mat-table hdw-table ass-table row galv-p
|
|
std-hole-dia part-details tmp notes notes-loc notes-width
|
|
dimspace error-p fab-p style sigil )
|
|
"Creates a generic fab drawing in the current folder
|
|
|
|
DATA is the data list of properties and ENT-TYPE is either 'stair or 'land."
|
|
(declare (vars (data list)
|
|
(ent-type sym (member ent-type '(stair land)))))
|
|
;; inhibit legacy allload.lsp
|
|
(vl-bb-set 'RUN_ALL_LOAD 0)
|
|
(setq
|
|
;; keep active doc as acadDoc until we are ready to create the fab dwg
|
|
acadDoc (vla-get-ActiveDocument acadObj)
|
|
oldAcadDoc acadDoc
|
|
path (vla-get-Path acadDoc)
|
|
assemblies (car data)
|
|
data (cdr data)
|
|
galv-p (= (xd-value "finish" data) "Galvanized")
|
|
std-hole-dia (if (= ent-type 'stair)
|
|
((lambda(/ ret)
|
|
(setq ret (apply 'min
|
|
(mapcar 'x2x-hole-dia
|
|
(strip-nil
|
|
(list (xd-value "top_hdw" data)
|
|
(xd-value "bot_hdw" data))))))
|
|
(if (= ret 0) 0.6875 ret)))
|
|
(if galv-p 0.75 0.6875))
|
|
notes (strcat "{\\LSHOP NOTES}:\n"
|
|
"1. ALL MATERIAL TO BE ASTM-A36\n"
|
|
"2. GRIND BURRS & ROUGH EDGES SMOOTH\n"
|
|
((lambda(/ hole-str)
|
|
(setq hole-str (strcat "3. ALL OPEN HOLES TO BE "
|
|
(frac std-hole-dia)
|
|
"\"%%c U.N.O.\n"))
|
|
(if galv-p
|
|
(strcat hole-str "4. HOT DIP GALVANIZE AFTER FAB")
|
|
(strcat hole-str
|
|
(if (begins-with (xd-value "finish" data) "Bare")
|
|
""
|
|
"4. SHOP PRIME PAINT AFTER FAB"))))))
|
|
fab-p T)
|
|
|
|
(cond ((= ent-type 'stair)
|
|
(setq template "fab/fab36.dwt"
|
|
piece-mark "S"
|
|
sigil "S"
|
|
dwg-width 603
|
|
dwg-height 387
|
|
notes-loc (list 360 36)
|
|
notes-width 90
|
|
style "STAIRS"))
|
|
((= ent-type 'land)
|
|
(setq template "fab/fab21.dwt"
|
|
piece-mark "P"
|
|
sigil "L"
|
|
dwg-width 348
|
|
dwg-height 222
|
|
notes-width 52
|
|
notes-loc (list 210 21)
|
|
style "LANDINGS")))
|
|
(setq dwgno (calc-dwg-no jobno stairno sigil))
|
|
|
|
;; switch acadDoc and modelSpace to fab dwg
|
|
(setq acadDoc (vla-Add (vla-get-Documents acadObj)
|
|
(strcat psc-src-dir template))
|
|
modelSpace (vla-get-ModelSpace acadDoc)
|
|
dimspace (* (vla-getvar 'dimdli) (vla-getvar 'dimscale))
|
|
mat-table (get-table-by-title "Material")
|
|
hdw-table (get-table-by-title "Hardware")
|
|
ass-table (get-table-by-title "Assembly*")
|
|
fin-table (get-table-by-title "Finish")
|
|
filename (strcat path "/" dwgno ".dwg"))
|
|
(vla-SaveAs acadDoc filename)
|
|
(setup-env nil)
|
|
;; update title block
|
|
(write-title-block job-info stairno (getvar 'loginname) style)
|
|
|
|
;; insert sheet notes
|
|
(vla-AddMText modelSpace (3dpt notes-loc) notes-width notes)
|
|
(if (/= std-hole-dia 0.6875)
|
|
((lambda(/ textsize)
|
|
(setq textsize (vla-getvar 'textsize))
|
|
(insert-lib-block modelSpace
|
|
(displace-pt notes-loc (list (- dimspace) (- (* 5.5 textsize))))
|
|
"lookright"
|
|
(* 2 textsize)))))
|
|
|
|
;; set up assembly table rows
|
|
(table-insert-rows ass-table
|
|
(length assemblies)
|
|
(vla-get-Rows ass-table))
|
|
|
|
(setq row 2)
|
|
(foreach assembly assemblies
|
|
(vla-SetText ass-table row 0 piece-mark)
|
|
(vla-SetText ass-table row 1 (car assembly))
|
|
(vla-SetText ass-table row 2 (cadr assembly))
|
|
(vla-SetText ass-table row 3 (caddr assembly))
|
|
(inc! 'row))
|
|
|
|
;; update finish table
|
|
(vla-SetText fin-table 1 0 (xd-value "finish" data))
|
|
|
|
;; call type-specific function
|
|
(setq piece-mark (next-mark-prefix)
|
|
material-list (read-csv "fab/material.csv"))
|
|
(with-data data
|
|
;; don't catch errors in dev mode
|
|
'((if *dev-mode*
|
|
(apply (read (strcat "make-" (to-string ent-type) "-fab")) nil)
|
|
(progn
|
|
(setq attempt (vl-catch-all-apply
|
|
(read (strcat "make-" (to-string ent-type) "-fab")) nil))
|
|
(if (vl-catch-all-error-p attempt)
|
|
(progn
|
|
(setq error-p T
|
|
assembly (car assemblies))
|
|
(debug-print '("caught error: " #(catch-all-error attempt)))
|
|
(add-to-list 'errors (strcat "S"
|
|
(car assembly)
|
|
"-"
|
|
(cadr assembly)
|
|
(caddr assembly)
|
|
": "
|
|
(catch-all-error attempt)))))))))
|
|
|
|
;; multiply quantities
|
|
(table-multiply-qty mat-table 1 (length assemblies))
|
|
(table-multiply-qty hdw-table 0 (length assemblies))
|
|
|
|
;; insert comment
|
|
;; include comments for custom connections
|
|
((lambda(/ comment custom-conn custom-conns)
|
|
(defun custom-conn (key location)
|
|
(if (wcmatch (xd-value key data) "*Custom*") (strcat "Custom " location " conection\n")))
|
|
(setq custom-conns (if (= ent-type 'stair)
|
|
(map-apply 'custom-conn
|
|
'(("top_conn" "top")
|
|
("bot_conn" "bottom")))
|
|
(map-apply 'custom-conn
|
|
'(("fl_chan" "front-left")
|
|
("fr_chan" "front-right")
|
|
("bl_chan" "back-left")
|
|
("br_chan" "back-right"))))
|
|
comment (apply 'strcat (mapcar '?s (rcons custom-conns (xd-value "comment" data)))))
|
|
(if (/= comment "")
|
|
(progn
|
|
(setq comment (add-mtext modelSpace '(10 10) comment (/ dwg-width 4.0) 'bottomleft))
|
|
(vla-put-Layer comment "TEXT")
|
|
(vla-put-Color comment acCyan)
|
|
(vla-put-Height comment (* 2 (vla-getvar 'textsize)))
|
|
(Vla-put-BackgroundFill comment :vlax-true)))))
|
|
|
|
(vla-Save acadDoc)
|
|
(if error-p (setq path (vla-get-fullname acaddoc)))
|
|
(vla-Close acadDoc)
|
|
(if *dev-mode*
|
|
(vla-Open (vla-get-Documents acadObj) filename))
|
|
(setq acadDoc oldAcadDoc
|
|
modelSpace (vla-get-Modelspace acadDoc)))
|
|
(defun-r 'make-generic-fab)
|
|
|
|
(defun-q write-title-block (job-info stairno login style / title-data)
|
|
"Rewrites special text objects in a fab drawing title block"
|
|
(setq title-data
|
|
(with-data job-info
|
|
'((list (list "$DWGNO" dwgno)
|
|
(list "$NAME" name)
|
|
(list "$LOCATION" location)
|
|
(list "$DATE" (curdate))
|
|
(list "$CUSTOMER" customer)
|
|
(list "$DRAWN" (if (= login "Dennis Dreischmeyer")
|
|
"DD"
|
|
(uppercase (substr login 1 2))))
|
|
(list "$DESCRIPTION" (strcat "STAIR " stairno " - " style))))))
|
|
(foreach obj (select-all "TEXT")
|
|
((lambda(/ textstr)
|
|
(setq textstr (vla-get-TextString obj))
|
|
(if (begins-with textstr "$")
|
|
(progn
|
|
(vla-put-TextString obj (xd-value textstr title-data))
|
|
(vla-Update obj)))))))
|
|
(defun-r 'write-title-block)
|
|
|
|
(defun-q calc-dwg-no (jobno stairno sigil / files-with-matching-sigil sorted-files tmp num)
|
|
"Returns the next available fab drawing number with this SIGIL"
|
|
(declare (vars (jobno str)
|
|
(stairno str)
|
|
(sigil str)))
|
|
(setq files-with-matching-sigil (vl-remove-if-not
|
|
'(lambda (x)
|
|
(and (wcmatch x "*#.dwg")
|
|
(wcmatch x (strcat jobno
|
|
"-"
|
|
sigil
|
|
stairno
|
|
"`.*`.dwg"))))
|
|
(vl-directory-files (vla-get-path acadDoc)))
|
|
sort-func '(lambda (a b / al bl)
|
|
(setq al (strlen a)
|
|
bl (strlen b))
|
|
(if (= al bl)
|
|
(> a b)
|
|
(> al bl)))
|
|
sorted-files (vl-sort files-with-matching-sigil sort-func))
|
|
(strcat jobno
|
|
"-"
|
|
sigil
|
|
stairno
|
|
"."
|
|
(if sorted-files
|
|
(itoa (1+ (atoi (substr (car sorted-files) (+ 7 (strlen stairno) (strlen sigil))))))
|
|
(if (= sigil "L") "1" "0"))))
|
|
(defun-r 'calc-dwg-no)
|
|
|
|
(defun-q fab-combine-like-data (data-lists keys)
|
|
"Returns groups of similar datalists for fab drawing consolidation
|
|
|
|
Similarity is based on equivalence of the values of all keys in KEYS."
|
|
(setq data-lists (mapcar '(lambda(x) (subst-key "assembly"
|
|
(list (xd-value "number" x)
|
|
(xd-value "level" x)
|
|
(?s (xd-value "sequence" x)))
|
|
x))
|
|
data-lists)
|
|
data-lists (combine-like-data data-lists keys "assembly"))
|
|
(mapcar '(lambda(x)
|
|
(cons (xd-value "assembly" x)
|
|
(remove x '(= (car x) "assembly"))))
|
|
data-lists))
|
|
(defun-r 'fab-combine-like-data)
|
|
|
|
(defun-q calc-weight-formula (table row / desc line wt wt-type col-names letters col)
|
|
"Returns the weight formula for a material description"
|
|
(declare (vars (table vla-object (table-p table))
|
|
(row int)))
|
|
(setq col-names (get-table-column-names table)
|
|
description (vla-GetText table row (vl-position "description" col-names)))
|
|
(setq line (assoc description (read-csv "fab/material.csv")))
|
|
(if (not line) (error (strcat "Weight formula not found: " description)))
|
|
(defun col (name)
|
|
(strcat (chr (vl-string-elt letters (vl-position name col-names))) (to-string (1+ row))))
|
|
(setq letters "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
|
wt (nth 1 line)
|
|
wt-type (nth 2 line))
|
|
(cond ((= wt-type "sqft")
|
|
(strcat "=(" (col "qty") "*" (col "length") "*" (col "width") "/144)*" wt))
|
|
((= wt-type "foot")
|
|
(strcat "=(" (col "qty") "*" (col "length") "/12)*" wt))
|
|
((= wt-type "each")
|
|
(strcat "=" (col "qty") "*" wt))))
|
|
(defun-r 'calc-weight-formula)
|
|
|
|
(defun-q next-mark-prefix (/ job-dir filename file mark ret increment-mark )
|
|
"Returns the next available mark prefix and increments it"
|
|
|
|
(if (not (setq job-dir (find-job-dir)))
|
|
(error "Attempted to get next mark prefix while not in a job folder"))
|
|
|
|
;; internal function to actually calc next mark prefix
|
|
(defun increment-mark (mark /
|
|
glyphs
|
|
i
|
|
carry
|
|
ret
|
|
)
|
|
|
|
(setq glyphs (vl-string->list "ABCDEFGHJKLMNQRSTWXYZ")
|
|
mark (reverse (vl-string->list mark))
|
|
carry T)
|
|
(while (and carry mark)
|
|
(setq i (vl-position (car mark) glyphs))
|
|
(add-to-list 'ret
|
|
(if (= i (1- (length glyphs)))
|
|
(progn
|
|
(setq carry T)
|
|
(car glyphs))
|
|
(progn
|
|
(setq carry nil)
|
|
(nth (1+ i) glyphs))))
|
|
(setq mark (cdr mark)))
|
|
(cond (mark
|
|
(setq ret (append ret mark)))
|
|
(carry
|
|
(setq ret (cons (ascii "A") ret))))
|
|
(vl-list->string (reverse ret)))
|
|
|
|
(setq filename (strcat job-dir "/markprefix.txt"))
|
|
|
|
;; create file if not present
|
|
(if (not (member "markprefix.txt" (vl-directory-files job-dir)))
|
|
(progn
|
|
(setq file (open filename "w"))
|
|
(write-line "A" file)
|
|
(close file)))
|
|
|
|
;; read file to get current mark
|
|
(setq file (open filename "r"))
|
|
(setq mark (read-line file))
|
|
(close file)
|
|
|
|
;; write next mark to file
|
|
(setq file (open filename "w"))
|
|
(write-line (increment-mark mark) file)
|
|
(close file)
|
|
|
|
mark)
|
|
(defun-r 'next-mark-prefix)
|
|
|
|
(defun-q make-rail-fab-common (template eval-form / oldacaddoc path dwgno login prefix style)
|
|
"Common function to make rail fab drawings
|
|
|
|
Opens TEMPLATE, sets up title block and variables, and evals EVAL-FORM. Then it saves and
|
|
closes the drawing."
|
|
(cond ((begins-with template "stair-rail")
|
|
(setq prefix "SR"
|
|
style "STAIR RAILS"))
|
|
((begins-with template "wall-rail")
|
|
(setq prefix "WR"
|
|
style "WALL RAILS"))
|
|
((begins-with template "guard-rail")
|
|
(setq prefix "GR"
|
|
style "GUARD RAILS"))
|
|
((begins-with template "handrail-return")
|
|
(setq prefix "HR"
|
|
style "HANDRAIL RETURNS")))
|
|
|
|
(setq oldAcadDoc acadDoc
|
|
path (vla-get-Path acadDoc)
|
|
dwgno (calc-dwg-no jobno stairno prefix)
|
|
login (getvar 'loginname)
|
|
acadDoc (vla-Add (vla-get-Documents acadObj)
|
|
(strcat psc-src-dir "fab/" template ".dwt"))
|
|
modelspace (vla-get-modelspace acaddoc))
|
|
|
|
(vla-SaveAs acadDoc (strcat path "/" dwgno ".dwg"))
|
|
|
|
(write-title-block job-info stairno login style)
|
|
(eval eval-form)
|
|
|
|
(vla-Regen acadDoc acAllViewports)
|
|
(vla-Save acadDoc)
|
|
(if (not *dev-mode*) (vla-Close acadDoc))
|
|
(reset-doc))
|
|
(defun-r 'make-rail-fab-common)
|
|
|
|
(defun-q set-finish (value / table)
|
|
"Sets the finish in the finish table to VALUE
|
|
|
|
Returns VALUE if successful or nil if no finish table found"
|
|
(declare (vars (value str)))
|
|
(setq table (get-table-by-title "Finish"))
|
|
(if table (vla-SetText table 1 0 value)))
|
|
(defun-r 'set-finish)
|
|
|
|
(defun-q get-finish ()
|
|
"Returns the finish from the finish table or nil if no finish table found"
|
|
(setq table (get-table-by-title "Finish"))
|
|
(if table (vla-GetText table 1 0)))
|
|
(defun-r 'get-finish)
|
|
|
|
(defun-q get-material (/
|
|
matlst
|
|
;; variables defined here for dialog-init
|
|
defaults-file
|
|
popup-keys
|
|
dist-keys
|
|
int-keys
|
|
toggle-keys
|
|
plain-string-keys
|
|
default-actions
|
|
dialog-ties
|
|
sub-dialogs
|
|
;; variables included here for scope,
|
|
;; but not defined here directly
|
|
extra-keys
|
|
tile-actions
|
|
)
|
|
"Prompts the user to choose a material description via dialog and returns it"
|
|
(setq matlst (read-csv "fab/material.csv")
|
|
toggle-keys '("show_all")
|
|
default-actions '(("category" . update-material)
|
|
("show_all" . update-material))
|
|
popup-keys (list (append '("category"
|
|
"All")
|
|
(uniquify (mapcar '(lambda(x) (nth 4 x)) matlst)))
|
|
'("material" . current-material)))
|
|
|
|
;; calculate value of material box
|
|
(defun current-material ( / cat mlst)
|
|
(setq cat (dialog-popup-val "category")
|
|
mlst matlst)
|
|
(if (= (get_tile "show_all") "0")
|
|
(remove! 'mlst '(= (nth 3 x) "xtra")))
|
|
(if (not (= cat "All"))
|
|
(remove! 'mlst '(not (= (nth 4 x) cat))))
|
|
(mapcar 'car mlst))
|
|
|
|
(xd-value "material" (dialog-init "fab/material.dcl" "material" nil)))
|
|
(defun-r 'get-material)
|
|
|
|
(defun-q get-hardware (/
|
|
;; variables defined here for dialog-init
|
|
defaults-file
|
|
popup-keys
|
|
dist-keys
|
|
int-keys
|
|
toggle-keys
|
|
plain-string-keys
|
|
default-actions
|
|
dialog-ties
|
|
sub-dialogs
|
|
;; variables included here for scope,
|
|
;; but not defined here directly
|
|
extra-keys
|
|
tile-actions
|
|
)
|
|
"Prompts the user to choose a hardware description via dialog and returns it"
|
|
(setq hdwlst (read-csv "fab/hardware.csv")
|
|
toggle-keys '("show_all")
|
|
default-actions '(("category" . update-hardware)
|
|
("show_all" . update-hardware))
|
|
popup-keys (list (append '("category"
|
|
"All")
|
|
(uniquify (mapcar 'cadddr hdwlst)))
|
|
'("hardware" . current-hardware)))
|
|
|
|
;; calculate value of hardware box
|
|
(defun current-hardware ( / cat hlst)
|
|
(setq cat (dialog-popup-val "category")
|
|
hlst hdwlst)
|
|
(if (= (get_tile "show_all") "0")
|
|
(remove! 'hlst '(= (nth 2 x) "xtra")))
|
|
(if (not (= cat "All"))
|
|
(remove! 'hlst '(not (= (nth 3 x) cat))))
|
|
(mapcar 'car hlst))
|
|
|
|
;; update hardware list box
|
|
(defun update-hardware (k v / )
|
|
(dialog-popup-list-update "hardware"))
|
|
|
|
(xd-value "hardware" (dialog-init "fab/hardware.dcl" "hardware" nil)))
|
|
(defun-r 'get-hardware)
|
|
|
|
(defun-q get-finish ()
|
|
"Prompts the user to choose a finish description via dialog and returns it"
|
|
nil)
|
|
(defun-r 'get-finish)
|