Aller au contenu

Lisp tableau de liste des blocs avec certains attributs


Facilo

Messages recommandés

Bonjour à tous,

Je cherche comment modifier ce lisp joint qui compte la selection de blocs en sortant un tableau Autocad avec les colonnes suivantes :

colonne 1 : Numéro d’ordre, colonne 2 : nom du bloc, colonne 3 : nombre de blocs identiques, colonne 4 : bloc design.

tri sur nom de bloc

 

modifier pour arriver au résultat suivant :

colonne 1 : Numéro d’ordre, colonne 2 : attribut des blocs « MARQUE » valeurs diverses « A » ou « B » etc… (la marque du constructeur plusieurs marques différentes) , colonne 3 nom du bloc, colonne 4 : attribut des blocs « PRODUIT » valeurs diverses « D » ou « E » etc… (la désignation commerciale du produit plusieurs designation différente), colonne 5 : nombre de blocs identique, colonne 6 : bloc design.

tri 1 sur « MARQUE », puis tri 2 sur nom de bloc, puis tri 3 sur « PRODUIT ».

 

C’est un lisp que nous utilisons tous les jour pour les tableaux de nomenclature de bloc.

Merci de votre aide par avance.

Très cordialement.

Hervé

tabl.lsp

Lien vers le commentaire
Partager sur d’autres sites

  • 2 ans après...

Bonjour à tous,

Ci-joint le lisp pour réaliser un tableau de liste de blocs dans Autocad. ce lisp tri dans un tableau l'attribut "MARQUE", le nom du bloc et l'attribut "REFERENCE". Cependant il ne fonctionne pas avec les blocs dynamiques. Quelqu'un peut-il m'aider à trouver la solution.

Bien cordialement.

;******************* 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

Lien vers le commentaire
Partager sur d’autres sites

  • 5 semaines après...

Bonjour, le tableau de nomenclature de blocs marche maintenant avec les blocs dynamiques. Je vous le met dans le post si cela peut servir à quelqu'un.

;**********************************************************
;******************* 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 15/09/2014 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

Lien vers le commentaire
Partager sur d’autres sites

  • 6 ans après...

Créer un compte ou se connecter pour commenter

Vous devez être membre afin de pouvoir déposer un commentaire

Créer un compte

Créez un compte sur notre communauté. C’est facile !

Créer un nouveau compte

Se connecter

Vous avez déjà un compte ? Connectez-vous ici.

Connectez-vous maintenant
×
×
  • Créer...

Information importante

Nous avons placé des cookies sur votre appareil pour aider à améliorer ce site. Vous pouvez choisir d’ajuster vos paramètres de cookie, sinon nous supposerons que vous êtes d’accord pour continuer. Politique de confidentialité