PHILPHIL

bonjour a tous dans un fichier de travail avec plein de fenetres, et presentations. je viens d'utiliser le convertisseur de calque suivant une norme , pour remettre tous mes calques a la bonne couleurs. sauf que celui ci en a profité pour dégeler dans TOUTES LES FENETRES les calques qui étaient gelés. en gros il a fait plus de boulot que demandé sans avertir en quelque sorte. donc pas mal d'heures pour tous remettre en ordre. auriez vous un LISP qui remettrait la bonne couleur de calques, ou / et type de lignes suivant un fichier gabarit *.dwg. et qui ne ferait QUE CA. merci Phil

hello Gile GRAND MERCI Phil

hello Gile merci. mais j'ai beau chercher, et lu toutes tes explications dans les posts précédents, je trouve pas comment en LISp, Visual lisp accéder a ce dictionnaire. quelle fonction faut il utiliser ? comment récupérer les propriétés de la table "layers" pour avoir le nom du dictionnaire d'extension ( le ENAME si j'ai bien compris ) pour en faire la liste dedans merci Phil

bonjour Gile je cherche le nom du dictionnaire pour les "noms de filtre de calques" et des XREFs implantés dans le fichier car ce lisp ne semble pas fonctionner, alors que j'ai bien des filtres de calques existants deja (defun c:test_dictionnaire () (setq test301 ( gc:dictdatalist "ACAD_MLEADERSTYLE" )) (setq test300 ( gc:dictdatalist "ACAD_LAYERFILTERS" )) ) grace a ton appli "inspector" je trouve les noms des dictionnaires existant dans le fichier ACAD_MLEADERSTYLE : existe bien et ca marche ACAD_LAYERFILTERS : celui ci n existe pas ( normale ou pas ) ou alors il a changé de nom depuis, car sur le net il existe dans des lisp en 2011 ( notamment chez LEE-MAC ) ;; gc:DictDataList ;; ;; Liste les données des entrées d'un dictionnaire ;; Arguments : ;; dict : le nom du dictionnaire (chaine) ou de l'object (ename) (defun gc:dictdatalist (name / dict elst lst) (if (or (and (= (type name) 'str) (dictsearch (namedobjdict) name) (setq dict (dictsearch (namedobjdict) name)) ) (and (or (= (type name) 'ename) (and (= (type name) 'vla-object) (setq name (vlax-vla-object->ename name))) ) (setq dict (entget (cdr (assoc 360 (member '(102 . "{ACAD_XDICTIONARY") (entget name)))))) ) ) (progn (setq elst (vl-member-if (function (lambda (x) (= (car x) 3))) dict)) (while elst (setq lst (cons (cons (cdar elst) (mapcar 'cdr (cdr (vl-member-if (function (lambda (x) (= (car x) 280))) (entget (cdadr elst))))) ) lst ) elst (cddr elst) ) ) (reverse lst) ) ) ) merci Phil

Hello Eric pas de soucis avec la palette de référence externes. je cherche a faire un LISP pour les recharger tous d'un coup en cliquant sur un xref( papa ). Phil

bonjour a tous je bosse en mettant tous les fichiers des differents niveaux archi en XREFS ( enfants ) dans un fichier ( papa ) que j'importe en XREF dans mon fichier de travail. j'ai donc un XREF ( papa ) avec des XREFS ( enfants ) dedans, implanté sur un calque spécifique. ca permet d'implanter, geler, dégeler, .... tout en une seule fois et /ou de les implanter tous dans d'autres fichiers de travail et si besoin de ne pas charger les niveaux que je n'ai pas besoin sauf que quand je veux inserer ( pour diffusion ) MON xref ( papa ) de tous les niveaux, si un seul XREF ( enfants ) de niveau n'a pas été recharger avant, celui ( papa ) n'est pas inseré. avez vous un bout de lisp qui permet de connaitre la liste des XREFS ( enfants ) implantés dans un XREF.( papa ) pour les recharger tous d'un seul coup, en cliquant sur l'XREF ( papa ou maman ) merci Phil

