Aller au contenu
Problème de lien d'inscription (résolu ?) ×

Transcription du lisp TABM sur Zwcad ??

fredel

Par fredel
dans ZWCAD

 Partager

Messages recommandés

fredel Newbie

fredel

Posté(e)
Posté(e)

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

 

Lien vers le commentaire
Partager sur d’autres sites
lecrabe Experienced

lecrabe

Posté(e)
Posté(e)

Hello

 

1) DESOLE mais DEJA ton VLisp ne fonctionne pas sur AutoCAD !

Commande: TABM
Choisir une option [Collection/Objet/Selection] < Selection >:
Sélectionner des objets: Régénération du modèle.
Spécifiez le coin opposé: 61 trouvé(s)
Sélectionner des objets:
Hauteur du text <1.00> :
Placer la tableau:; erreur: Erreur Automation Entrée incorrecte
Commande:

 

2) As tu la version originale en US/English operationnelle ?

 

Bye, lecrabe

 

Autodesk Expert Elite Team

Lien vers le commentaire
Partager sur d’autres sites
bonuscad Enthusiast

bonuscad

Posté(e)
Posté(e)

J'ai trouvé l'original ICI c'est exactement le même...

Pas très bien monté ce code! Les variables ne sont pas déclarées en locale (j'ai pas corrigé)

Les fonctions (defun TxtWidth et (defun GetOrCreateTableStyle sont définis deux fois. Si la première est identique, la seconde est différente mais le lisp fonctionne quand même quelque soit la fonction choisie (j'en ai commentée une au hasard).

Il manquait une fonction (defun SelByObj  pour l'option "Objet", j'ai pris celle de (gile) car une autre fonction de (gile) était déjà présente.

J'ai corrigé la ligne :

(list i (nth 2 tyty) blk_name (nth 3 tyty) (nth 1 tyty))

par (situé à la ligne 516):

(subst "" nil (list i (nth 2 tyty) blk_name (nth 3 tyty) (nth 1 tyty)))

Qui pour mon test succinct à fonctionné, mais cette correction peut se révéler insuffisante... à voir

Voilà le code corrigé sommairement, censé fonctionner sous autocad: 

;**********************************************************
;******************* 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
)
;;; SelByObj -Gilles Chanteau- 10/06/2006
;;; Creates a selection set from an object (circle ellipse or closed
;;; lwpolyline) by Window polygon or Crossing Polygon.
;;;
;;; Arguments :
;;; - ent: ename or vla-object
;;; - opt: selection mode (Cp or Wp)
;;; - fltr: selection filter or nil
;;;
;;; Added a ZoomExtents to select objects out of the viewport (07/20/2007)

(defun SelByObj	(ent opt fltr / obj dist n lst prec dist p_lst ss)
  (vl-load-com)
  (if (= (type ent) 'ENAME)
    (setq obj (vlax-ename->vla-object ent))
    (setq obj ent
	  ent (vlax-vla-object->ename ent)
    )
  )
  (cond
    ((member (vla-get-ObjectName obj) '("AcDbCircle" "AcDbEllipse"))
     (setq dist	(/ (vlax-curve-getDistAtParam
		     obj
		     (vlax-curve-getEndParam obj)
		   )
		   50
		)
	   n	0
     )
     (repeat 50
       (setq
	 lst
	  (cons
	    (trans
	      (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
	      0
	      1
	    )
	    lst
	  )
       )
     )
    )
    ((and (= (vla-get-ObjectName obj) "AcDbPolyline")
	  (= (vla-get-Closed obj) :vlax-true)
	  )
     (setq p_lst (vl-remove-if-not
		   '(lambda (x)
		      (or (= (car x) 10)
			  (= (car x) 42)
		      )
		    )
		   (entget ent)
		 )
     )
     (while p_lst
       (setq
	 lst
	  (cons
	    (trans (append (cdr (assoc 10 p_lst))
				 (list (cdr (assoc 38 (entget ent))))
			 )
			 ent
			 1
	    )
	    lst
	  )
       )
       (if (/= 0 (cdadr p_lst))
	 (progn
	   (setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
		 dist (/ (- (if	(cdaddr p_lst)
			      (vlax-curve-getDistAtPoint
				obj
				(trans (cdaddr p_lst) ent 0)
			      )
			      (vlax-curve-getDistAtParam
				obj
				(vlax-curve-getEndParam obj)
			      )
			    )
			    (vlax-curve-getDistAtPoint
			      obj
			      (trans (cdar p_lst) ent 0)
			    )
			 )
			 prec
		      )
		 n    0
	   )
	   (repeat (1- prec)
	     (setq
	       lst (cons
		     (trans
			 (vlax-curve-getPointAtDist
			   obj
			   (+ (vlax-curve-getDistAtPoint
				obj
				(trans (cdar p_lst) ent 0)
			      )
			      (* dist (setq n (1+ n)))
			   )
			 )
			 0
			 1
		       )
		     lst
		   )
	     )
	   )
	 )
       )
       (setq p_lst (cddr p_lst))
     )
    )
  )
  (cond
    (lst
     (vla-ZoomExtents (vlax-get-acad-object))
     (setq ss (ssget opt lst fltr))
     (vla-ZoomPrevious (vlax-get-acad-object))
     ss
    )
  )
)
;**********************************************************
;*** 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))
  (subst "" nil (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

 

Choisissez un travail que vous aimez et vous n'aurez pas à travailler un seul jour de votre vie. - Confucius

Lien vers le commentaire
Partager sur d’autres sites
  • 3 semaines 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
 Partager
Aller sur la liste des sujets
×
×
  • 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é