ATT to Mleader

[nG! Hebus]

Bonjour,

 

Est ce qu'une bonne ame pourrait faire un mix entre ces deux lisp :

 

(defun c:BNameLabel (/ ent entl obj)
 (cond ((not (setq ent (car (entsel "\nSelect block: ")))))
       ((not (eq (cdr (assoc 0 (entget ent))) "INSERT")) (princ "\nInvalid object!"))
       ((setq pt (getpoint "\nSpecify first point: "))
        (setq entl (entlast))
        (vl-cmdf "_.mleader" "_non" pt "\\")
        (while (eq (logand 1 (getvar 'CMDACTIVE)) 1) (vl-cmdf ""))
        (if (not (equal entl (setq entl (entlast))))
          (vla-put-textstring
            (vlax-ename->vla-object entl)
            (vlax-get-property
              (setq obj (vlax-ename->vla-object ent))
              (if (vlax-property-available-p obj 'EffectiveName)
                'EffectiveName
                'Name
              )
            )
          )
        )
       )
 )
 (princ)
)
(vl-load-com)
(princ)

 

;; 
;; https://autocadtips1.com/2011/04/26/autolisp-attribute-to-text-mtext/
;; 
;; Routine: ATT2MT - Convert Attribute to MText ...
;; 
;; The routine ATT2MT asks for text height ... 
;; Then you can select MANY Blocks with Attributes
;; ALL Attributes will be written as a MText of N Lines
;; 

;;;;;; 
:;;;; Written by Smirnoff
;;;;;  
;;;;; Found @ http://www.cadtutor.net/forum/showthread.php?56833-Display-ATTRIBUTES-as-Text-from-multiple-blocks&highlight=attmt
;;;;;  


(defun c:Att2MT(/ aDoc aSp oSiz bSet aLst cLst tStr nTxt bCtr Tags TextInsert)

; *****************************************************************************

; ADJUSTMENTS ;

; (Modify it to adjust for your own requirements) ;

; *****************************************************************************

(setq Tags T) ; - if T add tags to MText if Nil not

(setq TextInsert T) ; - Text insertion point. If T center of Bounding Box

; of block, if Nil Block insertion point.

; ******************************* END ADJUSTMENTS *****************************

(vl-load-com)

(defun GetBoundingCenter (vlaObj / blPt trPt cnPt)

(vla-GetBoundingBox vlaObj 'minPt 'maxPt)

(setq blPt(vlax-safearray->list minPt)

trPt(vlax-safearray->list maxPt)

cnPt(vlax-3D-point

(list

(+(car blPt)(/(-(car trPt)(car blPt))2))

(+(cadr blPt)(/(-(cadr trPt)(cadr blPt))2))

0.0

); end list

); end vlax-3D-point

); end setq

); end of GetBoundingCenter

(if(not attmt:Size)(setq attmt:Size(getvar "TEXTSIZE")))

(setq oSiz attmt:Size

attmt:Size(getreal(strcat "\nText size <"(rtos attmt:Size)">: ")))

(if(null attmt:Size)(setq attmt:Size oSiz))

(setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object)))

(if(= 1(vla-get-ActiveSpace aDoc))

(setq aSp(vla-get-ModelSpace aDoc))

(setq aSp(vla-get-PaperSpace aDoc))

); end if

(princ "\n<<< Select Text to extract Attributes to MText >>> ")

(if(setq bSet(ssget '((0 . "INSERT"))))

(progn

(foreach b(mapcar 'vlax-ename->vla-object

(vl-remove-if 'listp

(mapcar 'cadr(ssnamex bSet))))

(setq aLst '()

tStr "") ; end setq

(if TextInsert

(setq bCtr(GetBoundingCenter B))

(setq bCtr(vla-get-InsertionPoint B))

); end if

(if(= :vlax-true(vla-get-HasAttributes B))

(progn

(setq aLst

(mapcar '(lambda (a)

(list (vla-get-TagString a)

(vla-get-TextString a)))

(vlax-safearray->list

(vlax-variant-value(vla-GetAttributes B)))))

(foreach i(reverse aLst)

(setq tStr(strcat tStr(if Tags(strcat(car i) ": ")"")(last i)"\\P"))

); end foreach

(if(/= "" tStr)

(progn

(setq nTxt(vla-AddMText aSp bCtr (* attmt:Size 30.0) tStr))

(vla-put-Height nTxt attmt:Size)

); end progn

); end if

); end progn

); end if

); end foreach

(vla-EndUndoMark aDoc)

); end progn

); end if

(princ)

); end of c:att2mt 

 

le but est d'extraire un attribut toujours le même, nommé "REPERE", dans un bloc.

Merci d'avance pour ceux qui passeront du temps dessus.

 

Cordialement

 

 

PS : Sujet de base

[Patrick_35]

Salut

 

A partir de ce lisp

(defun c:atm(/ att doc ent grr new pt1 pt2 mlead gc:3dPointListToVariant)
 (defun gc:3dPointListToVariant (lst)
   (vlax-make-variant
     (vlax-safearray-fill
(vlax-make-safearray
         vlax-VbDouble
  (cons 0 (1- (* 3 (length lst))))
)
(apply 'append lst)
     )
   )
 )

 (defun mlead(pt2 / pts)
   (setq pts (gc:3dPointListToVariant (list (trans pt1 1 0) (trans pt2 1 0))))
   (if new
     (progn
(vla-setleaderlinevertices new 0 pts)
(vla-setdoglegdirection new 0 (vlax-3D-point (trans (list (if (> (car pt2) (car pt1)) 1 -1) 0 0) 1 0 T)))
(vla-update new)
     )
     (progn
(setq new (vla-addmleader (vla-get-modelspace doc) pts 0))
(vla-put-textstring new att)
(vla-rotate new (vlax-3d-point (trans pt2 1 0))
		(angle (trans '(0 0 0) 1 0) (trans '(1 0 0) 1 0))
)
     )
   )
 )

 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark doc)
 (while (setq ent (entsel "\nSélectionnez un bloc : "))
   (and (setq ent (vlax-ename->vla-object (car ent)))
 (eq (vla-get-objectname ent) "AcDbBlockReference")
 (eq (vla-get-hasattributes ent) :vlax-true)
 (setq att (vl-remove-if-not '(lambda(x)(eq (strcase (vla-get-tagstring x)) "REPERE")) (vlax-invoke ent 'getattributes)))
 (setq att (vla-get-textstring (car att)))
 (setq pt1 (getpoint "\n1er point : "))
 (setq new nil pt2 pt1)
 (princ "\n2em point : ")
     (while (and pt2
	  (setq grr (grread t 9 0))
	  (vl-position (car grr) '(2 3 5))
     )
(cond
	  ((= (car grr) 3)(setq pt2 nil))
  ((= (car grr) 5)(mlead (cadr grr)))
	  (T  (setq pt2 nil)(if new (vla-delete new)))
)
     )
   )
 )
 (vla-endundomark doc)
 (princ)
)

 

@+

[nG! Hebus]

Salut Patrick,

 

Merci c'est nickel, juste est ce qu'il est possible de mettre le placer suivant le SCU courant et non le SCUg?

 

Je l'aurai bien tenté mais je ne sais pas retrouvé le bout de LISP qui fait que tu le bloque sur le SCUg.

 

Merci d'avance

[Patrick_35]

Le lisp travail avec le scu courant ???

 

@+

[nG! Hebus]

Bah non le SCU est en général...

 

même en le changeant à la main :unsure:

 

je met un screencast pour montrer des fois que je fait mal quelque chose.

 

J'ai fait le test avec "BNameLabel" est pas de soucis de SCU, mais avec ATM soucis de SCU, je ne comprend pas trop d'ou ça viens, SNIIFF!

 

Lien screencast : https://knowledge.autodesk.com/community/screencast/08f35630-6e01-40df-9431-231507fd7a33

[Patrick_35]

Je ne vois pas les résultats avec le screencast.

 

Tu peux donner un exemple avec le résultat attendu.

 

@+

[nG! Hebus]

Alors en gros, cela doit donner environ ça :

 

http://image.noelshack.com/fichiers/2016/34/1471878183-capture.jpg

 

Je met mes Mleader dans l'espace objet, le reste est issue d'une extraction de données et du LISP TUY de usegomme.

[Patrick_35]

Ok, j'ai compris. C'est le Z qui reste à 0 malgré les bonnes coordonnées.

Reste à comprendre pourquoi.

 

@+

[Patrick_35]

Salut

 

Le lisp corrigé

(defun c:atm(/ att doc ent grr new pt1 pt2 mlead)
 (defun mlead(pt2 / pts)
   (setq pt2 (list (car pt2) (cadr pt2) (caddr pt1))
  pts (append (trans pt1 1 0) (trans pt2 1 0))
   )
   (if new
     (progn
(vlax-invoke new 'setleaderlinevertices 0 pts)
(vla-setdoglegdirection new 0 (vlax-3D-point (trans (list (if (> (car pt2) (car pt1)) 1 -1) 0 0) 1 0 T)))
(vla-update new)
     )
     (progn
(setq new (vlax-invoke (vla-get-modelspace doc) 'addmleader pts 0))
(vla-put-textstring new att)
(vla-rotate new (vlax-3d-point (trans pt2 1 0))
		(angle (trans '(0 0 0) 1 0) (trans '(1 0 0) 1 0))
)
(setq pts (vlax-invoke new 'getleaderlinevertices 0))
(vlax-invoke new 'move	(trans (list 0.0 0.0 (last  pts)) 1 0)
			(trans (list 0.0 0.0 (caddr pt2)) 1 0)
)
     )
   )
 )

 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark doc)
 (while (setq ent (entsel "\nSélectionnez un bloc : "))
   (and (setq ent (vlax-ename->vla-object (car ent)))
 (eq (vla-get-objectname ent) "AcDbBlockReference")
 (eq (vla-get-hasattributes ent) :vlax-true)
 (setq att (vl-remove-if-not '(lambda(x)(eq (strcase (vla-get-tagstring x)) "REPERE")) (vlax-invoke ent 'getattributes)))
 (setq att (vla-get-textstring (car att)))
 (setq pt1 (getpoint "\n1er point : "))
 (setq new nil pt2 pt1)
 (princ "\n2em point : ")
     (while (and pt2
	  (setq grr (grread t 9 0))
	  (vl-position (car grr) '(2 3 5))
     )
(cond
	  ((= (car grr) 3)(setq pt2 nil))
  ((= (car grr) 5)(mlead (cadr grr)))
	  (T  (setq pt2 nil)(if new (vla-delete new)))
)
     )
   )
 )
 (vla-endundomark doc)
 (princ)
)

 

@+

[nG! Hebus]

Salut Patrick,

 

Toujours le même soucis...

 

et en partant de ce LISP?

 

(defun c:BNameLabel (/ ent entl obj)
 (cond ((not (setq ent (car (entsel "\nSelect block: ")))))
       ((not (eq (cdr (assoc 0 (entget ent))) "INSERT")) (princ "\nInvalid object!"))
       ((setq pt (getpoint "\nSpecify first point: "))
        (setq entl (entlast))
        (vl-cmdf "_.mleader" "_non" pt "\\")
        (while (eq (logand 1 (getvar 'CMDACTIVE)) 1) (vl-cmdf ""))
        (if (not (equal entl (setq entl (entlast))))
          (vla-put-textstring
            (vlax-ename->vla-object entl)
            (vlax-get-property
              (setq obj (vlax-ename->vla-object ent))
              (if (vlax-property-available-p obj 'EffectiveName)
                'EffectiveName
                'Name
              )
            )
          )
        )
       )
 )
 (princ)
)
(vl-load-com)
(princ)

 

 

Car aucun soucis avec celui ci, mais je n'arrive pas à voir comment le modifier :huh:

 

 

j'ai essayé un truc du genre :

 

(defun c:BNameLabel (/ ent entl obj)
 (cond ((not (setq ent (car (entsel "\nSelect block: ")))))
       ((not (eq (cdr (assoc 0 (entget ent))) "INSERT")) (princ "\nInvalid object!"))
       ((setq pt (getpoint "\nSpecify first point: "))
        (setq entl (entlast))
        (vl-cmdf "_.mleader" "_non" pt "\\")
        (while (eq (logand 1 (getvar 'CMDACTIVE)) 1) (vl-cmdf ""))
        (if (not (equal entl (setq entl (entlast))))
          (vla-put-textstring
            (vlax-ename->vla-object entl)
            (vlax-get-property
              (setq obj (vlax-ename->get-tagstring x)) "REPERE"))
              (if (vlax-invoke ent 'getattributes)
                'getattributes
                'REPERE
              )
            )
          )
        )
       )
 )
 (princ)
)
(vl-load-com)
(princ)

 

Mais ça fonctionne pas :(

[Patrick_35]

Le lisp modifié pour répondre à ta demande

 

(defun c:BNameLabel (/ ent entl obj)
 (cond ((not (setq ent (car (entsel "\nSelect block: ")))))
       ((not (eq (cdr (assoc 0 (entget ent))) "INSERT")) (princ "\nInvalid object!"))
       ((setq pt (getpoint "\nSpecify first point: "))
        (setq entl (entlast))
 (setq att (vl-remove-if-not '(lambda(x)(eq (strcase (vla-get-tagstring x)) "REPERE")) (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)))
        (vl-cmdf "_.mleader" "_non" pt "\\")
        (while (eq (logand 1 (getvar 'CMDACTIVE)) 1) (vl-cmdf ""))
        (if (not (equal entl (setq entl (entlast))))
   (vla-put-textstring (vlax-ename->vla-object entl) (vla-get-textstring (car att)))
        )
       )
 )
 (princ)
)

 

Mais je ne comprends pas. Celui que je t'ai donné devrait fonctionner ?

 

@+

[nG! Hebus]

YEEEEAAAH, merci c'est impec'.

 

Pour ce qui est du premier LISP fournis, je ne comprend pas (j'essaye d'apprendre à lire mais il y a des fonctions que je ne connais pas).

 

Faut que je m'y mette, car à chaque fois je demande de l'aide en LISP...

Je me sens utile sur ce forum seulement quand une personne pose une question sur AutoCAD 3D...

 

Encore merci d'avoir passé du temps ( à qui j'envoi la facture? :P )

[Patrick_35]

Faut que je m'y mette, car à chaque fois je demande de l'aide en LISP...

Ben, tu sais ce qu'il te reste à faire ;)

 

Je me sens utile sur ce forum seulement quand une personne pose une question sur AutoCAD 3D...

Je suis certain qu'il y a d'autres domaines

 

Encore merci d'avoir passé du temps ( à qui j'envoi la facture? :P )

De rien, je ne suis pas contre une bière :D

 

@+

[nG! Hebus]

Tu crois que c'est possible de livrer de la bière?

 

Parce que le 35 c'est pas à coté :P

Pis par ici c'est plutôt le saucisson que la bière (y'a qu'en Belgique qu'on sais brasser :(rires forts): )

[Patrick_35]

Tu crois que c'est possible de livrer de la bière?

Pour ça, il n'y a jamais de problèmes B)

 

Pis par ici c'est plutôt le saucisson que la bière (y'a qu'en Belgique qu'on sais brasser <img src='http://cadxp.com/public/style_emoticons/<#EMO_DIR#>/laugh.gif' class='bbc_emoticon' alt=':(rires forts):' /> )

Sauf que les belges ont été voir les allemands pour alléger leurs bières, mais bon.

Il y a plusieurs pays qui savent brasser, même en France et en Bretagne :)

 

@+

[nG! Hebus]

ho non pas de la bière bavaroise (beurk !)

 

:P

 

Oui je sais y'a une brasserie coopérative pas loin de la ou je suis (la Biére du Pilat, PS: pas la Dune du pilat, la réserve naturelle du Pilat, "un beau p'tit coin ou y fait bon vivre, "raclement de gorge", **crache** ! Pour sur ! :P )

 

Oui les Bretons font même du Cola (Breizh Cola). Je vous envie les galettes et les fest-noz (mes premières cuites)

 

Mais mes Frites me manquent :unsure: ici la patate est pas bonne et c'est cuit dans l'huile végétal... "HOOOooo Friiites, hooo fricadelle, hoooo pluie quotidienne, tu me manque"

 

Sans déconné ici il pleut jamais, j'ai déménagé l'an dernier et y'a pas plu pendant 4 MOIS, c'est quoi cette région, quand y'a plu je suis sortis prendre l'eau...

 

PS : Je suis jamais content :P (Didier sors de ce corps, ho le vilain qui se moque :P )

 

 

 

 

 

**tente de passer la pinte par le Fax**, t'es sur que ça passe, j'ai un doute...Bah si un jour tu fait un saut à Lyon ou que je bouge en Bretagne ;)