fredel

Merci, Malheureusement, j'ai fait quelques tentatives à l'aide de ce topic ci-dessous pour convertir les commandes, mais cela ne fonctionne toujours pas sur ZWCAD Est-ce peine perdue, ou y a-t-il une autre approche ?

Hello, Je souhaiterais faire fonctionner ce lisp développé initialement sur autocad sur Zwcad, est-ce qu'il est possible de l'adapter ? Pour le moment, je n'obtiens que le message d'erreur suivant, après avoir retiré les accents sur "sélectionner" : Erreur : incorrect type - nil ;********************************************************** ;******************* 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

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/

:mellow: J'ai tellement pris l'habitude de piocher des textes existants, puis de les modifier, sans les créer que j'ai oublié qu'il y avait cette variable.

Hello Gile, En fait j'ai utilisé totalperim qui fonctionne bien. Je teste aussi le lisp et je vois que j'ai un problème avec la taille du texte. Est-il possible de le paramétrer? j'utilise en général une taille 50 en arial et la couleur du texte doit être en "dubloc" T'en remerciant pour le lisp ;)

Merci, Toutefois, pour une polyligne, ca peut aller, mais j'ai plusieurs plans avec environs 50 à 100 polylignes à mesurer. D'où mon souhait qu'en deux clics je puisse afficher la longueur en mètre chaque polyligne. Un peu comme le lisp "Totalarea" de Gile ou Patrick [EDIT] La réponse est quelque peu dans ma question. Je viens juste de tester le lisp "Totalperim" de Gile. Mais si il y a une petite amélioration avec l'application des couleurs sur le texte en correspondance avec la polyligne, mon bonheur sera maximal. B)

Bonjour, Je souhaiterai avoir un lisp qui, en cliquant sur une polyligne, et en cliquant après à coté, place une ligne comprenant la longueur de la polyligne en m. (je travaille sur des formats en mm) et ce texte doit avoir la même couleur que la polyligne? Est ce possible ? En vous remerciant par avance ;)