;;; 2016 Thomas Gail Haws GPL V3 license
;;; Namespace HAWS-
;;; Options:
;;; Include table name in label: T or nil
(defun haws-adedtt-include-table-name-in-label-p () T)
;;; Include field name in label: T or nil
(defun haws-adedtt-include-field-name-in-label-p () T)
(defun c:adedtt () (c:haws-adedatatotext))
(defun c:haws-adedatatotext (/ ssobjects datafieldlist)
(haws-adedtt-get-objects)
(haws-adedtt-get-user-field-list)
(haws-adedtt-label-objects)
)
(defun haws-adedtt-get-objects (/)
(setq ssobjects (ssget '((0 . "POLYLINE,LWPOLYLINE"))))
)
;; Get the list of fields the user wants to see
(defun haws-adedtt-get-user-field-list (/ f)
(setq datafieldlist (haws-adedtt-get-object-field-list))
)
(defun haws-adedtt-get-object-field-list
(/ FIELD-LIST table-list TABLE-NAMES TABLEDEF)
(setq table-names (ade_odgettables (ssname ssobjects 0)))
(foreach table-name table-names
(setq tabledef (ade_odtabledefn table-name))
(foreach field (cdr (assoc "Columns" tabledef))
(setq table-list (cons (cdr (assoc "ColName" field)) table-list))
)
(setq table-list (cons table-name (list (reverse table-list))))
(setq field-list (cons table-list field-list))
)
(reverse field-list)
)
(defun haws-adedtt-label-objects (/ EN I)
(setq i -1)
(while (setq en (ssname ssobjects (setq i (1+ i))))
(haws-adedtt-label-object en)
)
)
(defun haws-adedtt-label-object
(en / LABEL-POSITION LABEL-TEXT ptlabel)
(setq label-text (haws-adedtt-get-label-text en))
(cond
((/= label-text "")
(setq label-position (haws-adedtt-get-label-position en))
(haws-adedtt-add-text label-position label-text)
)
)
)
(defun haws-adedtt-get-label-text (en / field label table)
(setq label "")
(foreach table datafieldlist
(foreach field (cadr table)
(haws-adedtt-add-field-to-label)
)
)
)
(defun haws-adedtt-add-field-to-label (/ data)
(cond
((setq
data
(ade_odgetfield en (car table) field 0)
)
(setq
label
(strcat
label
"\n"
(cond ((haws-adedtt-include-table-name-in-label-p)
(strcat (car table) ": ")
)
(T "")
)
(cond ((haws-adedtt-include-field-name-in-label-p)
(strcat field ": ")
)
(T "")
)
(vl-princ-to-string data)
)
)
)
)
)
(defun haws-adedtt-get-label-position (en)
(cond
((haws-adedtt-closed-polyline-p en)
(haws-adedtt-get-centroid-position en)
)
(T
(haws-adedtt-get-middle-position en)
)
)
)
(defun haws-adedtt-closed-polyline-p (en)
(= 1 (logand 1 (cdr (assoc 70 (entget en)))))
)
(defun haws-adedtt-get-centroid-position (en / CENTROID-POINT OBJ)
(command "._region" en "")
(setq en (entlast))
(setq obj (vlax-ename->vla-object en))
(setq centroid-point
(vlax-safearray->list
(vlax-variant-value (vla-get-centroid obj))
)
)
(command "._undo" "")
(list centroid-point)
)
(defun haws-adedtt-get-middle-position
(en / MIDDLE-POINT POLYLINE-LENGTH)
(setq polyline-length
(vlax-curve-getDistAtParam
en
(vlax-curve-getEndParam en)
)
)
(command "._measure" en (/ polyline-length 1.999))
(setq en (entlast))
(setq middle-point (cdr (assoc 10 (entget en))))
(command "._undo" "1")
(list middle-point)
)
(defun haws-adedtt-add-text (label-position label-text)
(cond
(label-text
(command
"._mtext"
(car label-position)
"_justify"
"_mc"
"_width"
"0"
label-text
""
)
)
)
)
No comments:
Post a Comment