;;Program allows dialog layer selection or entsel pick, object filter, and txt (or alert box) report.
;;Txt report placed in dwgprefix folder and includes:
;;Drawing Name, Layer quantified, object filter, objects found, tot# of obj, and combined length
;;Inspection includes zoom to and out buttons, layer, type, length, center x & y.
;;Performs zoom extents to view before layer was selected when 'next' or 'previous' is selected.

(defun Makelst (key lst);;Lee Mac
(start_list key)
(mapcar 'add_list lst)
(end_list))

(defun QL_AddMeasurement (/ )
(setq len
(if (vlax-property-available-p obj 'Measurement)
(vla-get-measurement obj)
(vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)))
llen (+ llen len)
enum (1+ enum)
num (1+ num)
);setq
)
(defun VPCords (/ );VPCords by MP
( (lambda (offset)
( (lambda (viewctr)
(list
(mapcar '- viewctr offset)
(mapcar '+ viewctr offset)
)
)
(getvar "viewctr")
)
)
( (lambda (halfHeight aspectRatio)
(list
(* halfHeight aspectRatio)
halfHeight
)
)
(* 0.5 (getvar "viewsize"))
(apply '/ (getvar "screensize"))
)
)
)

(defun ql_set_tiles (/)
(vla-GetBoundingBox (vlax-ename->vla-object (ssname ss entnumber)) 'LL 'UR)
(setq LL (safearray-value LL))
(setq UR (safearray-value UR))
(setq center (mapcar '(lambda (a b) (/ (+ a b) 2.0)) LL UR))
(set_tile "txt1" (strcat (itoa (1+ entnumber)) " of " (itoa enum) ))
(set_tile "txt2" (strcat " Layer : " lar))
(set_tile "txt3" (strcat " Type : " (cdr (assoc 0 (entget (ssname ss entnumber))))))
(set_tile "txt4" (strcat " Length : "
(if (vlax-property-available-p (vlax-ename->vla-object (ssname ss entnumber)) 'Measurement)
(rtos (vla-get-measurement (vlax-ename->vla-object (ssname ss entnumber))) 2 2)
(rtos (vlax-curve-getdistatparam (ssname ss entnumber) (vlax-curve-getendparam (ssname ss entnumber))) 2 2)
);if
);strcat
);set_tile
(set_tile "txt5" (strcat "Center X: " (rtos (car center) 2 2)))
(set_tile "txt6" (strcat "Center Y: " (rtos (cadr center) 2 2)))
)

(defun ql_dialog (fname / wpath fn)
(if (setq wPath (findfile "ACAD.PAT"))
(progn
(setq wPath (vl-filename-directory wPath));;Lee Mac
(or (eq "\\" (substr wPath (strlen wPath)))
(setq wPath (strcat wPath "\\")))
(setq fn (open (strcat wPath fname) "w"))
(foreach str
'("ql : dialog { label = \"QL_Quantify Layer.lsp\";"
" :row {"
" : popup_list { label = \"Select Layer Name:\"; key = \"Selection\"; value = \"0\"; edit_width = 25;}"
" : button { key = \"lmc\"; label = \">\"; edit_width = true; alignment = centered;}"
" }"
" :boxed_column { label = \"Include\";"
" :row {"
" : toggle { key= \"lopoly\"; label = \"Lines and Open Polylines\";}"
" : toggle { key= \"cpoly\";label = \"Closed Polylines\";}"
" }"
" :row {"
" : toggle { key= \"arcs\";label = \"Arcs \";}"
" : toggle { key= \"circles\";label = \"Circles\";}"
" }"
" :row {"
" : toggle { key= \"splines\";label = \"Splines\";}"
" }"
" }"
" :row {"
" : toggle { key= \"txtdoc\";label = \"Generate Text Document\";}"
" : toggle { key= \"inspection\"; label = \"Inspect Objects\";}"
" }"
" :row {"
" : button { key = \"accept\"; label = \"Quantify\"; is_default = true; edit_width = true; alignment = centered;}"
" : button { key = \"cancel\"; label = \"Cancel\"; edit_width = true; alignment = centered; is_cancel = true;}"
" }"
" : errtile { width = true; }}"
"inspection : dialog {"
"label = \"QL Object Inspection\";"
" :text { key = \"txt1\"; alignment = centered;}"
" :row {"
" : button { key = \"zoomto\"; label = \"Zoom To\"; edit_width = true; alignment = centered;}"
" : button { key = \"zoomout\"; label = \"Zoom Out\"; edit_width = true; alignment = centered;}"
" }"
" :boxed_column { label = \"Info\";"
" :text { key = \"txt2\";}"
" :text { key = \"txt3\";}"
" :text { key = \"txt4\";}"
" :text { key = \"txt5\";}"
" :text { key = \"txt6\";}"
" }")
(write-line str fn))
(write-line ":row {" fn)
(and ss entnumber (ssname ss (1- entnumber))
(write-line ": button { key = \"prev\"; label = \"<>\"; mnemonic = \"N\"; is_default = true; edit_width = true; alignment = centered;}" fn)
)
(write-line "}
: button { key = \"done\"; label = \"Continue\"; mnemonic = \"E\"; width = 45.0; fixed_width = true; alignment = centered; is_cancel = true;}
: errtile { width = true; }}" fn)
(close fn)
t)
nil)
)

(defun massoc (key alist / x nlist);Jaysen Long
(foreach x alist
(if
(eq key (car x))
(setq nlist (cons (cdr x) nlist))
)
)
(reverse nlist)
);defun

(defun c:QL (/ entlay ss num enum llen ent lar PL AR CR SP CP RP LMC acadobj vsize layername
fname fn dcl_id nfilter obj len userclick filter *error* LL UR center
line arc circle spline oplines cplines options prev next entnumber done)
(vl-load-com)
(setq acadobj (vlax-get-acad-object))
(setq fname "QL-Quantify.dcl")
(setq options (cons (getvar "clayer")(acad_strlsort (ai_table "layer" 4))))
(ql_dialog fname)
(setq dcl_id (load_dialog fname))
(if (not (new_dialog "ql" dcl_id))
(exit )
);if
(Makelst "Selection" Options)
(setq pl 1 ar 1 cr 1 sp 1 cp 1 rp 1 in 0)
(mapcar (function (lambda (x) (set_tile x "1"))) '("lopoly" "arcs" "circles" "splines" "cpoly" "txtdoc"))
(set_tile "inspection" "0")
(action_tile "lopoly" "(setq PL (atoi $value))")
(action_tile "arcs" "(setq AR (atoi $value))")
(action_tile "circles" "(setq CR (atoi $value))")
(action_tile "splines" "(setq SP (atoi $value))")
(action_tile "cpoly" "(setq CP (atoi $value))")
(action_tile "txtdoc" "(setq RP (atoi $value))")
(action_tile "inspection" "(setq IN (atoi $value))")
(action_tile "lmc" (strcat "(progn (done_dialog)(setq LMC 1)(setq userclick T))"))
(action_tile "accept"
(strcat
"(progn (setq layername (atof(get_tile \"Selection\")))(done_dialog)(setq userclick T))"
);strcat
);action_tile

(start_dialog)
(unload_dialog dcl_id)
(if userclick
(progn
(if (zerop (+ pl ar cr sp cp))(progn (alert "No object types selected! Try again!")(exit)))
(if LMC (while (not entlay)(setq entlay (entsel "\nSelect entity on layer to quantify: ")))
(setq layername (fix layername) layername (nth layername OPTIONS))
))
);if
(and (not userclick)(princ "\nCancel")(exit))
(setq filter
(list '(-4 . "")
);list
);setq

(foreach x filter (if (/= x nil)(setq nfilter (append nfilter (list x)))))
(setq ss
(if entlay (ssget "_X" (cons (cons 8 (cdr(assoc 8 (entget (car entlay))))) nfilter))
(ssget "_X" (cons (cons 8 layername) nfilter)))
)
(mapcar (function (lambda (x) (set x 0)))'(llen enum num oplines cplines))
(if ss
(progn
(repeat (sslength ss)
(setq ent (ssname ss num))
(setq obj (vlax-ename->vla-object ent))

(cond
((and (= PL 1)(member (cdr (assoc 0 (entget ent))) '("LWPOLYLINE" "POLYLINE"))(not (vlax-curve-isclosed obj)))
(QL_AddMeasurement)
(setq oplines (1+ oplines))
)
((and (= CP 1)(member (cdr (assoc 0 (entget ent))) '("LWPOLYLINE" "POLYLINE"))(vlax-curve-isclosed obj))
(QL_AddMeasurement)
(setq cplines (1+ cplines))
)
((not (member (cdr (assoc 0 (entget ent))) '("LWPOLYLINE" "POLYLINE")))
(QL_AddMeasurement)
(if (null (eval (read (cdr (assoc 0 (entget ent))))))
(set (read (cdr (assoc 0 (entget ent)))) 0)
)
(set (read (cdr (assoc 0 (entget ent))))(1+ (eval (read (cdr (assoc 0 (entget ent)))))))
)
((ssdel ent ss))
);cond
);repeat

(setq llen (rtos llen 2 3))
(if entlay (setq lar (cdr (assoc 8 (entget (car entlay)))))
(setq lar layername)
)
(setq vsize (vpcords) entnumber 0)
(and (zerop enum)(alert (strcat "No Valid Objects on layer '" Lar "'. Try again."))(exit))
(and (= IN 1)
(not (redraw (ssname ss entnumber) 3))
(while (not done)
(if (not (and (ssname ss (+ entnumber 2))(ssname ss (- entnumber 2))))
(and
(ql_dialog fname)
(setq dcl_id (load_dialog fname))
(if (not (new_dialog "inspection" dcl_id "" '(1 1)))(exit));if
))
(ql_set_tiles)
(action_tile "zoomto"
(vl-prin1-to-string
(quote
(progn
;(done_dialog)
(redraw (ssname ss entnumber) 3)
(vla-zoomwindow acadobj (vlax-3d-point LL)(vlax-3d-point UR))
))))
(action_tile "zoomout"
(vl-prin1-to-string
(quote
(progn
;(done_dialog)
(vla-zoomscaled acadobj 0.75 acZoomScaledRelative)
))))
(action_tile "prev"
(vl-prin1-to-string
(quote
(progn
(and (eq (1+ entnumber) enum)(done_dialog))
(if (not (ssname ss (- entnumber 2))) (done_dialog))
(redraw (ssname ss entnumber) 4)
(setq entnumber (1- entnumber))
(redraw (ssname ss entnumber) 3)
(vla-zoomwindow acadobj (vlax-3d-point (car vsize))(vlax-3d-point (cadr vsize)))
(ql_set_tiles)
))))
(action_tile "next"
(vl-prin1-to-string
(quote
(progn
(and (eq entnumber 0)(done_dialog))
(if (not (ssname ss (+ entnumber 2))) (done_dialog))
(redraw (ssname ss entnumber) 4)
(setq entnumber (1+ entnumber))
(redraw (ssname ss entnumber) 3)
(vla-zoomwindow acadobj (vlax-3d-point (car vsize))(vlax-3d-point (cadr vsize)))
(ql_set_tiles)
))))
(action_tile "done"
(vl-prin1-to-string
(quote
(progn
(done_dialog)
(vla-zoomwindow acadobj (vlax-3d-point (car vsize))(vlax-3d-point (cadr vsize)))
(setq done 1)
))))
(and (not (and (ssname ss (+ entnumber 2))(ssname ss (- entnumber 2)))) (start_dialog)(unload_dialog dcl_id))
))
(redraw (ssname ss entnumber) 4)
(If (= RP 1)
(progn
(setq filter (massoc 0 nfilter))
(setq f (open (strcat (getvar 'dwgprefix) "temp.txt") "w"))
(write-line (strcat "Drawing Name: " (getvar 'dwgname)) f)
(write-line (strcat "Layer Quantified: " lar) f)
(write-line (strcat "Object Filter:") f)
(and (= CP 1) (= PL 0)(write-line (strcat " (OPEN POLYLINES EXCLUDED)")f))
(and (= CP 0) (= PL 1)(write-line (strcat " (CLOSED POLYLINES EXCLUDED)")f))
(foreach x filter (write-line (strcat " " x) f))
(write-line (strcat "Objects Found:") f)
(and (> line 0)(write-line (strcat " "(itoa line) " Line(s)") f))
(and (> arc 0)(write-line (strcat " "(itoa arc) " Arc(s)") f))
(and (> circle 0)(write-line (strcat " "(itoa circle) " Circle(s)") f))
(and (> spline 0)(write-line (strcat " "(itoa spline) " Spline(s)") f))
(and (> oplines 0)(= PL 1)(write-line (strcat " "(itoa oplines) " Open Polyline(s)") f))
(and (> cplines 0)(= CP 1)(write-line (strcat " "(itoa cplines) " Closed Polyline(s)") f))
(write-line (strcat "\nTot. # of Obj. = " (itoa enum)) f)
(write-line (strcat "Combined Length = " llen) f)
(close f)
(startapp "explorer" (strcat (getvar 'dwgprefix) "temp.txt"))
);progn
(alert (strcat " Filtered Entities on Layer '" lar "' = " (itoa enum)
"\nCombined Length of Entities = " llen " Ft."
);strcat
);alert
);if
);progn
(alert (strcat "No Valid Objects on layer '" layername "'. Try again."))
);if
);defun
(c:ql)

Advertisements