hello Tchantal en lisp fonction : ACAL premier extrait de nom de calque : TOPO deuxieme extrait de nom de calque : un bout du nom de tes calque a geler ( zaza) action souhaiter : G ca devrait geler tous les calques que tu souhaites, ceux qui ont dans leurs nom : TOPO*zaza* apres tu testes toutes les autres action que l'on peut faire avec les calques. a+ Phil (defun c:acal ( / lay layers ) (setvar "cmdecho" 0) (setq parcalque1 (getcfg "APPDATA/parcalque1")) (setq com1 (getstring t (strcat "\nVEUILLEZ ENTRER L'EXTRAIT 1 DU NOM DE CALQUE A ACTIVER <" parcalque1 "> : ") ) ) (if (/= com1 "") (setq parcalque1 com1) ) (setcfg "APPDATA/parcalque1" parcalque1) (setq parcalque2 (getcfg "APPDATA/parcalque2")) (setq com2 (getstring t (strcat "\nVEUILLEZ ENTRER L'EXTRAIT 2 DU NOM DE CALQUE A ACTIVER <" parcalque2 "> : ") ) ) (if (/= com2 "") (setq parcalque2 com2) ) (setcfg "APPDATA/parcalque2" parcalque2) ;;; (setq test (strcat "*" parcalque "*")) (setq actioncalque (getcfg "APPDATA/ACTIONCALQUE")) (initget "ac AC in IN g G l L v V d D t T int INT li LI co CO ar AR av AV") (setq tmp (getstring t (strcat "\nENTRER L'ACTION SOUHAITE SUR LES CALQUES [ ACtiver / INactiver / Geler / Libérer / Verrouiller / Déverrouiller / Tracer / INTracable / LIster / COuleur / AVant / ARriere ] <" actioncalque ">: " ) ) ) (if (/= tmp "") (setq actioncalque (strcase tmp)) ) (setcfg "APPDATA/ACTIONCALQUE" actioncalque) (while (setq lay (tblnext "LAYER" (not lay))) (setq layers (cons (cdr (assoc 2 lay)) layers))) (setq layerfiltre nil) (foreach layer layers (if (wcmatch layer (strcat "*" parcalque1 "*" parcalque2 "*")) (progn (setq layerfiltre (cons layer layerfiltre))) ) ) (setq layers (vl-remove-if '(lambda (x) (member x '("0" "Defpoints" "DEFPOINTS" "Ashade" "ASHADE"))) layerfiltre)) (setq layers (vl-sort layers '<)) (foreach layer layers (setq test33 layer) (prompt (strcat "\nCALQUE : " layer)) ) (if (or (= actioncalque "ac") (= actioncalque "AC")) (command-s "-calque" "actif" (strcat "*" parcalque1 "*" parcalque2 "*") "") ) (if (or (= actioncalque "in") (= actioncalque "IN")) (command-s "-calque" "inactif" (strcat "*" parcalque1 "*" parcalque2 "*") "") ) (if (or (= actioncalque "g") (= actioncalque "G")) (command-s "-calque" "geler" (strcat "*" parcalque1 "*" parcalque2 "*") "") ) (if (or (= actioncalque "l") (= actioncalque "L")) (command-s "-calque" "liberer" (strcat "*" parcalque1 "*" parcalque2 "*") "") ) (if (or (= actioncalque "v") (= actioncalque "V")) (command-s "-calque" "V" (strcat "*" parcalque1 "*" parcalque2 "*") "") ) (if (or (= actioncalque "d") (= actioncalque "D")) (command-s "-calque" "D" (strcat "*" parcalque1 "*" parcalque2 "*") "") ) (if (or (= actioncalque "t") (= actioncalque "T")) (command-s "-calque" "T" "T" (strcat "*" parcalque1 "*" parcalque2 "*") "") ) (if (or (= actioncalque "int") (= actioncalque "INT")) (command-s "-calque" "T" "A" (strcat "*" parcalque1 "*" parcalque2 "*") "") ) (if (or (= actioncalque "li") (= actioncalque "LI")) (command-s "-calque" "?" (strcat "*" parcalque1 "*" parcalque2 "*") "") ) (if (or (= actioncalque "co") (= actioncalque "CO")) (progn (setq couleurnew (acad_colordlg 1)) (command-s "-calque" "co" couleurnew (strcat "*" parcalque1 "*" parcalque2 "*") "") ) ) (if (or (= actioncalque "av") (= actioncalque "AV")) (foreach layer layers (setq obj (ssget "X" (list (cons 8 layer)))) (command-s "DRAWORDER" obj "" "AV") ) ) (if (or (= actioncalque "ar") (= actioncalque "AR")) (foreach layer layers (setq obj (ssget "X" (list (cons 8 layer)))) (command-s "DRAWORDER" obj "" "AR") ) ) (princ) )

bonjour a tester petit LISP pour ne garder que certaines présentations d'un GROS fichier de travail ( et les entités dans l'espace objet qui vont avec ) a partir d'un gros fichier de travail le lisp détruit tout ce dont on ne veux plus garder et le sauve sous un autre nom ( ca permet de garder les calques FREEZE dans les fenêtres de présentations, alors qu'un export de fenêtre "DEFREEZE" les calques, puis d'autre parametres propres au fichier de travail ) ( si je ne dis pas de bêtises ) commencer par choisir un sous-répertoire pour l'export une fois pour toute sauvegardé dans le fichier de travail : fonction : sauve_repertoire_export le lisp demande : un nom de fichier d'export des caractères pour filtrer les noms de présentations ( * pour toutes ) de sélectionner les présentations a garder apres il bosse, purge et sauvegarde sous un autre nom fonction : fichier_exPORT_presentations FICHIER_EXPORT_PRESENTATIONS.LSP VPOutlineV1-3.lsp il y a surement des nom de calques dans le lisp que vous devrez modifier Phil

hello rajoute un wipeout ( masque )en fond de rectangle paramétrable , et passe le bloc l'un par dessus l'autre. et le cercle sera masqué par le wipeout du bloc Phil

HELLO et que dit la sauvegarde automatique ? Phil

hello un "wiepout" geant qui se balade. un bloc detouré ? des entites avec des z. Phil

hello GEGEMATIC merci. passer par les etats de calques, n'est plus vraiment ma priorité, pas assez fiable je pense, je trouve que ca bug. dans mon LISP précédent j'avais piquer un bout de code de ton lisp pour le FREEZE des calques. je cherche toujours ou trouver la liste des calques dans une fenetre avec leurs modifications : gel, couleur et autres ...... dans quel dictionnaire c'est planqué ? ca doit bien etre rangé quelque part. Phil

Bonjour suite a ce LISP ou je propage dans les fenetres de présentation les calques FREEZE d'une fenetre de présentation. j'aimerai en faire autant avec les calques dont la couleur a été changée / forcée. comment récupérer en lisp la liste des calques de couleurs forcée dans une fenetre et la couleur qui va avec ?? Merci Phil

