zebulon_

Bonjour, (tblnext "BLOCK" (= 0 i)) bien sûr... plutôt que de faire exprès un (tblnext "BLOCK" T) juste pour le premier. On en apprend tous les jours. Vous me direz : "c'est le but de ces challenges !" A la course au benchmark, je suis 2ème :) ou dernier :(, suivant le niveau d'imbrication. Mais j'étais déjà content que ça marche. Si en plus ça marche vite, c'est pas exprès. Merci Amicalement Vincent

Bonjour, Allez ! Je me lance... La recherche se fait dans la table des blocs. Je n'ai pas fait de filtre pour supprimer les xrefs. (defun listprembloc (/ lst NEXT PREMS) ;; la liste des premiers éléments de chaque bloc de la table (if (setq PREMS (tblnext "BLOCK" T)) (setq lst (list (cdr (assoc -2 PREMS)))) ) (while (setq NEXT (tblnext "BLOCK")) (setq lst (cons (cdr (assoc -2 NEXT)) lst)) ) lst ) (defun successeur (e / succlst a) ;; renvoie la liste des successeurs de e (if (not e) (setq succlst (listprembloc)) (while e (setq a (entget e)) (if (= (cdr (assoc 0 a)) "INSERT") (progn (setq a (tblsearch "BLOCK" (cdr (assoc 2 a)))) (setq succlst (cons (cdr (assoc -2 a)) succlst)) ) ) (setq e (entnext e)) ) ) succlst ) (defun profondeur (e / slst s lh) (setq slst (successeur e)) (foreach s slst (setq lh (cons (profondeur s) lh)) ) (if slst (+ 1 (apply 'max lh)) ;; le maximum de la hauteur des successeurs + 1 0 ;; 0 quand il n'y a plus de successeur ) ) (defun c:blimb (/) (alert (itoa (profondeur nil))) ) J'ai eu un peu de mal et j'espère que ce que j'ai écrit est correct. Je n'ai pas trop l'habitude d'utiliser la récursivité (et c'est un tort ;)), ni de manipuler des arbres. Amicalement Vincent [Edité le 1/12/2009 par zebulon_]

