bonjour à tous, J utilise un Lisp qui marche parfaitement quand je travaille en mètre or voilà il m'arrive de travailler en millimètre et j'aurais aimé qu'il marche également sans forcement un calcul long. Par exemple, me donner le ml comme si j'étais en mètre. je dessine une ligne de 1 en mm ( = 1000 ), le Lisp me donne le résultat de 1 et non 1000 voici le Lisp en question : ;; CotonGratte.lsp : préparation et dessin des multilignes pour représenter des faces de coton gratté. ;; ;; Fichiers et styles nécessaires : ;; 1. Style de texte : ;; nom=CotonGratté, police=romans.shx, ht.=0.18 ;; ;;============================================================================================= ;; Contrôle d'erreur (defun *cgr_err* (s) (if U:F (eval (read U:F)) ) (if (not (member s '("Fonction annulée" "interruption de la console") ) ) (princ (strcat "\nErreur: " s)) ) (if old_tx (setvar "textstyle" old_tx) ) (if old_cycle (setvar "selectioncycling" old_cycle) ) (if old_fd (setvar "filedia" old_fd) ) (if old_cd (setvar "cmddia" old_cd) ) (if old_ce (setvar "cmdecho" old_ce) ) (if old_celtscale (setvar "celtscale" old_celtscale) ) (if old_cecolor (setvar "cecolor" old_cecolor) ) (if old_trans (setvar "cetransparency" old_trans) ) (if old_lay (setvar "clayer" old_lay) ) (if cgr:err (setq *error* cgr:err cgr:err nil ) ) (princ) ) ;;;============================================================================================= (defun c:cgr () (c:CotonGratte) ) ;;;============================================================================================= (defun c:CotonGratte (/ old_fd old_cd old_ce old_tx temp temp_coul temp_lai U:D U:F list_coul tex p1 p2 p3 mlines mlineslist whatnext lstyltxt temp_face old_trans old_lay fillcolor ) (setq cgr:err *error* *error* *cgr_err* old_fd (getvar "filedia") old_cd (getvar "cmddia") old_ce (getvar "cmdecho") old_tx (getvar "textstyle") old_lay (getvar "clayer") old_cycle (getvar "selectioncycling") coul_coton (if (or (= nil coul_coton) (= "" coul_coton)) "" (strcase coul_coton) ) coul_temp "" hauteur_face (if (or (= nil hauteur_face) (= "" hauteur_face)) "" hauteur_face ) df_ou_sf (if (or (= nil df_ou_sf) (= "" df_ou_sf)) "" df_ou_sf ) lstyl (getvar "cmlstyle") temp T temp_lai "" ) (setvar "filedia" 0) (setvar "cmddia" 0) (setvar "cmdecho" 0) (setvar "selectioncycling" 0) (setq U:D "(command-s \"_UNDO\" \"_be\")" U:F "(command-s \"_UNDO\" \"_e\")" ) (eval (read U:D)) (if (= 1 (cgr:definestyles)) ;define text style and charge pointillé line type (progn (if (= 1 (makemlinelist)) (cgr:userchoice) ;main command line ) ) ) (if U:F (eval (read U:F)) ) (if old_tx (setvar "textstyle" old_tx) ) (if old_cycle (setvar "selectioncycling" old_cycle) ) (if old_fd (setvar "filedia" old_fd) ) (if old_cd (setvar "cmddia" old_cd) ) (if old_ce (setvar "cmdecho" old_ce) ) (if old_celtscale (setvar "celtscale" old_celtscale) ) (if old_cecolor (setvar "cecolor" old_cecolor) ) (if old_trans (setvar "cetransparency" old_trans) ) (if old_lay (setvar "clayer" old_lay) ) (if cgr:err (setq *error* cgr:err cgr:err nil ) ) (princ) ) ;;;============================================================================================= (defun cgr:definestyles () (if (not (tblsearch "STYLE" "CotonG")) (progn (if (vl-cmdf "_.-style" "CotonG" "romans.shx" "0.18" "1" "0" "" "" "") (setq whatnext 1) (setq whatnext 0) ) (setvar "textstyle" "CotonG") ) (progn (setvar "textstyle" "CotonG") (setq whatnext 1) ) ) ;(if (not (tblsearch "LTYPE" "POINTILLE")) (if (not (tblsearch "LTYPE" "POINTILLE")) (progn (if (vl-cmdf ".-typeligne" "ch" "POINTILLE" "acad.lin" "") (setq whatnext 1) (setq whatnext 0) ) ) (setq whatnext 1) ) ) ;;;============================================================================================ ;; make list of mlinestyles (defun makemlinelist () (setq mlines (dictsearch (namedobjdict) "ACAD_MLINESTYLE")) (foreach x mlines (if (= 3 (car x)) (setq mlineslist (cons (cdr x) mlineslist)) ) ) ;;; (if (setq mlineslist (reverse mlineslist)) (setq whatnext 1) ;;; ) ) ;;;============================================================================================= (defun cgr:userchoice () (setq p1 T) (while (/= nil p1) (initget (+ 1024 128) "Paramètres") (setq p1 (getpoint (strcat "\nParamètres courants : Coton gratté = " ;;; lstyl coul_coton " / Simple ou double face = " df_ou_sf "\nSélectionnez un point du départ ou [Paramètres] : " ) ) ) (cond ((or (= p1 "Paramètres") (= nil coul_coton) (= "?" coul_coton) (= "" coul_coton) (= nil hauteur_face) (= "?" hauteur_face) (= "" coul_coton) (= nil df_ou_sf) (= "?" df_ou_sf) (= "" coul_coton) ) (setq ptemp T) (while (/= nil ptemp) (Initget "Couleur Hauteur Nombre Faces") (setq ptemp (getkword (strcat "\nModifier les paramètres [Couleur<" coul_coton ">/Hauteur<" hauteur_face ">/Nombre de Faces<" df_ou_sf ">] : " ) ) ) (cond ((= ptemp "Couleur") (setq coul_temp (strcase (getstring (strcat "\nRéférence de coton <" coul_coton "> : " ) ) ) ) (if (and (/= nil coul_temp) (/= "" coul_temp)) (setq coul_coton coul_temp) ) ) ((= ptemp "Hauteur") (initget "0.25 0.5 1 1.10 1.25 1.5 1.6 1.7 2 2.25 2.5 2.7 3 3.2 3.5 4 4.30 5") (setq temp_lai (getkword (strcat "\nHauteur de face 0.25 / 0.5 / 1 / 1.10 / 1.25 / 1.5 / 1.6 / 1.7 / 2 / 2.25 / 2.5 / 2.7 / 3 / 3.2 / 3.5 / 4 / 4.30 / 5 /<" hauteur_face "> : " ) ) ) (if (and (/= nil temp_lai) (/= "" temp_lai)) (setq hauteur_face temp_lai) ) ) ((or (= ptemp "Nombre") (= ptemp "Faces")) (initget "SF DF") (setq temp_face (getkword (strcat "\nSimple ou double face <" df_ou_sf "> : " ) ) ) (if (and (/= nil temp_face) (/= "" temp_face)) (setq df_ou_sf (strcase temp_face)) ) ) (T (if (and coul_coton hauteur_face) (progn (setq lstyl (strcat "CG_" coul_coton "_X_" hauteur_face) ;;; lstyltxt (strcat coul_coton "x" hauteur_face) ) (if (/= 0 (- (atof hauteur_face) (atoi hauteur_face))) (setq lstyl (strcat "CG_" coul_coton "_X_" (substr hauteur_face 1 1) "-" (substr hauteur_face 3 3) ) ) ) (if (member lstyl mlineslist) (setq ptemp nil) (progn (cgr:mlstylemake lstyl hauteur_face) (if (= 1 whatnext) (setq ptemp nil) ) ) ) ) ) ) ) ) ) (T (setq lstyltxt (strcat coul_coton "x" hauteur_face)) (if (tblsearch "LAYER" (strcat "Coton Gratté " coul_coton) ) (progn (vl-cmdf "_.-layer" "_Thaw" (strcat "Coton Gratté " coul_coton) "_On" (strcat "Coton Gratté " coul_coton) "_Unlock" (strcat "Coton Gratté " coul_coton) "E" (strcat "Coton Gratté " coul_coton) "" ) (setq whatnext 1) ) (progn (if (= nil fillcolor) (setq fillcolor (acad_colordlg 1)) ) (vl-cmdf "_.-layer" "E" (strcat "Coton Gratté " coul_coton) "CO" fillcolor (strcat "Coton Gratté " coul_coton) "" ) (setq whatnext 1) ) ) (if p1 (cgr:draw p1 lstyl lstyltxt) ) ) ) ) ) ;;;============================================================================================= (defun cgr:mlstylemake (newstyle newlarg / datalist xname decal_haut) (alert "Creation de nouveau style. Vous allez choisir un couleur du fond." ) (if (setq fillcolor (acad_colordlg 1)) (progn (setq ;;; fillcolor (cons ;;; 62 ;;; fillcolor ;;; ) decal_haut (cons 49 0.25) datalist '((0 . "MLINESTYLE") (100 . "AcDbMlineStyle") (70 . 1) (3 . "") ;;; (62 . 10) (51 . 1.5708) (52 . 1.5708) (71 . 2) (49 . 1) (62 . 7) (6 . "CONTINUOUS") (49 . 0.0) (62 . 7) (6 . "POINTILLE") ) ;;; datalist (subst fillcolor '(62 . 10) datalist) datalist (subst decal_haut '(49 . 1) datalist) xname (entmakex datalist) ) (dictadd (cdr (assoc -1 (dictsearch (namedobjdict) "ACAD_MLINESTYLE")) ) newstyle xname ) (makemlinelist) ;update list mlines (setq whatnext 1) ) (setq whatnext 0) ) ) ;;;============================================================================================= (defun cgr:draw (p1 mline mlinetxt / p2) ;;; (while (setq p1 (getpoint "\nDu point : ")) (if (setq p2 (getpoint p1 "\nAu point : ")) (progn (cgr:draw2 p1 p2 mline mlinetxt) (if (= df_ou_sf "DF") (cgr:draw2 p2 p1 mline mlinetxt) ) ) ) ;;; ) ) ;;;============================================================================================= (defun cgr:draw2 (p1 p2 mline mlinetxt / p1 p2 old_celtscale old_cecolor) (setq old_celtscale (getvar "celtscale")) (setvar "celtscale" 100) (setq ptemp p1 p1 (polar p1 (+ (angtof "90.0") (angle ptemp p2)) 0.15 ) p2 (polar p2 (+ (angtof "90.0") (angle ptemp p2)) 0.15 ) ) (command "mligne" "_j" "_z" "_st" mline "_s" "1" p1 p2 "") (setvar "celtscale" old_celtscale) (setq old_cecolor (getvar "cecolor") old_trans (getvar "cetransparency") ) (setvar "cecolor" "7") (setvar "cetransparency" 0) (setq ptemp p1 p1 (polar p1 (+ (angtof "90.0") (angle ptemp p2)) 0.125 ) p2 (polar p2 (+ (angtof "90.0") (angle ptemp p2)) 0.125 ) ) (vl-cmdf "_text" "_j" "mc" (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)) (angtos (angle p1 p2) 0 4) mlinetxt ) (setvar "cecolor" old_cecolor) (setvar "cetransparency" old_trans) ) ;;;============================================================================================= ;;CGext.lsp : routine pour calculer les longueurs des lignes utilis‚s ;;pour longueurs de coton (y compris multilignes). ;;=========================================================================== ;; Extraire second partie d'une paire pointé (type dxf) (defun dxf (n ed) (cdr (assoc n ed))) ;;=========================================================================== ;; Construire liste par addition (defun cdr_cg++ (key alist dist) ((lambda (x) (cond (x (subst (cons (car x) (+ dist (cdr x))) x alist)) (t (cons (cons key dist) alist)) ) ) (assoc key alist) ) ) ;;=========================================================================== ;; Trouver le nombre de caractères jusqu'à une clé donnée (defun list_str (string key) (setq cs (strlen string) l1 '() ) (repeat cs (setq l1 (cons (cons (substr string cs 1) cs) l1) cs (1- cs) ) ) (cdr (assoc key l1)) ) ;;============================================================================ ;; Imprimer les résultats dans un fichier sous form de table, 1 par bloc (defun table_print_cg (alist title1 title2 headsub coltab padchr car-form cdr-form / maxlen maxline padstr ) (setq *cpage-disable* nil car-form (cond (car-form) (t '(lambda (x) x)) ) cdr-form (cond (cdr-form) (t '(lambda (x) x)) ) maxlen (mapcar '(lambda (pair) (cons (strlen (car pair)) (strlen (cdr pair)) ) ) (setq alist (mapcar '(lambda (pair) (cons (apply car-form (list (car pair))) (apply cdr-form (list (cdr pair))) ) ) alist ) ) ) maxlen (+ -2 (apply 'max (mapcar 'car maxlen)) (apply 'max (mapcar 'cdr maxlen)) ) maxline 50 ;(max (+ maxlen coltab) (+ (strlen title1 title2) coltab)) padstr (repl_cg padchr 70) ) (cprinc-init_cg) (cprinc_cg (strcat title1 " " (ctab_cg (cons title1 title2) maxline (repl_cg " " 70) ) " " title2 ) ) (cprinc_cg (repl_cg headsub (+ maxline 2))) (mapcar '(lambda (pair) (cprinc_cg (strcat (car pair) " " (ctab_cg pair maxline padstr) " " (cdr pair) ) ) ) alist ) ) (defun repl_cg (char len / res) (apply 'strcat (repeat len (setq res (cons char res)))) ) (defun ctab_cg (pair ctabmax padstr) (substr padstr 1 (- ctabmax (strlen (car pair) (cdr pair)))) ) (defun cprinc-init_cg () (setq *console-lines* (cond (*console-lines*) (t 25) ) *cprinc-msg* (cond (*cprinc-msg*) (t "--- Press any key ---") ) *cprinc-rubout* (cond ((or textpage *clear-screen*) "") (t (strcat "\r" (repl_cg " " (strlen *cprinc-msg*)) "\r")) ) *cprinc-line* -1 ) (cond ((= nil fichier) (cond (textpage (textpage)) (*clear-screen* (*clear-screen*)) (t (textscr) (terpri)) ) ) ) ) (defun cprinc-page_cg () (princ *cprinc-msg*) (grread) (cond ((= nil fichier) (cond (textpage (textpage)) (*clear-screen* (*clear-screen*)) (t (textscr) (terpri)) ) ) ) (princ *cprinc-rubout*) (setq *cprinc-line* 0) ) (defun cprinc_cg (s) (cond (*cpage-disable*) ((not *cprinc-line*) (cprinc-init_cg) ) ((eq (setq *cprinc-line* (1+ *cprinc-line*)) (1- *console-lines*) ) (cprinc-page_cg) ) ) (cond (fichier (write-line s fichier)) (t (write-line s)) ) ) ;;=========================================================================== (defun c:cgext (/ ent_grp ct en1 ct2 p1 p2 d_list temp_list ans fichier titre comment ) (setq cgr:err *error* *error* *cgr_err* d_list3 nil d_list2 nil ) ;; Selectionner (if ;;; (setq ent_grp (ssget "X" '((0 . "MLINE") (2 . "CG_*")))) (setq ent_grp (ssget '((0 . "MLINE") (2 . "CG_*")))) ;; Pour chaque multiligne, calculer la distance entre chacun des sommets ;; et rajouter ce distance, avec le nom de style, dans une liste. (progn ;; Imprimer ou non les r‚sultats dans une fichier (initget 1 "Ecran Fichier") (setq ans (getkword "Impression Ecran/Fichier : ")) (cond ((= ans "Fichier") (setq fichier ;;AJ - WARNING: The DWGNAME sysvar has changed. (getstring T (strcat "\nNom de fichier <" (getvar "dwgprefix")(getvar "dwgname") "> : ") ) ) (if (or (= "" fichier) (= nil fichier)) ;;AJ - WARNING: The DWGNAME sysvar has changed. (setq fichier (open (strcat (getvar "dwgprefix") (getvar "dwgname") ".coton.txt" ) "w" ) ) (setq fichier (open (strcat (getvar "dwgprefix") fichier ".txt") "w")) ) (setq titre (getstring t "\nAffaire : ") comment (getstring t "\nZone : ") ) (write-line (strcat "Affaire : " titre) fichier) (write-line (strcat "Zone : " comment) fichier) (write-line (strcat "Extraction : " (getvar "dwgprefix") (getvar "dwgname") ) fichier ) (write-line (strcat "Dessinateur : " (getvar "loginname")) fichier ) (write-line (strcat "Date : " (menucmd "M=$(edtime,$(getvar,date),DDDD DD MONTH YYYY - H:MM)" ) ) fichier ) (write-line "Version : CotonGratte.lsp 27.01.2014" fichier) (write-line "" fichier) ) (T nil) ) (setq ct 0) (repeat (sslength ent_grp) (princ ".") (setq en1 (entget (ssname ent_grp ct))) (if (= "MLINE" (dxf 0 en1)) (progn (setq ct2 0) (while (< ct2 (length en1)) (if p2 (setq p1 p2) ) (setq pair (nth ct2 en1)) (if (= 11 (car pair)) (progn (if (not p1) (setq p1 (cdr pair)) (setq p2 (cdr pair)) ) (if p2 (setq d_list (cdr_cg++ (dxf 2 en1) d_list (fix (+ 0.5 (distance p1 p2)))) ) ) ) ) (setq ct2 (1+ ct2)) ) ;fin while (setq p1 nil p2 nil ) ) ;fin progn ) ;fin if (setq ct (1+ ct)) ) ;fin repeat (princ "Terminé.") (if (= nil fichier) (princ "\nRésultats:\n") ) ;;Trier la liste des distances totaux (setq temp_list (acad_strlsort (mapcar 'car d_list)) d_list2 (mapcar '(lambda (x) (assoc x d_list) ) temp_list ) temp_list nil ;; Section … garder; cr‚er liste des coloris de coton seules ; (mapcar '(lambda (x) ; (setq item (substr (car x) 1 (1- (list_str (car x) "_")))) ; (if (= nil (member item d_list3)) ; (progn (setq d_list3 (cons item d_list3)) (print d_list3)) ; ) ; ) ; (reverse d_list2) ; ) ;; Imprimer la liste, une table par coloris ; mettre la liste en sens inverse pour garantir le bon ; fonctionnement de wcmatch d_list2 (reverse d_list2) ct3 (length d_list2) ) ; Tant que la liste n'est pas vide... (while (>= ct3 1) (setq en_tete (car (nth 0 d_list2)) en_tete (substr en_tete 1 (1- (list_str en_tete "_"))) ) ; ...pour chaque pair qui correspond au coloris... (while (and (>= ct3 1) (wcmatch (car (nth 0 d_list2)) (strcat en_tete "*")) ) (setq temp_list (cons (nth 0 d_list2) temp_list) ; ...tronquer la liste au fur et … mesure... d_list2 (cdr d_list2) ct3 (1- ct3) ) ) (if (= nil fichier) (terpri) ) ; ...imprimer la liste (table_print_cg temp_list en_tete "Longueur" "-" 8 " " nil 'rtos) (if fichier (write-line "" fichier) ) (setq temp_list nil) ) (if fichier (close fichier) ) ) (alert "Pas de multiligne à compter") ) (setq ent_grp nil *error* cgr:err cgr:err nil ) (princ) ) (defun c:cgx () (c:cgext) ) (princ "\nCotonGrattév2.lsp chargé. Tapez CGR pour dessiner ou CGX pour extraire les longueurs de coton gratté." ) (princ)

Bonjour @AlexisF Puisque vous passez en 3D effectivement ça ne fonctionne pas ! Maintenant, je me permets de déconseiller cette façon de faire, en effet lorsque vous allez relier les points, les distances seront fausses du fait de l'éloignement du point par rapport à la droite qui sert de référence à la façade. Et en plus, vous ne connaitrez pas facilement le débord ou le retrait de ce point par rapport à l'alignement de la façade (balcon, retrait toiture...) c'est ICI Deux solutions : Vous allez voir ce que je propose pour dessiner des façades sur mon site Vous continuez avec cette démarche et je vais revoir ma routine. prévenez-moi ici ou par le formulaire de contact de mon site. Amicalement

Merci beaucoup Steven ! C'est parfait !!!!! J'ai une 50ene de plans à faire, ça va bien m'aider !!!!!

Bonjour @angelique, Voici le lisp, RINS, de Patrick_35, et le lisp INSEDIT, de Gile.😉 Les 2, font le job 😀 INSEDIT.zip RINS_V320.7z

Salut, J'ai fait une routine il y très longtemps pour le même problème ;########################################################################### ;# Copyright (C) 04-2011 Vincent PRELAT # ;# This program is free software: you can redistribute it and/or modify # ;# it under the terms of the GNU General Public License as published by # ;# the Free Software Foundation, either version 3 of the License, or # ;# any later version. # ;# This program is distributed in the hope that it will be useful, # ;# but WITHOUT ANY WARRANTY; without even the implied warranty of # ;# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # ;# GNU General Public License for more details. # ;# You should have received a copy of the GNU General Public License # ;# along with this program. If not, see <http://www.gnu.org/licenses/>. # ;########################################################################### ; Redefinit le point de base d'un bloc sans le deplacer (vl-load-com) ;; getMatrixRot Retourne la matrice d'une rotation (defun getMatrixRot (rot) (list (list (cos rot) (- (sin rot)) 0 0) (list (sin rot) (cos rot) 0 0) (list 0 0 1 0) (list 0 0 0 1) ) ) ;; getMatrixEch Retourne la matrice d'une echelle (defun getMatrixEch (ech) (list (list (nth 0 ech) 0 0 0) (list 0 (nth 1 ech) 0 0) (list 0 0 (nth 2 ech) 0) (list 0 0 0 1) ) ) ;; getMatrixTranst Retourne la matrice d'une translation (defun getMatrixTrans (trans) (list (list 1 0 0 (nth 0 trans)) (list 0 1 0 (nth 1 trans)) (list 0 0 1 (nth 2 trans)) (list 0 0 0 1) ) ) ;; mxv Apply a transformation matrix to a vector by Vladimir Nesterovsky (defun mxv (m v) (mapcar '(lambda (row) (apply '+ (mapcar '* row v))) m) ) ;; Transpose une matrice Doug Wilson (defun trp (m) (apply 'mapcar (cons 'list m)) ) ;; mxm Multiply two matrices by Vladimir Nesterovsky (defun mxm (m q) (mapcar (function (lambda (r) (mxv (trp q) r))) m) ) ;;; butlast Retourne la liste privée du dernier élément (defun butlast (lst) (reverse (cdr (reverse lst))) ) ;; REMOVE-I ;; Retourne la liste privée de l'élément à l'indice spécifié (premier élément = 0) ;; Arguments : la liste et l'indice de l'élément à supprimer (defun remove-i (ind lst) (if (or (zerop ind) (null lst)) (cdr lst) (cons (car lst) (remove-i (1- ind) (cdr lst))) ) ) ;;; VXV Retourne le produit scalaire (réel) de deux vecteurs (defun vxv (v1 v2) (apply '+ (mapcar '* v1 v2)) ) ;; V^V (gile) ;; Retourne le produit vectoriel (vecteur) de deux vecteurs ;; Arguments : deux vecteurs (defun v^v (v1 v2) (list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2))) (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2))) (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2))) ) ) ;; M+M ;; Additionne 2 matrices ;; Arguments : deux matrices (defun m+m (m1 m2) (mapcar '(lambda (v1 v2) (mapcar '+ v1 v2)) m1 m2) ) ;; MXS ;; Multiplie une martice par un nombre ;; Arguments : une matrice et un nombre (defun mxs (m s) (mapcar '(lambda (v) (vxs v s)) m)) ;; IMAT ;; Crée une matrice d'identité de dimension n ;; Argument ;; n : la dimension de la matrice (defun Imat (d / i n r m) (setq i d) (while (<= 0 (setq i (1- i))) (setq n d r nil) (while (<= 0 (setq n (1- n))) (setq r (cons (if (= i n) 1.0 0.0) r)) ) (setq m (cons r m)) ) ) ;; INVERSEMATRIX ;; Inverse une matrice carrée (méthode Gauss-Jordan) ;; Argument: la matrice ;; Retour : la matrice inverse ou nil (si non inversible) (defun InverseMatrix (mat / col piv row res) (setq mat (mapcar '(lambda (x1 x2) (append x1 x2)) mat (Imat (length mat)))) (while mat (setq col (mapcar '(lambda (x) (abs (car x))) mat)) (repeat (vl-position (apply 'max col) col) (setq mat (append (cdr mat) (list (car mat)))) ) (if (equal (setq piv (caar mat)) 0.0 1e-14) (setq mat nil res nil ) (setq piv (/ 1.0 piv) row (mapcar '(lambda (x) (* x piv)) (car mat)) mat (mapcar '(lambda (r / e) (setq e (car r)) (cdr (mapcar '(lambda (x n) (- x (* n e))) r row)) ) (cdr mat) ) res (cons (cdr row) (mapcar '(lambda (r / e) (setq e (car r)) (cdr (mapcar '(lambda (x n) (- x (* n e))) r row)) ) res ) ) ) ) ) (reverse res) ) (defun c:insredef (/ ent bl rot ech invech ptnouv ptins vect vect2 mat matrot matech debut nb nb1 allbl pt n i namebl) (setvar "cmdecho" 0) (command "_.undo" "_m") (setq ent (car (entsel "Selectionner le bloc a modifier :"))) (if (/= ent nil) (progn (setq bl (cdr (assoc 2 (entget ent)))) ;; Calcul du vecteur de deplacement dans le scu du bloc (setq ptins (cdr (assoc 10 (entget ent)))) (setq rot (cdr (assoc 50 (entget ent)))) (setq ech (list (cdr (assoc 41 (entget ent))) (cdr (assoc 42 (entget ent))) (cdr (assoc 43 (entget ent))) )) (vla-highlight (vlax-ename->vla-object ent) :vlax-true) (setq ptnouv (getpoint "Pointez le nouveau point de base du bloc :")) (vla-highlight (vlax-ename->vla-object ent) :vlax-false) (setq ptnouv (trans ptnouv 1 0)) (setq vect (mapcar '(lambda (x y) (- y x)) ptins ptnouv)) (setq invech (mapcar '(lambda (x) (/ 1 x)) ech)) (setq matech (getMatrixEch invech)) (setq matrot (getMatrixRot (- rot))) (setq mat (mxm matech matrot)) (setq vect (butlast (mxv mat vect))) ;;_fin calc vect dep ;; Modif definition du bloc (setq debut 1) (while (/= namebl bl) (setq i (tblnext "block" debut) debut nil) (setq namebl (cdr (assoc 2 i))) ) (if (/= i nil) (progn (setq n (cdr (assoc -2 i))) (while n (if (and (/= (cdr (assoc 0 (entget n))) "VERTEX") (/= (cdr (assoc 0 (entget n))) "COVAPTSEL")) (vla-move (vlax-ename->vla-object n) (vlax-3d-point (list 0.0 0.0 0.0)) (vlax-3d-point (mapcar '(lambda (x) (- x)) vect))) ) (setq n (entnext n)) (if (/= n nil) (if (= (cdr (assoc 0 (entget n))) "SEQEND") (setq n nil)) ) ) ;_while )) ;_if ;; Fin modif bloc ;; Deplace les blocs (setq allbl (ssget "x" (list (cons 2 bl)))) (setq nb 0 nb1 (sslength allbl)) (while (< nb nb1) (setq ent (ssname allbl nb)) (setq ptins (cdr (assoc 10 (entget ent)))) (setq rot (cdr (assoc 50 (entget ent)))) (setq ech (list (cdr (assoc 41 (entget ent))) (cdr (assoc 42 (entget ent))) (cdr (assoc 43 (entget ent))) )) (setq matech (getMatrixEch ech)) (setq matrot (getMatrixRot rot)) (setq mat (mxm matech matrot)) (setq vect2 (butlast (mxv mat vect))) (setq pt (mapcar '(lambda (x y) (+ x y)) ptins vect2)) (entmod (subst (cons 10 pt) (assoc 10 (entget ent)) (entget ent))) (setq nb (+ nb 1)) ) ;; Fin deplace blocs )) ;;_if (/= ent nil) )