Menyisipkan Koordinat XYZ Gambar Ke Tabel Pada ModelSpace

Kadang kita harus menyisipkan tabel koordinat XYZ gambar di dalam Model Space, menggambarnya secara manual dgn menggunakan lines atau polyline akan memakan waktu lama. Untuk menyingkat pekerjaan dapat dilakukan dengan menjalankan program di bawah ini (text berwarna biru):

;; coordstottable.lsp
;; helpers
;; collect segment numbers and values of polyline bulges

(defun get-bulge-list (pline_obj / idx bulge_list point_list)
(setq point_list (get-vexs pline_obj))
(setq idx 0)
(while (<>
(setq bulg (vla-getbulge pline_obj idx)
bulge_list (cons (cons idx bulg) bulge_list)
idx (1+ idx)
)
)
(vl-remove-if
(function (lambda (x) (zerop (cdr x))))
(reverse bulge_list)
)
)

;; group list by number of items in the sublist

(defun group-by-num (lst num / ls ret)
(if (= (rem (length lst) num ) 0)
(progn
(setq ls nil)
(repeat (/ (length lst) num)
(repeat num (setq ls
(cons (car lst) ls)
lst (cdr lst)))
(setq ret (append ret (list (reverse ls)))
ls nil)))
)
ret
)

;; get polyline vertices

(defun get-vexs (pline_obj / verts)
(setq verts (vlax-get pline_obj 'Coordinates)
verts
(cond
((wcmatch (vlax-get pline_obj 'Objectname )
"AcDb2dPolyline,AcDb3dPolyline")
(group-by-num verts 3)
)
((eq (vlax-get pline_obj 'Objectname )
"AcDbPolyline")
(group-by-num verts 2)
)
(T nil)
)
)
)

;; get bulge radius
;; math by Juergen Menzi
(defun get-radii (p1 p2 bulge)
(abs (/ (distance p1 p2) 2 (sin (/ (* 4 (atan (abs bulge))) 2)))));+

;;get segment arc center
;;math by John Uhden
(defun get-segm-center (pline p1 p2 bulge / cpt midc midp rad)
(setq rad (get-radii p1 p2 bulge)
midp (vlax-curve-getpointatparam pline
(+ (fix (vlax-curve-getparamatpoint pline p1)) 0.5))
midc (mapcar (function (lambda (x y)(/ (+ x y) 2))) p1 p2)
cpt (trans (polar midp (angle midp midc) rad) 0 1)
)
cpt
)
;; return position of vertex and bulge value
(defun bulge-info (pln / coors ept rad ret_list spt val_list)
(vl-load-com)

(setq val_list (get-bulge-list pln))
(if (eq (vla-get-closed pln) :vlax-false)
(setq coors (get-vexs pln))
(progn (setq coors (get-vexs pln))
(setq coors (append coors (list (car coors))))))
(repeat (length val_list)
(setq spt (nth (caar val_list) coors)
ept (nth (1+ (caar val_list)) coors))
(setq rad (get-radii spt ept (cdar val_list)))
(setq ret_list (cons (cons (caar val_list) rad) ret_list))
(setq val_list (cdr val_list)))
(reverse ret_list)
)
;; return coordinates, radiuses and center points of segments
(defun trace-pline (pline val_list /)
(setq coors (get-vexs pline))
(if (eq (vla-get-closed pline) :vlax-true)
(setq coors (append coors (list (car coors)))))
(foreach itm val_list
(setq pos (car itm)
p1 (nth pos coors)
p2 (nth (1+ pos) coors)
rad (get-radii p1 p2 (cdr itm))
cpt (get-segm-center pline p1 p2 (cdr itm))
cpt (list (car cpt)(cadr cpt))
tmp (append cpt (list rad))
coors (append_item coors pos tmp)
)
)
coors
)
;; append item in the particular position into list
(defun append_item (lst pos itm / hd)
(setq i 0)
(while (<= i pos)
(setq hd (cons (car lst) hd))
(setq i (1+ i))
(setq lst (cdr lst)))
(append (reverse hd)(append (list itm) lst))
)

(defun add-table-style (adoc / acmcol adoc clsname keyname newstyleobj tbldict tblstylename)

(setq tbldict
(vla-item
(vla-get-dictionaries
(vla-get-database adoc)
)
"Acad_TableStyle"
)
)
(setq keyname "NewStyle"
clsname "AcDbTableStyle"
tblstylename "Coordinates" ;change name
)
(setq newstyleobj
(vlax-invoke tbldict 'Addobject keyname clsname)
)
(vlax-put newstyleobj 'TitleSuppressed :vlax-false)
(vlax-put newstyleobj 'HeaderSuppressed :vlax-false)
(setq acmcol (vla-GetInterfaceObject
(vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (itoa (atoi (getvar "acadver"))))
)
)
(vlax-put acmcol 'Colorindex 24)
(vlax-put newstyleobj 'Name TblStyleName)
(vlax-put newstyleobj 'Description "Coordinates Table")
(vlax-put newstyleobj 'BitFlags 1)
(vlax-put newstyleobj 'HorzCellMargin 0.06)
(vlax-put newstyleobj 'VertCellMargin 0.06)

(vlax-invoke newstyleobj 'SetColor acDataRow acmcol)
(vlax-invoke newstyleobj
'SetBackgroundColorNone
acDataRow
:vlax-false
)
(vlax-invoke newstyleobj 'SetTextStyle acDataRow "Standard")
;;; (vlax-invoke newstyleobj 'SetTextHeight acTitleRow 0.25)
(vlax-invoke newstyleobj 'SetTextHeight acHeaderRow 0.2)
(vlax-invoke newstyleobj 'SetTextHeight acDataRow 0.18)
(vlax-invoke newstyleobj 'SetGridVisibility acVertInside acDataRow
:vlax-true)
(vlax-invoke newstyleobj
'SetAlignment
acDataRow
acMiddleCenter
)
(vla-update newstyleobj)
(vlax-release-object acmcol)
;| ETC |;
(princ)
)

(vl-load-com)

;;================main part================;;

(defun C:CAP (/ acsp ac_table adoc bulge_list col col_names data_list dmz
ent i itm lpc lup max_wid pin pline_data pln row row_hgt stylelist
table_data tblstyledict tmp txt_hgt)

(or adoc
(setq adoc (vla-get-activedocument
(vlax-get-acad-object))))
(or acsp (setq acsp (if (= (getvar "CVPORT") 1)
(vla-get-paperspace
adoc)
(vla-get-modelspace
adoc)
)
)
)
(vla-endundomark
adoc)
(vla-startundomark
adoc)
(setq lup (getvar "lunits"))
(setvar "lunits" 2)
(setq lpc (getvar "luprec"))
(setvar "luprec" 3)
(setq dmz (getvar "dimzin"))
(setvar "dimzin" 8)


(setq tblstyledict
(vla-item
(vla-get-dictionaries adoc)
"ACAD_TABLESTYLE")
)
(vlax-for tblstyle tblstyledict
(setq stylelist (cons
(vla-get-name tblstyle)
stylelist)))

(if (not (member "Coordinates" stylelist))
(add-table-style adoc)
)
(setq table_data nil);debug only
(setq pln (vlax-ename->vla-object
(car (setq ent (entsel "\n\t>>>\tSelect polyline\t<<<\n")))))
(setq bulge_list (bulge-info pln))
(setq pline_data (trace-pline pln bulge_list))

(setq pin (vlax-3d-point
(getpoint "\nSpecify table insertion point : \n"))
row_hgt (getreal "\nSpecify row height : \n")
;;; header_txt_hgt (getreal "\nSpecify the header cell text height : \n")
txt_hgt (getreal "\nSpecify the data cell text height : \n"))
(setq col_names (list "Point" "X" "Y" "Radius"))
(setq
max_wid 9.5
data_list (mapcar (function (lambda(x)(mapcar 'rtos x))) pline_data))
(if (eq :vlax-true (vla-get-closed pln))
(setq data_list (reverse (cdr (reverse data_list)))))
(setq i 0)
(repeat (length data_list)
(setq tmp (car data_list))
(if (= 2 (length tmp))
(progn
(setq itm (append (list (chr (+ i 65))) tmp))
(setq i (1+ i)))
(setq itm (append (list "CENTER") tmp)))
(setq table_data (cons itm table_data))

(setq data_list (cdr data_list))
)
(setq table_data (reverse table_data))

;;; draw table

(setq ac_table (vla-addtable acsp pin
(+ (length table_data) 2)
(length col_names)
row_hgt
(* txt_hgt max_wid))
)
(vla-put-stylename ac_table "Coordinates")
(vla-put-regeneratetablesuppressed ac_table :vlax-true)
(vla-put-headersuppressed ac_table :vlax-false)
(vla-put-titlesuppressed ac_table :vlax-false)

;; popup table

(vla-settext ac_table 0 0 "Coordinates")
(vla-setcellalignment ac_table 0 0 acmiddlecenter)
(vla-setcelltextheight ac_table 0 0 (* txt_hgt 1.25))
(vla-setrowheight ac_table 0 (* txt_hgt 2))
(setq col 0)

(foreach item col_names
(vla-settext ac_table 1 col item)
(vla-setcellalignment ac_table 1 col acmiddlecenter)
(vla-setcelltextheight ac_table 1 col txt_hgt)
(setq col (1+ col)))

(setq row 2)
(foreach item table_data
(vla-setrowheight ac_table row (* txt_hgt 2))
(setq col 0)
(foreach a item
(vla-settext ac_table row col a)
(vla-setcellalignment ac_table row col acmiddlecenter)
(vla-setcelltextheight ac_table row col txt_hgt)
(setq col (1+ col)))
(setq row (1+ row)))
(vla-put-regeneratetablesuppressed ac_table :vlax-false)
(setvar "luprec" lpc)
(setvar "lunits" lup)
(setvar "dimzin" dmz)
(vla-endundomark
adoc)
(princ)
)
(prompt "\n\t\t***\tType CAP to execute\t***")
(princ)

Perhatikan setiap saran atau perintah yang diminta pada baris command.