Facilo Posté(e) le 9 août 2014 Posté(e) le 9 août 2014 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
Facilo Posté(e) le 2 octobre 2016 Auteur Posté(e) le 2 octobre 2016 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
Facilo Posté(e) le 1 novembre 2016 Auteur Posté(e) le 1 novembre 2016 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
(gile) Posté(e) le 1 novembre 2016 Posté(e) le 1 novembre 2016 ;********************************************************** ;*** Retourner une valeur à la fin d'une fonction (defun c_return (v_value) v_value) :blink: :blink: :blink: Gilles Chanteau - gileCAD - GitHub Développements sur mesure pour AutoCAD
didier Posté(e) le 1 novembre 2016 Posté(e) le 1 novembre 2016 Coucou Sacré assemblage de codes !Est-ce que tu peux fournir un dwg avec les blocs et le tableau réalisé pour qu'on se rende compte de ce qu'il y a à faireS'il te plaît Éternel débutant... Mon site perso : Programmer dans AutoCAD
fredel Posté(e) le 16 novembre 2022 Posté(e) le 16 novembre 2022 Hello, J'essaye de mettre la dernière version de TABM sur zwcad, mais il me laisse ce message suivant : Erreur : incorrect type - nil Si quelqu'un peut m'aider ? Ouvert un topic ici ---> https://cadxp.com/topic/59978-transcription-du-lisp-tabm-sur-zwcad/
Messages recommandé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 compteSe connecter
Vous avez déjà un compte ? Connectez-vous ici.
Connectez-vous maintenant