Bonjour, Au sujet des blocs, est-ce qu'on peut se contenter de lire la table des blocs et de prendre ceux qui s'y trouve ou faut-il faire un (ssget "_X" '((0 . "INSERT")))) pour ne prendre que ceux qui sont insérés dans le fichier ? Amicalement Vincent

Merci

Bonsoir, je suis un peu plus lent et j'ai pondu ceci (defun c:selpoly (/ AcDoc ss KEY I J e eobj typ coords nbvtx) (vl-load-com) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) ) (setq ss (ssget '((0 . "*POLYLINE")))) (if ss (progn (if (not selpolyNB) (setq selpolyNB 2)) (if (not selpolyCRIT) (setq selpolyCRIT "=")) (if (not selpolyCOL) (setq selpolyCOL 1)) (setq KEY "N") (while KEY (prompt (strcat "\nParamètres courants : NOMBRE SOMMETS " (itoa selpolyNB) ", CRITERE " selpolyCRIT ", COULEUR " (itoa selpolyCOL))) (initget "N T C") (setq Key (Getkword "\ntraiter les polylignes ou [Nombre de sommets/criTère/Couleur] : ")) (cond ((= KEY "N") (setq selpolyNB (getint "\nNombre de sommets : ")) ) ((= KEY "C") (setq selpolyCOL (acad_colordlg selpolyCOL nil)) ) ((= KEY "T") (initget "= <= >=") (setq selpolyCRIT (getkword "\nCritère [=, <=, >=] <=> ")) (if (not selpolyCRIT) (setq selpolyCRIT "=")) ) ) ) ;; while (setq I 0 J 0) (vla-StartUndoMark AcDoc) (repeat (sslength ss) (setq e (ssname ss I)) (setq eobj (vlax-ename->vla-object e)) (setq typ (cdr (assoc 0 (entget e)))) (setq coords (vlax-get eobj 'coordinates)) (if (= typ "LWPOLYLINE") (setq nbvtx (/ (length coords) 2)) (setq nbvtx (/ (length coords) 3)) ) (if ((eval (read selpolyCRIT)) nbvtx selpolyNB) (progn (vla-put-Color eobj selpolyCOL) (setq J (+ J 1)) ) ) (setq I (+ I 1)) ) ;; repeat (alert (strcat "Nombre de polylignes sélectionnées : " (itoa (sslength ss)) "\nNombre de polylignes traitées : " (itoa J))) (vla-EndUndoMark AcDoc) ) ) (princ) ) Cela ressemble à ce qu'à fait Bonuscad. Je voulais juste savoir à quoi correspond le code dxf 70 . 112 (puisque mon ssget est beaucoup plus simpliste, trop sans doute) Amicalement Vincent

Bonjour, pour lancer un lisp pour un ensemble de fichiers dwg, il faut passer par un script (fichier .scr) qui est un simple fichier texte (fait avec notepad) dans lequel tu décris toutes les actions dans l'ordre. _open "C:\rep1\rep2\fichier1.dwg" (load "ChPropTx") chproptxmain _qsave _close _open "C:\rep1\rep2\fichier2.dwg" (load "ChPropTx") chproptxmain _qsave _close ... etc ... Un script se lance avec la commande SCRIPT. Le truc pour avoir la liste des noms de fichiers d'un répertoire est de passer par une antique commande MS-DOS. dir /b > monfichier.scr Comme ça, on a déjà la liste des noms de fichiers dans un fichier .scr qu'il suffit d'éditer pour rajouter les commandes adéquates. Sinon, il y a également un outil beaucoup plus évolué (et dont j'ai donné l'adresse dans mon message précédent). Il s'agit de SAS, qui et qui semble répondre à ta requête. Amicalement Vincent [Edité le 24/11/2009 par zebulon_]

Bonjour, (defun ChPropTx (HT COL / ss) (setq ss (ssget "_X" (list '(8 . "TEXTES") ;; le calque '(0 . "*TEXT") ;; les text et mtext (cons 40 HT) ;; la hauteur ) ) ) (if ss (command "_chprop" ss "" "_c" COL "") ) ) (defun c:ChPropTxMain () (ChPropTx 0.15 1) ;; texte de hauteur 0.15 -> couleur 1 (ChPropTx 0.25 2) ;; texte de hauteur 0.25 -> couleur 2 (ChPropTx 0.35 3) ;; texte de hauteur 0.35 -> couleur 3 ;;; etc (princ) ) Le moyen c'est le script ou mieux SuperAutoScript, ou sas pour les intimes. Amicalement Vincent

Bonjour, Mais que se passe-t-il "à la marge" quand lcomp vaut '(15 5 0) ou alors '(0 1 0) ? Avec une liste non triée et une vérification des limites : (defun PtNear (lis lcomp / RES index) ;; trier la liste selon les abscisses croissantes (setq lis (vl-sort lis '(lambda (x1 x2) (< (car x1) (car x2)) ) ) ) (setq index 0) (while (and (< (car (nth index lis)) (car lcomp)) (< index (length lis))) (setq index (+ index 1)) ) (cond ((zerop index) (alert "x inférieur au premier point") ) ((= index (length lis)) (alert "x supérieur au dernier point") ) (T (setq RES (list (nth (- index 1) lis) (nth index lis))) ) ) RES ) (defun c:PtnearMain () (setq lis '((1 1 0) (8 3 2) (5 6 1) (2 3 1) (9 1 5))) (setq lcomp '(4 5 0)) (setq RES (PtNear lis lcomp)) (if RES (print RES) ) (princ) ) Amicalement Vincent [Edité le 23/11/2009 par zebulon_]

Un soucis de moins qui trotte dans ta tête. A part le soucis de choisir entre les grips et le lisp. Je n'utilise jamais cette façon de faire avec les grips. C'est sans doute un tort, mais cela doit venir du fait que quand j'ai pris en main Autocad (V12), ces fonctionnalités ne devaient pas exister, ou alors on ne m'en avait pas parlé. Après, on a pris ses petites habitudes... on lance la commande puis on sélectionne les objets concernés et pas le contraire. Vous noterez que la solution que je propose ne fonctionne que sur des versions récentes où la commande _rotate permet de faire directement une copie (ce qui est déjà un progrès remarquable). Si vous souhaitez utiliser ricm dans des versions plus anciennes (la version 2004 ne possédait pas encore l'option Copie), il faut adapter le lisp pour lui faire faire une copie avant la rotation. C'est moins évident que ça en à l'air, puisque a priori, on souhaite tourner la copie et pas l'original, or si on fait une duplication du jeu de sélection ss, puis une rotation du jeu précédent (donc du jeu ss) c'est l'original qui tourne et la copie qui reste en place. Amicalement Vincent [Edité le 19/11/2009 par zebulon_]

Bonjour Steven, j'ai regardé ta vidéo et il me semble que tu n'utilises pas l'option "c" (pour copy) de la commande rotation. Tu fais une duplication des objets, puis une rotation avec la sélection précédente. Cela était nécessaire sur d'anciennes versions mais depuis... je ne sais plus... il y a cette option "c" qui évite la duplication préalable. Donc, juste avant de faire "r" (pour référence), il faut taper "c" (pour copier). C'est déjà pas mal, mais cela n'est pas encore une "copie/rotation" multiple. Pour cela je te propose ceci (defun c:ricm (/ ss PTC PT1 PT2 CPT) (setvar "CMDECHO" 0) (prompt "\nRICM") (setq ss (ssget)) (setq PTC (getpoint "\nPoint de rotation : ")) (setq PT1 (getpoint PTC "\nAngle de référence : ")) (setq PT2 nil) (setq CPT 0) (while (/= PT2 "Q") (if (zerop CPT) (progn (initget "Q") (setq PT2 (getpoint PTC "\nSpécifier le second point ou [Quitter] : ")) ) (progn (initget "Q R") (setq PT2 (getpoint PTC "\nSpécifier le second point ou [Quitter/Rétablir] : ")) ) ) (cond ((= PT2 "R") (command "_undo" "1") (setq CPT (- CPT 1)) ) ((= (type PT2) 'LIST) (command "_rotate" ss "" "_non" PTC "_c" "_r" "_non" PTC "_non" PT1 "_non" PT2) (setq CPT (+ CPT 1)) ) (T (setq PT2 "Q")) ) ) (princ) ) Amicalement Vincent

Des aliens ? Que nénni. Il s'agissait bien évidemment de Nicolas Sarkozy. Ne l'a-t-on pas vu en compagnie de Neil Armstrong, sur la Lune en 1969 ? D'ailleurs François Fillion en a pris la photo depuis le module lunaire Apollo. Il faut enfin que la vérité éclate aux yeux du monde concernant ce sujet hautement important et polémique. Cependant, le mystère reste entier : quel était l'usage de ces 12 seaux ? Pourquoi 12 ? (les 12 apôtres, mais Saint Nicolas n'était pas un apôtre - les 12 tribus d'Israël - les 12 travaux d'Hercules ?). Et pourquoi des seaux et non des bouteilles plastiques (développement durable, sans doute) ? Amicalement Vincent [Edité le 16/11/2009 par zebulon_]

et cela renforce mon humilité quand je constate qu'il est possible de résoudre ce problème en 4 lignes, alors qu'il m'en a fallu 30. Allez, pour me consoler, on va dire qu'il n'y a que le résultat qui compte ;) Amicalement Vincent

Ok. Je n'avais bloqué que l'index 0. Il faut aussi bloquer l'index 1, lorsqu'il y a un index 0. L'index 2, lorsqu'il y a un index 1 et un index 0 etc... Dans l'exemple qui nous préoccupe : '(0 1 4 5) 0 et 1 sont bloqués. Or 0 et 1 sont les seuls à être à la bonne position dans la liste. 4 est à la deuxième place et 5 à la troisième. Donc un test avec vl-position devrait pouvoir résoudre le problème. (defun ulist_up (nb lst lsi / NL I) (if (and (/= (vl-position nb lsi) nb) (< NB (length lst))) (progn (setq I 0) (repeat (length lst) (cond ((= I (- NB 1)) (setq NL (cons (nth NB lst) NL)) ) ((= I NB) (setq NL (cons (nth (- NB 1) lst) NL)) ) (T (setq NL (cons (nth I lst) NL))) ) (setq I (+ I 1)) ) (setq NL (reverse NL)) ) (setq NL lst) ) NL ) (defun list_up (lsi lst / I IDX) (setq I 0) (repeat (length lsi) (setq IDX (nth I lsi)) (setq lst (ulist_up IDX lst lsi)) (setq I (+ I 1)) ) lst ) (defun c:poplist () (vl-load-com) (setq lst '("a" "b" "c" "d" "e" "f")) ;;(setq lst '(0 1 2 3 4 5)) (setq lsi '(0 1 4 5)) (list_up lsi lst) ) Amicalement Vincent

Bonjour, pourquoi le "b" ne remonte pas dans ce cas ? Une erreur dans l'énoncé, le ps de Patrick_35 semble le confirmer. (defun ulist_up (nb lst / NL I) (if (and (/= NB 0) (< NB (length lst))) (progn (setq I 0) (repeat (length lst) (cond ((= I (- NB 1)) (setq NL (cons (nth NB lst) NL)) ) ((= I NB) (setq NL (cons (nth (- NB 1) lst) NL)) ) (T (setq NL (cons (nth I lst) NL))) ) (setq I (+ I 1)) ) (setq NL (reverse NL)) ) (setq NL lst) ) NL ) (defun list_up (lsi lst / I IDX) (setq I 0) (repeat (length lsi) (setq IDX (nth I lsi)) (setq lst (ulist_up IDX lst)) (setq I (+ I 1)) ) lst ) (defun c:poplist () ;;(setq lst '("a" "b" "c" "d" "e" "f")) (setq lst '(0 1 2 3 4 5)) (setq lsi '(3 4 5)) (list_up lsi lst) ) Amicalement Vincent [Edité le 13/11/2009 par zebulon_]

Bonjour Rhymone, tu peux peut-être nous partager ton fichier dwg afin de pouvoir le tester, sinon cela va être difficile de te dire ce qui cloche. Amicalement Vincent

Bonjour, Si tu veux créer des fichiers textes, il faut créer le fichier avec open, écrire des lignes dans le fichier avec write-line puis refermer le fichier avec close (defun c:ecrirefichier () (setq f (open "NouveauFichier.txt" "w")) (write-line "Ligne1" F) (write-line "Ligne2" F) (close F) ) La fonction (getfiled Titre défaut ext drapeau) est également intéressante afin de saisir un nom de fichier grâce à une boite de dialogue. Amicalement Vincent

ce n'est pas interdit d'adapter. J'ai dit que c'était similaire, libre à toi de t'en inspirer. Amicalement Vincent

Bonjour, regarde ici . La requête de lecrabe semble être similaire à la tienne. Amicalement Vincent

je pense que lecrabe espérait trouver une commande battman en ligne de commande, ce qui aurait permis d'intervenir sur les modes des attributs d'un bloc sans passer en revue la définition du bloc via vlisp. Amicalement Vincent

Bonsoir, (defun c:AttInvi (/ e eobj) (vl-load-com) (setq e (car (nentsel))) (if (= (cdr (assoc 0 (entget e))) "ATTRIB") (progn (setq eobj (vlax-ename->vla-object e)) (vla-put-visible eobj :vlax-false) ) (alert "Pas un attribut") ) (princ) ) (defun c:AttVisi (/ e eobj LATT ATT) (vl-load-com) (setq e (car (entsel))) (if (= (cdr (assoc 0 (entget e))) "INSERT") (progn (setq eobj (vlax-ename->vla-object e)) (setq LATT (vlax-invoke eobj 'getAttributes)) (foreach ATT LATT (setq REP (vla-put-visible ATT :vlax-true)) ) ) (alert "Pas un bloc") ) (princ) ) Amicalement Vincent

c'est vrai que ça revient souvent. Mais on a du mal a retrouver ses petits sur CadXP (la rançon du succès, sans doute). S'il y avait une FAQ, ce sujet aurait effectivement un certain succès. Amicalement Vincent

tout ce que je connais des bulges, je l'ai appris ici Personnellement, j'en suis à développer des courbes à des endroits non stratégiques... ;) Dommage que le site AfraLisp ne s'affiche bien qu'avec Intenet Explorer et pas avec FireFox (en tout cas chez moi) Amicalement Vincent

(defun getPolySegs (ent / entl p1 pt bulge seg ptlst) (cond (ent (setq entl (entget ent)) ;; save start point if polyline is closed (if (= (logand (cdr (assoc 70 entl)) 1) 1) (setq p1 (cdr (assoc 10 entl))) ) ;; run thru entity list to collect list of segments (while (setq entl (member (assoc 10 entl) entl)) ;; if segment then add to list (if (and pt bulge) (setq seg (list pt bulge)) ) ;; save next point and bulge (setq pt (cdr (assoc 10 entl)) bulge (cdr (assoc 42 entl)) ) ;; if segment is build then add last point to segment ;; and add segment to list (if seg (setq seg (append seg (list pt)) ptlst (cons seg ptlst)) ) ;; reduce list and clear temporary segment (setq entl (cdr entl) seg nil ) ) ) ) ;; if polyline is closed then add closing segment to list (if p1 (setq ptlst (cons (list pt bulge p1) ptlst))) ;; reverse and return list of segments (reverse ptlst) ) (defun getArcInfo (segment / a p1 bulge p2 c p3 p4 p r s result) ;; assigner variables avec les valeurs de l'argument (mapcar 'set '(p1 bulge p2) segment) (if (not (zerop bulge)) (progn ;; trouver la corde (setq c (distance p1 p2)) ;; trouver la flèche (setq s (* (/ c 2.0) (abs bulge))) ;; trouver le rayon par Pythagore (setq r (/ (+ (expt s 2.0) (expt (/ c 2.0) 2.0)) (* 2.0 s))) ;; distance au centre (setq a (- r s)) ;; coordonnées du milieu de p1 et P2 (setq P4 (polar P1 (angle P1 P2) (/ c 2.0))) ;; coordonnées du centre (setq p (if (>= bulge 0) (polar p4 (+ (angle p1 p2) (/ pi 2.0)) a) (polar p4 (- (angle p1 p2) (/ pi 2.0)) a) ) ) ;; coordonnées de P3 (setq p3 (if (>= bulge 0) (polar p4 (- (angle p1 p2) (/ pi 2.0)) s) (polar p4 (+ (angle p1 p2) (/ pi 2.0)) s) ) ) (setq result (list p r)) ) (setq result nil) ) result ) (defun c:PolyCen () (setq e (car (entsel))) (if e (progn (setvar "CMDECHO" 0) (command "_undo" "_begin") (setq lseg (GetPolySegs e)) (setq I 0) (repeat (length lseg) (setq seg (nth I lseg)) (setq I (+ I 1)) (if (not (zerop (cadr seg))) ;; bulge non nul (command "_point" "_non" (trans (car (getarcinfo seg)) 0 1)) ) ) (command "_undo" "_end") ) ) (princ) ) Avec les routines getarcinfo et getpolysegs issues de Afralisp Amicalement Vincent [Edité le 19/10/2009 par zebulon_]

Bonjour, un problème de langue. Il ne fonctionne plus sous Autocad 2009 version française, parce qu'elle ne connait pas les commandes anglo-saxonnes. Il faudrait donc changer toutes les lignes où il y a (command ...) (command "PEDIT" "L" "E" "T" (- (rtd ang) 90) "X" "F" "") deviendrait (command "_PEDIT" "_L" "_E" "_T" (- (rtd ang) 90) "_X" "_F" "") avec un "_" devant toutes les commandes et toutes les options de commande pour que la version française (ou autre) comprenne la commande internationale Amicalement Vincent

Bonjour, ; Super-simple little routine to force ; all z-coordinants in a drawing to zero ; (with thanks to Randy Richardson and ; the Autodesk NG's). ; ; From Tee Square Graphics - 01/28/2000 (defun C:SMASH ( ) (command "_.move" "_all" "" '(0 0 1e99) "" "_.move" "_p" "" '(0 0 -1e99) "") (princ) ) Amicalement Vincent