nen

SalutPhilphil, Je te remercie pour ton message :D . J'ai donc créé les deux lisp et changé dans le dessin contenant les deux types d'étiquettes. Malheureusement j'ai peut-être malfait quelques choses, car aucune modification s'applique. La boîte de dialogue avec les cases à cocher s'ouvre bien mais, aucune modification s'applique ? Ci-dessous le lien avec les deux lisp et le dwg https://www.dropbox.com/sh/ph9xe4flege8ivw/AAA8lsYYN0rOtwGOr-Uo1CAGa?dl=0 Merci d'avance Meilleures salutations

Bonjour le forum, Je me permet de revenir sur le sujet :-) J'ai un bloc, on l'appeler bloc1, avec les attributs renseigné ci-dessous: DESIGNATION NUMERO LONGUEUR SURFACE J'aimerais importer les données ci-dessus dans le bloc2 avec les attributs: DESIGNATION NUMERO SURFACE J'ai essayé avec le lisp "CAT" comme il n'y a pas le même nombre d'attribut, dans l'attribut SURFACE il m'importe la LONGUEUR :( . J'ai essayer le lisp RBLOC.lsp, j'ai le message suivant: le fichier RBLOC.DCL est introuvable. PS: j'ai AutoCAD 2018 Est-ce le problème ? Merci d'avance Meilleures salutations

Salut Gile, Il est génial ton lisp, bravo :D . J'ai une petite remarque si c'est possible :) . Comme en général je rentre les infos par niveau. Est-il possible qu'au moment de demander le numéro les 4 premiers chiffres soient mémorisés (par exemple: 5K-0) dans la boîte de dialogue (GetNumero.DCL) ? :huh: Car en faite tu fais niveau par niveau donc le bâtiment et le niveau ne change pas, un peu rébarbatif de les retaper :( . Merci de ton aide Meilleures salutations

Salut, Merci pour ton message :D J'ai réussi à modifier les lisp,dcl et dwg et à rajouter une boite de dialogue pour le numéro du local ;) Jette-s'y un œil et donne moi ton avis c'est correct :D ;) Le fichier zip est dans le même lien ci-dessus. Merci de ton aide Meilleures salutations

Bonjour le forum ;) , J'ai une question au sujet d'une étiquette, bloc avec trois attributs que j'ai créés :D . Sur le plan (ci-dessous le lien) dans l'étiquette le champ "Surface" en sélectionnent la polygonale du local 01 en bleu. Si j'inserts à nouveau mon bloc "Etiquette" dans le local 02 et 03, si je change la dimension de la pièce la surface ne change pas, car l'attribut "Surface" est lié avec la polygonale du local 01 en bleu. Est-il possible de pouvoir demander à l'insertion du bloc de pouvoir choisir la polygonale pour le champ "Surface" ? Lien: https://www.dropbox.com/sh/kjgf1jaexk4d3c6/AAD4V8xDiFXtvt-D_m-WRgsJa?dl=0 Merci d'avance Meilleures salutations

Bonjour, Je te remercie pour ton nouveau lisp, nickel, c'est exactement ça :D. En effet tu tapes sur la barre d'espace ou enter, mais quand tu as 60 blocs avec 3 attributs dans chaque. Tu fais déjà 240 cliques sans le rappel de la commande barre d'espace avec le rappel cela fait 300 cliques pour un niveau, il y en a 5 :o Je te remercie infiniment pour ton aide ;) Meilleures salutations

Bonjour, Merci pour la mise à jour du lisp, je l'ai testé ce matin... nickel :D . J'ai une petite remarques ;) Est-il possible qu'au départ de la commande "pushtext" qu'il y ait une demande du type "un seul ou plusieurs attributs", si l'option "Plusieurs" une fois l'attribut renseigné la commande reste active et on passe au suivant sans relancer la commande "pushtext" car suivant le nombre d'attributs c'est un peu pénible. Merci d'avance :) Meilleures salutations

