21.02.2020 08:16    

Verdiği tabloyu 100 ile scale etmek aynı şey değil mi ?

02.11.2023 13:40    

bir arkadaşımdan aldığım lisp belki işinize yarayabilir;


;; free lisp from cadviet.com
;;; this lisp was downloaded from

Linkleri görebilmek için ÜYE olmalısınız.


(defun c:bsay (/ blk_id blk_len blk_name blks cur_var ent h header_lsp height i
ins j len0 lst_blk msp pt row ss str tblobj width width1 width2 x y)
;; By : Gia Bach, gia_bach @ www.CadViet.com ;;
(defun TxtWidth (val h msp / txt minp maxp)
(setq txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
(vla-getBoundingBox txt 'minp 'maxp )
(vla-Erase txt)
(-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp))) )

(defun GetOrCreateTableStyle (tbl_name / name namelst objtblsty objtblstydic tablst txtsty)
(setq objTblStyDic (vla-item (vla-get-dictionaries *adoc) "ACAD_TABLESTYLE") )
(foreach itm (vlax-for itm objTblStyDic
(setq tabLst (append tabLst (list itm))))
(if (not
(vl-catch-all-error-p
(setq name (vl-catch-all-apply 'vla-get-Name (list itm)))))
(setq nameLst (append nameLst (list name))) ) )
(if (not (vl-position tbl_name nameLst))
(vla-addobject objTblStyDic tbl_name "AcDbTableStyle"))
(setq objTblSty (vla-item objTblStyDic tbl_name)
TxtSty (variant-value (vla-getvariable *adoc "TextStyle")))
(mapcar '(lambda (x)(vla-settextstyle objTblSty x TxtSty))
(list acTitleRow acHeaderRow acDataRow) )
(vla-setvariable *adoc "CTableStyle" tbl_name) )

(defun GetObjectID (obj)
(if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
(vlax-invoke-method
(setq Utility
(cond
(Utility)
((vla-get-Utility *adoc))))
'GetObjectIdString obj :vlax-false )
(vla-get-Objectid obj)))
;main
(if (setq ss (ssget (list (cons 0 "INSERT"))))
(progn
(vl-load-com)
(setq i -1 len0 8)
(while (setq ent (ssname ss (setq i (1+ i))))
(setq blk_name (vla-get-name (vlax-Ename->Vla-Object ent)))
(if (> (setq blk_len (strlen blk_name)) len0)
(setq str blk_name len0 blk_len) )
(if (not (assoc blk_name lst_blk))
(setq lst_blk (cons (cons blk_name 1) lst_blk))
(setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk))))
(assoc blk_name lst_blk) lst_blk))) )
(setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)) ) ))
(setq cur_var (mapcar 'getvar '("DYNMODE" "DYNPROMPT")))
(mapcar 'setvar '("DYNMODE" "DYNPROMPT") '(1 1))
(initget "Yes No")
(setq ins (getkword "\nTabloda blok sembol g sterilsinmi? [Yes/No ] <yes> : ") )
(or ins (setq ins "Yes"))
(mapcar 'setvar '("DYNMODE" "DYNPROMPT") cur_var)
(or *h* (setq *h* (* (getvar "dimtxt")(getvar "dimscale"))))
(initget 6)
(setq h (getreal (strcat "\nYaz karakter boyutu <" (rtos *h*) "> :")))
(if h (setq *h* h) (setq h *h*) )
(setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))
msp (vla-get-modelspace *adoc)
blks (vla-get-blocks *adoc))
(setq width1 (* 2 (TxtWidth "SIRA NO" h msp))
width (* 2 (TxtWidth "ADET" h msp))
height (* 2 h))
(if str
(setq width2 (* 1.5 (TxtWidth (strcase str) h msp)))
(setq width2 width))
(if (> h 3)
(setq width (* (fix (/ width 10))10)
width1 (* (fix (/ width1 10))10)
width2 (* (fix (/ width2 10))10)
height (* (fix (/ height 5))5)))
(GetOrCreateTableStyle "CadViet")
(setq pt (getpoint "\nTablonun konulaca yeri se iniz :")
TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst_blk) 2) 5 height width))
(vla-put-regeneratetablesuppressed TblObj :vlax-true)
(vla-SetColumnWidth TblObj 0 width1)
(vla-SetColumnWidth TblObj 1 width2)
(vla-put-vertcellmargin TblObj (* 0.75 h))
(vla-put-horzcellmargin TblObj (* 0.75 h))
(mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
(list acTitleRow acHeaderRow acDataRow) )
(mapcar '(lambda (x)(vla-setAlignment TblObj x 2))
(list acTitleRow acHeaderRow acDataRow))
(vl-catch-all-error-p (vl-catch-all-apply (function(lambda () (vla-MergeCells TblObj 0 0 0 3)) )))
(vla-setText TblObj 0 0 "LISTE")
(setq j -1 header_lsp (list "SIRA NO" "BLOK ADI" "BIRIM" "ADET" "RESIM"))
(repeat (length header_lsp)
(vla-setText TblObj 1 (setq j (1+ j)) (nth j header_lsp)))
(setq row 2 i 1)
(foreach pt lst_blk
(setq blk_name (car pt) j -1)
(mapcar '(lambda (x)(vla-setText TblObj row (setq j (1+ j)) x))
(list i blk_name "Ad." (cdr pt)))
(if (= ins "Yes")
(vla-SetBlockTableRecordId TblObj row 4 (GetObjectID (vla-item blks blk_name)) :vlax-true))
(vla-SetCellAlignment TblObj row 1 7)
(vla-SetCellAlignment TblObj row 3 9)
(setq row (1+ row) i (1+ i)) )
(vla-put-regeneratetablesuppressed TblObj :vlax-false)
(vlax-release-object TblObj) ) )
(princ))

</yes>