Solved: lisp for sorting a list of selected block

Facilo · ‎06-12-2013

Hello, I found a lisp for counting of selected block in a table drawing, but I can not remove the bottom line of this lisp that displays "total" blocks. Can you help me to remove this line from "total" that is created in the last row of the table that lisp. In advance thank you. Sincerely.

lisp : ========================================

(defun c:TABL (/ 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
)
(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
(setq parnombloc1 (getcfg "APPDATA/PARNOMBLOC1"))

(setq com1

(getstring

t

(strcat

"\nVEUILLEZ ENTRER UNE PARTIE DU NOM DES BLOCS A LISTER<"

parnombloc1

"> : "

)

)
(if (/= com1 "")

(setq parnombloc1 com1)

)

(setcfg "APPDATA/PARNOMBLOC1" parnombloc1)

; (setq test (strcat "*" parnombloc1 "*"))

;; (prompt (strcat

;; "\nle bout du nom de bloc est : "

;; test

;; )

(prompt

"\nSélectionnez les blocs à lister"

)

(or (setq ss

(ssget

(list '(0 . "INSERT") (cons 2 (strcat "*" parnombloc1 "*")))

)

(setq ss

(ssget

"_X"

(list '(0 . "INSERT") (cons 2 (strcat "*" parnombloc1 "*")))

)

col T

)

(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 "\nHauteur du text <" (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 (* 3 (TxtWidth " " h msp));latgeur de N°
width (* 0.8 (TxtWidth "Hauteur du text" h msp)); largeur globale
height (* 2 h))
(if str
(setq width2 (* 1.4 (TxtWidth (strcase str) h msp))); largeur nom du bloc
(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 "tabing")
(setq pt (getpoint "\nPlacer La 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.4 h))
(vla-put-horzcellmargin TblObj (* 0.4 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 "TABLEAU DE NOMENCLATURE DES BLOCS")
(setq j -1 header_lsp (list "N°" "NOM DES BLOCS" "QTES" "BLOCS"));;;;;;;;;;;;;;;;;;;;;;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)

aqdam1978 · ‎06-18-2013

Do you know you can use BCount command?(in Express tools)

Can you translate your lisp's prompts to english?

(defun c:TABL (/       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
	      )
  (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
  (setq parnombloc1 (getcfg "APPDATA/PARNOMBLOC1"))
  (setq	com1
	 (getstring
	   t
	   (strcat
	     "\nVEUILLEZ ENTRER UNE PARTIE DU NOM DES BLOCS A LISTER<"
	     parnombloc1
	     "> : "
	   )
	 )
  )
  (if (/= com1 "")
    (setq parnombloc1 com1)
  )
  (setcfg "APPDATA/PARNOMBLOC1" parnombloc1)

					; (setq test (strcat "*" parnombloc1 "*"))

  ;; (prompt (strcat
  ;; "\nle bout du nom de bloc est : "
  ;; test
  ;; )
  ;; )

  (prompt
    "\nSélectionnez les blocs à lister"
  )
  (or (setq ss
	     (ssget
	       (list '(0 . "INSERT") (cons 2 (strcat "*" parnombloc1 "*")))
	     )
      )
      (setq ss
	     (ssget
	       "_X"
	       (list '(0 . "INSERT") (cons 2 (strcat "*" parnombloc1 "*")))
	     )
	    col	T
      )
  )
  (progn
    (vl-load-com)
    (setq i -1
	  len0 8
    )
    (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 "\nHauteur du text <" (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 (* 3 (TxtWidth " " h msp)) ;latgeur de N°
	  width	 (* 0.8 (TxtWidth "Hauteur du text" h msp))
					; largeur globale
	  height (* 2 h)
    )
    (if	str
      (setq width2 (* 1.4 (TxtWidth (strcase str) h msp)))
					; largeur nom du bloc
      (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 "tabing")
    (setq pt	 (getpoint "\nPlacer La 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.4 h))
    (vla-put-horzcellmargin TblObj (* 0.4 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 "TABLEAU DE NOMENCLATURE DES BLOCS")
    (setq j -1
	  header_lsp
	   (list "N°" "NOM DES BLOCS" "QTES" "BLOCS")
    )
;;;;;;;;;;;;;;;;;;;;;;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)

alanjt_ · ‎06-18-2013

The code has a lot of slop, but I only edited out what you wanted:

(defun c:TABL (/       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
              )
  (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
  (setq parnombloc1 (getcfg "APPDATA/PARNOMBLOC1"))
  (setq com1
         (getstring
           t
           (strcat
             "\nVEUILLEZ ENTRER UNE PARTIE DU NOM DES BLOCS A LISTER<"
             parnombloc1
             "> : "
           )
         )
  )
  (if (/= com1 "")
    (setq parnombloc1 com1)
  )
  (setcfg "APPDATA/PARNOMBLOC1" parnombloc1)

 ; (setq test (strcat "*" parnombloc1 "*"))

  ;; (prompt (strcat
  ;; "\nle bout du nom de bloc est : "
  ;; test
  ;; )
  ;; )

  (prompt
    "\nSélectionnez les blocs à lister"
  )
  (or (setq ss
             (ssget
               (list '(0 . "INSERT") (cons 2 (strcat "*" parnombloc1 "*")))
             )
      )
      (setq ss
             (ssget
               "_X"
               (list '(0 . "INSERT") (cons 2 (strcat "*" parnombloc1 "*")))
             )
            col T
      )
  )
  (progn
    (vl-load-com)
    (setq i -1
          len0 8
    )
    (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 "\nHauteur du text <" (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 (* 3 (TxtWidth " " h msp)) ;latgeur de N°
          width  (* 0.8 (TxtWidth "Hauteur du text" h msp))
 ; largeur globale
          height (* 2 h)
    )
    (if str
      (setq width2 (* 1.4 (TxtWidth (strcase str) h msp)))
 ; largeur nom du bloc
      (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 "tabing")
    (setq pt     (getpoint "\nPlacer La Table :")
          TblObj (vla-addtable
                   msp
                   (vlax-3d-point pt)
                   (+ (length lst_blk) 2) ;edit (from 3 to 2)
                   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.4 h))
    (vla-put-horzcellmargin TblObj (* 0.4 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 "TABLEAU DE NOMENCLATURE DES BLOCS")
    (setq j -1
          header_lsp
           (list "N°" "NOM DES BLOCS" "QTES" "BLOCS")
    )
;;;;;;;;;;;;;;;;;;;;;;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") ;edit
;;;    (VLA-SETTEXT TBLOBJ ROW 2 TOTAL) ;edit
;;;    (vla-SetCellAlignment TblObj row 1 7) ;edit
;;;    (vla-SetCellAlignment TblObj row 2 9) ;edit
    (vla-put-regeneratetablesuppressed TblObj :vlax-false)
    (vlax-release-object TblObj)
  )
)
(princ)

Facilo · ‎06-19-2013

You totally met my expectations. This is exactly what I wanted. This is the second time I call to your site it is clear that you have mastered perfectly what extra tool Autocad. With warm thanks, receive my cordial greetings. Hats off! tested ok!

alanjt_ · ‎06-19-2013

@hpinchon wrote:
You totally met my expectations. This is exactly what I wanted. This is the second time I call to your site it is clear that you have mastered perfectly what extra tool Autocad. With warm thanks, receive my cordial greetings. Hats off! tested ok!

You're very welcome.

Facilo · ‎10-02-2016

Hello, the lisp previously posted does not work with dynamic blocks. I put you below a version enhanced with Search 2 block attributes "MARQUE" and "REFERENCE". Can anyone help me fix it.
Best regards.

;******************* DEBUT TABM ***************************
;*****************************************************************
;*** Retourner une valeur à la fin d'une fonction
(defun c_return (v_value) v_value)

;**********************************************************
;*** Fonction pour Rechercher la valeur d'un attribut
(defun rec_val_att (n_ent etiq / val_att test test1)
  (while (/= test "SEQEND")
    (if	(/= test1 etiq)
      (progn
	(setq n_ent (entnext n_ent))
	(setq test (cdr (assoc 0 (entget n_ent))))
	(setq test1 (cdr (assoc 2 (entget n_ent))))
      )
      (progn
	(setq test "SEQEND")
	(setq val_att (cdr (assoc 1 (entget n_ent))))
      )
    )
  )
  (c_return val_att)
)

;**********************************************************
;*** Fonction pour Remplacer valeur d'un attribut
(defun rem_att (n_ent etiq valeur / ent1 test test1)
  (while (/= test "SEQEND")
    (if	(/= test1 etiq)
      (progn
	(setq n_ent (entnext n_ent))
	(setq test (cdr (assoc 0 (entget n_ent))))
	(setq test1 (cdr (assoc 2 (entget n_ent))))
      )
      (progn
	(setq test "SEQEND")
	(setq ent1 (entget n_ent))
	(setq ent1 (subst (cons 1 valeur) (assoc 1 ent1) ent1))
	(entmod ent1)
      )
    )
  )
)

;**********************************************************
;*** Fonction pour trouver la largeur d'un texte
(defun TxtWidth	(val h msp / txt minp maxp)
  (vl-load-com)  
  (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))
  )
)

;**********************************************************
;*** Fonction pour créer un style de tableau
(defun GetOrCreateTableStyle (tbl_name	  /	      name
			      namelst	  objtblsty   objtblstydic
			      tablst	  txtsty
			     )
  (vl-load-com)
  (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)
)

;**********************************************************
;*** Processeur 64
(defun GetObjectID (obj)
  (vl-load-com)
  (if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
    (vlax-invoke-method *util 'GetObjectIdString obj :vlax-false)
    (vla-get-Objectid obj)
    )
)
;**********************************************************
;******************* PROGRAMME PRINCIPAL ******************
(defun c:tabm (/       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
        blocks libloc  col
 ptins tableVL cont  blk      )
    (vl-load-com)
    
;*** type de sélection
    (initget "Collection Objet Sélection")
    (setq kw (getkword "\nChoisir une option [Collection/Objet/Sélection] < Sélection >: "))
    (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq blocks (vla-get-Blocks *acdoc*))
    (setq liref nil)
    (setq parnombloc1 (getcfg "APPDATA/PARNOMBLOC1"))
    (cond ((= kw "Objet")
            (if (setq obj (car (entsel "\nSélectionnez l'objet délimitant la sélection: ")))
                (if (member (cdr (assoc 0 (entget obj))) '("CIRCLE" "ELLIPSE" "LWPOLYLINE"))
                (setq ss (SelByObj obj "WP" '((0 . "INSERT"))))
                (princ "\nEntité non valide.")
                )
            (princ "\nAucune entité sélectionnée.")
            )
          )
    ((= kw "Collection") (setq ss  (ssget "_X" '((0 . "INSERT"))) col T))
    (T (setq ss (ssget '((0 . "INSERT")))))
    )
    (if ss (setq liref (mapcar '(lambda (x) (setq x (vlax-ename->vla-object x))
                    (if (vlax-property-available-p x 'EffectiveName)
                        (vla-get-EffectiveName x)
                        (vla-get-Name x)
                    )
                )
            (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
            )
        )
    (setq liref '())
    )
  ;;; Calcul la longeur maxi des noms de blocs puis création liste lst_blk1 ---> Nom Bloc - Quantité Bloc - Marque - Reference
  (setq i    -1   len0  8 ) ;;; longeur par defaut
  (setq lst_blk nil lst_blk1 nil)
  (while (setq ent (ssname ss (setq i (1+ i))))
    (setq blk_name (cdr (assoc 2 (entget ent))))
    (if (> (strlen blk_name) len0)
      (setq str  blk_name
            len0 (strlen blk_name)
      )
    )
    (setq Ent_Marque (rec_val_att ent "MARQUE"))
    (setq Ent_Reference (rec_val_att ent "REFERENCE"))
    (if (not (assoc blk_name lst_blk1))
    ;;; Si le bloc n'existe pas dans la liste
      (progn
        (setq toto (list blk_name 1 Ent_Marque Ent_Reference))
        (setq lst_blk1 (cons toto lst_blk1))
      )
    ;;; Si le bloc existe dans la liste
    ;;; Vérification si la marque est la même
      (progn
        (setq toto2 nil)
        (foreach n lst_blk1
          (setq crit0 (nth 0 n))
          (setq crit2 (nth 2 n))
          (setq crit3 (nth 3 n))
          (if (and (= crit0 blk_name) (= crit2 Ent_Marque) (= crit3 Ent_Reference))
            (setq toto2 n)
          )
        )
        ;;; Si la marque est la même, incrémenter la quantité
	(if toto2
          (setq lst_blk1 (subst (list blk_name
                                     (1+ (nth 1 toto2))
                                      (nth 2 toto2)
                                      (nth 3 toto2)
                                )
                                toto2
                                lst_blk1
                         )
          )
        ;;; Sinon, ajouter à la liste lst_blk1
          (progn
            (setq toto (list blk_name 1 Ent_Marque Ent_Reference))
            (setq lst_blk1 (cons toto lst_blk1))
          )
        )
      )
    )
    ;;; à effacer 
    (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
	     )
      )
    )
  )
  ;;; Tri la liste des blocs en fonction de la marque puis nom du bloc
(setq lst_blk1 (vl-sort lst_blk1 '(lambda (a B)
            (if (eq (caddr a) (caddr B))
                (if (eq (car a) (car b))
                (< (cadddr a) (cadddr B))
                (< (car a) (car b))
                )
            (< (caddr a) (caddr B))
            )
        )
    )
)
;;; à effacer 
  (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)))))
;;; Calcul hauteur de texte dans le tableau
  (or *h* (setq *h* (* (getvar "dimtxt") (getvar "dimscale"))) )
  (initget 6)
  (setq h (getreal (strcat "\nHauteur du text <" (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 (* 8 (TxtWidth " " h msp)) ;largeur de N°
	width  (* 0.8 (TxtWidth "Hauteur du text" h msp)) ; largeur globale
	height (* 2 h)
  )
  (setq width2 width);largeur Marque
  (if str
    (setq width3 (* 1.2 (TxtWidth (strcase str) h msp))) ;largeur nom du bloc
    (setq width3 width)
  )
  (setq width4 (1+ width));largeur Référence
  (setq width5 width);largeur Quantités
  (setq width6 width);largeur Image du bloc
  (if (> h 3)
    (setq width	 (* (fix (/ width 8)) 8)
	  width1 (* (fix (/ width1 8)) 8)
	  width2 (* (fix (/ width2 8)) 8)
	  width3 (* (fix (/ width2 8)) 8)
	  width4 (* (fix (/ width2 8)) 8)
	  width5 (* (fix (/ width2 8)) 8)
	  width6 (* (fix (/ width2 8)) 8)
	  height (* (fix (/ height 5)) 5)
    )
  )
;;; Création style du tableau puis création tableau
  (GetOrCreateTableStyle "tableau espace objet")
  (setq	pt     (getpoint "\nPlacer la tableau:")
	TblObj (vla-addtable
		 msp                  ;Espace objet
		 (vlax-3d-point pt)
		 (+ (length lst_blk1) 2)	;Nombre de lignes
		 6                      ;Nombre de Colonne
		 height                 ;Hauteur de la ligne par defaut
		 width                  ;Largeur de la ligne par defaut
	       )
  )
  (vla-put-regeneratetablesuppressed TblObj :vlax-true)
  (vla-SetColumnWidth TblObj 0 width1);largeur de N°
  (vla-SetColumnWidth TblObj 1 width2);largeur Marque
  (vla-SetColumnWidth TblObj 2 width3);largeur nom du bloc
  (vla-SetColumnWidth TblObj 3 width4);largeur Référence
  (vla-SetColumnWidth TblObj 4 width5);largeur Quantités
  (vla-SetColumnWidth TblObj 5 width6);largeur Image du bloc

  (vla-put-vertcellmargin TblObj (* 0.4 h))
  (vla-put-horzcellmargin TblObj (* 0.4 h))
  (mapcar '(lambda (x) (vla-setTextHeight TblObj x h))
	  (list acTitleRow acHeaderRow acDataRow)
  )
  (mapcar '(lambda (x) (vla-setAlignment TblObj x 5))
	  (list acTitleRow acHeaderRow acDataRow)
  )
  (vla-MergeCells TblObj 0 0 0 3)	;change 4 to 3
;;; Entête du tableau
  (vla-setText TblObj 0 0 "TABLEAU DE NOMENCLATURE DES BLOCS")
  (setq j	-1
        header_lsp (list "N°" "MARQUE" "NOM DES BLOCS" "REFERENCE" "QTES" "BLOCS")
  )
  ;;;;;;;;;;;;;;;;;;;;;;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 tyty lst_blk1
  (setq	blk_name (nth 0 tyty) j	 -1)
  (mapcar '(lambda (x) (vla-setText TblObj row (setq j (1+ j)) x))
	  (list i (nth 2 tyty) blk_name (nth 3 tyty) (nth 1 tyty))
  )
;;;;;Colonne 6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;REMOVE "CAI"
  (vla-SetBlockTableRecordId
    TblObj
    row
    5
    (GetObjectID (vla-item blks blk_name))
    :vlax-true
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;CENTRAGES CELLULES
  (vla-SetCellAlignment TblObj row 0 5)
  (vla-SetCellAlignment TblObj row 1 4)
  (vla-SetCellAlignment TblObj row 2 4)
  (vla-SetCellAlignment TblObj row 3 4)
  (vla-SetCellAlignment TblObj row 4 5)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;CHANGE 3 TO 2
  (setq	row (1+ row)
	i   (1+ i)
  )
)
;;;    (VLA-SETTEXT TBLOBJ ROW 1 "TOTAL") ;edit
;;;    (VLA-SETTEXT TBLOBJ ROW 2 TOTAL) ;edit
;;;    (vla-SetCellAlignment TblObj row 1 7) ;edit
;;;    (vla-SetCellAlignment TblObj row 2 9) ;edit
(vla-put-regeneratetablesuppressed TblObj :vlax-false)
(vlax-release-object TblObj)
)
(princ)
;******************fin de tabm

Facilo · ‎11-01-2016

Hello, the blocks BOM table now works with dynamic blocks. I'll put it in the post if it can be useful to someone.

;**********************************************************
;******************* DEBUT TABM ***************************
;
; free lisp from cadviet.com
;
; Altered by Greg Battin 1/10/2011 for english use
;
; Find replace 10 with 8
;
;  By : Gia Bach, gia_bach @  www.CadViet.com
;
;  Modifie le 11/09/2014 par CHCTB pour ASTEM @CHCTB
;  Modifié le 01/11/2016 par hpinchon ASTEM

;*************** Fonction liste blocs dynamiques
(defun Fdxf (entite / lstdxf)			  ; l'argument et la variable
  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq lstdxf (entget entite))
    (progn
      ;;; definition du nom vba de l'entite
      (setq Vba-ent (vlax-ename->vla-object entite))
      ;;; Si cennte entité est un bloc dynamique 
      (if (= (vla-get-IsDynamicBlock Vba-ent) :vlax-true)
	;;; récupération du effectivename et ajout à la lstdxf
	(progn
	  (setq lstdxf (vla-get-effectivename Vba-ent))
	)
  (setq lstdxf (cdr (assoc 2 (entget ent))))
      )
    )
  lstdxf					  ; le rappel de la variable sans rien sert de valeur de retour de la fonction
)

;**********************************************************
;*** Retourner une valeur à la fin d'une fonction
(defun c_return (v_value) v_value)

;**********************************************************
;*** Fonction pour Rechercher la valeur d'un attribut
(defun rec_val_att (n_ent etiq / val_att test test1)
  (while (/= test "SEQEND")
    (if	(/= test1 etiq)
      (progn
	(setq n_ent (entnext n_ent))
	(setq test (cdr (assoc 0 (entget n_ent))))
	(setq test1 (cdr (assoc 2 (entget n_ent))))
      )
      (progn
	(setq test "SEQEND")
	(setq val_att (cdr (assoc 1 (entget n_ent))))
      )
    )
  )
  (c_return val_att)
)

;**********************************************************
;*** Fonction pour Remplacer valeur d'un attribut
(defun rem_att (n_ent etiq valeur / ent1 test test1)
  (while (/= test "SEQEND")
    (if	(/= test1 etiq)
      (progn
	(setq n_ent (entnext n_ent))
	(setq test (cdr (assoc 0 (entget n_ent))))
	(setq test1 (cdr (assoc 2 (entget n_ent))))
      )
      (progn
	(setq test "SEQEND")
	(setq ent1 (entget n_ent))
	(setq ent1 (subst (cons 1 valeur) (assoc 1 ent1) ent1))
	(entmod ent1)
      )
    )
  )
)

;**********************************************************
;*** Fonction pour trouver la largeur d'un texte
(defun TxtWidth	(val h msp / txt minp maxp)
  (vl-load-com)  
  (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))
  )
)

;**********************************************************
;*** Fonction pour créer un style de tableau
(defun GetOrCreateTableStyle (tbl_name	  /	      name
			      namelst	  objtblsty   objtblstydic
			      tablst	  txtsty
			     )
  (vl-load-com)
  (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)
)

;**********************************************************
;*** Processeur 64
(defun GetObjectID (obj)
  (vl-load-com)
  (if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
    (vlax-invoke-method *util 'GetObjectIdString obj :vlax-false)
    (vla-get-Objectid obj)
    )
)


(defun C:TABM (/ ss refs lst ele ins tbl row lstdxf bdn)

;**************** création du jeu de sélection
    (initget "Collection Objet Sélection")
  (setq kw (getkword "\nChoisir une option [Collection/Objet/Sélection] < Sélection >: "))
  (or *acdoc*
      (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
  )
  (setq blocks (vla-get-Blocks *acdoc*))
  (setq liref nil)
  (setq parnombloc1 (getcfg "APPDATA/PARNOMBLOC1"))
  (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)
    )
  )
 ;***********************************************
  (cond
    ((= kw "Objet")
     (if
       (setq
         obj
          (car
            (entsel "\nSélectionnez l'objet délimitant la sélection: ")
          )
       )
        (if (member (cdr (assoc 0 (entget obj)))
                    '("CIRCLE" "ELLIPSE" "LWPOLYLINE")
            )
          (setq ss (SelByObj obj "WP" '((0 . "INSERT"))))
          (princ "\nEntité non valide.")
        )
        (princ "\nAucune entité sélectionnée.")
     )
    )
    ((= kw "Collection")
      (setq ss  (ssget "_X" '((0 . "INSERT")))
            col T
      )
    )
    (T (setq ss (ssget '((0 . "INSERT")))))
  )
  (if ss
    (setq liref
           (mapcar '(lambda (x)
                      (setq x (vlax-ename->vla-object x))
                      (if (vlax-property-available-p x 'EffectiveName)
                        (vla-get-EffectiveName x)
                        (vla-get-Name x)
                      )
                    )
                   (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
           )
    )
    (setq liref '())
  )
(setq sstoto ss)
  (if ss
    (progn
      (vlax-for x (setq ss (vla-get-ActiveSelectionSet *acdoc*))
        (or (vlax-property-available-p x 'Path)
            (setq refs
                   (cons
                     (cons
                       (vla-get-EffectiveName x)
                       (gc:GetVisibilityState x)
                     )
                     refs
                   )
            )
        )
      )
      (vla-delete ss)
    )
  )
  (foreach n refs
    (setq lst (if (setq ele (assoc n lst))
                (subst (cons (car ele) (1+ (cdr ele))) ele lst)
                (cons (cons n 1) lst)
              )
    )
  )

  ;*****************************Charger les fonctions Visual LISP
  (vl-load-com)
  ;*******************************Calcul la longeur maxi des noms de blocs puis création liste lst_blk1 ---> Nom Bloc - Quantité Bloc - Marque - Reference
  (setq i    -1   len0  8 ) ;;; longeur par defaut
  (setq lst_blk nil lst_blk1 nil)
  (while (setq ent (ssname sstoto (setq i (1+ i))))
    (setq ent (ssname sstoto i))			  ; ent est l'entité place en position i du selection-set ss
    (setq blk_name (Fdxf ent))			  ; je stoke dans lstdxf la valeur de retour de la fonction fdxf pour l'élément ent
    (if (> (strlen blk_name) len0)
      (setq str  blk_name
            len0 (strlen blk_name)
      )
      )
    (setq Ent_Marque (rec_val_att ent "MARQUE"))
    (setq Ent_Reference (rec_val_att ent "REFERENCE"))
    (if (not (assoc blk_name lst_blk1))
    ;;; Si le bloc n'existe pas dans la liste
      (progn
        (setq toto (list blk_name 1 Ent_Marque Ent_Reference))
        (setq lst_blk1 (cons toto lst_blk1))
      )
    ;;; Si le bloc existe dans la liste
    ;;; Vérification si la marque est la même
      (progn
        (setq toto2 nil)
        (foreach n lst_blk1
          (setq crit0 (nth 0 n))
          (setq crit2 (nth 2 n))
          (setq crit3 (nth 3 n))
          (if (and (= crit0 blk_name) (= crit2 Ent_Marque) (= crit3 Ent_Reference))
            (setq toto2 n)
          )
        )
        ;;; Si la marque est la même, incrémenter la quantité
	(if toto2
          (setq lst_blk1 (subst (list blk_name
                                     (1+ (nth 1 toto2))
                                      (nth 2 toto2)
                                      (nth 3 toto2)
                                )
                                toto2
                                lst_blk1
                         )
          )
        ;;; Sinon, ajouter à la liste lst_blk1
          (progn
            (setq toto (list blk_name 1 Ent_Marque Ent_Reference))
            (setq lst_blk1 (cons toto lst_blk1))
          )
        )
      )
    )
    ;;; à effacer 
    (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
	     )
      )
    )
    )
  ;;; Tri la liste des blocs en fonction de la marque puis nom du bloc
(setq lst_blk1 (vl-sort lst_blk1 '(lambda (a B)
            (if (eq (caddr a) (caddr B))
                (if (eq (car a) (car b))
                (< (cadddr a) (cadddr B))
                (< (car a) (car b))
                )
            (< (caddr a) (caddr B))
            )
        )
    )
)
;;; à effacer 
  (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)))))

;;; Calcul hauteur de texte dans le tableau
  (or *h* (setq *h* (* (getvar "dimtxt") (getvar "dimscale"))) )
  (initget 6)
  (setq h (getreal (strcat "\nHauteur du text <" (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 (* 8 (TxtWidth " " h msp)) ;largeur de N°
	width  (* 0.8 (TxtWidth "Hauteur du text" h msp)) ; largeur globale
	height (* 2 h)
  )
  (setq width2 width);***************largeur Marque
  (if str
    (setq width3 (* 1.2 (TxtWidth (strcase str) h msp))) ;***************largeur nom du bloc
    (setq width3 width)
  )
  (setq width4 (1+ width));***************largeur Référence
  (setq width5 width);********************largeur Quantités
  (setq width6 width);********************largeur Image du bloc
  (if (> h 3)
    (setq width	 (* (fix (/ width 8)) 8)
	  width1 (* (fix (/ width1 8)) 8)
	  width2 (* (fix (/ width2 8)) 8)
	  width3 (* (fix (/ width2 8)) 8)
	  width4 (* (fix (/ width2 8)) 8)
	  width5 (* (fix (/ width2 8)) 8)
	  width6 (* (fix (/ width2 8)) 8)
	  height (* (fix (/ height 5)) 5)
    )
  )
;;; Création style du tableau puis création tableau
  (GetOrCreateTableStyle "tableau espace objet")
  (setq	pt     (getpoint "\nPlacer la tableau:")
	TblObj (vla-addtable
		 msp                  ;************Espace objet
		 (vlax-3d-point pt)
		 (+ (length lst_blk1) 2);**********Nombre de lignes
		 6                      ;**********Nombre de Colonne
		 height                 ;**********Hauteur de la ligne par defaut
		 width                  ;**********Largeur de la ligne par defaut
	       )
  )
  (vla-put-regeneratetablesuppressed TblObj :vlax-true)
  (vla-SetColumnWidth TblObj 0 width1);************largeur de N°
  (vla-SetColumnWidth TblObj 1 width2);************largeur Marque
  (vla-SetColumnWidth TblObj 2 width3);************largeur nom du bloc
  (vla-SetColumnWidth TblObj 3 width4);************largeur Référence
  (vla-SetColumnWidth TblObj 4 width5);************largeur Quantités
  (vla-SetColumnWidth TblObj 5 width6);************largeur Image du bloc

  (vla-put-vertcellmargin TblObj (* 0.4 h))
  (vla-put-horzcellmargin TblObj (* 0.4 h))
  (mapcar '(lambda (x) (vla-setTextHeight TblObj x h))
	  (list acTitleRow acHeaderRow acDataRow)
  )
  (mapcar '(lambda (x) (vla-setAlignment TblObj x 5))
	  (list acTitleRow acHeaderRow acDataRow)
  )
  (vla-MergeCells TblObj 0 0 0 3)	;change 4 to 3

;;; **************************Entête du tableau
  (vla-setText TblObj 0 0 "TABLEAU DE NOMENCLATURE DES BLOCS")
  (setq j	-1
        header_lsp (list "N°" "MARQUE" "NOM DES BLOCS" "REFERENCE" "QTES" "BLOCS")
  )
  ;;;;;;;;;;;;;;;;;;;;;;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 tyty lst_blk1
  (setq	blk_name (nth 0 tyty) j	 -1)
  (mapcar '(lambda (x) (vla-setText TblObj row (setq j (1+ j)) x))
	  (list i (nth 2 tyty) blk_name (nth 3 tyty) (nth 1 tyty))
  )
;******************************Colonne 6
    (vla-SetBlockTableRecordId TblObj row 5 (GetObjectID (vla-item blks blk_name)) :vlax-true)
;******************************CENTRAGES CELLULES
  (vla-SetCellAlignment TblObj row 0 5)
  (vla-SetCellAlignment TblObj row 1 4)
  (vla-SetCellAlignment TblObj row 2 4)
  (vla-SetCellAlignment TblObj row 3 4)
  (vla-SetCellAlignment TblObj row 4 5)
;******************************CHANGE 3 TO 2
  (setq	row (1+ row)
	i   (1+ i)
  )
)
(vla-put-regeneratetablesuppressed TblObj :vlax-false)
(vlax-release-object TblObj)

(prompt "\n(C) Facilo thanks to CHCTB & Autodesk\n")(princ)
)
(princ)


;; gc:GetVisibilityState
;; Retourne l'état de visibilité d'un bloc dynamique ou nil
(defun gc:GetVisibilityState (blk / state)
  (if (= (vla-get-IsDynamicblock blk) :vlax-true)
    (foreach p (vlax-invoke blk 'GetDynamicBlockProperties)
      (if (= (type (car (vlax-get p 'AllowedValues))) 'STR)
        (setq state (vlax-get p 'Value))
      )
    )
  )
  state
)
;******************fin de tabm

lisp for sorting a list of selected block

lisp for sorting a list of selected block

Forums Links

Post to forums