Bonjour, Je te remercie pour ton message :) . Ci-dessous le code modifié avec le fameux "defun c:pushtext" ;) En effet l'utilisateur de connaitre parfaitement l'ordre des attributs mais c'est quand même une possibilité intéressante suivant le cas. Pour améliorer le lisp je laisserais faire les pros parce que moi ce n'est pas ça :(rires forts): Merci pour ton aide Meilleures salutations ; This will record text picked and push it into a block with attributes ; By Alan H oct 2018 ; Edit by CAB (defun c:pushtext ( / lst ent txt blk x att) (setq blk (vlax-ename->vla-object (car (entsel "Choisir un objet bloc avec des attributs")))) (foreach att (vlax-invoke blk 'getattributes) (setq txt (vla-get-textstring (vlax-ename->vla-object (car (entsel "\nChoisir un objet texte"))))) (vla-put-textstring att txt) (princ "\n") ) )

Bonjour, Je te remercie pour ton aide et ton message . Ton lisp fonctionne impeccable, il est en plus facilement modifiable :D Juste pour mon info personnel j'avais des rechercher entre temps sur le net et j'ai trouvé ce lisp ci-dessous. Je ne comprends pas comment il fonctionne ? Si tu fais un copier/coller ok mais, ensuite comment charger ce type de lisp ? et il n'a pas de commande "defun c: pushtext" ? :( Il fonctionne bien aussi, mais le problème c'est que tu dois faire du copier/coller à chaque fois :( ; This will record text picked and push it into a block with attributes ; By Alan H oct 2018 (defun pushtext ( / lst ent txt blk x att) (setq blk (vlax-ename->vla-object (car (entsel "Pick block object")))) (foreach att (vlax-invoke blk 'getattributes) (setq txt (vla-get-textstring (vlax-ename->vla-object (car (entsel "Pick text object"))))) (vla-put-textstring att txt) (princ "\n") ) ) (pushtext) Merci de ton aide Vincent Meilleures salutations

Bonjour, Vous trouverez ci-dessous le lien dropbox(j'espère qu'il fonctionne) ;) https://www.dropbox.com/sh/eqawyiupcsyrnxg/AADc9IlcflBQE23gXu-t1lqba?dl=0 Meilleures salutations

Bonjour, Non ce n'est pas un cas isolé j'en ai plus de 50 :( Malheureusement je n'arrive pas à joindre un dwg ou un gif, j'ai le message ci-dessous depuis le boulot et depuis chez moi :( Erreur Le serveur a retourné une erreur durant l'envoi. Je fais comment ? :wacko: Merci d'avance Meilleures salutations

Bonjour le forum, J'ai un petit problème… en faite j'ai fait une boulette :blink: , j'aurais besoin de votre aide ;) . J'ai un attribut existant "Info_Local" avec trois champs, Désignation, Numéro et surface. Et naturellement pour aller vite, et cela devait être seulement pour un exemple, j'ai créé ses trois champs dans du texte normale, en utilisant la commande « texte ». Je voudrais donc récupérer les textes simples dans le bloc "Info_Local" composé des trois attribut "Désignation, Numéro et surface". Est-ce possible ? Existe-t-il une commande ou un lisp ? J'ai cherché sur internet et les forums un je n'ai rien trouvé, est-ce que quelqu'un a une solution ? Meilleures salutations

Salut, Je me suis permis de faire un post sur le lisp Isolant.lsp. sur le site "www.theswamp.org" J'ai eu une réponse afin d'aller sur ce lien https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/insulation-batt-representation-in-polyline-form/m-p/2458792#M275725 Il te propose un autre lisp "InsulBattPoly.lsp", il est pas mal. Il y a quand même un hic le lisp déconne un peu, il faut utiliser l'option "Existant" C'est dommage qu'il n'arrive pas à faire l'isolation en angle droit (90°) Je te laisserais tester. ;;; InsulBattPoly.LSP [Command name: IB] ;;; To draw a lightweight Polyline representation of Batt Insulation. ;;; Draws a zero-width continuous LWPolyline as a series of S-curves, alternating direction and forming ;;; touching loops. Intermediate point locations are adjusted for localized path direction on curved ;;; paths, narrowing inside-of-curve loops and widening outside-of-curve loops to eliminate overlaps ;;; or gaps. [Non-tangent changes in direction in Polyline paths, or overly tight curves relative to ;;; insulation thickness in various entity types, or non- Centered justification with Polylines or Splines ;;; that intersect (or relative to insulation thickness, get too close to) themselves, will yield quirky results.] ;;; Divides path length into whole S-curve "length" increments to eliminate need for trimming at ends ;;; (other than for e.g. ventilation-baffle taper); forces an even number of S's for closed paths so that result ;;; looks continuous across start/end point (will be a tiny gap on tangent-closed Pline path -- see slength). ;;; Draws on current Layer, unless Deleting pre-Existing path; if so, draws on its Layer, assuming the ;;; intent is to replace it (e.g. to replace something with BATTING linetype). ;;; Under select-Existing option, asks User to select again if nothing is selected, or if selected object is an ;;; inappropriate entity type. ;;; Accounts for different Coordinate Systems. ;;; Remembers option choices and offers them as defaults for subsequent use. ;;; Options: ;;; 1. create new within the routine, or select pre-Existing, path of any 2D finite type with linearity; ;;; 2. if selected Existing object is on a locked Layer, whether to unlock it and Proceed, or Quit; ;;; 3. PRevious = redraw along prior path (whether retained or deleted) allowing different choices; ;;; 4. Flip = one-step replacement of prior result, if Left- or Right-justified, on other side -- meant for ;;; Existing Line/Pline/Spline (drawing direction not visually apparent), but works on all types; ;;; 5. Retain or Delete base path, whether new or selected Existing; ;;; 6. insulation thickness, with some pre-defined [uS] common-thickness options; ;;; 7. Center-line or Left- or Right-side justification (Left & Right are relative to drawing direction ;;; for Line/Pline/Spline; for Arc/Circle/Ellipse, Left draws inside, Right draws outside). ;;; ;;; Kent Cooper, last edited March 2010 ; (vl-load-com) ; (defun ibreset () (setvar 'osmode osm) (setvar 'blipmode blips) (setvar 'plinewid plwid) (setvar 'plinetype pltyp) (setvar 'celtype ltyp) (command "_.undo" "_end") (setvar 'cmdecho cmde) ); end defun - ibreset ; (defun locdir (path dist); LOCal DIRection of path at distance along it, accounting for UCS (angle '(0 0 0) (trans (vlax-curve-getFirstDeriv path (vlax-curve-getParamAtDist path dist) ); end getFirstDeriv 0 1 T ; world to current CS, as displacement ); end trans ); end angle ); end defun - locdir ; (defun ibpt (advpro offpro) ;; This subroutine calculates an Insulation-Batt polyline definition PoinT, with arguments: ;; advpro = localized amount of ADVance from current S-curve segment's basepoint along path, ;; as a PROportion of segment length ;; offpro = localized amount of OFFset to side from path, as a PROportion of thickness (polar (trans (vlax-curve-getPointAtDist ; advance point along working path ibtpath (+ (vlax-curve-getDistAtPoint ibtpath sbase) (* advpro slength); proportion of segment length ); end + ); end getPointAtDist 0 1 ; from World coordinates to object's coordinates ); end trans (+ ; localized angle of offset (locdir ibtpath (+ (vlax-curve-getDistAtPoint ibtpath sbase) (* advpro slength) ); end + ); end locdir (* pi 0.5 side); perpendicular to center-line path [side +/- gives left/right] ); end + (* offpro *ibthk*); proportion of insulation thickness ); end polar ); end defun - ibpt ; (defun ibptend (offpro) ;; This subroutine calculates an Insulation-Batt polyline definition PoinT, aligned with the ;; END of the path, to avoid possible failure from calculation-rounding going beyond end ;; [except in closed Plines - see slength], with offpro argument as above (polar (trans (vlax-curve-getEndPoint ibtpath) 0 1) (+ ; localized angle of offset ; following instead of (locdir ibtpath pathlength), because that fails at end of "heavy" ; 2D Polyline -- somehow (vlax-curve-getParamAtDist ibtpath pathlength) returns nil (angle '(0 0 0) (trans (vlax-curve-getFirstDeriv ibtpath (vlax-curve-getEndParam ibtpath) ); end getFirstDeriv 0 1 T ; world to current CS, as displacement ); end trans ); end angle (* pi 0.5 side); perpendicular to center-line path [side +/- gives left/right] ); end + (* offpro *ibthk*); proportion of insulation thickness ); end polar ); end defun - ibptend ; ;;; ******************************** Main Routine: IB ******************************** (defun C:IB (/ *error* cmde osm blips plwid pltyp ltyp typetemp pathsel pathdata pathtype polyclosed unlktemp deltemp thktemp justtemp ucschanged ptno side pldist plpt ibtpath pathlength isCurved vertcheck vertbulge sbase ssegs slength) ; (defun *error* (errmsg) (if (not (wcmatch errmsg "Function cancelled,quit / exit abort")) (princ (strcat "\nError: " errmsg)) ); end if (command) (command) (if ucschanged (command "_.ucs" "_prev")) ; ^ i.e. don't go back unless routine reached UCS change but didn't change it back (ibreset) ); end defun - *error* ; (command "_.undo" "_begin") (setq cmde (getvar 'cmdecho)) (setvar 'cmdecho 0) (setq osm (getvar 'osmode) blips (getvar 'blipmode) plwid (getvar 'plinewid) pltyp (getvar 'plinetype) ltyp (getvar 'celtype) ); end setq (setvar 'plinewid 0) (setvar 'plinetype 2) (setvar 'celtype "CONTINUOUS") ; (initget (strcat "Existing Line Arc Circle Pline ELlipse Spline" (if *ibtype* " PRevious" ""); add PR option only if not first use (if (member *ibjust* '("Left" "Right")) " Flip" ""); add Flip option only if prior was L/R ); end strcat ); end initget (setq typetemp (getkword (strcat "\nPath type [Existing, or new Line(single)/Arc/Circle/Pline/ELlipse/Spline" (if *ibtype* "/PRevious" ""); offer PR option if not first use (if (member *ibjust* '("Left" "Right")) "/Flip" ""); add Flip option only if prior was L/R "] <" (if *ibtype* *ibtype* "Line"); prior choice default if applicable; otherwise Line ">: " ); end strcat ); end getkword & typetemp *ibtype* (cond (typetemp); if User typed something other than Enter, use it (*ibtype*); if Enter and there's a prior choice, use that (T "Line"); otherwise [Enter on first use], Line default ); end cond & *ibtype* ); end setq ; (if (and (wcmatch *ibtype* "PRevious,Flip") *isLocked*) (command "_.layer" "_unlock" *pathlay* ""); then - unlock layer without asking [prior Proceed option] ); end if ; (cond ; select or make path ((= *ibtype* "Existing") (while (not (and (setq pathsel (car (entsel "\nSelect object to draw batt insulation along an Existing path: ")) pathdata (if pathsel (entget pathsel)) pathtype (if pathsel (substr (cdr (assoc 100 (cdr (member (assoc 100 pathdata) pathdata)))) 5)) ; ^ = entity type from second (assoc 100) without "AcDb" prefix; using this because (assoc 0) ; value is the same for 2D & 3D Polylines; 2D OK, but not 3D because they can't be offset, ; so only center justification could be offered, and result would be flattened in current CS ); end setq (wcmatch pathtype "Line,Arc,Circle,Ellipse,Spline,Polyline,2dPolyline") ); end and ); end not (prompt "\nNothing selected, or it is not a 2D finite path type; try again:") ); end while ); end first condition - Existing ((and (wcmatch *ibtype* "PRevious,Flip") (= *ibdel* "Delete")) (entdel *ibpath*)); bring back prior ((= *ibtype* "Line") (setvar 'cmdecho 1) (command "_.line" pause pause "") (setvar 'cmdecho 0)) ((not (wcmatch *ibtype* "PRevious,Flip")); all other entity types (setvar 'cmdecho 1) (command *ibtype*) (while (> (getvar 'cmdactive) 0) (command pause)) (setvar 'cmdecho 0) ); end fourth condition ); end cond (setvar 'blipmode 0) ; (setq *ibpath* ; set object as base path [not localized, so it can be brought back if PR/F and D options] (cond ((= *ibtype* "Existing") pathsel); selected object ((wcmatch *ibtype* "PRevious,Flip") *ibpath*); keep the same ((entlast)); otherwise, newly created path ); end cond & *ibpath* pathdata (entget *ibpath*) pathtype (cdr (assoc 0 pathdata)); can now use this, once past possibility of selecting 3D Polyline polyclosed ; used in offsetting and segment-length determinations (and (wcmatch pathtype "*POLYLINE"); allow for "heavy" 2D or "lightweight" Polylines (vlax-curve-isClosed *ibpath*) ); end and *pathlay* (cdr (assoc 8 pathdata)) ; ^ not localized, so that under PRevious or Flip options, knows what layer to unlock if needed *isLocked* ; not localized, so that under PRevious or Flip options, don't need to ask again (if (and (wcmatch *ibtype* "PRevious,Flip") *isLocked*) T ; keep with PR/F if prior object was on locked layer (/= (cdr (assoc 70 (tblsearch "layer" *pathlay*))) 0); other types - 0 for Unlocked: nil; 4 for Locked: T ); end if & *isLocked* ); end setq ; (if *isLocked* (if (not (wcmatch *ibtype* "PRevious,Flip")); then - check for not redoing prior object (progn ; then - ask whether to unlock (initget "Proceed Quit") (setq unlktemp (getkword (strcat "\nLayer is locked; temporarily unlock and Proceed, or Quit? [P/Q] <" (if *ibunlk* (substr *ibunlk* 1 1) "P"); at first use, Proceed default; otherwise, prior choice ">: " ); end strcat ); end getkword & unlktemp *ibunlk* (cond (unlktemp); if User typed something, use it (*ibunlk*); if Enter and there's a prior choice, keep that (T "Proceed"); otherwise [Enter on first use], Proceed ); end cond & *ibunlk* ); end setq (if (= *ibunlk* "Proceed") (command "_.layer" "_unlock" *pathlay* ""); then (progn (ibreset) (quit)); else ); end if ); end progn & inner else argument ); end inner if & outer then argument ); end outer if - no else argument [no issue if not on locked layer] ; (if (wcmatch *ibtype* "PRevious,Flip") (entdel *ib*)) ; ^ if re-using Previous path with new choices, or Flipping to other side, delete previous result ; (if (/= *ibtype* "Flip") (progn ; then - ask whether to Retain or Delete if not Flipping (initget "Retain Delete") (setq deltemp (getkword (strcat "\nRetain or Delete base path [R/D] <" (if *ib* (substr *ibdel* 1 1) "D"); at first use, Delete default; otherwise, prior choice ">: " ); end strcat ); end getkword *ibdel* (cond (deltemp); if User typed something, use it (*ibdel*); if Enter and there's a prior choice, keep that (T "Delete"); otherwise [Enter on first use], Delete ); end cond & *ibdel* ); end setq ); end progn ); end if -- no else argument [keep previous option if Flipping] ; (if (/= *ibtype* "Flip") (progn ; then - ask for thickness if not Flipping (initget (if *ibthk* 6 7) "A B C D"); no Enter on first use, no 0, no negative (setq thktemp (getdist (strcat "\nThickness of insulation batting, or [A=3.5/B=5.5/C=9.5/D=12]" (if *ibthk* (strcat " <" (rtos *ibthk* 2 2) ">") ""); default only if not first use ": " ); end strcat ); end getdist & thktemp *ibthk* (cond ((= thktemp "A") 3.5) ((= thktemp "B") 5.5) ((= thktemp "C") 9.5) ((= thktemp "D") 12.0) ((numberp thktemp) thktemp); user entered number or picked distance (T *ibthk*); otherwise, user hit Enter - keep value ); end cond & *ibthk* ); end setq ); end progn ); end if -- no else argument [keep previous thickness if Flipping] ; (if (/= *ibtype* "Flip") (progn ; then - ask for justification if not Flipping (initget "Center Left Right") (setq justtemp (getkword (strcat "\nJustification [Center/Left(inside arc,circle,ellipse)/Right(outside)] <" (if *ibjust* (substr *ibjust* 1 1) "C"); at first use, Center default; otherwise, prior choice ">: " ); end strcat ); end getkword *ibjust* (cond (justtemp); if User typed something, use it (*ibjust*); if Enter and there's a prior choice, use that (T "Center"); otherwise [Enter on first use], Center ); end cond & *ibjust* ); end setq ); end progn (setq *ibjust* (if (= *ibjust* "Left") "Right" "Left")); else - reverse justification if Flipping ); end if ; (command "_.ucs" "_new" "_object" *ibpath*) ; set UCS to match object (setq ucschanged T ; marker for *error* to reset UCS if routine doesn't get to it ptno 0 ; starting point-number value for intermediate point multiplier side 1 ; starting directional multiplier for 'side' [left/right of center-path] argument in (ibpt) ); end setq ; (setvar 'osmode 0); placed here so running Osnap can be used to draw path, if desired ; (if (= *ibjust* "Center") (command "_.copy" *ibpath* "" '(0 0 0) '(0 0 0)); then - copy in place for Center justification (command ; else - offset by half insulation thickness for Left or Right justification "_.offset" (/ *ibthk* 2) *ibpath* (polar (if polyclosed ; less risk of inside-offsetting Plines closing at acute angles wrongly to outside (setq ; then - partway in pldist (vlax-curve-getDistAtParam *ibpath* 0.5) plpt (trans (vlax-curve-getPointAtParam *ibpath* 0.5) 0 1) ); end setq (trans (vlax-curve-getStartPoint *ibpath*) 0 1); else - start point ); end if - point argument (apply (if (= *ibjust* "Left") '+ '-); add for Left, subtract for Right (list (locdir *ibpath* (if polyclosed pldist 0)) (/ pi 2)); partway into closed Pline; else, startpoint ); end apply - angle argument 0.1 ; distance ); end polar "" ; end offset ); end command - offset & else argument ); end if ; (setq ibtpath (entlast); save as Temporary [working] PATH pathlength (vlax-curve-getDistAtParam ibtpath (vlax-curve-getEndParam ibtpath)) isCurved ; Determine whether path has any curves, calling for more definition points - without them, ; widened curves on outside of curved paths bulge beyond insulation thickness [even with ; them, this can still happen very slightly, if path curves sharply enough relative to thickness] (cond ((= pathtype "LINE") nil); Lines are never curved ((= pathtype "LWPOLYLINE"); check LWPolylines for arc segments (if (vl-remove-if-not ; recognize only non-0 bulge factors '(lambda (x) (and (= (car x) 42) (/= (cdr x) 0.0))) pathdata ); end vl-remove-if-not; returns list only if there are arc segments T ; contains at least one arc segment nil ; all line segments ); end if ); end LWPolyline condition ((= pathtype "POLYLINE"); check heavy 2D Polylines for arc segments (setq vertcheck (entnext ibtpath)) (while (and (not vertbulge) (= (cdr (assoc 0 (entget vertcheck))) "VERTEX") ); end and (setq vertbulge (/= (cdr (assoc 42 (entget vertcheck))) 0.0); T if bulge factor vertcheck (entnext vertcheck) ); end setq ); end while vertbulge ); end heavy 2D Polyline condition (T) ; Arc/Circle/Ellipse/Spline are always curved ); end cond & isCurved sbase (vlax-curve-getStartPoint ibtpath); startpoint is first S-curve BASE point ssegs ; closed paths need even numbers of S-SEGmentS; open can have odd number (if (vlax-curve-isClosed *ibpath*) (* (fix (+ (/ pathlength *ibthk* 0.4) 0.5)) 2); then - round to nearest *even* number (fix (+ (/ pathlength *ibthk* 0.2) 0.5)); else - round to nearest *whole* number ); end if & ssegs slength ; proportioned S-segment LENGTH (/ pathlength (if polyclosed ; First derivative returns nil at end parameter of closed LWPolyline, causing failure ; of angle calculation, so in that case, (+ ssegs 0.001); then - shorten segment length very slightly [results in tiny gap at tangent closure] ssegs ; else - divisor is unadjusted number of segments ); end if ); end / & pathlength ); end setq ; (if (= *ibdel* "Delete") (setvar 'clayer *pathlay*)) ; if Deleting Existing path, draw on same Layer ; (command "_.pline" (ibpt 0 0.5); start point of first S-curve "_arc" (while (< ptno ssegs) (setq sbase (vlax-curve-getPointAtDist ibtpath (* slength ptno)); incremented base along path for S segment ptno (1+ ptno); increment point number for next time [put here so it's not last function in (while) loop] ); end setq (command "_second") (if isCurved (command ; then - more definition points for curved paths (ibpt 0.3 0.49); second point of first shorter curve (ibpt 0.6 0.46); third point of first shorter curve "_second" ); end interim command ); end if [no else - continue to next second-point designation] (command (ibpt 0.8 0.42); second point of [second shorter, or first longer] curve (if (and (= ptno ssegs) (not polyclosed)); third point of curve at touch-point (ibptend 0.3); then - at end if not closed Pline (ibpt 1.0 0.3); else - intermediate, or end of closed Pline ); end if "_second" (ibpt 0.9 0.19); second point of next curve (ibpt 0.8 0.14); third point of next curve "_line" ); end interim command (setq side (- side)); for second half of S-curve on other side of path (command (ibpt 0.2 0.14); feed end of cross-the-path line segment out to Pline "_arc" "_second" (ibpt 0.1 0.19); second point of first curve (ibpt 0 0.3); third point of first curve at touch-point "_second" (ibpt 0.2 0.42); second point of curve after touch-point ); end interim command (if isCurved ; then - more definition points for curved paths (command (ibpt 0.4 0.46); third point of first shorter curve "_second" (ibpt 0.7 0.49); second point of second shorter curve ); end interim command ); end if [no else - continue to next second-point designation] (command (if (and (= ptno ssegs) (not polyclosed)); third point of last curve in overall S-curve (ibptend 0.5); then - at end if not closed Pline (ibpt 1.0 0.5); else - intermediate, or end of closed Pline ); end if ); end command ); end while ); end command - pline ; (command "_.ucs" "_prev") (setq ucschanged nil ; eliminate UCS reset in *error* since routine did it already *ib* (entlast); save result in case of recall of routine with PRevious or Flip option ); end setq (entdel ibtpath); remove temporary working path (if (= *ibdel* "Delete") (entdel *ibpath*)); remove base path under Delete option ; (if (and (wcmatch *ibtype* "Existing,PRevious,Flip") (= *ibdel* "Delete")) (command "_.layerp")) ; ^ reset Layer if appropriate (if *isLocked* (command "_.layer" "_lock" *pathlay* "")); re-lock layer if appropriate (ibreset) (princ) ); end defun - IB (prompt "Type IB to make polyline-form Insulation Batting.") Meilleure salutations

Salut Denis, Je te remercie d'avoir pris le temps de me répondre. Tanpis pour la commande DHSOMPOLY :( Mais vraiment dommage pour ma deuxième question elle aurait été très utile... surtout pour moi :D ;) Merci pour tout Meilleures salutations

Bonjour, Je vous remercie pour le partage de vos lisp . Je me permets de vous écrire au sujet du lisp SomPoly. La commande SomPoly fonctionne correctement ;) . Malheureusement la commande DHSomPoly ne fonctionne pas et j'ai ce message ci-dessous : Commande: DHSOMPOLY Somme des Polylignes par calques; erreur: no function definition: SET_TILE_LIST Le fichier dcl et placé dans un répertoire reconnu, il est placé au même endroit des fichier dcl d'origine d'autocad : C:\Users\nen\AppData\Roaming\Autodesk\AutoCAD 2018\R22.0\fra\Support Une autre petite question ;), est-il possible dans la commande SomPoly de rajouter la possibilité de sélectionner qu'une partie de polyligne et non tous ? Merci d'avance Meilleures salutations

Re salut, Après avoir manipulé dans tous les sens... j'ai enfin réussi :D ce code fonctionne si il est copier/coller directement dans la commande d'autocad (startapp "C:\\Program Files\\Internet Explorer\\iexplore.exe" "http://www.cadxp.com") Mais si on veux créer une commande type macro c'est plutôt ceci (startapp "C:/Program Files/Internet Explorer/iexplore.exe" "http://www.cadxp.com") Salutations à tous Meilleures salutations

Salut , Je te remercie pour ton message ;) Malheureusement cela ne fonctionne pas :blink: Voici le code ^C^C(startapp "C:\\Program Files\\Internet Explorer\\iexplore.exe" "http://www.cadxp.com") Et j'ai ceci comme réponse sur AutoCAD: (startapp "C: et rien ne se passe :( Merci d'avance¨ Meilleures salutations

Bonjour, Une autre petite question si jeux me permettre :D J'ai essayé d'ouvrir une page internet avec les deux codes ci-dessous. C'est à peux près la même chose qu'avec un exe, pourquoi cela ne fonctionne pas ? :huh: Le principe devrait être le même non ? :blink: ^C^C(startapp "iexplore.exe" "https://www.google.fr/") ou ^C^C(startapp "https://www.google.fr/") Merci d'avance Meilleures salutations

Salut, Essaye de faire un post sur ce site "www.theswamp.org" il est en anglais . Il est très réactif et en général tu obtiens toujours de l’aide, je l’utilise fréquemment ;) . PS : ta demande m’intéresse aussi :D Meilleures salutations

Bonjour, Je vous remercie de votre aides à tous. Sur le site The Swamp ;) le code ci-dessous : ^C^C(startapp "C:/Program Files/Autodesk/AutoCAD 2018/Support/DWGVersion/DWGVersion.exe") Dans la fichier "acad.pgp" il est aussi possible de faire démarrer une application par exemple Word: WINWORD, START WINWORD, 1,, Meilleures salutations

.

Salut Patrick_35, Je te remercie pour ton message. :) J'ai essayé plusieurs combinaison et cela ne fonctionne pas :( Un peu d'aide serait sympa ;) Merci d'avance Meilleures salutations

Bonjour le forum, J’aurais besoin de vos lumières ;) . J’ai créé un menu perso et je voudrais ouvrir depuis ce menu une application « DWGVersion » J’ai ce code ci-dessous qui fonctionne pour ouvrir un lisp mais malheureusement ne fonctionne pas pour un exe, j’ai ce message : « ; erreur: caractère lu incorrect (octal): 0 » :( Est-ce que quelqu’un aurait une idée ? :blink: ^C^C((lambda ( exe ) (if (findfile exe) (load exe nil) (princ (strcat (chr 10) exe " not found.")))) "C:/Program Files/Autodesk/AutoCAD 2018/Support/DWGVersion/DWGVersion.exe") Merci d’avance Meilleures salutations

Bonjour, Merci Patrick_35 pour le conseil, en effet je suis allé faire un post sur le site "The Swamp.org". :D J'ai eu une réponse, mais pas du créateur du lisp, mais de "Augusto". :) Il a rajouté la fonction "attsync" dans le lisp, ce qui fait que maintenant l'option rotation fonctionne avec des attributs dans un bloc, les autres options je ne les ai pas testées. ;) Ci-dessous le code modifié :D ;| ;; DBMAN Dynamic Block MANipulator ;; By: Andrea Andreetti 2009-01 10 ;; V.1.0 ;; ;; v.1.1 By Andre Andreetti ;; - + - added for scale factor ;; ;; v.1.2 By Andre Andreetti 16-03-2009 ;; - English/French messages added ;; - Rotate Relative/Absolute/Value option added ;; - Mtext info added ;; .Cursor Angle ;; .Angle Object ;; .X Scale Object ;; .Y Scale Object ;; .Base Point ;; .Block Layer ;; - Switch MTEXT information with TAB key ;; - Mtext for distance added ;; - Copy option added ;; |; (vl-load-com) (princ "\nDBMAN v. 1.2 by Andrea Andreetti -Loaded-") (defun c:DBMan () (defun *error* (msg) (dbMANFinishMode) (redraw) (princ (strcat "\n" msg)) ) ;; FRENCH/ENGLISH DETECTION ;; ;; (defun Langage () (if (vl-string-search "(FR)" (strcase (ver))) (progn (setq LANG "FR") (setq mess1 "\nSelectionnez votre block...") (setq mess2 "\n(R)otation/(E)chelle/(D)éplacer/(C)opier/(A)ligner: ") (setq mess3 "\n(D)ynamique/(V)aleur: ") (setq mess4 "\n(A)bsolu/(R)elatif/(V)aleur: ") (setq mess5 "Angle: ") (setq mess6 "Échelle: ") (setq mess7 "\nCopie... ") (setq mTss1 "Angle Curseur: ") (setq mTss2 "Angle Object: ") (setq mTss3 "Échelle Object X: ") (setq mTss4 "Échelle Object Y: ") (setq mTss5 "Point d'insertion: ") (setq mTss6 "Calque: ") ) (progn (setq LANG "EN") (setq mess1 "\nPlease Select your Block...") (setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ") (setq mess3 "\n(D)ynamic/(V)alue: ") (setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ") (setq mess5 "Angle: ") (setq mess6 "Scale: ") (setq mess7 "\nCopy... ") (setq mTss1 "Cursor Angle: ") (setq mTss2 "Object Angle: ") (setq mTss3 "Object Scale X: ") (setq mTss4 "Object Scale Y: ") (setq mTss5 "Insertion Point: ") (setq mTss6 "Layer: ") ) ) ) (Langage) ;; ;; FRENCH/ENGLISH DETEXTION ;; ;; Degree Conversion ;; ;; (defun dtr (a) (* pi (/ a 180.0)) ) (defun rtd (a) (/ (* a 180) pi) ) ;; ;; Degree Conversion ;; ;; ENTITY SELECTION ;; ;; (setq dr_sel1 nil) (while (or (= dr_sel1 nil) (/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) "INSERT" ) ) (setq dr_sel1 (entsel mess1)) ) (setq Bedata (entget (car dr_sel1))) (setq Bselec (cdar Bedata)) (setq Bname (cdr (assoc 2 Bedata))) (setq Bbase (cdr (assoc 10 Bedata))) (setq bENAME (cdr (assoc -1 Bedata))) (setq insPblock Bbase) (setq allBlock (ssget "X" (list (cons 0 "INSERT") (cons 2 Bname)))) (setq #block (1- (sslength allBlock))) (setq #block2 #block) ;; ;; ENTITY SELECTION ;; (setq ANGpoints nil) (setq _val -1) (repeat (1+ #block2) (setq _SSblock (ssname allBlock (setq _val (1+ _val)))) (setq _entBdata (entget _SSblock)) (setq ANGpoints (append ANGpoints (list (list _SSblock (cdr (assoc 50 _entBdata)))) ) ) ) (setq snapang (getvar "snapang")) (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object))) (DBM_go) ;_while (while (and (not (= (car input) 25)) ;RIGHT CLICK (not (= (car input) 11)) ;RIGHT CLICK (not (= (car input) 3)) ;LEFT CLICK (not (and (= (car input) 2) (= (cadr input) 32))) ;ESCAPE (not (and (= (car input) 2) (= (cadr input) 13))) ;ENTER ) (DBM_go) ) (dbMANFinishMode) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object))) ) ;; ;| ;; DBMAN Dynamic Block MANipulator ;; |; ;| ;; DBMAN KEY PRESSED DETECTION ;; |; ;; (defun DBM_GO () (setvar "CMDECHO" 0) (setq orthm (getvar "ORTHOMODE")) (setq snapa (getvar "SNAPANG")) (setq ToDo nil) (setq INSpoints nil ANGpoints nil SCALEpoints nil DBMTdata nil DBMTdataDI nil) (setq val -1) (repeat (1+ #block) (setq SSblock (ssname allBlock (setq val (1+ val)))) (setq entBdata (entget SSblock)) (setq INSpoints (append INSpoints (list (list SSblock (cdr (assoc 10 entBdata)))) ) ) (setq INSlocation INSpoints) (setq ANGpoints (append ANGpoints (list (list SSblock (cdr (assoc 50 entBdata)))) ) ) (setq SCALEpoints (append SCALEpoints (list (list SSblock (list (cdr (assoc 41 entBdata)) (cdr (assoc 42 entBdata))))) ) ) ) (setq LLent (vl-list-length INSpoints)) (setq #iblock 0) (setq multiplier 1.4) (setq RotRequest nil) (princ mess2) (setq messPRINT T) (setq input (grread t 4 4)) (while (and (setq input (grread t 4 4)) (or (= (car input) 5) ; *cursor (and (= (car input) 2) (= (cadr input) 9)) ;TAB (and (= (car input) 2) (= (cadr input) 15)) ; F8 Orthomode (and (= (car input) 2) (= (cadr input) 114)) ; r = Rotation (and (= (car input) 2) (= (cadr input) 82)) ; R = Rotation (and (= (car input) 2) (= (cadr input) 115)) ; s = Scale (and (= (car input) 2) (= (cadr input) 83)) ; S = Scale (and (= (car input) 2) (= (cadr input) 101)) ; e = Echelle (and (= (car input) 2) (= (cadr input) 69)) ; E = Echelle (and (eq LANG "FR")(= (car input) 2) (= (cadr input) 100)) ; d = Déplacer (and (eq LANG "FR")(= (car input) 2) (= (cadr input) 68)) ; D = Déplacer (and (eq LANG "EN") (= (car input) 2) (= (cadr input) 109)) ; m = Move (and (eq LANG "EN")(= (car input) 2) (= (cadr input) 77)) ; M = Move (and (= (car input) 2) (= (cadr input) 99)) ; c = Copy (and (= (car input) 2) (= (cadr input) 67)) ; C = Copy (and (= (car input) 2) (= (cadr input) 97)) ; a = Aligned (and (= (car input) 2) (= (cadr input) 65)) ; A = Aligned (and (= (car input) 2) (= (cadr input) 45)) ;(and (= (car input) 2) (= (cadr input) 51)) ; 3D ; - (and (= (car input) 2) (= (cadr input) 61)) (and (= (car input) 2) (= (cadr input) 43)) ; + ) ) (redraw) (if (not messPRINT) (progn (princ mess2) (setq messPRINT T) ) ) (if (not cursorpoint) (setq cursorpoint (getvar "Lastpoint")) ) ; Cursor Point (if (= (car input) 5) (progn (setq cursorpoint (cadr input)) (setq cursorangle (angle Bbase cursorpoint)) (setq cursordistance (distance Bbase cursorpoint)) ) ) ; TAB (if (and (= (car input) 2) (= (cadr input) 9)) (progn (if (eq #iblock (1- LLent)) (setq #iblock 0) (setq #iblock (1+ #iblock)) ) (setq bENAME (car (nth #iblock INSpoints))) (setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints)))))) (setq itemLayer (cdr (assoc 8 (entget bENAME)))) ;Block Layer bENAME ) ) (if (or (and (= (car input) 2) (= (cadr input) 114)) ; r = Rotation (and (= (car input) 2) (= (cadr input) 82)) ; R ) (progn (setq RotRequest nil) (setq messPRINT nil) (setq Todo "ROTATION") ) ) (if (or (and (= (car input) 2) (= (cadr input) 109)) ; m = Move (and (= (car input) 2) (= (cadr input) 77)) ; M (and (= (car input) 2) (= (cadr input) 100)) ; D = Déplacer (and (= (car input) 2) (= (cadr input) 68)) ; D ) (progn (setq RotRequest nil) (setq Todo "MOVE") ) ) (if (or (and (= (car input) 2) (= (cadr input) 99)) ; c = Copy (and (= (car input) 2) (= (cadr input) 67)) ; C ) (progn (setq RotRequest nil) (setq Todo "COPY") ) ) (if (vl-string-search "(FR)" (strcase (ver))) (if (or (and (= (car input) 2) (= (cadr input) 101)) ; e = Echelle (and (= (car input) 2) (= (cadr input) 69)) ; E ) (progn (setq RotRequest nil) (setq messPRINT nil) (setq Todo "SCALE") ) ) (if (or (and (= (car input) 2) (= (cadr input) 115)) ; s = Scale (and (= (car input) 2) (= (cadr input) 83)) ; S ) (progn (setq RotRequest nil) (setq Todo "SCALE") ) ) ) (if (or (and (= (car input) 2) (= (cadr input) 97)) ; m = Move (and (= (car input) 2) (= (cadr input) 65)) ; M ) (progn (setq RotRequest nil) (setq Todo "ALIGNED") ) ) (if (and (= (car input) 2) (= (cadr input) 15)) (setq Todo "ORTHO") ) ; + (if (or (and (= (car input) 2) (= (cadr input) 61)) (and (= (car input) 2) (= (cadr input) 43)) ) (setq multiplier (1+ multiplier)) ) ; - (if (and (= (car input) 2) (= (cadr input) 45)) (setq multiplier (1- multiplier)) ) ;;SWITCH ORTHOMODE ;; ;; (if (eq ToDo "ORTHO") (progn (if (eq orthm 1) (progn (setvar "ORTHOMODE" 0) (setq orthm 0)) (progn (setvar "ORTHOMODE" 1) (setq orthm 1)) ) (setq ToDo PreviousToDo) ) ) (if (eq orthM 1) (DBMANortho) ) ;; ;;SWITCH ORTHOMODE ;; ;| R O T A T I O N |; (setq val -1) (if (eq ToDo "ROTATION") (progn (if (not RotRequest) (progn (initget "R A V" 1) (setq RotRequest (getKword mess4)) (if (eq RotRequest "V") (progn (setq snapA (dtr (getreal mess5))) (command "SNAPANG" (rtd snapA)) (setvar "ORTHOMODE" 1) (setq orthm 1) ) ) ) ) (UpdateBlocks 50 nil) ) ) ;| M O V E |; (setq val -1) (if (eq ToDo "MOVE") (progn (setq _val -1) (repeat (1+ #block2) (setq _SSblock (ssname allBlock (setq _val (1+ _val)))) (setq _entBdata (entget _SSblock)) (setq INSlocation (append INSlocation (list (list _SSblock (cdr (assoc 10 _entBdata)))) ) ) ) (UpdateBlocks 10 nil) ) ) ;| C O P Y |; (setq val -1) (if (eq todo "COPY") (progn (setq newobjects (ssadd)) (princ mess7) (setq messprint t) (setq input2 (grread t 5 0)) (while input2 (if (= (car input2) 3) (setq copycursor (cadr input2)) ) (if newobjects (vl-cmdf "._erase" newobjects "") ) (if (= (car input2) 5) (progn (redraw) (setq cursorpos (cadr input2)) (DBMANtextDI 254 (polar Bbase (angle Bbase cursorpos) (/ (distance Bbase cursorpos) 2)) (distance Bbase cursorpos)) (foreach n inspoints (setq copypoint (polar (cadr n) (angle bbase (cadr input2)) (distance bbase (cadr input2)) ) ) (entmake (subst (cons 10 copypoint) (assoc 10 (entget (car n))) (entget (car n)) ) ) (setq newobject (entlast)) (ssadd newobject newobjects) (grdraw (cadr n) (polar (cadr n) (angle bbase (cadr input2)) (distance bbase (cadr input2)) ) 4 1 ) ) ) ) (if (and copycursor (= (car input2) 3)) (progn (foreach n inspoints (setq copypoint (polar (cadr n) (angle bbase copycursor) (distance bbase copycursor) ) ) (entmake (subst (cons 10 copypoint) (assoc 10 (entget (car n))) (entget (car n)) ) ) ) ) ) (if (= (car input2) 11) (setq input2 nil) (setq input2 (grread t 5 0)) ) );_while (if (eq (car input2) 11) (if newobjects (vl-cmdf "._erase" newobjects "") ) ) ) ) (if NewObjects (setq NewObjects nil) ) ;| S C A L E |; (setq val -1) (if (eq ToDo "SCALE") (progn (if (not RotRequest) (progn (initget "R A V" 1) (setq RotRequest (getKword mess4)) (if (eq RotRequest "V") (progn (setq SpecScale (getreal mess6)) (UpdateBlocks nil SpecScale) ) (setq SpecScale cursordistance) ) ;(UpdateBlocks nil (/ cursordistance (abs multiplier))) ) ) ;(princ "eee") (if (/= RotRequest "V") ;(UpdateBlocks nil SpecScale) (UpdateBlocks nil (/ SpecScale (abs multiplier))) ) ) ) | ;| R O T A T I O N |; ;| (setq val -1) (if (eq ToDo "ROTATION") (progn (if (not RotRequest) (progn (initget "R A V" 1) (setq RotRequest (getKword mess4)) (if (eq RotRequest "V") (progn (setq snapA (dtr (getreal mess5))) (command "SNAPANG" (rtd snapA)) (setvar "ORTHOMODE" 1) (setq orthm 1) ) ) ) ) (UpdateBlocks 50 nil) ) ) |; ;| A L I G N E D |; (setq val -1) (if (eq ToDo "ALIGNED") (UpdateBlocks 50 cursorpoint) ) (setq PreviousToDo ToDo) ) (if DBMTdata (progn (vl-cmdf "._erase" DBMTdata "") (setq DBMTdata nil) ) ) (if DBMTdataDI (progn (vl-cmdf "._erase" DBMTdataDI "") (setq DBMTdataDI nil) ) ) (redraw) ) ;; ;| ;; DBMAN KEY PRESSED DETECTION ;; |; ;| ;; BLOCK UPDATE ;; |; ;; (defun UpdateBlocks (cons1 value) (setq NBpoint (cadr (assoc Bselec INSlocation))) (repeat (1+ #block) (setq SSblock (ssname allBlock (setq val (1+ val)))) (setq entBdata (entget SSblock)) (setq ent10 (cdr (assoc 10 entBdata))) ;insertion point (setq itemangle (cdr (assoc 50 entBdata))) ;Block Angle (setq cursorpoint2 cursorpoint) (setq cursorangle2 (angle NBpoint cursorpoint)) (setq cursordistance2 (distance NBpoint cursorpoint)) (if (eq ToDo "MOVE") (progn (setq Npoint2 (polar (cadr (assoc SSblock INSpoints)) cursorangle2 cursordistance2)) (grdraw (cadr (assoc SSblock INSpoints)) Npoint2 4 1 ) (setq cursorangle2 (angle (cadr (assoc SSblock INSpoints)) Npoint2)) (setq entBdata (subst (cons cons1 Npoint2) (assoc cons1 entBdata) entBdata ) ) (setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints)))))) ) ) (if (eq todo "ROTATION") (progn (grdraw ent10 (polar ent10 (angle NBpoint cursorpoint) cursordistance) 4 1 ) (setq value (angle ent10 (polar ent10 (angle NBpoint cursorpoint) cursordistance))) (if (eq rotrequest "R");Relatif (progn (Setq IBangle (+ value (cadr (assoc SSblock ANGpoints)))) (Setq itemAngle (cdr (assoc cons1 entbdata))) ) ) (if (eq rotrequest "A");Absolu (progn (setq itemangle value) (setq IBangle value) ) ) (if (eq rotrequest "V");Valeur (progn (setq itemangle value) (setq IBangle value) ) ) (setq entbdata (subst (cons cons1 IBangle) (assoc cons1 entbdata) entbdata ) ) ) ) (if (eq ToDo "SCALE") (progn (grdraw ent10 (polar ent10 cursorangle2 cursordistance2 ) 4 1 ) (if (eq rotrequest "R");Relatif (progn (Setq itemXscale (+ value (caadr (assoc SSblock SCALEpoints)))) (Setq itemYscale (+ value (cadadr (assoc SSblock SCALEpoints)))) ) ) (if (eq rotrequest "A");Absolu (progn (setq itemXscale value) (setq itemYscale value) ) ) (if (eq rotrequest "V");Valeur (progn (setq itemXscale value) (setq itemYscale value) ) ) (setq entBdata (subst (cons 41 itemXscale) (assoc 41 entBdata) entBdata )) (setq entBdata (subst (cons 42 itemYscale) (assoc 42 entBdata) entBdata )) ) ) (if (eq ToDo "ALIGNED") (progn (setq e10 (cdr (assoc 10 entBdata))) (grdraw e10 (polar e10 (angle e10 value) (distance e10 value)) 4 1 ) (setq entBdata (subst (cons cons1 (angle e10 value)) (assoc cons1 entBdata) entBdata ) ) ) ) (setq itemAngle (rtd (cdr (assoc 50 (entget bENAME))))) (setq itemXscale (cdr (assoc 41 (entget bENAME)))) (setq itemYscale (cdr (assoc 42 (entget bENAME)))) (if (> itemAngle 360.0) (setq itemAngle (- itemAngle 360.0)) ) (DBMANtext 252 (rtd cursorangle2) itemAngle itemXscale itemYscale insPblock itemLayer) (entmod entBdata) ;-------------------------------------------------------------------- ;the "attsync" command has been included here ;-------------------------------------------------------------------- (vl-cmdf "_.attsync" "_N" (cdr (assoc 2 (entget bENAME)))) ;-------------------------------------------------------------------- ) (if (or (eq ToDo "MOVE") (eq ToDo "COPY") ) (DBMANtextDI 254 (polar NBpoint (angle NBpoint cursorpoint) (/ (distance NBpoint cursorpoint) 2)) (distance NBpoint cursorpoint)) ) (setq cursorpoint2 nil) ) ;; ;| ;; BLOCK UPDATE ;; |; ;| ;; DBMAN ORTHOMODE ;; |; ;; (defun DBMANortho (/ distP NorthP WestP EastP SouthP) (setq distP (distance Bbase cursorpoint)) (setq NorthP (polar Bbase (+ snapA (dtr 90)) distP)) (setq WestP (polar Bbase (+ snapA (dtr 180)) distP)) (setq EastP (polar Bbase snapA distP)) (setq SouthP (polar Bbase (- snapA (dtr 90)) distP)) (if (and (< (distance cursorpoint NorthP) (distance cursorpoint WestP)) (< (distance cursorpoint NorthP) (distance cursorpoint EastP)) (< (distance cursorpoint NorthP) (distance cursorpoint SouthP)) ) (setq cursorpoint NorthP) ) (if (and (< (distance cursorpoint WestP) (distance cursorpoint NorthP)) (< (distance cursorpoint WestP) (distance cursorpoint EastP)) (< (distance cursorpoint WestP) (distance cursorpoint SouthP)) ) (setq cursorpoint WestP) ) (if (and (< (distance cursorpoint EastP) (distance cursorpoint WestP)) (< (distance cursorpoint EastP) (distance cursorpoint NorthP)) (< (distance cursorpoint EastP) (distance cursorpoint SouthP)) ) (setq cursorpoint EastP) ) (if (and (< (distance cursorpoint SouthP) (distance cursorpoint WestP)) (< (distance cursorpoint SouthP) (distance cursorpoint EastP)) (< (distance cursorpoint SouthP) (distance cursorpoint NorthP)) ) (setq cursorpoint SouthP) ) ) ;; ;| ;; DBMAN ORTHOMODE ;; |; ;| ;; MTEXT CREATION DISTANCE ;; |; ;; (defun DBMANtextDI ( bakgr ;background color po ;Position DI ;DIstance ) (if DBMTdataDI (progn (vl-cmdf "._erase" DBMTdataDI "") (setq DBMTdataDI nil) ) ) (setq DBMTstringDI (strcat "{\\fArial|b0|i0|c0|p34;\\C250;" "\\C5;" (vl-princ-to-string DI) "\\C250\\P" ) ) (setq ViewSize (getvar "VIEWSIZE")) (setq DBMTdataDI (entmakex (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 1 DBMTstringDI) (cons 10 (polar po 0 (/ ViewSize 90.0)) ) (cons 40 (/ ViewSize 70.0)) (cons 50 0.0) (cons 62 250) (cons 71 5) (cons 72 5) (cons 73 1) (cons 90 1) (cons 63 bakgr) (cons 45 1.2) ) ) ) ) ;; ;| ;; MTEXT CREATION DISTANCE ;; |; ;| ;; MTEXT CREATION INFO ;; |; ;; (defun DBMANtext ( bakgr ;background color CA ;Cursor Angle AO ;Angle Object xSO ;X Scale Object ySO ;Y Scale Object BP ;Base Ppoint BL ;Block Layer ) (if DBMTdata (progn (vl-cmdf "._erase" DBMTdata "") (setq DBMTdata nil) ) ) (setq DBMTstring (strcat "{\\fArial|b0|i0|c0|p34;\\C250;" mTss1 "\\C5;" (vl-princ-to-string CA) "°\\C250\\P" mTss2 "\\C5;" (vl-princ-to-string AO) "°\\C250\\P" mTss3 "\\C5;" (vl-princ-to-string xSO) "\\C250\\P" mTss4 "\\C5;" (vl-princ-to-string ySO) "\\C250\\P" mTss5 "\\C5;" (vl-princ-to-string BP) "\\C250\\P" mTss6 "\\C5;" (vl-princ-to-string BL) "\\C250\\P" ) ) (setq ViewSize (getvar "VIEWSIZE")) (setq DBMTdata (entmakex (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 1 DBMTstring) (cons 10 (polar BP 0 (/ ViewSize 90.0)) ) (cons 40 (/ ViewSize 70.0)) (cons 50 0.0) (cons 62 250) (cons 71 1) (cons 72 5) (cons 90 1) (cons 63 bakgr) (cons 45 1.2) ) ) ) ) ;; ;| ;; MTEXT CREATION INFO ;; |; ;| ;; RESET VARIABLES ;; |; ;; (defun dbmanfinishmode () (redraw) (if dbmtdata (progn (vl-cmdf "._erase" dbmtdata "") (setq dbmtdata nil)) ) (if dbmtdatadi (progn (vl-cmdf "._erase" dbmtdatadi "") (setq dbmtdatadi nil) ) ) (command "SNAPANG" (rtd snapang)) (foreach var '(mess1 mess2 dr_sel1 bedata bename bname #block bbase allblock todo inspoints cal ssblock entbdata cursorpoint cursorangle cursordistance entbdata npoint npoint2 ent10 _val _ssblock _entbdata ass41 ass42 cursorpoint2 cursorangle2 cursordistance2 orthm snapa snapang ) (setq var nil) ) ) ;; ;| ;; RESET VARIABLES ;; |; ;|«Visual LISP© Format Options» (120 2 1 2 nil "Ende von " 60 20 1 1 0 nil nil nil T) ;*** NE PAS AJOUTER de texte au-dessous du commentaire! ***|; Merci à bientôt Meilleures salutations

Bonjour, Je me permets de sollicité l’aide du forum :D J’ai trouvé un lisp de Andrea Andreetti de la société DuctiSoft (http://www.ductisoft.com) qui me servirait super bien, c’est surtout l’option rotation qui m’intéresse. ;) Malheureusement il a un ou deux petit bug. :huh: 1. J’ai des attribut dans un blocs et quand j’effectue une rotation avec la commande DBMAN le texte ne tourne pas avec le blocs ? 2. Si on utilise l’option Déplacé, il déplace bien les blocs mais pas les attributs ? 3. L’option Copier fait planter mon AutoCAD 2018 ? 4. L’option Echelle j’ai pas compris comment elle fonctionne ? Est-ce que quelqu’un aurait une solution ? ;| ;; DBMAN Dynamic Block MANipulator ;; By: Andrea Andreetti 2009-01 10 ;; V.1.0 ;; ;; v.1.1 By Andre Andreetti ;; - + - added for scale factor ;; ;; v.1.2 By Andre Andreetti 16-03-2009 ;; - English/French messages added ;; - Rotate Relative/Absolute/Value option added ;; - Mtext info added ;; .Cursor Angle ;; .Angle Object ;; .X Scale Object ;; .Y Scale Object ;; .Base Point ;; .Block Layer ;; - Switch MTEXT information with TAB key ;; - Mtext for distance added ;; - Copy option added ;; |; (vl-load-com) (princ "\nDBMAN v. 1.2 by Andrea Andreetti -Loaded-") (defun c:DBMan () (defun *error* (msg) (dbMANFinishMode) (redraw) (princ (strcat "\n" msg)) ) ;; FRENCH/ENGLISH DETECTION ;; ;; (defun Langage () (if (vl-string-search "(FR)" (strcase (ver))) (progn (setq LANG "FR") (setq mess1 "\nSelectionnez votre block...") (setq mess2 "\n(R)otation/(E)chelle/(D)éplacer/(C)opier/(A)ligner: ") (setq mess3 "\n(D)ynamique/(V)aleur: ") (setq mess4 "\n(A)bsolu/(R)elatif/(V)aleur: ") (setq mess5 "Angle: ") (setq mess6 "Échelle: ") (setq mess7 "\nCopie... ") (setq mTss1 "Angle Curseur: ") (setq mTss2 "Angle Object: ") (setq mTss3 "Échelle Object X: ") (setq mTss4 "Échelle Object Y: ") (setq mTss5 "Point d'insertion: ") (setq mTss6 "Calque: ") ) (progn (setq LANG "EN") (setq mess1 "\nPlease Select your Block...") (setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ") (setq mess3 "\n(D)ynamic/(V)alue: ") (setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ") (setq mess5 "Angle: ") (setq mess6 "Scale: ") (setq mess7 "\nCopy... ") (setq mTss1 "Cursor Angle: ") (setq mTss2 "Object Angle: ") (setq mTss3 "Object Scale X: ") (setq mTss4 "Object Scale Y: ") (setq mTss5 "Insertion Point: ") (setq mTss6 "Layer: ") ) ) ) (Langage) ;; ;; FRENCH/ENGLISH DETEXTION ;; ;; Degree Conversion ;; ;; (defun dtr (a) (* pi (/ a 180.0)) ) (defun rtd (a) (/ (* a 180) pi) ) ;; ;; Degree Conversion ;; ;; ENTITY SELECTION ;; ;; (setq dr_sel1 nil) (while (or (= dr_sel1 nil) (/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) "INSERT" ) ) (setq dr_sel1 (entsel mess1)) ) (setq Bedata (entget (car dr_sel1))) (setq Bselec (cdar Bedata)) (setq Bname (cdr (assoc 2 Bedata))) (setq Bbase (cdr (assoc 10 Bedata))) (setq bENAME (cdr (assoc -1 Bedata))) (setq insPblock Bbase) (setq allBlock (ssget "X" (list (cons 0 "INSERT") (cons 2 Bname)))) (setq #block (1- (sslength allBlock))) (setq #block2 #block) ;; ;; ENTITY SELECTION ;; (setq ANGpoints nil) (setq _val -1) (repeat (1+ #block2) (setq _SSblock (ssname allBlock (setq _val (1+ _val)))) (setq _entBdata (entget _SSblock)) (setq ANGpoints (append ANGpoints (list (list _SSblock (cdr (assoc 50 _entBdata)))) ) ) ) (setq snapang (getvar "snapang")) (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object))) (DBM_go) ;_while (while (and (not (= (car input) 25)) ;RIGHT CLICK (not (= (car input) 11)) ;RIGHT CLICK (not (= (car input) 3)) ;LEFT CLICK (not (and (= (car input) 2) (= (cadr input) 32))) ;ESCAPE (not (and (= (car input) 2) (= (cadr input) 13))) ;ENTER ) (DBM_go) ) (dbMANFinishMode) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object))) ) ;; ;| ;; DBMAN Dynamic Block MANipulator ;; |; ;| ;; DBMAN KEY PRESSED DETECTION ;; |; ;; (defun DBM_GO () (setvar "CMDECHO" 0) (setq orthm (getvar "ORTHOMODE")) (setq snapa (getvar "SNAPANG")) (setq ToDo nil) (setq INSpoints nil ANGpoints nil SCALEpoints nil DBMTdata nil DBMTdataDI nil) (setq val -1) (repeat (1+ #block) (setq SSblock (ssname allBlock (setq val (1+ val)))) (setq entBdata (entget SSblock)) (setq INSpoints (append INSpoints (list (list SSblock (cdr (assoc 10 entBdata)))) ) ) (setq INSlocation INSpoints) (setq ANGpoints (append ANGpoints (list (list SSblock (cdr (assoc 50 entBdata)))) ) ) (setq SCALEpoints (append SCALEpoints (list (list SSblock (list (cdr (assoc 41 entBdata)) (cdr (assoc 42 entBdata))))) ) ) ) (setq LLent (vl-list-length INSpoints)) (setq #iblock 0) (setq multiplier 1.4) (setq RotRequest nil) (princ mess2) (setq messPRINT T) (setq input (grread t 4 4)) (while (and (setq input (grread t 4 4)) (or (= (car input) 5) ; *cursor (and (= (car input) 2) (= (cadr input) 9)) ;TAB (and (= (car input) 2) (= (cadr input) 15)) ; F8 Orthomode (and (= (car input) 2) (= (cadr input) 114)) ; r = Rotation (and (= (car input) 2) (= (cadr input) 82)) ; R = Rotation (and (= (car input) 2) (= (cadr input) 115)) ; s = Scale (and (= (car input) 2) (= (cadr input) 83)) ; S = Scale (and (= (car input) 2) (= (cadr input) 101)) ; e = Echelle (and (= (car input) 2) (= (cadr input) 69)) ; E = Echelle (and (eq LANG "FR")(= (car input) 2) (= (cadr input) 100)) ; d = Déplacer (and (eq LANG "FR")(= (car input) 2) (= (cadr input) 68)) ; D = Déplacer (and (eq LANG "EN") (= (car input) 2) (= (cadr input) 109)) ; m = Move (and (eq LANG "EN")(= (car input) 2) (= (cadr input) 77)) ; M = Move (and (= (car input) 2) (= (cadr input) 99)) ; c = Copy (and (= (car input) 2) (= (cadr input) 67)) ; C = Copy (and (= (car input) 2) (= (cadr input) 97)) ; a = Aligned (and (= (car input) 2) (= (cadr input) 65)) ; A = Aligned (and (= (car input) 2) (= (cadr input) 45)) ;(and (= (car input) 2) (= (cadr input) 51)) ; 3D ; - (and (= (car input) 2) (= (cadr input) 61)) (and (= (car input) 2) (= (cadr input) 43)) ; + ) ) (redraw) (if (not messPRINT) (progn (princ mess2) (setq messPRINT T) ) ) (if (not cursorpoint) (setq cursorpoint (getvar "Lastpoint")) ) ; Cursor Point (if (= (car input) 5) (progn (setq cursorpoint (cadr input)) (setq cursorangle (angle Bbase cursorpoint)) (setq cursordistance (distance Bbase cursorpoint)) ) ) ; TAB (if (and (= (car input) 2) (= (cadr input) 9)) (progn (if (eq #iblock (1- LLent)) (setq #iblock 0) (setq #iblock (1+ #iblock)) ) (setq bENAME (car (nth #iblock INSpoints))) (setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints)))))) (setq itemLayer (cdr (assoc 8 (entget bENAME)))) ;Block Layer bENAME ) ) (if (or (and (= (car input) 2) (= (cadr input) 114)) ; r = Rotation (and (= (car input) 2) (= (cadr input) 82)) ; R ) (progn (setq RotRequest nil) (setq messPRINT nil) (setq Todo "ROTATION") ) ) (if (or (and (= (car input) 2) (= (cadr input) 109)) ; m = Move (and (= (car input) 2) (= (cadr input) 77)) ; M (and (= (car input) 2) (= (cadr input) 100)) ; D = Déplacer (and (= (car input) 2) (= (cadr input) 68)) ; D ) (progn (setq RotRequest nil) (setq Todo "MOVE") ) ) (if (or (and (= (car input) 2) (= (cadr input) 99)) ; c = Copy (and (= (car input) 2) (= (cadr input) 67)) ; C ) (progn (setq RotRequest nil) (setq Todo "COPY") ) ) (if (vl-string-search "(FR)" (strcase (ver))) (if (or (and (= (car input) 2) (= (cadr input) 101)) ; e = Echelle (and (= (car input) 2) (= (cadr input) 69)) ; E ) (progn (setq RotRequest nil) (setq messPRINT nil) (setq Todo "SCALE") ) ) (if (or (and (= (car input) 2) (= (cadr input) 115)) ; s = Scale (and (= (car input) 2) (= (cadr input) 83)) ; S ) (progn (setq RotRequest nil) (setq Todo "SCALE") ) ) ) (if (or (and (= (car input) 2) (= (cadr input) 97)) ; m = Move (and (= (car input) 2) (= (cadr input) 65)) ; M ) (progn (setq RotRequest nil) (setq Todo "ALIGNED") ) ) (if (and (= (car input) 2) (= (cadr input) 15)) (setq Todo "ORTHO") ) ; + (if (or (and (= (car input) 2) (= (cadr input) 61)) (and (= (car input) 2) (= (cadr input) 43)) ) (setq multiplier (1+ multiplier)) ) ; - (if (and (= (car input) 2) (= (cadr input) 45)) (setq multiplier (1- multiplier)) ) ;;SWITCH ORTHOMODE ;; ;; (if (eq ToDo "ORTHO") (progn (if (eq orthm 1) (progn (setvar "ORTHOMODE" 0) (setq orthm 0)) (progn (setvar "ORTHOMODE" 1) (setq orthm 1)) ) (setq ToDo PreviousToDo) ) ) (if (eq orthM 1) (DBMANortho) ) ;; ;;SWITCH ORTHOMODE ;; ;| R O T A T I O N |; (setq val -1) (if (eq ToDo "ROTATION") (progn (if (not RotRequest) (progn (initget "R A V" 1) (setq RotRequest (getKword mess4)) (if (eq RotRequest "V") (progn (setq snapA (dtr (getreal mess5))) (command "SNAPANG" (rtd snapA)) (setvar "ORTHOMODE" 1) (setq orthm 1) ) ) ) ) (UpdateBlocks 50 nil) ) ) ;| M O V E |; (setq val -1) (if (eq ToDo "MOVE") (progn (setq _val -1) (repeat (1+ #block2) (setq _SSblock (ssname allBlock (setq _val (1+ _val)))) (setq _entBdata (entget _SSblock)) (setq INSlocation (append INSlocation (list (list _SSblock (cdr (assoc 10 _entBdata)))) ) ) ) (UpdateBlocks 10 nil) ) ) ;| C O P Y |; (setq val -1) (if (eq todo "COPY") (progn (setq newobjects (ssadd)) (princ mess7) (setq messprint t) (setq input2 (grread t 5 0)) (while input2 (if (= (car input2) 3) (setq copycursor (cadr input2)) ) (if newobjects (vl-cmdf "._erase" newobjects "") ) (if (= (car input2) 5) (progn (redraw) (setq cursorpos (cadr input2)) (DBMANtextDI 254 (polar Bbase (angle Bbase cursorpos) (/ (distance Bbase cursorpos) 2)) (distance Bbase cursorpos)) (foreach n inspoints (setq copypoint (polar (cadr n) (angle bbase (cadr input2)) (distance bbase (cadr input2)) ) ) (entmake (subst (cons 10 copypoint) (assoc 10 (entget (car n))) (entget (car n)) ) ) (setq newobject (entlast)) (ssadd newobject newobjects) (grdraw (cadr n) (polar (cadr n) (angle bbase (cadr input2)) (distance bbase (cadr input2)) ) 4 1 ) ) ) ) (if (and copycursor (= (car input2) 3)) (progn (foreach n inspoints (setq copypoint (polar (cadr n) (angle bbase copycursor) (distance bbase copycursor) ) ) (entmake (subst (cons 10 copypoint) (assoc 10 (entget (car n))) (entget (car n)) ) ) ) ) ) (if (= (car input2) 11) (setq input2 nil) (setq input2 (grread t 5 0)) ) );_while (if (eq (car input2) 11) (if newobjects (vl-cmdf "._erase" newobjects "") ) ) ) ) (if NewObjects (setq NewObjects nil) ) ;| S C A L E |; (setq val -1) (if (eq ToDo "SCALE") (progn (if (not RotRequest) (progn (initget "R A V" 1) (setq RotRequest (getKword mess4)) (if (eq RotRequest "V") (progn (setq SpecScale (getreal mess6)) (UpdateBlocks nil SpecScale) ) (setq SpecScale cursordistance) ) ;(UpdateBlocks nil (/ cursordistance (abs multiplier))) ) ) ;(princ "eee") (if (/= RotRequest "V") ;(UpdateBlocks nil SpecScale) (UpdateBlocks nil (/ SpecScale (abs multiplier))) ) ) ) | ;| R O T A T I O N |; ;| (setq val -1) (if (eq ToDo "ROTATION") (progn (if (not RotRequest) (progn (initget "R A V" 1) (setq RotRequest (getKword mess4)) (if (eq RotRequest "V") (progn (setq snapA (dtr (getreal mess5))) (command "SNAPANG" (rtd snapA)) (setvar "ORTHOMODE" 1) (setq orthm 1) ) ) ) ) (UpdateBlocks 50 nil) ) ) |; ;| A L I G N E D |; (setq val -1) (if (eq ToDo "ALIGNED") (UpdateBlocks 50 cursorpoint) ) (setq PreviousToDo ToDo) ) (if DBMTdata (progn (vl-cmdf "._erase" DBMTdata "") (setq DBMTdata nil) ) ) (if DBMTdataDI (progn (vl-cmdf "._erase" DBMTdataDI "") (setq DBMTdataDI nil) ) ) (redraw) ) ;; ;| ;; DBMAN KEY PRESSED DETECTION ;; |; ;| ;; BLOCK UPDATE ;; |; ;; (defun UpdateBlocks (cons1 value) (setq NBpoint (cadr (assoc Bselec INSlocation))) (repeat (1+ #block) (setq SSblock (ssname allBlock (setq val (1+ val)))) (setq entBdata (entget SSblock)) (setq ent10 (cdr (assoc 10 entBdata))) ;insertion point (setq itemangle (cdr (assoc 50 entBdata))) ;Block Angle (setq cursorpoint2 cursorpoint) (setq cursorangle2 (angle NBpoint cursorpoint)) (setq cursordistance2 (distance NBpoint cursorpoint)) (if (eq ToDo "MOVE") (progn (setq Npoint2 (polar (cadr (assoc SSblock INSpoints)) cursorangle2 cursordistance2)) (grdraw (cadr (assoc SSblock INSpoints)) Npoint2 4 1 ) (setq cursorangle2 (angle (cadr (assoc SSblock INSpoints)) Npoint2)) (setq entBdata (subst (cons cons1 Npoint2) (assoc cons1 entBdata) entBdata ) ) (setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints)))))) ) ) (if (eq todo "ROTATION") (progn (grdraw ent10 (polar ent10 (angle NBpoint cursorpoint) cursordistance) 4 1 ) (setq value (angle ent10 (polar ent10 (angle NBpoint cursorpoint) cursordistance))) (if (eq rotrequest "R");Relatif (progn (Setq IBangle (+ value (cadr (assoc SSblock ANGpoints)))) (Setq itemAngle (cdr (assoc cons1 entbdata))) ) ) (if (eq rotrequest "A");Absolu (progn (setq itemangle value) (setq IBangle value) ) ) (if (eq rotrequest "V");Valeur (progn (setq itemangle value) (setq IBangle value) ) ) (setq entbdata (subst (cons cons1 IBangle) (assoc cons1 entbdata) entbdata ) ) ) ) (if (eq ToDo "SCALE") (progn (grdraw ent10 (polar ent10 cursorangle2 cursordistance2 ) 4 1 ) (if (eq rotrequest "R");Relatif (progn (Setq itemXscale (+ value (caadr (assoc SSblock SCALEpoints)))) (Setq itemYscale (+ value (cadadr (assoc SSblock SCALEpoints)))) ) ) (if (eq rotrequest "A");Absolu (progn (setq itemXscale value) (setq itemYscale value) ) ) (if (eq rotrequest "V");Valeur (progn (setq itemXscale value) (setq itemYscale value) ) ) (setq entBdata (subst (cons 41 itemXscale) (assoc 41 entBdata) entBdata )) (setq entBdata (subst (cons 42 itemYscale) (assoc 42 entBdata) entBdata )) ) ) (if (eq ToDo "ALIGNED") (progn (setq e10 (cdr (assoc 10 entBdata))) (grdraw e10 (polar e10 (angle e10 value) (distance e10 value)) 4 1 ) (setq entBdata (subst (cons cons1 (angle e10 value)) (assoc cons1 entBdata) entBdata ) ) ) ) (setq itemAngle (rtd (cdr (assoc 50 (entget bENAME))))) (setq itemXscale (cdr (assoc 41 (entget bENAME)))) (setq itemYscale (cdr (assoc 42 (entget bENAME)))) (if (> itemAngle 360.0) (setq itemAngle (- itemAngle 360.0)) ) (DBMANtext 252 (rtd cursorangle2) itemAngle itemXscale itemYscale insPblock itemLayer) (entmod entBdata) ) (if (or (eq ToDo "MOVE") (eq ToDo "COPY") ) (DBMANtextDI 254 (polar NBpoint (angle NBpoint cursorpoint) (/ (distance NBpoint cursorpoint) 2)) (distance NBpoint cursorpoint)) ) (setq cursorpoint2 nil) ) ;; ;| ;; BLOCK UPDATE ;; |; ;| ;; DBMAN ORTHOMODE ;; |; ;; (defun DBMANortho (/ distP NorthP WestP EastP SouthP) (setq distP (distance Bbase cursorpoint)) (setq NorthP (polar Bbase (+ snapA (dtr 90)) distP)) (setq WestP (polar Bbase (+ snapA (dtr 180)) distP)) (setq EastP (polar Bbase snapA distP)) (setq SouthP (polar Bbase (- snapA (dtr 90)) distP)) (if (and (< (distance cursorpoint NorthP) (distance cursorpoint WestP)) (< (distance cursorpoint NorthP) (distance cursorpoint EastP)) (< (distance cursorpoint NorthP) (distance cursorpoint SouthP)) ) (setq cursorpoint NorthP) ) (if (and (< (distance cursorpoint WestP) (distance cursorpoint NorthP)) (< (distance cursorpoint WestP) (distance cursorpoint EastP)) (< (distance cursorpoint WestP) (distance cursorpoint SouthP)) ) (setq cursorpoint WestP) ) (if (and (< (distance cursorpoint EastP) (distance cursorpoint WestP)) (< (distance cursorpoint EastP) (distance cursorpoint NorthP)) (< (distance cursorpoint EastP) (distance cursorpoint SouthP)) ) (setq cursorpoint EastP) ) (if (and (< (distance cursorpoint SouthP) (distance cursorpoint WestP)) (< (distance cursorpoint SouthP) (distance cursorpoint EastP)) (< (distance cursorpoint SouthP) (distance cursorpoint NorthP)) ) (setq cursorpoint SouthP) ) ) ;; ;| ;; DBMAN ORTHOMODE ;; |; ;| ;; MTEXT CREATION DISTANCE ;; |; ;; (defun DBMANtextDI ( bakgr ;background color po ;Position DI ;DIstance ) (if DBMTdataDI (progn (vl-cmdf "._erase" DBMTdataDI "") (setq DBMTdataDI nil) ) ) (setq DBMTstringDI (strcat "{\\fArial|b0|i0|c0|p34;\\C250;" "\\C5;" (vl-princ-to-string DI) "\\C250\\P" ) ) (setq ViewSize (getvar "VIEWSIZE")) (setq DBMTdataDI (entmakex (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 1 DBMTstringDI) (cons 10 (polar po 0 (/ ViewSize 90.0)) ) (cons 40 (/ ViewSize 70.0)) (cons 50 0.0) (cons 62 250) (cons 71 5) (cons 72 5) (cons 73 1) (cons 90 1) (cons 63 bakgr) (cons 45 1.2) ) ) ) ) ;; ;| ;; MTEXT CREATION DISTANCE ;; |; ;| ;; MTEXT CREATION INFO ;; |; ;; (defun DBMANtext ( bakgr ;background color CA ;Cursor Angle AO ;Angle Object xSO ;X Scale Object ySO ;Y Scale Object BP ;Base Ppoint BL ;Block Layer ) (if DBMTdata (progn (vl-cmdf "._erase" DBMTdata "") (setq DBMTdata nil) ) ) (setq DBMTstring (strcat "{\\fArial|b0|i0|c0|p34;\\C250;" mTss1 "\\C5;" (vl-princ-to-string CA) "°\\C250\\P" mTss2 "\\C5;" (vl-princ-to-string AO) "°\\C250\\P" mTss3 "\\C5;" (vl-princ-to-string xSO) "\\C250\\P" mTss4 "\\C5;" (vl-princ-to-string ySO) "\\C250\\P" mTss5 "\\C5;" (vl-princ-to-string BP) "\\C250\\P" mTss6 "\\C5;" (vl-princ-to-string BL) "\\C250\\P" ) ) (setq ViewSize (getvar "VIEWSIZE")) (setq DBMTdata (entmakex (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 1 DBMTstring) (cons 10 (polar BP 0 (/ ViewSize 90.0)) ) (cons 40 (/ ViewSize 70.0)) (cons 50 0.0) (cons 62 250) (cons 71 1) (cons 72 5) (cons 90 1) (cons 63 bakgr) (cons 45 1.2) ) ) ) ) ;; ;| ;; MTEXT CREATION INFO ;; |; ;| ;; RESET VARIABLES ;; |; ;; (defun dbmanfinishmode () (redraw) (if dbmtdata (progn (vl-cmdf "._erase" dbmtdata "") (setq dbmtdata nil)) ) (if dbmtdatadi (progn (vl-cmdf "._erase" dbmtdatadi "") (setq dbmtdatadi nil) ) ) (command "SNAPANG" (rtd snapang)) (foreach var '(mess1 mess2 dr_sel1 bedata bename bname #block bbase allblock todo inspoints cal ssblock entbdata cursorpoint cursorangle cursordistance entbdata npoint npoint2 ent10 _val _ssblock _entbdata ass41 ass42 cursorpoint2 cursorangle2 cursordistance2 orthm snapa snapang ) (setq var nil) ) ) ;; ;| ;; RESET VARIABLES ;; |; ;|«Visual LISP© Format Options» (120 2 1 2 nil "Ende von " 60 20 1 1 0 nil nil nil T) ;*** NE PAS AJOUTER de texte au-dessous du commentaire! ***|; Merci d’avance Meilleures salutations