HELLO Un truc comme ca ??

Bonjour a tester PROPAGE_FREEZE_calqueS_dans_fenetres Ca récupère la liste des calques qui sont "freeze" dans une fenêtre et le propage dans les fenetres sélectionner dans les présentations PROPAGE FREEZE CALQUE DANS FENETRES.LSP il faut installer vplayerlisp de Gile on doit pouvoir propager autre chose que FREEZE des calques, pour peu que l'on récupère les paramètres du calque a+ Phil

hello je me répond a moi même sélectionner une entité du bloc qui est dans l'Xref ( autre que un attribut ) pour avoir la source ;;; Copier des attributs d('un bloc dans un XREf vers un bloc fichier ;;; ;;; Copyright (C) (gile) (defun c:catt_xref_bloc (/ source attlst ss attrib) (vl-load-com) (setq couleurreticule (vla-get-modelcrosshaircolor (vla-get-display (vla-get-preferences (vlax-get-acad-object))))) (vla-put-modelcrosshaircolor (vla-get-display (vla-get-preferences (vlax-get-acad-object))) 255) (if (and ;;; (setq source (car (nentsel "\nSélectionnez le bloc source: "))) (setq ent1 (nentsel "\nSELECTIONNER UNE SOUS-ENTITE DU BLOC AUTRE QU'UN ATTRIBUT :")) ;;;(setq sourcebis (car(car (cdddr ENT1)))) (setq source (vlax-ename->vla-object (car (car (cdddr ent1))))) (= (vla-get-objectname source) "AcDbBlockReference") (= (vla-get-hasattributes source) :vlax-true) ) (progn (vla-put-modelcrosshaircolor (vla-get-display (vla-get-preferences (vlax-get-acad-object))) couleurreticule ) (foreach att (vlax-invoke source 'getattributes) (setq attlst (cons (cons (vla-get-tagstring att) (vla-get-textstring att)) attlst)) ) (if (ssget '((0 . "INSERT") (66 . 1))) (progn (vlax-for blk (setq ss (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))) (foreach att (vlax-invoke blk 'getattributes) (if (setq attrib (assoc (vla-get-tagstring att) attlst)) (vla-put-textstring att (cdr attrib)) ) ) ) (vla-delete ss) ) ) ) (princ "\nEntité non valide") ) (princ) ) Phil

bonjour j'utilise CATT.lsp de Gile qui copie les attributs d'un bloc vers un autre bloc. pour peu que ces blocs soit dans le meme fichiers *.dwg. je cherche la solution en lisp, pour allé récupérer les attributs d'un bloc source qui est lui dans un XREF de mon fichier. source = bloc dans l'xref de mon fichier *.dwg destination = un bloc dans mon fichier *.dwg si je remplace "ENTSEL" par "NENTSEL" je ne récupére qu'une entité du bloc source. mais ca permetrait de chercher a quel bloc cette entite appartient, et en récupérer les infos d'attributs. mais comment faire ????? comment modifie ca en gros (setq source (car (entsel "\nSélectionnez le bloc source: "))) merci Phil ;;; Copier des attributs ;;; ;;; Copyright (C) (gile) (defun c:catt1 (/ ;;; source attlst ss attrib ) (vl-load-com) (if (and (setq source (car (entsel "\nSélectionnez le bloc source: "))) (setq source (vlax-ename->vla-object source)) (= (vla-get-objectname source) "AcDbBlockReference") (= (vla-get-hasattributes source) :vlax-true) ) (progn (foreach att (vlax-invoke source 'getattributes) (setq attlst (cons (cons (vla-get-tagstring att) (vla-get-textstring att)) attlst)) ) (if (ssget '((0 . "INSERT") (66 . 1))) (progn (vlax-for blk (setq ss (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))) (foreach att (vlax-invoke blk 'getattributes) (if (setq attrib (assoc (vla-get-tagstring att) attlst)) (vla-put-textstring att (cdr attrib)) ) ) ) (vla-delete ss) ) ) ) (princ "\nEntité non valide") ) (princ) )

hello Rebcao voici le lisp la deuxieme version que j'ai modifie doit etre pour bosser en cm ou avoir un carre plus grand . j'ai testé une seule fois Phil ;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp Hatch Maker (c) 2005 Larry Schiele ;;;* ====== B E G I N C O D E N O W ====== ;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation ;;;* Lanny.Schiele@tmisystems.com ;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up. ;;; Traduction littérale et approximative des invites en français : Gile ;;; c:drawhatch remplacer par c:hatchdraw ;;; c:savehatch remplacer par c:hatchsave (defun c:hatchdraw (/) (command "_undo" "_begin") (setq os (getvar "OSMODE")) (setvar "OSMODE" 0) (command "_ucs" "_w") (command "_pline" "0,0" "0,1" "1,1" "1,0" "_c") (command "_zoom" "_c" "0.5,0.5" 1.1) (setvar "OSMODE" os) (setvar "SNAPMODE" 1) (setvar "SNAPUNIT" (list 0.01 0.01)) (command "_undo" "_end") (alert "Dessiner le modèle dans un carré de 1x1 \nen utilisant uniquement des POINTS et des LIGNES..." ) (princ) ) (defun c:hatchsave (/ round dxf listtofile user selset selsetsize ssnth ent entinfo enttype pt1 pt2 dist angto angfrom xdir ydir gap deltax deltay angzone counter ratio factor hatchname hatchdescr filelines filelines filename scaler scaledx scaledy rf x y h _ab _bc _ac _ad _de _ef _eh _fh dimzin ) ;;;* BEGIN NESTED FUNCTIONS (defun round (num) (if (>= (- num (fix num)) 0.5) (fix (1+ num)) (fix num) ) ) (defun dxf (code enameorelist / vartype) (setq vartype (type enameorelist)) (if (= vartype (read "ENAME")) (cdr (assoc code (entget enameorelist))) (cdr (assoc code enameorelist)) ) ) (defun listtofile (textlist filename doopenwithnotepad asappend / textitem file retval) (if (setq file (open filename (if asappend "a" "w" ) ) ) (progn (foreach textitem textlist (write-line textitem file)) (setq file (close file)) (if doopenwithnotepad (startapp "notepad" filename) ) ) ) (findfile filename) ) ;;;* END NESTED FUNCTIONS (princ (strcat "\n." "\n 0,1 ----------- 1,1" "\n | | " "\n | Lignes et | " "\n | points doivent | " "\n | être accrochés | " "\n | au plus proche | " "\n | 0.01 | " "\n | | " "\n 0,0 ----------- 1,0" "\n." "\nNota: Les lignes doivent être dessinées entre 0,0 et 1,1 et sur une grille de 0.01." ) ) (textscr) (getstring "\nTaper [ENTER] pour continuer...") (princ "\nSelectionnez un modèle de 1x1 constitué de lignes et/ou de points pour un nouveau motif de hachures..." ) (while (not (setq selset (ssget (list (cons 0 "LINE,POINT")))))) (setq ssnth 0 selsetsize (sslength selset) dimzin (getvar "DIMZIN") ) (setvar "DIMZIN" 11) (if (> selsetsize 0) (princ "\nAnalyse des entités...") ) (while (< ssnth selsetsize) (setq ent (ssname selset ssnth) entinfo (entget ent) enttype (dxf 0 entinfo) ssnth (+ ssnth 1) ) (cond ((= enttype "POINT") (setq pt1 (dxf 10 entinfo) fileline (strcat "0," (rtos (car pt1) 2 6) "," (rtos (cadr pt1) 2 6) ",0,1,0,-1") ) (princ (strcat "\n" fileline)) (setq filelines (cons fileline filelines)) ) ((= enttype "LINE") (setq pt1 (dxf 10 entinfo) pt2 (dxf 11 entinfo) dist (distance pt1 pt2) angto (angle pt1 pt2) angfrom (angle pt2 pt1) isvalid nil ) (if (or (equal (car pt1) (car pt2) 0.0001) (equal (cadr pt1) (cadr pt2) 0.0001)) (setq deltax 0 deltay 1 gap (- dist 1) isvalid t ) (progn (setq ang (if (< angto pi) angto angfrom ) angzone (fix (/ ang (/ pi 4))) xdir (abs (- (car pt2) (car pt1))) ydir (abs (- (cadr pt2) (cadr pt1))) factor 1 rf 1 ) (cond ((= angzone 0) (setq deltay (abs (sin ang)) deltax (abs (- (abs (/ 1.0 (sin ang))) (abs (cos ang)))) ) ) ((= angzone 1) (setq deltay (abs (cos ang)) deltax (abs (sin ang)) ) ) ((= angzone 2) (setq deltay (abs (cos ang)) deltax (abs (- (abs (/ 1.0 (cos ang))) (abs (sin ang)))) ) ) ((= angzone 3) (setq deltay (abs (sin ang)) deltax (abs (cos ang)) ) ) ) (if (not (equal xdir ydir 0.001)) (progn (setq ratio (if (< xdir ydir) (/ ydir xdir) (/ xdir ydir) ) rf (* ratio factor) scaler (/ 1 (if (< xdir ydir) xdir ydir ) ) ) (if (not (equal ratio (round ratio) 0.001)) (progn (while (and (<= factor 100) (not (equal rf (round rf) 0.001))) (setq factor (+ factor 1) rf (* ratio factor) ) ) (if (and (> factor 1) (<= factor 100)) (progn (setq _ab (* xdir scaler factor) _bc (* ydir scaler factor) _ac (sqrt (+ (* _ab _ab) (* _bc _bc))) _ef 1 x 1 ) (while (< x (- _ab 0.5)) (setq y (* x (/ ydir xdir)) h (if (< ang (/ pi 2)) (- (+ 1 (fix y)) y) (- y (fix y)) ) ) (if (< h _ef) (setq _ad x _de y _ae (sqrt (+ (* x x) (* y y))) _ef h ) ) (setq x (+ x 1)) ) (if (< _ef 1) (setq _eh (/ (* _bc _ef) _ac) _fh (/ (* _ab _ef) _ac) deltax (+ _ae (if (> ang (/ pi 2)) (- _eh) _eh ) ) deltay (+ _fh) gap (- dist _ac) isvalid t ) ) ) ) ) ) ) ) (if (= factor 1) (setq gap (- dist (abs (* factor (/ 1 deltay)))) isvalid t ) ) ) ) (if isvalid (progn (setq fileline (strcat (angtos angto 0 6) "," (rtos (car pt1) 2 8) "," (rtos (cadr pt1) 2 8) "," (rtos deltax 2 8) "," (rtos deltay 2 8) "," (rtos dist 2 8) "," (rtos gap 2 8) ) ) (princ (strcat "\n" fileline)) (setq filelines (cons fileline filelines)) ) (princ (strcat "\n * * * Ligne avec angle non valide " (angtos angto 0 6) (chr 186) " proscrit. * * *") ) ) ) ((princ (strcat "\n * * * Entite non valide " enttype " proscrit(e)."))) ) ) (setvar "DIMZIN" dimzin) (if (and filelines (setq hatchdescr (getstring t "\nDécrivez brièvement ce motif de hachures: ")) (setq filename (getfiled "Fichier de hachures" "c:\\perso\\hachure\\hachure phil\\" ; Chemin du dossier des hachures personnalisées[/surligneur] "pat" 1 ) ) ) (progn (if (= hatchdescr "") (setq hatchdescr "Modèle de hachures personnalisé") ) (setq hatchname (vl-filename-base filename) filelines (cons (strcat "*" hatchname "," hatchdescr) (reverse filelines)) ) (princ "\n============================================================") (princ (strcat "\nAttendez que le fichier de hachures soit créé SVP...\n")) (listtofile filelines filename nil nil) (command "_delay" 1500) ; Délai requis pour que le fichier soit créé et trouvé (stupide, mais requis) (if (findfile filename) (progn (setvar "HPNAME" hatchname) (princ (strcat "\nLe motif de hachures '" hatchname "' est prêt pour l'utilisation !")) ) (progn (princ "\nImpossible de créer le fichier de hachures:") (princ (strcat "\n " filename))) ) ) (princ (if filelines "\nAbandon." "\nImpossible de créer le motif de hachures avec les entités sélectionnées." ) ) ) (princ) ) (princ "\n ************************************************************** ") (princ "\n** **") (princ "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *") (princ "\n* *") (princ "\n* Taper DRAWHATCH pour avoir l'environment de dessin. *") (princ "\n* Taper SAVEHATCH pour enregistrer le motif créé. *") (princ "\n** **") (princ "\n ************************************************************** ") (princ) ;;;* ====== B E G I N C O D E N O W ====== ;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation ;;;* Lanny.Schiele@tmisystems.com ;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up. ;;; Traduction littérale et approximative des invites en français : Gile ;;; c:drawhatch remplacer par c:hatchdraw ;;; c:savehatch remplacer par c:hatchsave (defun c:hatchdraw2 (/) (command "_undo" "_begin") (setq os (getvar "OSMODE")) (setvar "OSMODE" 0) (command "_ucs" "_w") (command "_pline" "0,0" "0,100" "100,100" "100,0" "_c") (command "_zoom" "_c" "0.5,0.5" 1.1) (setvar "OSMODE" os) (setvar "SNAPMODE" 1) (setvar "SNAPUNIT" (list 0.01 0.01)) (command "_undo" "_end") (alert "Dessiner le modèle dans un carré de 1x1 \nen utilisant uniquement des POINTS et des LIGNES..." ) (princ) ) (defun c:hatchsave2 (/ round dxf listtofile user selset selsetsize ssnth ent entinfo enttype pt1 pt2 dist angto angfrom xdir ydir gap deltax deltay angzone counter ratio factor hatchname hatchdescr filelines filelines filename scaler scaledx scaledy rf x y h _ab _bc _ac _ad _de _ef _eh _fh dimzin ) ;;;* BEGIN NESTED FUNCTIONS (defun round (num) (if (>= (- num (fix num)) 0.5) (fix (1+ num)) (fix num) ) ) (defun dxf (code enameorelist / vartype) (setq vartype (type enameorelist)) (if (= vartype (read "ENAME")) (cdr (assoc code (entget enameorelist))) (cdr (assoc code enameorelist)) ) ) (defun listtofile (textlist filename doopenwithnotepad asappend / textitem file retval) (if (setq file (open filename (if asappend "a" "w" ) ) ) (progn (foreach textitem textlist (write-line textitem file)) (setq file (close file)) (if doopenwithnotepad (startapp "notepad" filename) ) ) ) (findfile filename) ) ;;;* END NESTED FUNCTIONS (princ (strcat "\n." "\n 0,1 ----------- 1,1" "\n | | " "\n | Lignes et | " "\n | points doivent | " "\n | être accrochés | " "\n | au plus proche | " "\n | 0.01 | " "\n | | " "\n 0,0 ----------- 1,0" "\n." "\nNota: Les lignes doivent être dessinées entre 0,0 et 1,1 et sur une grille de 0.01." ) ) (textscr) (getstring "\nTaper [ENTER] pour continuer...") (princ "\nSelectionnez un modèle de 1x1 constitué de lignes et/ou de points pour un nouveau motif de hachures..." ) (while (not (setq selset (ssget (list (cons 0 "LINE,POINT")))))) (setq ssnth 0 selsetsize (sslength selset) dimzin (getvar "DIMZIN") ) (setvar "DIMZIN" 11) (if (> selsetsize 0) (princ "\nAnalyse des entités...") ) (while (< ssnth selsetsize) (setq ent (ssname selset ssnth) entinfo (entget ent) enttype (dxf 0 entinfo) ssnth (+ ssnth 1) ) (cond ((= enttype "POINT") (setq pt1 (dxf 10 entinfo) fileline (strcat "0," (rtos (car pt1) 2 6) "," (rtos (cadr pt1) 2 6) ",0,1,0,-1") ) (princ (strcat "\n" fileline)) (setq filelines (cons fileline filelines)) ) ((= enttype "LINE") (setq pt1 (dxf 10 entinfo) pt2 (dxf 11 entinfo) dist (distance pt1 pt2) angto (angle pt1 pt2) angfrom (angle pt2 pt1) isvalid nil ) (if (or (equal (car pt1) (car pt2) 0.0001) (equal (cadr pt1) (cadr pt2) 0.0001)) (setq deltax 0 deltay 1 gap (- dist 1) isvalid t ) (progn (setq ang (if (< angto pi) angto angfrom ) angzone (fix (/ ang (/ pi 4))) xdir (abs (- (car pt2) (car pt1))) ydir (abs (- (cadr pt2) (cadr pt1))) factor 1 rf 1 ) (cond ((= angzone 0) (setq deltay (abs (sin ang)) deltax (abs (- (abs (/ 1.0 (sin ang))) (abs (cos ang)))) ) ) ((= angzone 1) (setq deltay (abs (cos ang)) deltax (abs (sin ang)) ) ) ((= angzone 2) (setq deltay (abs (cos ang)) deltax (abs (- (abs (/ 1.0 (cos ang))) (abs (sin ang)))) ) ) ((= angzone 3) (setq deltay (abs (sin ang)) deltax (abs (cos ang)) ) ) ) (if (not (equal xdir ydir 0.001)) (progn (setq ratio (if (< xdir ydir) (/ ydir xdir) (/ xdir ydir) ) rf (* ratio factor) scaler (/ 1 (if (< xdir ydir) xdir ydir ) ) ) (if (not (equal ratio (round ratio) 0.001)) (progn (while (and (<= factor 100) (not (equal rf (round rf) 0.001))) (setq factor (+ factor 1) rf (* ratio factor) ) ) (if (and (> factor 1) (<= factor 100)) (progn (setq _ab (* xdir scaler factor) _bc (* ydir scaler factor) _ac (sqrt (+ (* _ab _ab) (* _bc _bc))) _ef 1 x 1 ) (while (< x (- _ab 0.5)) (setq y (* x (/ ydir xdir)) h (if (< ang (/ pi 2)) (- (+ 1 (fix y)) y) (- y (fix y)) ) ) (if (< h _ef) (setq _ad x _de y _ae (sqrt (+ (* x x) (* y y))) _ef h ) ) (setq x (+ x 1)) ) (if (< _ef 1) (setq _eh (/ (* _bc _ef) _ac) _fh (/ (* _ab _ef) _ac) deltax (+ _ae (if (> ang (/ pi 2)) (- _eh) _eh ) ) deltay (+ _fh) gap (- dist _ac) isvalid t ) ) ) ) ) ) ) ) (if (= factor 1) (setq gap (- dist (abs (* factor (/ 1 deltay)))) isvalid t ) ) ) ) (if isvalid (progn (setq fileline (strcat (angtos angto 0 6) "," (rtos (car pt1) 2 8) "," (rtos (cadr pt1) 2 8) "," (rtos deltax 2 8) "," (rtos deltay 2 8) "," (rtos dist 2 8) "," (rtos gap 2 8) ) ) (princ (strcat "\n" fileline)) (setq filelines (cons fileline filelines)) ) (princ (strcat "\n * * * Ligne avec angle non valide " (angtos angto 0 6) (chr 186) " proscrit. * * *") ) ) ) ((princ (strcat "\n * * * Entite non valide " enttype " proscrit(e)."))) ) ) (setvar "DIMZIN" dimzin) (if (and filelines (setq hatchdescr (getstring t "\nDécrivez brièvement ce motif de hachures: ")) (setq filename (getfiled "Fichier de hachures" "c:\\perso\\hachure\\hachure phil\\" ; Chemin du dossier des hachures personnalisées[/surligneur] "pat" 1 ) ) ) (progn (if (= hatchdescr "") (setq hatchdescr "Modèle de hachures personnalisé") ) (setq hatchname (vl-filename-base filename) filelines (cons (strcat "*" hatchname "," hatchdescr) (reverse filelines)) ) (princ "\n============================================================") (princ (strcat "\nAttendez que le fichier de hachures soit créé SVP...\n")) (listtofile filelines filename nil nil) (command "_delay" 1500) ; Délai requis pour que le fichier soit créé et trouvé (stupide, mais requis) (if (findfile filename) (progn (setvar "HPNAME" hatchname) (princ (strcat "\nLe motif de hachures '" hatchname "' est prêt pour l'utilisation !")) ) (progn (princ "\nImpossible de créer le fichier de hachures:") (princ (strcat "\n " filename))) ) ) (princ (if filelines "\nAbandon." "\nImpossible de créer le motif de hachures avec les entités sélectionnées." ) ) ) (princ) ) (princ "\n ************************************************************** ") (princ "\n** **") (princ "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *") (princ "\n* *") (princ "\n* Taper DRAWHATCH pour avoir l'environment de dessin. *") (princ "\n* Taper SAVEHATCH pour enregistrer le motif créé. *") (princ "\n** **") (princ "\n ************************************************************** ") (princ)

hello il faut le lisp de LEE_MAC getfiles GetFilesV1-6.lsp changer "C:\\PERSO\\BIBLIOTHEQUE" soit par "" soit par un nom de sousrepertoire a vous "C:\\toto" (defun c:import_plusieurs_blocs (/ listefich) (setvar "cmdecho" 0) (setq listefich (lm:getfiles "SELECTIONNER DES FICHIERS" "C:\\PERSO\\BIBLIOTHEQUE" "dwg")) (setq poi nil) (while (null poi) (setq poi (getpoint "\nPOINT D'INSERTION DES BLOCS :"))) (foreach ibloc listefich (vl-cmdf "_-insert" ibloc poi "1" "1" "")) (princ) ) Phil

hello comment faire pour sélectionner plusieurs fichier dans une boite de dialogue ? la commande "XA" ouvre une boite de dialogue permettant de sélectionner plusieurs fichiers *.dwg. la commande "inserclassique" "sélectionner" ouvre une boite de dialogue permettant de ne sélectionner qu'un seul fichier. hors ca a l'air d'etre a peut pres la meme boite de dialogue avec un paramétrage de sélection différents. pourrait on dans un LISP appeler cette boite de dialogue avec l'un ou l'autre de ce paramétrage ? un fichier a la fois, plusieurs a la fois. je cherche a creer un lisp pour charge plusieurs fichiers *.dwg en tant que bloc, ou de les mettre a jour. en gros a créer une liste de fichier selectionner dans un sous répertoire. Merci Phil

HELLO +1 avec BONUSCAD ton travail est en bas a gauche en tout petit pas loin du point 0,0,0 Phil

Hello pour le nom du bloc, il n'y a rien a cocher, le tableau le met d'office dans une colonne. pour le nom du groupe auquel l'entité pourrait appartenir, pas sur que ca fasse partie des données que l'on peut extraire Phil

hello ou un truc comme ca c:MCTB ;;;================================================================= ;;; ;;; mctb.LSP V1.01 ;;; ;;; Changer LE STYLE DES CTB DANS LES Présentations ;;; ;;; Copyright (C) Patrick_35 ;;; ;;;================================================================= (defun c:mctb(/ s *errmctb* MsgBox) ;;;--------------------------------------------------------------- ;;; ;;; Gestion des erreurs ;;; ;;;--------------------------------------------------------------- (defun *errmctb* (msg) (if (/= msg "Function cancelled") (if (= msg "quit / exit abort") (princ) (princ (strcat "\nErreur : " msg)) ) (princ) ) (setq *error* s) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (princ) ) ;;;--------------------------------------------------------------- ;;; ;;; Message ;;; ;;;--------------------------------------------------------------- (defun MsgBox (Titre Bouttons Message / Reponse WshShell) (vl-load-com) (setq WshShell (vlax-create-object "WScript.Shell")) (setq Reponse (vlax-invoke WshShell 'Popup Message 7 Titre (itoa Bouttons))) (vlax-release-object WshShell) Reponse ) ;;;--------------------------------------------------------------- ;;; ;;; Routine principale ;;; ;;;--------------------------------------------------------------- (defun multiplie_pre (/ config doc init_mctb lay liste_lay n position positiondests resultat stylenames ) (if (findfile "mctb.dcl") (progn (setq init_mctb (load_dialog (findfile "mctb.dcl"))) (setq liste_lay nil n 0 position "0" positiondest "0" doc (vla-get-activedocument (vlax-get-acad-object)) ) (setq stylenames (vl-remove-if '(lambda(x) (eq (vl-filename-extension x) ".stb")) (vlax-invoke (vla-get-layout (vla-get-modelspace doc)) 'getplotstyletablenames))) ;;; filtrer pour retirer les *.stb ;;; (setq stylenames (vlax-safearray->list (vlax-variant-value (vla-getplotstyletablenames (vla-get-layout (vla-get-modelspace doc)))) ) ) ;;; pas de flitre et prend les *.stb et *.ctb (if (vl-position "Aucun" stylenames) (setq stylenames (vl-remove "Aucun" stylenames)) ) (vlax-for lay (vla-get-layouts (vla-get-activedocument (vlax-get-acad-object))) (setq lst (append lst (list (cons (vla-get-taborder lay) lay)))) ) ;;; ;; List all the entries in the plot style table ;;; (setq styleNames (vlax-variant-value (vla-GetPlotStyleTableNames Layout))) ;;; (while (assoc n lst) ;;; (setq liste_lay (append liste_lay (list (vla-get-name (cdr (assoc n lst)))))) ;;; (setq n (1+ n)) ;;; ) (while (assoc n lst) (if (/= (vla-get-name (cdr (assoc n lst))) "Model") (setq liste_lay (append liste_lay (list (strcat (vla-get-name (cdr (assoc n lst))) " - [ "(vla-Get-Stylesheet (cdr (assoc n lst)))" ]" )))) ) (setq n (1+ n)) ) ;;; (if (vl-position "Model" liste_lay) ;;; (setq liste_lay (vl-remove "Model" liste_lay)) ;;; ) (new_dialog "mctb" init_mctb "") (start_list "mctb") (mapcar 'add_list stylenames) (end_list) (start_list "dest") (mapcar 'add_list liste_lay) (end_list) (set_tile "titre" "Sélection CTB V1") (set_tile "mctb" position) (set_tile "dest" positiondest) (mode_tile "mctb" 2) (while (and (/= resultat 1) (/= resultat 0)) (action_tile "mctb" "(setq position $value)") (action_tile "dest" "(setq positiondest $value)") (action_tile "accept" "(done_dialog 1)") (action_tile "cancel" "(done_dialog 0)") (setq resultat (start_dialog)) ) (unload_dialog init_mctb) (if (eq resultat 1) (while (not (eq positiondest "")) (setq n (read positiondest)) (vlax-for lay (vla-get-layouts doc) (if (eq (nth n liste_lay) (strcat (vla-get-name lay) " - [ "(vla-Get-Stylesheet lay)" ]" )) (progn (vla-put-stylesheet lay (nth (atoi position) stylenames)) (princ (strcat "\nPrésentation " (vla-get-name lay) " Configurée avec le CTB " (nth (atoi position) stylenames)) ) ) ) ) (setq positiondest (substr positiondest (+ 2 (strlen (itoa n))) (strlen positiondest))) ) ) ) (msgbox "mctb" 16 "Fichier mctb.DCL introuvable") ) (c:info_presentation) ) ;;;--------------------------------------------------------------- ;;; ;;; Routine de lancement ;;; ;;;--------------------------------------------------------------- (vl-load-com) (setq s *error*) (setq *error* *errmctb*) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) (multiplie_pre) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (setq *error* s) (princ) ) (setq nom_lisp "mctb") (if (/= app nil) (if (= (strcase (substr app (1+ (- (strlen app) (strlen nom_lisp))) (strlen nom_lisp))) nom_lisp) (princ (strcat "..." nom_lisp " chargé.")) (princ (strcat "\n" nom_lisp ".LSP Chargé.....Tapez " nom_lisp " pour l'éxecuter."))) (princ (strcat "\n" nom_lisp ".LSP Chargé......Tapez " nom_lisp " pour l'éxecuter."))) (setq nom_lisp nil) (princ) (defun c:info_presentation (/ listefen ) (setq listefen nil ) (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vlax-for lay (vla-get-layouts doc) (if (/= (vla-get-name lay) "Model") (progn (setq test33 lay table1 (vla-get-stylesheet lay) li1 (strcat (vla-get-name lay) " [ " table1 " ]" " " ) ) (setq listefen (cons li1 listefen)) ) ) ) (getlviewport1 listefen "LISTE DES ONGLETS PRESENTATIONS ET STYLE DE TRACE" t) (princ) ) ;; (gile) 03/12/07 ;; Retourne la liste des présentations choisies dans la boite de dialogue ;; ;; arguments ;; titre : titre de la boite de dialogue ou nil, défauts = Choisir la (ou les) présentation(s) ;; mult : T ou nil (pour choix multiple ou unique) (defun getlviewport1 (listefen titre mult / tmp file ret) (setq tmp (vl-filename-mktemp "tmp.dcl") file (open tmp "w") ) (write-line (strcat "getlviewport1:dialog{label=" (if titre (vl-prin1-to-string titre) (if mult "\"Choisir les présentations du fichier\"" "\"Choisir une présentation\"" ) ) ";:list_box{height = 100;key=\"lst\";multiple_select=" (if mult "true;width = 100;}:row{:retirement_button{label=\"Toutes\";key=\"all\";} ok_button;cancel_button;}}" "false;}ok_cancel;}" ) ) file ) (close file) (setq dcl_id (load_dialog tmp)) (if (not (new_dialog "getlviewport1" dcl_id)) (exit) ) (start_list "lst") (mapcar 'add_list listefen) (end_list) (action_tile "all" "(setq ret (reverse listefen)) (done_dialog)") (action_tile "accept" "(or (= (get_tile \"lst\") \"\") (foreach n (str2lst (get_tile \"lst\") \" \") (setq ret (cons (nth (atoi n) listefen) ret)))) (done_dialog)" ) (start_dialog) (unload_dialog dcl_id) (vl-file-delete tmp) (reverse ret) ) Phil

hello mise a jour : escalier double volée et groupe en fin de lisp Phil

hello tchetchi un truc comme ca ? (defun c:info_presentation (/ listefen ) (setq listefen nil ) (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vlax-for lay (vla-get-layouts doc) (if (/= (vla-get-name lay) "Model") (progn (setq test33 lay table1 (vla-get-stylesheet lay) li1 (strcat (vla-get-name lay) " [ " table1 " ]" " " ) ) (setq listefen (cons li1 listefen)) ) ) ) (getlviewport1 listefen "LISTE DES ONGLETS PRESENTATIONS ET STYLE DE TRACE" t) (princ) ) ;; (gile) 03/12/07 ;; Retourne la liste des présentations choisies dans la boite de dialogue ;; ;; arguments ;; titre : titre de la boite de dialogue ou nil, défauts = Choisir la (ou les) présentation(s) ;; mult : T ou nil (pour choix multiple ou unique) (defun getlviewport1 (listefen titre mult / tmp file ret) (setq tmp (vl-filename-mktemp "tmp.dcl") file (open tmp "w") ) (write-line (strcat "getlviewport1:dialog{label=" (if titre (vl-prin1-to-string titre) (if mult "\"Choisir les présentations du fichier\"" "\"Choisir une présentation\"" ) ) ";:list_box{height = 100;key=\"lst\";multiple_select=" (if mult "true;width = 100;}:row{:retirement_button{label=\"Toutes\";key=\"all\";} ok_button;cancel_button;}}" "false;}ok_cancel;}" ) ) file ) (close file) (setq dcl_id (load_dialog tmp)) (if (not (new_dialog "getlviewport1" dcl_id)) (exit) ) (start_list "lst") (mapcar 'add_list listefen) (end_list) (action_tile "all" "(setq ret (reverse listefen)) (done_dialog)") (action_tile "accept" "(or (= (get_tile \"lst\") \"\") (foreach n (str2lst (get_tile \"lst\") \" \") (setq ret (cons (nth (atoi n) listefen) ret)))) (done_dialog)" ) (start_dialog) (unload_dialog dcl_id) (vl-file-delete tmp) (reverse ret) ) Phil