AutoCAD Architecture Customization
Welcome to Autodesk’s AutoCAD Architecture Customization Forums. Share your knowledge, ask questions, and explore popular AutoCAD Architecture Customization topics.
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

Help with LISP routine

0 REPLIES 0
Reply
Message 1 of 1
sparker
950 Views, 0 Replies

Help with LISP routine

We are using Autocad 2014 and I am trying to create a lisp routine that will enable us to draw a legend of symbols selected with quantities, desription and symbol inserted all at once.

So far i managed to find some routines but they cant do all i want.

the best one is attached but i still need to add a field to add a full description.

This routine comes closest but still ot all info. I have also atttached a sample legend.

Thanks you clever people out there

 

 

 

(defun c:BlkQty (/ blk_id blk_len blk_name blks ent h header_lsp height i j TOTAL
  len0 lst_blk msp pt row ss str tblobj width width1 width2 x y
)
;;  By : Gia Bach, gia_bach @  www.CadViet.com ;;
(vl-load-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 *util '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 😎
      (while (setq ent (ssname ss (setq i (1+ i))))
 (setq blk_name (cdr (assoc 2 (entget 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 TOTAL 0)
      (FOREACH I LST_BLK (SETQ TOTAL (+ TOTAL (CDR I))))
      (or *h* (setq *h* (* (getvar "dimtxt")(getvar "dimscale"))))
      (initget 6)
      (setq h (getreal (strcat "\nText Height <" (rtos *h*) "> :")))     
      (if h (setq *h* h) (setq h *h*) )
      (or *adoc (setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))))
      (setq msp (vla-get-modelspace *adoc)
     *util (vla-get-Utility *adoc)
     blks (vla-get-blocks *adoc))     
      (setq width1 (* 4 (TxtWidth "    " h msp))
     width (* 2 (TxtWidth "Text Height" 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 8))8)
       width1 (* (fix (/ width1 8))8)
       width2 (* (fix (/ width2 8))8)
       height (* (fix (/ height 5))5)))
      (GetOrCreateTableStyle "CadEng")
      (setq pt (getpoint "\nPlace Table :")
     TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst_blk) 3) 4 height width));CHANGE 5 TO 4
      (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 8))
       (list acTitleRow acHeaderRow acDataRow))     
      (vla-MergeCells TblObj 0 0 0 3);change 4 to 3
      (vla-setText TblObj 0 0 "Block Count Table")
      (setq j -1 header_lsp (list "    " "Block Name" "Quantity" "Preview"));;;;;;;;;;;;;;;;;;;;;;REMOVE "DON VI"
      (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  (cdr pt)));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;REMOVE "CAI"
 (vla-SetBlockTableRecordId TblObj row 3 (GetObjectID (vla-item blks blk_name)) :vlax-true);CHANGE 4 TO 3
 (vla-SetCellAlignment TblObj row 1 7)
 (vla-SetCellAlignment TblObj row 2 9);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;CHANGE 3 TO 2
 (setq row (1+ row) i (1+ i)) )
        (VLA-SETTEXT TBLOBJ ROW 1 "TOTAL")
        (VLA-SETTEXT TBLOBJ ROW 2 TOTAL)
 (vla-SetCellAlignment TblObj row 1 7)
 (vla-SetCellAlignment TblObj row 2 9)
      (vla-put-regeneratetablesuppressed TblObj :vlax-false)
      (vlax-release-object TblObj) )  )
  (princ))

0 REPLIES 0

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Autodesk Design & Make Report

”Boost