Aller au contenu
Problème de lien d'inscription (résolu ?) ×

Carroyage

ddb64

Par ddb64
dans AutoCAD 2000 à 2002

 Partager

Messages recommandés

ddb64 Newbie

ddb64

Posté(e)
Posté(e)

Salut tout le monde,

 

j'ai retrouvé un lisp qui permet de tracer un carroyage à l'intérieur d'une polyligne avec insertion des coordonnées des points en périphérie de cette dernière.

 

Ce lisp qui tournait parfaitement sous Autocad 14 (eh oui, je sais...) ne fonctionne plus sur 2006. Mes faibles connaissances en lisp ne me permettent pas de résoudre le problème.

 

Je pense que cet outil pourrait interesser du monde, alors si une star du lisp pouvait m'aider...

 

[surligneur] voici le lisp:[/surligneur]

 

; DESCRIPTION

; permet de r‚aliser du carroyage et l'affichage des points d'intersection

; avec l'espace d‚limit‚ par l'utilisateur ainsi que l'affichage des

; coordonn‚es de ces points d'intersection

;

;----------------------------------------------------------------------------

 

 

;; Fonction d‚terminant si un point se trouve sur un segment

 

(defun point_sur_segment(pt1 pt2 ptinter / dist1 dist2 dist_ref)

(setq dist1 (sqrt (+ (expt (- (nth 0 ptinter) (nth 0 pt1)) 2)

(expt (- (nth 1 ptinter) (nth 1 pt1)) 2))))

(setq dist2 (sqrt (+ (expt (- (nth 0 ptinter) (nth 0 pt2)) 2)

(expt (- (nth 1 ptinter) (nth 1 pt2)) 2))))

(setq dist_ref (sqrt (+ (expt (- (nth 0 pt2) (nth 0 pt1)) 2)

(expt (- (nth 1 pt2) (nth 1 pt1)) 2))))

(cond ((and (<= dist1 dist_ref) (<= dist2 dist_ref)) T))

)

 

(defun c:CARROY (/ poly vertex som sommet closed elm fin coorx ptx mx X listx

y_inter ordre reste dx dy echel)

 

(setvar "cmdecho" 0)

 

;; Chargement du fichier contenant la forme (carroy.shx)

(command "charger" "carroy")

 

;; Initialisation des valeurs de la boite de dialogue

(setq plan "CARROYAGE")

(setq echelle "1:1")

(setq pas_x "100")

(setq pas_y "100")

(setq hauteur "3.0")

 

;; Ouverture de la boite de dialogue

(setq dcl_id (load_dialog "carroy.dcl"))

(if (not (new_dialog "carroy" dcl_id))

(exit)

)

 

;; Cr‚ation de la croix pleine dans la boite de dialogue

(setq width (dimx_tile "croix"))

(setq height (dimy_tile "croix"))

(start_image "croix")

(vector_image (/ width 2) (/ height 4) (/ width 2) (- height (/ height 4)) 7)

(vector_image (- (/ width 2) (/ height 4)) (/ height 2) (+ (/ width 2) (/ height 4)) (/ height 2) 7)

(end_image)

 

;; Cr‚ation de la croix ouverte dans la boite de dialogue

(setq width2 (dimx_tile "croix2"))

(setq height2 (dimy_tile "croix2"))

(start_image "croix2")

(vector_image (/ width2 2) (/ height2 4) (/ width2 2) (- (/ height2 2) (/ height 12)) 7)

(vector_image (/ width2 2) (+ (/ height2 2) (/ height2 12)) (/ width2 2) (- height2 (/ height2 4)) 7)

(vector_image (- (/ width2 2) (/ height2 4)) (/ height2 2) (- (/ width2 2) (/ height2 12)) (/ height2 2) 7)

(vector_image (+ (/ width2 2) (/ height2 12)) (/ height2 2) (+ (/ width 2) (/ height 4)) (/ height 2) 7)

(end_image)

 

(set_tile "nom_plan" "CARROYAGE")

(set_tile "nb_echel" "1:1")

(set_tile "nb_pasx" "100")

(set_tile "nb_pasy" "100")

(set_tile "nb_haut" "3.0")

 

(action_tile "nom_plan" "(setq plan $value)")

(action_tile "nb_echel" "(setq echelle $value)")

(action_tile "nb_pasx" "(setq pas_x $value)")

(action_tile "nb_pasy" "(setq pas_y $value)")

(setq crox 0) (setq crox2 0)

(action_tile "croix" "(setq crox $reason)")

(action_tile "croix2" "(setq crox2 $reason)")

(action_tile "nb_haut" "(setq hauteur $value)")

 

(if (or (= echelle 0) (= echelle ""))

(alert "Valeur de l'‚chelle invalide.\nVeuillez recommencer.")

)

(if (or (= pas_x 0) (= pas_x ""))

(alert "Valeur du pas en x invalide.\nVeuillez recommencer.")

)

(if (or (= pas_y 0) (= pas_y ""))

(alert "Valeur du pas en y invalide.\nVeuillez recommencer.")

)

(if (or (= nb_haut 0) (= nb_haut ""))

(alert "Valeur de la hauteur invalide.\nVeuillez recommencer.")

)

(start_dialog)

(unload_dialog dcl_id)

 

(print "Plan: ") (princ plan)

(print "Echelle: ") (princ echelle)

(print "Pas en x: ") (princ pas_x)

(print "Pas en y: ") (princ pas_y)

(print "Hauteur croix: ") (princ hauteur)

(print)

 

;; Cr‚ation d'un nouveau plan pour le carroyage

(command "-calque" "N" plan "CH" plan "")

 

(setq chaine1 "")

(setq chaine2 "")

(setq k 1)

(while (<= k (strlen echelle))

(setq mot (substr echelle k 1))

(if (= mot ":")

(progn

(while (<= k (strlen echelle))

(setq k (1+ k))

(setq mot (substr echelle k 1))

(setq chaine2 (strcat chaine2 mot))

)

)

(setq chaine1 (strcat chaine1 mot))

)

(setq k (1+ k))

)

 

(setq reel1 (atof chaine1))

(setq reel2 (atof chaine2))

(setq echel (/ reel1 reel2))

(setq dx (* (atoi pas_x) echel))

(setq dy (* (atoi pas_y) echel))

(setq i 1) (setq j 0)

(setq closed 0)

(setq haut (atof hauteur))

(while (= closed 0)

(setq poly (entget(setq elm (car (entsel "S‚lectionner la polyligne")))))

(setq efface elm)

(setq closed (cdr (assoc 70 poly)))

(if (= closed 0)

(alert "La polyligne doit ˆtre ferm‚e! \nVeuillez recommencer.")

)

)

 

(setq fin (cdr (assoc 0 poly)))

(while (/= fin "SEQEND")

(setq vertex (entget (setq elm (entnext elm))))

(setq fin (cdr (assoc 0 vertex)))

(setq coorx (cadr (assoc 10 vertex)))

(setq coory (caddr (assoc 10 vertex)))

(setq som (cdr(assoc 10 vertex)))

(if (/= som nil)

(setq sommet (append sommet (list som)))

)

(if (/= coorx nil)

(setq listx (append listx (list coorx)))

)

(if (/= coory nil)

(setq listy (append listy (list coory)))

)

 

)

 

(setq mx (nth 0 listx))

(setq xmax (nth 0 listx))

(setq i 0)

(while (< i (length listx))

(setq mx (min (nth i listx) mx))

(setq xmax (max (nth i listx) xmax))

(setq i (1+ i))

)

 

(setq valx (/ mx dx))

(if (< valx 0)

(setq intx (* (fix valx) dx))

(setq intx (* (+ (fix valx) 1) dx))

)

 

(while (<= intx xmax)

(setq y_inter nil)

(setq j 0)

(while (< j (length sommet))

(setq a (list intx 0))

(setq b (list intx 100))

(setq c (nth j sommet))

(setq d (nth (cond ((< j (1- (length sommet)))(1+ j))

((= j (1- (length sommet))) 0)) sommet))

(if (setq intersect (inters a b c d nil))

(if (point_sur_segment c d intersect)

(setq y_inter (append y_inter (list (nth 1 intersect))))

)

)

(setq j (1+ j))

) ; Fin du while (< j (length sommet))

 

(setq ordre nil)

(while (>= (length y_inter) 2)

(setq my_inter (nth 0 y_inter))

(setq k 1)

(while (< k (length y_inter))

(setq y1 (nth k y_inter))

(setq my_inter (min y1 my_inter))

(setq k (1+ k))

) ; Fin du while (< k (length y_inter))

 

(setq w 0)

(setq reste nil)

(while (< w (length y_inter))

(if (/= my_inter (nth w y_inter))

(setq reste (append reste (list (nth w y_inter))))

(setq ordre (append ordre (list my_inter)))

)

(setq w (1+ w))

) ; Fin du while (< w (length y_inter))

 

(setq y_inter reste)

) ; Fin du while (>= (length y_inter) 2)

 

(setq y_inter (append ordre reste))

 

;; Nombre d'intervalles … carroyer

(setq nb_inter (/ (length y_inter) 2))

(setq i 1)

 

;; Boucle sur les intervalles … carroyer suivant la droite X = intx

(while (<= i nb_inter)

 

;; Recherche du Y de d‚part pour l'intervalle

(setq my (nth (* (1- i) 2) y_inter))

(setq valy (/ my dy))

(if (< valy 0)

(setq inty (* (fix valy) dy))

(setq inty (* (+ (fix valy) 1) dy))

)

(setq inty (- inty dy) flag_out 0)

(while (= flag_out 0)

(setq inty (+ inty dy))

(if (and (>= inty (nth (* (1- i) 2) y_inter))

(<= inty (nth (+ (* (1- i) 2) 1) y_inter)))

(progn

(setq ptform (trans (list intx inty) 0 1))

(setq ptform1 (trans (list (+ intx dx) inty) 0 1))

(setq angl (atof (angtos (angle ptform ptform1) 0 3)))

(if (or (= crox 1) (= crox 4))

(command "formes" "crx" ptform haut angl)

)

(if (or (= crox2 1) (= crox2 4))

(command "formes" "crx2" ptform haut angl)

)

)

(setq flag_out 1)

)

) ; Fin du while (= flag_out 0)

 

(setq i (1+ i))

) ; Fin du while (<= i nbinter)

 

(setq intx (+ intx dx))

) ; Fin du while (<= intx xmax)

 

;; Placement des repŠres de coordonn‚es en x

(setq mx (nth 0 listx))

(setq xmax (nth 0 listx))

(setq i 0)

(while (< i (length listx))

(setq mx (min (nth i listx) mx))

(setq xmax (max (nth i listx) xmax))

(setq i (1+ i))

)

 

(setq valx (/ mx dx))

(if (< valx 0)

(setq intx (* (fix valx) dx))

(setq intx (* (+ (fix valx) 1) dx))

)

 

(while (<= intx xmax)

(setq y_inter nil)

(setq j 0)

(while (< j (length sommet))

(setq a (list intx 0))

(setq b (list intx 100))

(setq c (nth j sommet))

(setq d (nth (cond ((< j (1- (length sommet)))(1+ j))

((= j (1- (length sommet))) 0)) sommet))

(if (setq intersect (inters a b c d nil))

(if (point_sur_segment c d intersect)

(setq y_inter (append y_inter (list (nth 1 intersect))))

)

)

(setq j (1+ j))

) ; Fin du while (< j (length sommet))

 

;; Remise en ordre de la liste y_inter

(setq ordre nil)

(while (>= (length y_inter) 2)

(setq my_inter (nth 0 y_inter))

(setq k 1)

(while (< k (length y_inter))

(setq y1 (nth k y_inter))

(setq my_inter (min y1 my_inter))

(setq k (1+ k))

) ; Fin du while (< k (length y_inter))

 

(setq w 0)

(setq reste nil)

(while (< w (length y_inter))

(if (/= my_inter (nth w y_inter))

(setq reste (append reste (list (nth w y_inter))))

(setq ordre (append ordre (list my_inter)))

)

(setq w (1+ w))

) ; Fin du while (< w (length y_inter))

 

(setq y_inter reste)

) ; Fin du while (>= (length y_inter) 2)

 

(if (/= y_inter nil)

(setq y_inter (append ordre reste))

)

 

;; R‚alisation des traits de repŠre verticaux avec leur texte

(setq f 0)

(while (< f (length y_inter))

(setq point1 (strcat "*" (rtos intx 2 4)","(rtos (nth f y_inter) 2 4)))

(setq point2 (strcat "*" (rtos intx 2 4)","(rtos (+ (nth f y_inter) (/ dy 3)) 2 4)))

(setq point3 (strcat "*" (rtos intx 2 4)","(rtos (- (nth f y_inter) (/ dy 3)) 2 4)))

(setq pnt11 (trans (list intx (nth f y_inter)) 0 1))

(setq pnt22 (trans (list intx (+ (nth f y_inter) 5)) 0 1))

(setq ang (angle pnt11 pnt22))

(setq ang1 (atof (angtos ang 0 3)))

(if (= (rem f 2) 0)

(progn

(command "ligne" point1 point2 "")

(command "texte" "j" "MD" point3 (/ dy 10) ang1 (fix (/ intx echel)))

)

(progn

(command "ligne" point1 point3 "")

(command "texte" "j" "MG" point2 (/ dy 10) ang1 (fix (/ intx echel)))

)

)

(setq f (1+ f))

) ; Fin du while (< f(length y_inter)

 

(setq intx (+ intx dx))

) ; Fin du while (<= intx xmax)

 

;; Placement des repŠres de coordonn‚es en y

(setq my (nth 0 listy))

(setq ymax (nth 0 listy))

(setq i 0)

(while (< i (length listy))

(setq my (min (nth i listy) my))

(setq ymax (max (nth i listy) ymax))

(setq i (1+ i))

)

 

(setq valy (/ my dy))

(if (< valy 0)

(setq inty (* (fix valy) dy))

(setq inty (* (+ (fix valy) 1) dy))

)

 

(while (<= inty ymax)

(setq x_inter nil)

(setq j 0)

(while (< j (length sommet))

(setq a (list 0 inty))

(setq b (list 100 inty))

(setq c (nth j sommet))

(setq d (nth (cond ((< j (1- (length sommet)))(1+ j))

((= j (1- (length sommet))) 0)) sommet))

(if (setq intersect (inters a b c d nil))

(if (point_sur_segment c d intersect)

(setq x_inter (append x_inter (list (nth 0 intersect))))

)

)

(setq j (1+ j))

) ; Fin du while (< j (length sommet))

 

;; Remise en ordre de la liste x_inter

(setq ordre nil)

(while (>= (length x_inter) 2)

(setq mx_inter (nth 0 x_inter))

(setq k 1)

(while (< k (length x_inter))

(setq x1 (nth k x_inter))

(setq mx_inter (min x1 mx_inter))

(setq k (1+ k))

) ; Fin du while (< k (length x_inter))

 

(setq w 0)

(setq reste nil)

(while (< w (length x_inter))

(if (/= mx_inter (nth w x_inter))

(setq reste (append reste (list (nth w x_inter))))

(setq ordre (append ordre (list mx_inter)))

)

(setq w (1+ w))

) ; Fin du while (< w (length x_inter))

 

(setq x_inter reste)

) ; Fin du while (>= (length x_inter) 2)

 

(if (/= x_inter nil)

(setq x_inter (append ordre reste))

)

 

;; R‚alisation des traits de repŠre horizontaux

(setq f 0)

(while (< f (length x_inter))

(setq point1 (strcat "*" (rtos (nth f x_inter) 2 4)","(rtos inty 2 4)))

(setq point2 (strcat "*" (rtos (+ (nth f x_inter) (/ dx 3)) 2 4)","(rtos inty 2 4)))

(setq point3 (strcat "*" (rtos (- (nth f x_inter) (/ dx 3)) 2 4)","(rtos inty 2 4)))

(setq pnt1 (trans (list (nth f x_inter) inty) 0 1))

(setq pnt2 (trans (list (+ (nth f x_inter) 5) inty) 0 1))

(setq ang (angle pnt1 pnt2))

(setq ang1 (atof (angtos ang 0 3)))

(if (= (rem f 2) 0)

(progn

(command "ligne" point1 point2 "")

(command "texte" "j" "MD" point3 (/ dy 10) ang1 (fix (/ inty echel)))

)

(progn

(command "ligne" point1 point3 "")

(command "texte" "j" "MG" point2 (/ dy 10) ang1 (fix (/ inty echel)))

)

)

(setq f (1+ f))

) ; Fin du while (< f(length x_inter)

 

(setq inty (+ inty dy))

) ; Fin du while (<= inty ymax)

 

(entdel efface)

(setvar "cmdecho" 1)

(princ)

)

 

 

 

[surligneur] et le DCL correspondant:[/surligneur]

 

 

carroy : dialog {

label = "OPTIONS POUR LE CARROYAGE";

: edit_box {

label = "Plan: ";

key = "nom_plan";

}

: edit_box {

label = "Echelle: ";

key = "nb_echel";

}

: edit_box {

label = "Pas en x: ";

key = "nb_pasx";

}

: edit_box {

label = "Pas en y: ";

key = "nb_pasy";

}

: edit_box {

label = "Hauteur croix: ";

key = "nb_haut";

}

: row {

: text {

label = "Croix: ";

}

: boxed_row {

: image_button {

key = "croix";

width = 3.5;

aspect_ratio = 1.0;

color = 0;

allow_accept = true;

}

: image_button {

key = "croix2";

width = 3.5;

aspect_ratio = 1.0;

color = 0;

allow_accept = true;

}

}

}

ok_only;

}

 

 

 

d'avance merci à tous

 

Lien vers le commentaire
Partager sur d’autres sites
(gile) Proficient

(gile)

Posté(e)
Posté(e)

Salut,

 

Pourrais tu dire quel est le message d'erreur, si ça pouvait éviter d'avoir à décortiquer toutes ces lignes de code.

 

À tout hasard les fichiers DCL et SHX sont-ils bien enregistrés sous : carroy.dcl et carroy.shx dans un fichier du chemin de recherche des fichiers de support ?

Gilles Chanteau - gileCAD - GitHub
Développements sur mesure pour AutoCAD

Lien vers le commentaire
Partager sur d’autres sites
(gile) Proficient

(gile)

Posté(e)
Posté(e)

Là il est tard, je n'ai pas le courrage de corriger le code.

 

L'erreur vient du fait que ce LISP est fait pour fonctionner avec des polyligne 2d "old style" et pas avec des polyligne optimisées.

 

En attendant, tu peux toujours convertir une polyligne optimisée en polyligne 2d avec la commande CONVERTPOLY option Epais et le LISP fonctionnera.

 

Autre chose, remplace la ligne :

 

;; Cr‚ation d'un nouveau plan pour le carroyage

(command "-calque" "N" plan "CH" plan "")

 

par :

(command "-calque" "E" plan "CH" plan "")

 

Etablir à la place de Nouveau évitera un message d'erreur si le calque existe déjà

Gilles Chanteau - gileCAD - GitHub
Développements sur mesure pour AutoCAD

Lien vers le commentaire
Partager sur d’autres sites
(gile) Proficient

(gile)

Posté(e)
Posté(e)

Voilà j'ai juste ajouté quelques lignes au code pour qu'il fonctionne indifféremment avec les polylignes 2d et optimisées, j'ai aussi automatisé la désactivation des accrochages et mis une gestion des erreurs.

 

					; DESCRIPTION
				; permet de réaliser du carroyage et l'affichage des points d'intersection
				; avec l'espace délimité par l'utilisateur ainsi que l'affichage des
				; coordonnées de ces points d'intersection
				;
				;-------------------------------------------------------------------------- --


;; Fonction déterminant si un point se trouve sur un segment

(defun point_sur_segment (pt1 pt2 ptinter / dist1 dist2 dist_ref)
 (setq	dist1 (sqrt (+ (expt (- (nth 0 ptinter) (nth 0 pt1)) 2)
	       (expt (- (nth 1 ptinter) (nth 1 pt1)) 2)
	    )
      )
 )
 (setq	dist2 (sqrt (+ (expt (- (nth 0 ptinter) (nth 0 pt2)) 2)
	       (expt (- (nth 1 ptinter) (nth 1 pt2)) 2)
	    )
      )
 )
 (setq	dist_ref (sqrt (+ (expt (- (nth 0 pt2) (nth 0 pt1)) 2)
		  (expt (- (nth 1 pt2) (nth 1 pt1)) 2)
	       )
	 )
 )
 (cond ((and ()

(defun c:CARROY	(/	 carroy_err	 echo	 osmo	 poly
	 vertex	 som	 sommet	 closed	 elm	 fin
	 coorx	 ptx	 mx	 X	 listx	 y_inter
	 ordre	 reste	 dx	 dy	 echel
	)
 (defun carroy_err (msg)
   (if	(or (= msg "Fonction annulée")
    (= msg "quitter / sortir abandon")
)
     (princ)
     (princ (strcat "\n; erreur: " msg))
   )
   (setvar "cmdecho" echo)
   (setvar "osmode" osmo)
   (setq *error* m:err
  m:err	nil
   )
   (princ)
 )

 (setq	echo	(getvar "cmdecho")
osmo	(getvar "osmode")
m:err	*error*
*error*	carroy_err
 )

 (setvar "cmdecho" 0)
 (setvar "osmode" 0)

 ;; Chargement du fichier contenant la forme (carroy.shx)
 (command "charger" "carroy")

 ;; Initialisation des valeurs de la boite de dialogue
 (setq plan "CARROYAGE")
 (setq echelle "1:1")
 (setq pas_x "100")
 (setq pas_y "100")
 (setq hauteur "3.0")

 ;; Ouverture de la boite de dialogue
 (setq dcl_id (load_dialog "carroy.dcl"))
 (if (not (new_dialog "carroy" dcl_id))
   (exit)
 )

 ;; Création de la croix pleine dans la boite de dialogue
 (setq width (dimx_tile "croix"))
 (setq height (dimy_tile "croix"))
 (start_image "croix")
 (vector_image
   (/ width 2)
   (/ height 4)
   (/ width 2)
   (- height (/ height 4))
   7
 )
 (vector_image
   (- (/ width 2) (/ height 4))
   (/ height 2)
   (+ (/ width 2) (/ height 4))
   (/ height 2)
   7
 )
 (end_image)

 ;; Création de la croix ouverte dans la boite de dialogue
 (setq width2 (dimx_tile "croix2"))
 (setq height2 (dimy_tile "croix2"))
 (start_image "croix2")
 (vector_image
   (/ width2 2)
   (/ height2 4)
   (/ width2 2)
   (- (/ height2 2) (/ height 12))
   7
 )
 (vector_image
   (/ width2 2)
   (+ (/ height2 2) (/ height2 12))
   (/ width2 2)
   (- height2 (/ height2 4))
   7
 )
 (vector_image
   (- (/ width2 2) (/ height2 4))
   (/ height2 2)
   (- (/ width2 2) (/ height2 12))
   (/ height2 2)
   7
 )
 (vector_image
   (+ (/ width2 2) (/ height2 12))
   (/ height2 2)
   (+ (/ width 2) (/ height 4))
   (/ height 2)
   7
 )
 (end_image)

 (set_tile "nom_plan" "CARROYAGE")
 (set_tile "nb_echel" "1:1")
 (set_tile "nb_pasx" "100")
 (set_tile "nb_pasy" "100")
 (set_tile "nb_haut" "3.0")

 (action_tile "nom_plan" "(setq plan $value)")
 (action_tile "nb_echel" "(setq echelle $value)")
 (action_tile "nb_pasx" "(setq pas_x $value)")
 (action_tile "nb_pasy" "(setq pas_y $value)")
 (setq crox 0)
 (setq crox2 0)
 (action_tile "croix" "(setq crox $reason)")
 (action_tile "croix2" "(setq crox2 $reason)")
 (action_tile "nb_haut" "(setq hauteur $value)")

 (if (or (= echelle 0) (= echelle ""))
   (alert
     "Valeur de l'échelle invalide.\nVeuillez recommencer."
   )
 )
 (if (or (= pas_x 0) (= pas_x ""))
   (alert "Valeur du pas en x invalide.\nVeuillez recommencer."
   )
 )
 (if (or (= pas_y 0) (= pas_y ""))
   (alert "Valeur du pas en y invalide.\nVeuillez recommencer."
   )
 )
 (if (or (= nb_haut 0) (= nb_haut ""))
   (alert
     "Valeur de la hauteur invalide.\nVeuillez recommencer."
   )
 )
 (start_dialog)
 (unload_dialog dcl_id)

 (print "Plan: ")
 (princ plan)
 (print "Echelle: ")
 (princ echelle)
 (print "Pas en x: ")
 (princ pas_x)
 (print "Pas en y: ")
 (princ pas_y)
 (print "Hauteur croix: ")
 (princ hauteur)
 (print)

 ;; Création d'un nouveau plan pour le carroyage
 (command "-calque" "E" plan "CH" plan "")

 (setq chaine1 "")
 (setq chaine2 "")
 (setq k 1)
 (while (    (setq mot (substr echelle k 1))
   (if	(= mot ":")
     (progn
(while (	  (setq k (1+ k))
  (setq mot (substr echelle k 1))
  (setq chaine2 (strcat chaine2 mot))
)
     )
     (setq chaine1 (strcat chaine1 mot))
   )
   (setq k (1+ k))
 )

 (setq reel1 (atof chaine1))
 (setq reel2 (atof chaine2))
 (setq echel (/ reel1 reel2))
 (setq dx (* (atoi pas_x) echel))
 (setq dy (* (atoi pas_y) echel))
 (setq i 1)
 (setq j 0)
 (setq closed 0)
 (setq haut (atof hauteur))
 (while (= closed 0)
   (setq poly (entget
	 (setq elm (car (entsel "Sélectionner la polyligne")))
       )
   )
   (setq efface elm)
   (setq closed (cdr (assoc 70 poly)))
   (if	(= closed 0)
     (alert
"La polyligne doit être fermée! \nVeuillez recommencer."
     )
   )
 )

 (cond
   ((= (cdr (assoc 0 poly)) "POLYLINE")
    (setq fin (cdr (assoc 0 poly)))
    (while (/= fin "SEQEND")
      (setq vertex (entget (setq elm (entnext elm))))
      (setq fin (cdr (assoc 0 vertex)))
      (setq coorx (cadr (assoc 10 vertex)))
      (setq coory (caddr (assoc 10 vertex)))
      (setq som (cdr (assoc 10 vertex)))
      (if (/= som nil)
 (setq sommet (append sommet (list som)))
      )
      (if (/= coorx nil)
 (setq listx (append listx (list coorx)))
      )
      (if (/= coory nil)
 (setq listy (append listy (list coory)))
      )
    )
   )
   ((= (cdr (assoc 0 poly)) "LWPOLYLINE")
    (setq
      sommet (mapcar
	'cdr
	(vl-remove-if-not '(lambda (x) (= (car x) 10)) poly)
      )
    )
    (setq listx (mapcar 'car sommet))
    (setq listy (mapcar 'cadr sommet))
   )
   (T
    (alert
      "L'objet sélectionné n'est pas une polyligne (2D ou optimisée)"
    )
    (exit)
   )
 )

 (setq mx (nth 0 listx))
 (setq xmax (nth 0 listx))
 (setq i 0)
 (while (    (setq mx (min (nth i listx) mx))
   (setq xmax (max (nth i listx) xmax))
   (setq i (1+ i))
 )

 (setq valx (/ mx dx))
 (if (    (setq intx (* (fix valx) dx))
   (setq intx (* (+ (fix valx) 1) dx))
 )

 (while (    (setq y_inter nil)
   (setq j 0)
   (while (      (setq a (list intx 0))
     (setq b (list intx 100))
     (setq c (nth j sommet))
     (setq d (nth (cond ((			 ((= j (1- (length sommet))) 0)
	   )
	   sommet
      )
     )
     (if (setq intersect (inters a b c d nil))
(if (point_sur_segment c d intersect)
  (setq y_inter (append y_inter (list (nth 1 intersect))))
)
     )
     (setq j (1+ j))
   )					; Fin du while (
   (setq ordre nil)
   (while (>= (length y_inter) 2)
     (setq my_inter (nth 0 y_inter))
     (setq k 1)
     (while (	(setq y1 (nth k y_inter))
(setq my_inter (min y1 my_inter))
(setq k (1+ k))
     )					; Fin du while (
     (setq w 0)
     (setq reste nil)
     (while (	(if (/= my_inter (nth w y_inter))
  (setq reste (append reste (list (nth w y_inter))))
  (setq ordre (append ordre (list my_inter)))
)
(setq w (1+ w))
     )					; Fin du while (
     (setq y_inter reste)
   )					; Fin du while (>= (length y_inter) 2)

   (setq y_inter (append ordre reste))

   ;; Nombre d'intervalles à carroyer
   (setq nb_inter (/ (length y_inter) 2))
   (setq i 1)

   ;; Boucle sur les intervalles à carroyer suivant la droite X = intx
   (while (
     ;; Recherche du Y de départ pour l'intervalle
     (setq my (nth (* (1- i) 2) y_inter))
     (setq valy (/ my dy))
     (if (	(setq inty (* (fix valy) dy))
(setq inty (* (+ (fix valy) 1) dy))
     )
     (setq inty     (- inty dy)
    flag_out 0
     )
     (while (= flag_out 0)
(setq inty (+ inty dy))
(if (and (>= inty (nth (* (1- i) 2) y_inter))
	 (	    )
  (progn
    (setq ptform (trans (list intx inty) 0 1))
    (setq ptform1 (trans (list (+ intx dx) inty) 0 1))
    (setq angl (atof (angtos (angle ptform ptform1) 0 3)))
    (if	(or (= crox 1) (= crox 4))
      (command "formes" "crx" ptform haut angl)
    )
    (if	(or (= crox2 1) (= crox2 4))
      (command "formes" "crx2" ptform haut angl)
    )
  )
  (setq flag_out 1)
)
     )					; Fin du while (= flag_out 0)

     (setq i (1+ i))
   )					; Fin du while (
   (setq intx (+ intx dx))
 )					; Fin du while (
 ;; Placement des repères de coordonnées en x
 (setq mx (nth 0 listx))
 (setq xmax (nth 0 listx))
 (setq i 0)
 (while (    (setq mx (min (nth i listx) mx))
   (setq xmax (max (nth i listx) xmax))
   (setq i (1+ i))
 )

 (setq valx (/ mx dx))
 (if (    (setq intx (* (fix valx) dx))
   (setq intx (* (+ (fix valx) 1) dx))
 )

 (while (    (setq y_inter nil)
   (setq j 0)
   (while (      (setq a (list intx 0))
     (setq b (list intx 100))
     (setq c (nth j sommet))
     (setq d (nth (cond ((			 ((= j (1- (length sommet))) 0)
	   )
	   sommet
      )
     )
     (if (setq intersect (inters a b c d nil))
(if (point_sur_segment c d intersect)
  (setq y_inter (append y_inter (list (nth 1 intersect))))
)
     )
     (setq j (1+ j))
   )					; Fin du while (
   ;; Remise en ordre de la liste y_inter
   (setq ordre nil)
   (while (>= (length y_inter) 2)
     (setq my_inter (nth 0 y_inter))
     (setq k 1)
     (while (	(setq y1 (nth k y_inter))
(setq my_inter (min y1 my_inter))
(setq k (1+ k))
     )					; Fin du while (
     (setq w 0)
     (setq reste nil)
     (while (	(if (/= my_inter (nth w y_inter))
  (setq reste (append reste (list (nth w y_inter))))
  (setq ordre (append ordre (list my_inter)))
)
(setq w (1+ w))
     )					; Fin du while (
     (setq y_inter reste)
   )					; Fin du while (>= (length y_inter) 2)

   (if	(/= y_inter nil)
     (setq y_inter (append ordre reste))
   )

   ;; Réalisation des traits de repère verticaux avec leur texte
   (setq f 0)
   (while (      (setq point1 (strcat "*"
		   (rtos intx 2 4)
		   ","
		   (rtos (nth f y_inter) 2 4)
	   )
     )
     (setq point2 (strcat "*"
		   (rtos intx 2 4)
		   ","
		   (rtos (+ (nth f y_inter) (/ dy 3)) 2 4)
	   )
     )
     (setq point3 (strcat "*"
		   (rtos intx 2 4)
		   ","
		   (rtos (- (nth f y_inter) (/ dy 3)) 2 4)
	   )
     )
     (setq pnt11 (trans (list intx (nth f y_inter)) 0 1))
     (setq pnt22 (trans (list intx (+ (nth f y_inter) 5)) 0 1))
     (setq ang (angle pnt11 pnt22))
     (setq ang1 (atof (angtos ang 0 3)))
     (if (= (rem f 2) 0)
(progn
  (command "ligne" point1 point2 "")
  (command "texte"
	   "j"
	   "MD"
	   point3
	   (/ dy 10)
	   ang1
	   (fix (/ intx echel))
  )
)
(progn
  (command "ligne" point1 point3 "")
  (command "texte"
	   "j"
	   "MG"
	   point2
	   (/ dy 10)
	   ang1
	   (fix (/ intx echel))
  )
)
     )
     (setq f (1+ f))
   )					; Fin du while (
   (setq intx (+ intx dx))
 )					; Fin du while (
 ;; Placement des repères de coordonnées en y
 (setq my (nth 0 listy))
 (setq ymax (nth 0 listy))
 (setq i 0)
 (while (    (setq my (min (nth i listy) my))
   (setq ymax (max (nth i listy) ymax))
   (setq i (1+ i))
 )

 (setq valy (/ my dy))
 (if (    (setq inty (* (fix valy) dy))
   (setq inty (* (+ (fix valy) 1) dy))
 )

 (while (    (setq x_inter nil)
   (setq j 0)
   (while (      (setq a (list 0 inty))
     (setq b (list 100 inty))
     (setq c (nth j sommet))
     (setq d (nth (cond ((			 ((= j (1- (length sommet))) 0)
	   )
	   sommet
      )
     )
     (if (setq intersect (inters a b c d nil))
(if (point_sur_segment c d intersect)
  (setq x_inter (append x_inter (list (nth 0 intersect))))
)
     )
     (setq j (1+ j))
   )					; Fin du while (
   ;; Remise en ordre de la liste x_inter
   (setq ordre nil)
   (while (>= (length x_inter) 2)
     (setq mx_inter (nth 0 x_inter))
     (setq k 1)
     (while (	(setq x1 (nth k x_inter))
(setq mx_inter (min x1 mx_inter))
(setq k (1+ k))
     )					; Fin du while (
     (setq w 0)
     (setq reste nil)
     (while (	(if (/= mx_inter (nth w x_inter))
  (setq reste (append reste (list (nth w x_inter))))
  (setq ordre (append ordre (list mx_inter)))
)
(setq w (1+ w))
     )					; Fin du while (
     (setq x_inter reste)
   )					; Fin du while (>= (length x_inter) 2)

   (if	(/= x_inter nil)
     (setq x_inter (append ordre reste))
   )

   ;; Réalisation des traits de repère horizontaux
   (setq f 0)
   (while (      (setq point1 (strcat "*"
		   (rtos (nth f x_inter) 2 4)
		   ","
		   (rtos inty 2 4)
	   )
     )
     (setq point2 (strcat "*"
		   (rtos (+ (nth f x_inter) (/ dx 3)) 2 4)
		   ","
		   (rtos inty 2 4)
	   )
     )
     (setq point3 (strcat "*"
		   (rtos (- (nth f x_inter) (/ dx 3)) 2 4)
		   ","
		   (rtos inty 2 4)
	   )
     )
     (setq pnt1 (trans (list (nth f x_inter) inty) 0 1))
     (setq pnt2 (trans (list (+ (nth f x_inter) 5) inty) 0 1))
     (setq ang (angle pnt1 pnt2))
     (setq ang1 (atof (angtos ang 0 3)))
     (if (= (rem f 2) 0)
(progn
  (command "ligne" point1 point2 "")
  (command "texte"
	   "j"
	   "MD"
	   point3
	   (/ dy 10)
	   ang1
	   (fix (/ inty echel))
  )
)
(progn
  (command "ligne" point1 point3 "")
  (command "texte"
	   "j"
	   "MG"
	   point2
	   (/ dy 10)
	   ang1
	   (fix (/ inty echel))
  )
)
     )
     (setq f (1+ f))
   )					; Fin du while (
   (setq inty (+ inty dy))
 )					; Fin du while (
 (entdel efface)
 (setvar "cmdecho" echo)
 (setvar "osmode" osmo)
 (setq	*error*	m:err
m:err nil
 )
 (princ)
)

Gilles Chanteau - gileCAD - GitHub
Développements sur mesure pour AutoCAD

Lien vers le commentaire
Partager sur d’autres sites
bonuscad Enthusiast

bonuscad

Posté(e)
Posté(e)

ddb64,

 

J'ai voulu tester ton lisp par curiosité, et malgré l'absence des formes SHX, j'ai quand même pus arriver en bout de procédure. Cela m'a permis de voir que les coordonnées renseignées étaient complètement erronées !!! Pourquoi ? je n'ai pas cherché...

 

Donc je doute que dans l'état actuel, étant incomplet et présentant des dysfonctionnements, ce lisp puisse intéresser quelqu'un.

 

Si tu as besoin d'un tel lisp et que tu ne sache pas corriger ton lisp, je vais donc te suggérer un code ancien mais qui fonctionne encore bien. La mise en page se fait par défaut en multiple de format A4 (mieux pour le pliage), et tu peux écorner un coin pour mettre une page de garde.

 

4 fichiers seront nécessaires: 1 .lsp, 1 .dcl et 2 .pat qui devront être placés dans un dossier de recherche

 

LE LISP: lambert.lsp

(defun lamerr (ch)
(cond
	((eq ch "Function cancelled") nil)
	((eq ch "quit / exit abort") nil)
	((eq ch "console break") nil)
	(T (princ ch))
)
(command "_.undo" "_end")
(command "_.u")
(if (<= sv_und 3) (command "_.undo" "_control" "_one"))
(setq *error* olderr)
(redraw)
(setvar "cmdecho" 1)
(princ)
)
(defun tststr (chaine / chaine)
(if (wcmatch chaine "*[`?`,```*\\\"<>/=|:]*")
	(progn
		(set_tile "error" "Nom de plan incorrect !")
		(set_tile "pl_lamb" plnw1)
	)
	(progn
		(setq plnw1 chaine)
		(set_tile "error" "")
	)
)
)
(defun tstval (val idx_v / val idx_v)
(if (= (type (read val)) 'INT)
	(progn
		(if idx_v
			(progn
				(setq ech (atoi val))
				(setq pas (/ (read val) 10))
				(set_tile "c_pas" (itoa pas))
			)
			(setq pas (atoi val))
		)
		(set_tile "error" "")
	)
	(progn
		(set_tile "error" "Valeur entière incorrecte !")
		(if idx_v
			(set_tile "c_ech" (itoa ech))
			(set_tile "c_pas" (itoa pas))
		)
	)
)
)
(defun v_chg (index com_t)
(if com_t
	(progn
		(setq ech
			(read
				(nth
					(atoi index)
					'("50" "100" "200" "500" "1000" "2000" "2500" "5000" "10000")
				)
			)
		)
		(setq pas (/ ech 10))
		(set_tile "c_ech" (itoa ech))
		(set_tile "c_pas" (itoa pas))
		(set_tile "lst_pas" index)
		(mode_tile "lst_pas" 2)
	)
	(progn
		(setq pas
			(read
				(nth
					(atoi index)
					'("5" "10" "20" "50" "100" "200" "250" "500" "1000")
				)
			)
		)
		(set_tile "c_pas" (itoa pas))
	)
)
)
(defun getindex (item itemlist / m n)
(setq n (length itemlist))
(if (> (setq m (length (member item itemlist))) 0)
	(- n m)
	nil
)
)
(defun colorname (colnum)
(setq cn (abs colnum))
(cond
	((= cn 1) "rouge")
	((= cn 2) "jaune")
	((= cn 3) "vert")
	((= cn 4) "cyan")
	((= cn 5) "bleu")
	((= cn 6) "magenta")
	((= cn 7) "blanc")
	(T (itoa cn))
)
)
(defun makelaylists (/ layname onoff frozth color linetype vpf vpn ss cvpname xdlist vpldata sortlist name templist bit-70)
(if (= (setq tilemode (getvar "tilemode")) 0)
	(progn
		(setq ss
			(ssget "_x"
				(list (cons 0 "VIEWPORT")
					(cons 69 (getvar "CVPORT"))
				)
			)
		) 
		(setq cvpname (ssname ss 0))
		(setq xdlist (assoc -3 (entget cvpname '("acad"))))
		(setq vpldata (cdadr xdlist))
	)
)
(setq sortlist nil)
(setq templist (tblnext "LAYER" T))
(while templist
	(setq name (cdr (assoc 2 templist)))
	(setq sortlist (cons name sortlist))
	(setq templist (tblnext "LAYER"))
) 
(if (>= (getvar "maxsort") (length sortlist))
	(setq sortlist (acad_strlsort sortlist))
	(setq sortlist (reverse sortlist))
)
(setq laynmlst sortlist)
(setq longlist nil)
(setq layname (car sortlist))
(while layname
	(setq laylist (tblsearch "LAYER" layname))
	(setq color (cdr (assoc 62 laylist)))
	(if (minusp color)
		(setq onoff ".")
		(setq onoff "AC")
	)
	(setq color (abs color))
	(setq colname (colorname color))
	(setq bit-70 (cdr (assoc 70 laylist)))
	(if (= (logand bit-70 1) 1)
		(setq frozth "F" fchk laylist)
		(setq frozth ".")
	)
	(if (= (logand bit-70 2) 2)
		(setq vpn "N")
		(setq vpn ".")
	)
	(if (= (logand bit-70 4) 4)
		(setq lock "L")
		(setq lock ".")
	)
	(setq linetype (cdr (assoc 6 laylist)))
	(setq layname (substr layname 1 31))
	(if (= tilemode 0)
		(progn
			(if (member (cons 1003 layname) vpldata)
				(setq vpf "C")
				(setq vpf ".")
			)
		)
		(setq vpf ".")
	)
	(setq ltabstr (strcat layname "\t" onoff "\t" frozth "\t" lock "\t" vpf "\t" vpn "\t" colname "\t" linetype))
	(setq longlist (append longlist (list ltabstr)))
	(setq sortlist (cdr sortlist))
	(setq layname (car sortlist))
)
)
(defun getlayer (/ old-idx layname on off frozth linetype colname)
(if (not (new_dialog "setlayer" dcl_id)) (exit))
(makelaylists)
(if (= lay-idx ())
	(setq lay-idx (getindex (getvar "clayer") laynmlst))
)
(start_list "list_lay")
(mapcar 'add_list longlist)
(end_list)
(setq old-idx lay-idx)
(if (/= lay-idx nil) (laylist_act (itoa lay-idx)))
(set_tile "cur_layer" (getvar "clayer"))
(action_tile "list_lay" "(laylist_act $value)")
(action_tile "edit_lay" "(layedit_act $value)")
(action_tile "accept" "(test-ok)")
(action_tile "cancel" "(reset-lay)")
(if (= (start_dialog) 1)
	(progn
		(if (= lay-idx nil) (setq layname "Divers"))
		(set_tile "t_layer" layname)
		(if (= lt-idx 0)
			(set_tile "t_ltype" (bylayer_lt))
		)
		(if (= ecolor 256)
			(progn
				(set_tile "t_color" (bylayer_col))
				(col_tile "show_image" cn nil)
			)
		)
		layname
	)
	elayer
)
)
(defun test-ok ( / errtile)
(setq errtile (get_tile "error"))
(cond
	((= errtile "")
		(done_dialog 1)
		(set_tile "pl_lamb" layname)
	)
)
)
(defun reset-lay ()
(setq lay-idx old-idx)
(done_dialog 0)
(set_tile "pl_lamb" plnw1)
(setq elayer plnw1)
)
(defun laylist_act (index / layinfo color dashdata)
(set_tile "error" "")
(setq lay-idx (atoi index))
(setq layname (nth lay-idx laynmlst))
(setq layinfo (tblsearch "layer" layname))
(setq color (cdr (assoc 62 layinfo)))
(setq color (abs color))
(setq colname (colorname color))
(set_tile "list_lay" (itoa lay-idx))
(set_tile "edit_lay" layname)
(mode_tile "list_lay" 2)
)
(defun layedit_act (layvalue)
(setq layvalue (strcase layvalue))
(if (setq lay-idx (getindex layvalue laynmlst))
	(progn
		(set_tile "error" "")
		(laylist_act (itoa lay-idx))
	)
	(progn
		(set_tile "error" "Nom de Plan Incorrect.")
		(setq lay-idx old-idx)
	)
)
)
(defun ecri (ta tb det_or / dptx m1 m2 pd ecr ang_or)
(setq dptx (* (fix (/ (- (car lmtb) pas) pas)) pas))
(while (< dptx (car lmth))
	(setq m1 (cons dptx (cons (cadr lmtb) '(0.0)))
	      m2 (cons dptx (cons (cadr lmth) '(0.0)))
	)
	(if (zerop det_or)
		(setq m1 (cons (cadr m1) (cons (car m1) '(0.0)))
		      m2 (cons (cadr m2) (cons (car m2) '(0.0)))
		)
	)
	(setq pd (inters ta tb m1 m2))
	(if (/= pd ())
		(progn
			(if (zerop det_or)
				(setq ecr (rtos (cadr pd) 2 0) ang_or (angle ta tb) incl (angtos 0))
				(setq ecr (rtos (car pd) 2 0) ang_or (rem (+ (/ pi 2) (angle ta tb)) (* 2 pi)) incl (angtos (/ (* 3 pi) 2) (getvar "aunits") 5))
			)
			(cond
				((equal (rem ang_or pi) ang_or)
					(setq ecr (strcat "  " ecr))
					(command "_.text" "_justify" "_mleft" pd htx incl ecr)
				)
				(T
					(setq ecr (strcat ecr "  "))
					(command "_.text" "_justify" "_mright" pd htx incl ecr)
				)
			)
		)
	)
	(setq dptx (+ dptx pas))
)
)
(defun s_cadr (val eh_x eh_y / le_x le_y d_x d_y)
(setq le_x '() le_y ())
(foreach n pt_lst
	(setq le_x (cons (car n) le_x) le_y (cons (cadr n) le_y))
)
(setq
	d_x (- (apply 'max le_x) (apply 'min le_x))
	d_y (- (apply 'max le_y) (apply 'min le_y))
)
(setq
	se_x (/ (- (* eh_x d_x) (* 2.0 val)) d_x)
	se_y (/ (- (* eh_y d_y) (* 2.0 val)) d_y)
)
)
(defun cart (mod / lst)
(setq lst (new_list pt_lst mod))
(command "_.pline" (car lst) "_width" "0.0" "")
(setq lst (cdr lst))
(repeat (length lst)
	(command (car lst))
	(setq lst (cdr lst))
)
(command "_close")
)
(defun new_list (lst mat / )
(setq lst_b '())
(repeat (length lst)
	(setq lst_b
		(cons
			(list
				(+ 
					(* (car (nth 0 lst)) (car (nth 0 mat)))
					(* (cadr (nth 0 lst)) (cadr (nth 0 mat)))
					(cadddr (nth 0 mat))
				)
				(+ 
					(* (car (nth 0 lst)) (car (nth 1 mat)))
					(* (cadr (nth 0 lst)) (cadr (nth 1 mat)))
					(cadddr (nth 1 mat))
				)
			)
			lst_b
		)
	)
	(setq lst (cdr lst))
)
(reverse lst_b)
)
(defun v_matr (dpt alpha echx echy / )
(list
	(list
		(* echx (cos alpha))
		(* echy (-(sin alpha)))
		0.0
		(car dpt)
	)
	(list
		(* echx (sin alpha))
		(* echy (cos alpha))
		-0.0
		(cadr dpt)
	)
	(list 0.0 0.0 1.0 0.0)
	(list 0.0 0.0 0.0 1.0)
)
)
(defun des_vec (lst dat col / lst_sg)
(setq lst_sg (list (cadr lst) (car lst)))
(setq lst (cdr lst))
(while lst
	(if (cadr lst)
		(setq lst_sg (cons (cadr lst) (cons (car lst) lst_sg)))
		(setq lst_sg (cons (last lst_sg) (cons (car lst) lst_sg)))
	)
	(setq lst (cdr lst))
)
(setq lst_sg (cons col lst_sg))
(grvecs lst_sg dat)
)
(defun grpl (pt / pt1 pt2 pt3 pt4 rap)
(setq rap (getvar "viewsize")
      pt1 (list (+ (car pt) (/ rap 50)) (+ (cadr pt) (/ rap 50)))
      pt2 (list (+ (car pt) (/ rap 50)) (- (cadr pt) (/ rap 50)))
      pt3 (list (- (car pt) (/ rap 50)) (- (cadr pt) (/ rap 50)))
      pt4 (list (- (car pt) (/ rap 50)) (+ (cadr pt) (/ rap 50)))
)
(grdraw pt pt1 -1)
(grdraw pt pt2 -1)
(grdraw pt pt3 -1)
(grdraw pt pt4 -1)
)
(defun c:lambert
( / sv_und sv_blp sv_agb sv_osm sv_oth sv_stl sv_spb sv_sng sv_sun sv_smd sv_lck sv_pl sv_sty sv_ucs olderr pb ph ptx ang
    e_x e_y dm_x dm_y v_297 pt_lst ecart ok ech pas plnw1 plnw cod nom htx val1 val2 e_x2 e_y2 ecart2 e_x3 e_y3 ecart3
    c_cod c1_a4 c2_a4 c3_a4 c4_a4 cnt_d i_c se_x se_y pt s_ang lrg htr ent1 ent2 ent3 ent vx nbs cnt lmtb lmth incl n_ajou
    htx ecr rot lst_b dcl_id what_next
)
(setvar "cmdecho" 0)
(cond
	((and (eq (getvar "cvport") 2) (entlast) (eq (getvar "measurement") 1))
		(if (<= (setq sv_und (getvar "undoctl")) 3)
			(command "_.undo" "_control" "_all")
		)
		(command "_.undo" "_group")
		(setq sv_blp (getvar "blipmode"))
		(setvar "blipmode" 0)
		(setq sv_agb (getvar "angbase"))
		(setvar "angbase" 0)
		(setq sv_osm (getvar "osmode"))
		(setvar "osmode" 0)
		(setq sv_oth (getvar "orthomode"))
		(setvar "orthomode" 0)
		(setq sv_stl (getvar "snapstyl"))
		(setq sv_spb (getvar "snapbase"))
		(setvar "snapbase" '(0.0 0.0))
		(setq sv_sng (getvar "snapang"))
		(setvar "snapang" 0.0)
		(setq sv_sun (getvar "snapunit"))
		(setq sv_smd (getvar "snapmode"))
		(setq sv_lck (getvar "limcheck"))
		(setvar "limcheck" 0)
		(setq sv_pl (getvar "clayer"))
		(setq sv_sty (getvar "textstyle"))
		(setq sv_ucs (getvar "worlducs"))
		(if (= sv_ucs 0)
			(progn
				(command "._ucs" "_save" "$_TEMPO_$")
				(command "_.ucs" "")
			)
		)
		(setq olderr *error* *error* lamerr)	
		(if (not (equal (getvar "target") '(0.0 0.0 0.0)))
			(command "._dview" "" "_points" (list 0.0 0.0 0.0) "" "_exit")
		)
		(command "._plan" "_world")
		(setq pb (getvar "extmin") ph (getvar "extmax"))
		(setq pb (list (car pb) (cadr pb)) ph (list (car ph) (cadr ph)))
		(setq ptx
			(list
				(/ (+ (car pb) (car ph)) 2)
				(/ (+ (cadr pb) (cadr ph)) 2)
			)
		)
		(setq ang 0.0 e_x 1.0 e_y 1.0 ech 500 pas (/ ech 10) plnw1 "LAMBERT" v_297 (* 0.210 (sqrt 2)))
		(setq dm_x (/ (* (1+ (fix (/ (- (car ph) (car pb)) (* ech 0.210)))) (* ech 0.210)) 2)
		      dm_y (/ (* (1+ (fix (/ (- (cadr ph) (cadr pb)) (* ech v_297)))) (* ech v_297)) 2)
		)
		(setq pt_lst
			(list
				(list (- dm_x) (- dm_y))
				(list dm_x (- dm_y))
				(list dm_x dm_y)
				(list (- dm_x) dm_y)
			)
		)
		(setq ecart (v_matr ptx ang e_x e_y))
		(setq ok t)
		(command "._zoom" "0.4x")
		(setq dcl_id (load_dialog "lambert.dcl"))
		(setq what_next 2)
		(while (< 1 what_next)
			(if (not (new_dialog "lambert" dcl_id)) (exit))
			(start_list "lst_ech")
				(mapcar
					'(lambda (x)
					(add_list x)
				)
				'("50" "100" "200" "500" "1000" "2000" "2500" "5000" "10000")
			)
			(end_list)
			(set_tile "c_ech" (itoa ech))
			(start_list "lst_pas")
			(mapcar
				'(lambda (x)
					(add_list x)
				)
				'("5" "10" "20" "50" "100" "200" "250" "500" "1000")
			)
			(end_list)
			(set_tile "c_pas" (itoa pas))
			(set_tile "pl_lamb" plnw1)
			(set_tile "error" "")
			(action_tile "lst_ech" "(v_chg $value T)")
			(action_tile "c_ech" "(tstval $value T)")
			(action_tile "lst_pas" "(v_chg $value nil)")
			(action_tile "c_pas" "(tstval $value nil)")
			(action_tile "pl_lamb" "(tststr $value)")
			(action_tile "pl_name" "(setq plnw1 (getlayer))")
			(action_tile "accept" "(done_dialog 1)")
			(action_tile "cancel" "(done_dialog 0)")
			(setq what_next (start_dialog))
			(cond
				((= what_next 1)
					(if (= (setq cod (tblsearch "LAYER" plnw1)) ())
						(command "._layer" "_new" plnw1 "")
						(progn
							(setq nom (cdr (assoc 2 cod)))
							(cond
								((= (boole 1 7 (cdr (assoc 70 cod))) 1)
									(command "._layer" "_thaw" nom "")
								)
								((= (boole 1 7 (cdr (assoc 70 cod))) 2)
									(command "._vplayer" "_thaw" nom "" "")
								)
								((= (boole 1 7 (cdr (assoc 70 cod))) 3)
									(command "._layer" "_thaw" nom "")
									(command "._vplayer" "_thaw" nom "" "")
								)
								((= (boole 1 7 (cdr (assoc 70 cod))) 4)
									(command "._layer" "_unlock" nom "")
								)
								((= (boole 1 7 (cdr (assoc 70 cod))) 5)
									(command "._layer" "_unlock" nom "_thaw" nom "")
								)
								((= (boole 1 7 (cdr (assoc 70 cod))) 6)
									(command "._layer" "_unlock" nom "")
									(command "._vplayer" "_thaw" nom "" "")
								)
								((= (boole 1 7 (cdr (assoc 70 cod))) 7)
									(command "._vplayer" "_thaw" nom "" "")
									(command "._layer" "_unlock" nom "_thaw" nom "")
								)
							)
						)
					)
					(command "._layer" "_set" plnw1 "")
					(setq dm_x (* (/ dm_x 500.0) ech) dm_y (* (/ dm_y 500.0) ech))
					(setvar "snapstyl" 0)
					(setvar "snapbase" (list (- (car ptx) dm_x) (- (cadr ptx) dm_y)))
					(setvar "snapang" 0)
					(setvar "snapunit" (list (* ech (/ 0.210 2.0)) (* ech (/ v_297 2.0))))
					(setvar "snapmode" 0)
					(setq htx (/ ech 500.0) val1 (* htx 2.5) val2 (+ val1 (* htx 10.0)))
					(s_cadr val1 e_x e_y)
					(setq e_x2 se_x e_y2 se_y)
					(setq ecart2 (v_matr ptx ang e_x2 e_y2))
					(s_cadr val2 e_x e_y)
					(setq e_x3 se_x e_y3 se_y)
					(setq ecart3 (v_matr ptx ang e_x3 e_y3))
					(grpl ptx)
					(while ok
						(des_vec pt_lst ecart 2)
						(des_vec pt_lst ecart2 2)
						(des_vec pt_lst ecart3 2)
						(initget "Position Rotation Dimensions Sortir")
						(setq cod
							(getkword "\n[Position/Rotation/Dimensions/Sortir] < Sortir >: ")
						)
						(cond
							((eq cod "Position")
								(initget 8)
								(setq pt
									(getpoint ptx
										(strcat
											"\nNouveau point <"
											(rtos (car ptx))
											","
											(rtos (cadr ptx))
											">: "
										)
									)
								)
								(if (null pt) (setq pt ptx))
								(setvar "snapbase" (polar (getvar "snapbase") (angle ptx (list (car pt) (cadr pt))) (distance ptx (list (car pt) (cadr pt)))))
								(grpl ptx)
								(setq ptx (list (car pt) (cadr pt)))
								(grpl ptx)
								(des_vec pt_lst ecart 0)
								(des_vec pt_lst ecart2 0)
								(des_vec pt_lst ecart3 0)
								(setq ecart (v_matr ptx ang e_x e_y))
								(s_cadr val1 e_x e_y)
								(setq e_x2 se_x e_y2 se_y)
								(setq ecart2 (v_matr ptx ang e_x2 e_y2))
								(s_cadr val2 e_x e_y)
								(setq e_x3 se_x e_y3 se_y)
								(setq ecart3 (v_matr ptx ang e_x3 e_y3))
							)
							((eq cod "Rotation")
								(initget 0)
								(setq s_ang
									(getorient ptx
										(strcat
											"\nNouvel angle<"
											(angtos ang)
											">: "
										)
									)
								)
								(if (not s_ang) (setq s_ang ang))
								(if (and (> s_ang (/ pi 2)) (<= s_ang (/ (* 3 pi) 2)))
									(setq ang (+ s_ang pi))
									(setq ang s_ang)
								)
								(des_vec pt_lst ecart 0)
								(des_vec pt_lst ecart2 0)
								(des_vec pt_lst ecart3 0)
								(setq ecart (v_matr ptx ang e_x e_y))
								(s_cadr val1 e_x e_y)
								(setq e_x2 se_x e_y2 se_y)
								(setq ecart2 (v_matr ptx ang e_x2 e_y2))
								(s_cadr val2 e_x e_y)
								(setq e_x3 se_x e_y3 se_y)
								(setq ecart3 (v_matr ptx ang e_x3 e_y3))
								(setvar "snapbase" (polar ptx (+ (angle ptx (getvar "snapbase")) (- ang (getvar "snapang"))) (distance ptx (getvar "snapbase"))))
								(setvar "snapang" ang)
							)
							((eq cod "Dimensions")
								(setvar "snapmode" 1)
								(setvar "orthomode" 1)
								(initget 70)
								(setq lrg
									(getdist ptx
										(strcat
											"\nNouvelle demi-largeur<"
											(rtos (* (/ (distance (car pt_lst) (cadr pt_lst)) 2) e_x))
											">: "
										)
									)
								)
								(if (not lrg)
									(setq lrg (* (/ (distance (car pt_lst) (cadr pt_lst)) 2) e_x))
								) 
								(setq e_x
									(/
										(* 2.0 lrg)
										(distance (car pt_lst) (cadr pt_lst))
									)
								)
								(initget 70)
								(setq htr
									(getdist ptx
										(strcat
											"\nNouvelle demi-hauteur<"
											(rtos (* (/ (distance (car pt_lst) (last pt_lst)) 2) e_y))
											">: "
										)
									)
								)
								(if (not htr)
									(setq htr (* (/ (distance (car pt_lst) (last pt_lst)) 2) e_y))
								)
								(setq e_y
									(/
										(* 2.0 htr)
										(distance (car pt_lst) (last pt_lst))
									)
								)
								(des_vec pt_lst ecart 0)
								(des_vec pt_lst ecart2 0)
								(des_vec pt_lst ecart3 0)
								(setq ecart (v_matr ptx ang e_x e_y))
								(s_cadr val1 e_x e_y)
								(setq e_x2 se_x e_y2 se_y)
								(setq ecart2 (v_matr ptx ang e_x2 e_y2))
								(s_cadr val2 e_x e_y)
								(setq e_x3 se_x e_y3 se_y)
								(setq ecart3 (v_matr ptx ang e_x3 e_y3))
								(setvar "snapmode" 0)
								(setvar "orthomode" 0)
							)
							((or (eq cod "Sortir") (eq cod nil))
								(setq ok nil)
								(redraw)
								(des_vec pt_lst ecart 2)
								(setq
									c1_a4 (list (+ (caar pt_lst) (/ (* (car (getvar "snapunit")) 2.0) e_x)) (+ (cadar pt_lst) (/ (* (cadr (getvar "snapunit")) 2.0) e_y)))
									c2_a4 (list (- (caar (cdr pt_lst)) (/ (* (car (getvar "snapunit")) 2.0) e_x)) (+ (cadar (cdr pt_lst)) (/ (* (cadr (getvar "snapunit")) 2.0) e_y)))
									c3_a4 (list (- (caar (cddr pt_lst)) (/ (* (car (getvar "snapunit")) 2.0) e_x)) (- (cadar (cddr pt_lst)) (/ (* (cadr (getvar "snapunit")) 2.0) e_y)))
									c4_a4 (list (+ (caar (cdddr pt_lst)) (/ (* (car (getvar "snapunit")) 2.0) e_x)) (- (cadar (cdddr pt_lst)) (/ (* (cadr (getvar "snapunit")) 2.0) e_y)))
									cnt_d 1
								)
								(cond
									((and (> (distance (car pt_lst) (cadr pt_lst)) (* ech 0.210)) (> (distance (car pt_lst) (cadddr pt_lst)) (* ech v_297)))
										(foreach n pt_lst
											(initget "Oui Non")
											(cond
												((eq cnt_d 1)
													(des_vec (list n (list (car c1_a4) (cadr n)) c1_a4 (list (car n) (cadr c1_a4))) ecart 3)
													(setq c_cod (getkword "\nVoulez vous ecorner ce coin [Oui/Non] < N >: "))
													(if (eq c_cod "Oui")
														(setq 
															cnt_d 4
															pt_lst
																(list
																	(list (car c1_a4) (cadr n))
																	(cadr pt_lst) (caddr pt_lst) (cadddr pt_lst)
																	(list (car n) (cadr c1_a4))
																	c1_a4
																)
														)
														(des_vec (list n (list (car c1_a4) (cadr n)) c1_a4 (list (car n) (cadr c1_a4))) ecart 0)
													)
												)
												((eq cnt_d 2)
													(des_vec (list (list (car c2_a4) (cadr n)) n (list (car n) (cadr c2_a4)) c2_a4) ecart 3)
													(setq c_cod (getkword "\nVoulez vous ecorner ce coin [Oui/Non] < N >: "))
													(if (eq c_cod "Oui")
														(setq 
															cnt_d 4
															pt_lst
																(list
																	(car pt_lst)
																	(list (car c2_a4) (cadr n))
																	c2_a4
																	(list (car n) (cadr c2_a4))
																	(caddr pt_lst) (cadddr pt_lst)
																)
														)
														(des_vec (list (list (car c2_a4) (cadr n)) n (list (car n) (cadr c2_a4)) c2_a4) ecart 0)
													)
												)
												((eq cnt_d 3)
													(des_vec (list c3_a4 (list (car n) (cadr c3_a4)) n (list (car c3_a4) (cadr n))) ecart 3)
													(setq c_cod (getkword "\nVoulez vous ecorner ce coin [Oui/Non] < N >: "))
													(if (eq c_cod "Oui")
														(setq 
															cnt_d 4
															pt_lst
																(list
																	(car pt_lst) (cadr pt_lst)
																	(list (car n) (cadr c3_a4))
																	c3_a4
																	(list (car c3_a4) (cadr n))
																	(cadddr pt_lst)
																)
														)
														(des_vec (list c3_a4 (list (car n) (cadr c3_a4)) n (list (car c3_a4) (cadr n))) ecart 0)
													)
												)
												((eq cnt_d 4)
													(des_vec (list (list (car n) (cadr c4_a4)) c4_a4 (list (car c4_a4) (cadr n)) n) ecart 3)
													(setq c_cod (getkword "\nVoulez vous ecorner ce coin [Oui/Non] < N >: "))
													(if (eq c_cod "Oui")
														(setq 
															cnt_d 4
															pt_lst
																(list
																	(car pt_lst) (cadr pt_lst) (caddr pt_lst)
																	(list (car c4_a4) (cadr n))
																	c4_a4
																	(list (car n) (cadr c4_a4))
																)
														)
														(des_vec (list (list (car n) (cadr c4_a4)) c4_a4 (list (car c4_a4) (cadr n)) n) ecart 0)
													)
												)
											)
											(setq cnt_d (1+ cnt_d))
										)
									)
								)
								(redraw)
								(princ "\nDessin et ecriture du quadrillage en cours !!!")
								(setvar "snapbase" '(0.0 0.0))
								(setvar "snapang" 0.0)
								(cart ecart)
								(setq ent1 (entlast))
								(command "_.offset" val1 ent1 ptx "")
								(setq ent2 (entlast))
								(command "_.offset" val2 ent1 ptx "")
								(setq ent3 (entlast))
							)
						)
					)
					(setq ent (entget ent3))
					(cond
						((= (cdr (assoc 0 ent)) "POLYLINE")
							(setq vx (entget (entnext (cdar ent))) pt_lst '())
							(while (= (cdr (assoc 0 vx)) "VERTEX")
								(setq pt_lst (cons (cdr (assoc 10 vx)) pt_lst))
								(setq vx (entget (entnext (cdar vx))))
							)
							(setq pt_lst (reverse pt_lst))
						)
						((= (cdr (assoc 0 ent)) "LWPOLYLINE")
							(setq nbs (cdr (assoc 90 ent)) cnt 0 pt_lst '())
							(while (< cnt nbs)
								(if (= (caar ent) 10)
									(setq pt_lst (cons (cdar ent) pt_lst) cnt (+ cnt 1))
								)
								(setq ent (cdr ent))
							)
							(setq pt_lst (reverse pt_lst))
						)
					)
					(setq n_ajou 0)
					(cond
						((setq cod (tblnext "UCS" T))
							(while cod
								(if (wcmatch (cdr (assoc 2 cod)) "LAMBERT#")
									(setq n_ajou (1+ n_ajou))
								)
								(setq cod (tblnext "UCS"))
							)
						)
					)
					(princ
						(strcat
							"\nCréation d'un SCU < LAMBERT"
							(itoa n_ajou)
							" > pour une sortie traceur..."
						)
					)
					(command "_.ucs" "_3point" (car pt_lst) (cadr pt_lst) (last pt_lst))
					(command "_.ucs" "_save" (strcat "LAMBERT" (itoa n_ajou)))
					(command "_.plan" "_current")
					(command "_.ucs" "_world")
					(command "_.hatch" "quadiso" pas "0.0" ent3 "")
					(command "_.hatch" "repquadiso,_outermost" pas "0.0" ent1 ent2 "")
					(cond
						((null (tblsearch "STYLE" "$SPEC-LSP"))
							(command "_.-style" "$spec-lsp" "simplex" "0.0" "1.0" "0.0" "_no" "_no" "_no")
						)
					)
					(setvar "textstyle" "$SPEC-LSP")
					(setq
						lmtb
							(list
								(apply 'min (mapcar 'car pt_lst))
								(apply 'min (mapcar 'cadr pt_lst))
							)
						lmth
							(list
								(apply 'max (mapcar 'car pt_lst))
								(apply 'max (mapcar 'cadr pt_lst))
							)
						i_c -1
					)
					(princ "\nEcriture des X !")
					(repeat (length pt_lst)
						(ecri (nth (setq i_c (1+ i_c)) pt_lst) (nth (rem (1+ i_c) (length pt_lst)) pt_lst) (/ pi 2))
					)
					(princ "\nEcriture des Y !")
					(setq
						lmtb (cons (cadr lmtb) (list (car lmtb)))
						lmth (cons (cadr lmth) (list (car lmth)))
						i_c -1
					)
					(repeat (length pt_lst)
						(ecri (nth (setq i_c (1+ i_c)) pt_lst) (nth (rem (1+ i_c) (length pt_lst)) pt_lst) 0.0)
					)
					(if (not (tblsearch "BLOCK" "NORDLAMB"))
(foreach n
'(
(
(0 . "BLOCK")
(8 . "0")
(2 . "NORDLAMB")
(70 . 0)
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(10 0.0 0.0 0.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 3)
(70 . 0) 
(38 . 0.0)
(39 . 0.0)
(10 0.0140625 0.0)
(40 . 0.0)
(41 . 0.00124296) 
(42 . 0.0)
(10 0.00300077 -0.000621481)
(40 . 0.00124296)
(41 . 0.0)
(42 . 0.0)
(10 0.0 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 3)
(70 . 0) 
(38 . 0.0)
(39 . 0.0)

(10 0.00994369 -0.00994369)
(40 . 0.0)
(41 . 0.00124296) 
(42 . 0.0)
(10 0.00168241 -0.00256132)
(40 . 0.00124296)
(41 . 0.0)
(42 . 0.0) 
(10 0.0 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)

(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 2)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 0.0 -0.0140625)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 0.00124296 -0.00300077)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0) 
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 3)
(70 . 0)
(38 . 0.0)
(39 . 0.0)
(10 0.00994369 0.00994369)
(40 . 0.0)
(41 . 0.00124296)
(42 . 0.0)
(10 0.00256132 0.00168241)
(40 . 0.00124296)
(41 . 0.0)
(42 . 0.0)
(10 0.0 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 3)
(70 . 0)
(38 . 0.0)
(39 . 0.0)
(10 0.0 0.025)
(40 . 0.0)
(41 . 0.00124296)
(42 . 0.0)
(10 0.000621481 0.00300077)
(40 . 0.00124296)
(41 . 0.0)
(42 . 0.0)
(10 0.0 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 3)
(70 . 0)
(38 . 0.0)
(39 . 0.0)
(10 0.0 -0.0140625)
(40 . 0.0)
(41 . 0.00124296)
(42 . 0.0)
(10 -0.000621481 -0.00300077)
(40 . 0.00124296)
(41 . 0.0)
(42 . 0.0)
(10 0.0 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 3)
(70 . 0)
(38 . 0.0)
(39 . 0.0)
(10 -0.00994369 -0.00994369)
(40 . 0.0)
(41 . 0.00124296)
(42 . 0.0)
(10 -0.00256132 -0.00168241)
(40 . 0.00124296)
(41 . 0.0)
(42 . 0.0)
(10 0.0 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 2)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 -0.00994369 -0.00994369)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 -0.00124296 -0.00300077)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 2)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 0.0 0.025)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 -0.00124296 0.00300077)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 3)
(70 . 0)
(38 . 0.0)
(39 . 0.0)
(10 -0.0140625 0.0)
(40 . 0.0)
(41 . 0.00124296)
(42 . 0.0)
(10 -0.00300077 0.000621481)
(40 . 0.00124296)
(41 . 0.0)
(42 . 0.0)
(10 0.0 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 2)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 -0.0140625 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 -0.00300077 -0.00124296)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 3)
(70 . 0)
(38 . 0.0)
(39 . 0.0)
(10 -0.00994369 0.00994369)
(40 . 0.0)
(41 . 0.00124296)
(42 . 0.0)
(10 -0.00168241 0.00256132)
(40 . 0.00124296)
(41 . 0.0)
(42 . 0.0)
(10 0.0 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 2)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 -0.00994369 0.00994369)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 -0.00300077 0.00124296)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 2)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 0.00994369 -0.00994369)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 0.00300077 -0.00124296)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0) 
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 2)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 0.0140625 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 0.00300077 0.00124296)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 2)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 0.00994369 0.00994369)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 0.00124296 0.00300077)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
(100 . "AcDbPolyline")
(90 . 2)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 0.00994369 0.00994369)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(10 0.00124296 0.00300077)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(210 0.0 0.0 1.0)
)
(
(0 . "ENDBLK")
(8 . "0")
(62 . 0)
(6 . "ByBlock")
(370 . -2)
)
)
(entmake n)
)
					)
					(princ "\nDonnez le point d'insertion du Nord :")
					(command "_.-insert" "nordlamb" pause ech "" "")
					(setq htx (* htx 2) ecr (strcat "Échelle : 1/" (rtos ech 2 0)))
					(setq rot
						(angtos (angle (car pt_lst) (cadr pt_lst)) (getvar "aunits") 5)
					)
					(princ "\nDonnez le point de depart pour ecrire l'Echelle :")
					(command "_.text" pause htx rot ecr)
					(setq lamerr nil cart nil des_vec nil new_list nil grpl nil
					      s_cadr nil ecri nil v_matr nil v_chg nil c:lambert nil
					      colorname nil getindex nil getlayer nil layedit_act nil
					      laylist_act nil makelaylists nil reset-lay nil test-ok nil
					      tststr nil tstval nil
					)
				)
				(T (princ "\n*Arrêt*"))
			)
		)
		(unload_dialog dcl_id)
		(setvar "blipmode" sv_blp)
		(setvar "angbase" sv_agb)
		(setvar "osmode" sv_osm)
		(setvar "orthomode" sv_oth)
		(setvar "snapstyl" sv_stl)
		(setvar "snapbase" sv_spb)
		(setvar "snapang" sv_sng)
		(setvar "snapunit" sv_sun)
		(setvar "snapmode" sv_smd)
		(setvar "limcheck" sv_lck)
		(setvar "clayer" sv_pl)
		(setvar "textstyle" sv_sty)
		(if (= sv_ucs 0)
			(progn
				(command "._ucs" "_restore" "$_TEMPO_$")
				(command "._ucs" "_delete" "$_TEMPO_$")
			)
		)
		(command "_.undo" "_end")
		(if (<= sv_und 3) (command "_.undo" "_control" "_one"))
		(setq *error* olderr)
		(setvar "cmdecho" 1)
	)
	(T
		(alert "\nCommande LAMBERT inopérante:\nSoit vous êtes en présentation papier, soit le dessin est vide ou dans le système anglo-saxon")
	)
)
(princ)
)

 

LE DCL lambert.dcl

lambert	: dialog {
label = "Définition du carroyage LAMBERT";
:boxed_row {
label = "";
:boxed_column {
label = "Choix de l'échelle";
	:list_box	{
		multiple_select=false;
		key="lst_ech";
		width=10;
	}
	:edit_box {
	label      = "Echelle:";
	mnemonic   = "E";
	key        = "c_ech";
	width = 10;
	edit_width = 10;
	}
}
:boxed_column {
label = "Choix du pas";
	:list_box	{
		multiple_select=false;
		key="lst_pas";
		width=10;
	}
	:edit_box {
	label      = "Pas:";
	mnemonic   = "P";
	key        = "c_pas";
	width = 10;
	edit_width = 10;
	}
}
}
:boxed_column {
label = "Choix du calque pour le carroyage";
	:edit_box {
	label      = "Calque:";
	mnemonic   = "C";
	key        = "pl_lamb";
	width = 32;
	edit_width = 32;
	edit_limit = 31;
	}
	: button {
	label       = "Choix dans Liste des calques...";
	mnemonic    = "L";
	key         = "pl_name";
	fixed_width = true;
	alignment   = centered;
	}
}
ok_cancel_err;
}
setlayer : dialog {
   subassembly = 0;
   label = "Choix du Calque";
   initial_focus = "listbox";
   : concatenation {
       children_fixed_width = true;
       key = "clayer";
       : text_part {
           label = "Calque Courant: ";
       }
       : text_part {
           key = "cur_layer";
           width = 35;
       }
   }
   : row {
       fixed_width = true;
       key = "titles";
       children_fixed_width = true;
       : text {
           label = "Nom du Calque";
           width = 34;
       }
       : text {
           label = "Etat";
           width = 9;
       }
       : text {
           label = "Couleur";
           width = 8;
       }
       : text {
           label = "Type de ligne";
           width = 12;
       }
   }
   : list_box {
       tabs = "32 35 37 39 41 44 53";
       width = 67;
       height = 12;
       key = "list_lay";
       allow_accept = true;
   }
   : row {
       key = "controls";
       : column {
           key = "lname";
           fixed_width = true;
           : edit_box {
               label = "Définir le Nom du Calque:";
               mnemonic = "D";
               key = "edit_lay";
               width = 32;
               edit_width = 32;
               edit_limit = 31;
               allow_accept = true;
           }
       }
   }
   ok_cancel_err;
}

 

LE 1er fichier PAT: quadiso.pat

*QUADISO,Quadrillage lambert
0, -.015,0, 0,1, .03,-.97
90, 0,-.015, 0,1, .03,-.97

 

LE 2ème fichier PAT: repquadiso.pat

*REPQUADISO,Repere du quadrillage lambert
0, 0,0, 0,1
90, 0,0, 0,1

 

 

Choisissez un travail que vous aimez et vous n'aurez pas à travailler un seul jour de votre vie. - Confucius

Lien vers le commentaire
Partager sur d’autres sites
ddb64 Newbie

ddb64

Posté(e)
  • Auteur
Posté(e)

Bonuscad,

 

Bien vu, le Lisp était foireux...

 

En fait c'est la version béta que j'ai retrouvé hier.

 

Et ce soir ô miracle, j'ai retrouvé sur une disquette le code correct...

 

J'y ai intégré une partie des modifs de Giles, et voilà le résultat:

 

 

Le Lisp: CARROY.lsp

 ; DESCRIPTION
; permet de realiser du carroyage et l'affichage des points d'intersection
; avec l'espace delimite par l'utilisateur ainsi que l'affichage des
; coordonnees de ces points d'intersection
;
;----------------------------------------------------------------------------

(defun C:CARROY (/ poly vertex som sommet closed elm fin coorx ptx mx X listx
                  listy dx dy echel oldlayer plan echelle pas_x pas_y hautext
                  hauteur actstyle fixedheight elmstyle yes no intext extext
                  crox crox2)



;;---------------------------------------------------------------------------
;;
;; Fonction point_sur_segment :  un point se trouve-t-il sur un segment donne
;;
;;---------------------------------------------------------------------------
(defun point_sur_segment(pt1 pt2 ptinter / dist1 dist2 dist_ref)
       (setq dist1 (sqrt (+ (expt (- (nth 0 ptinter) (nth 0 pt1)) 2)
                            (expt (- (nth 1 ptinter) (nth 1 pt1)) 2))))
       (setq dist2 (sqrt (+ (expt (- (nth 0 ptinter) (nth 0 pt2)) 2)
                            (expt (- (nth 1 ptinter) (nth 1 pt2)) 2))))
       (setq dist_ref (sqrt (+ (expt (- (nth 0 pt2) (nth 0 pt1)) 2)
                            (expt (- (nth 1 pt2) (nth 1 pt1)) 2))))
       (cond ((and (<= dist1 dist_ref) (<= dist2 dist_ref)) T))
)
;;---------------------------------------------------------------------------
;;
;; Fonction init_variables : initialisation des valeurs des champs de la
;;                           case de dialogue
;;
;;---------------------------------------------------------------------------
(defun init_variables()
 (setq plan "CARROYAGE")
 (setq echelle "1:1")
 (setq pas_x "100")
 (setq pas_y "100")
 (setq hautext "7.5")
 (setq hauteur "3.0")
 (setq extext "0")
 (setq intext "0")
 (setq yes "0")
 (setq no "0")
)
;;---------------------------------------------------------------------------
;;
;; Fonction init_tiles : initialisation des champs de la case de dialogue
;;
;;---------------------------------------------------------------------------
(defun init_tiles()
 (set_tile "nom_plan" "CARROYAGE")
 (set_tile "nb_echel" "1:1")
 (set_tile "nb_pasx" "100")
 (set_tile "nb_pasy" "100")
 (set_tile "nb_haut" "3.0")
 (set_tile "h_text" "7.5")
)
;;---------------------------------------------------------------------------
;;
;; Fonction action_tiles : definition des actions associees aux champs
;;                         de la case de dialogue
;;
;;---------------------------------------------------------------------------
(defun action_tiles()
 (action_tile "nom_plan" "(setq plan $value)")
 (action_tile "nb_echel" "(setq echelle $value)")
 (action_tile "nb_pasx" "(setq pas_x $value)")
 (action_tile "nb_pasy" "(setq pas_y $value)")
 (action_tile "nb_haut" "(setq hauteur $value)")
 (action_tile "ext"
 "(setq extext $value)(if (= extext \"0\")(setq intext \"1\")(setq intext \"0\"))")
 (action_tile "int"
 "(setq intext $value)(if (= intext \"0\")(setq extext \"1\")(setq extext \"0\"))")
 (action_tile "h_text" "(setq hautext $value)")
 (action_tile "oui"
 "(setq yes $value)(if (= yes \"0\")(setq no \"1\")(setq no \"0\"))")
 (action_tile "non"
 "(setq no $value)(if (= no \"0\")(setq yes \"1\")(setq yes \"0\"))")
 (setq crox 0) (setq crox2 0)
 (action_tile "croix" "(setq crox $reason)")
 (action_tile "croix2" "(setq crox2 $reason)")
)
;;---------------------------------------------------------------------------
;;
;; Fonction carroy_dialog : gestion case de dialogue
;;
;;---------------------------------------------------------------------------
(defun carroy_dialog (/ dcl_id)
(init_variables)
;; Ouverture de la boite de dialogue
(setq dcl_id (load_dialog "carroy.dcl"))
(if (not (new_dialog "carroy" dcl_id)) 
       (exit)
)
       
;; Creation de la croix pleine dans la boite de dialogue
(setq width (dimx_tile "croix")) 
(setq height (dimy_tile "croix"))
(start_image "croix")
(vector_image (/ width 2) (/ height 4) (/ width 2) (- height (/ height 4)) 7)
(vector_image (- (/ width 2) (/ height 4)) (/ height 2) (+ (/ width 2) (/ height 4)) (/ height 2) 7)
(end_image)
       
;; Creation de la croix ouverte dans la boite de dialogue
(setq width2 (dimx_tile "croix2")) 
(setq height2 (dimy_tile "croix2"))
(start_image "croix2")
(vector_image (/ width2 2) (/ height2 4) (/ width2 2) (- (/ height2 2) (/ height 12)) 7)
(vector_image (/ width2 2) (+ (/ height2 2) (/ height2 12)) (/ width2 2) (- height2 (/ height2 4)) 7)
(vector_image (- (/ width2 2) (/ height2 4)) (/ height2 2) (- (/ width2 2) (/ height2 12)) (/ height2 2) 7)
(vector_image (+ (/ width2 2) (/ height2 12)) (/ height2 2) (+ (/ width 2) (/ height 4)) (/ height 2) 7)
(end_image)

(init_tiles)
(action_tiles)
       
(if (or (= echelle 0) (= echelle "")) 
       (alert "Valeur de l'echelle invalide.\nVeuillez recommencer.")
) 
(if (or (= pas_x 0) (= pas_x "")) 
       (alert "Valeur du pas en x invalide.\nVeuillez recommencer.")
)
(if (or (= pas_y 0) (= pas_y "")) 
       (alert "Valeur du pas en y invalide.\nVeuillez recommencer.")
)
(if (or (= h_text 0) (= h_text "")) 
       (alert "Valeur de la hauteur du text invalide.\nVeuillez recommencer.")
)
(if (or (= nb_haut 0) (= nb_haut "")) 
       (alert "Valeur de la hauteur de la croix invalide.\nVeuillez recommencer.")
)
(start_dialog)
(unload_dialog dcl_id)
)
;;---------------------------------------------------------------------------
;;
;; Fonction genere_point : genere un point sous forme de chaine
;;                         de caractere
;;
;;---------------------------------------------------------------------------
(defun genere_point(axe valx valy / pt)
 (if (= axe "X")
   (setq pt (strcat "*"(rtos valx 2)","(rtos valy 2)))
   (setq pt (strcat "*"(rtos valy 2)","(rtos valx 2)))
   )
)
;;---------------------------------------------------------------------------
;;
;; Fonction place_repere : placement des reperes "horizontaux" et "verticaux"
;;
;;---------------------------------------------------------------------------
(defun place_repere(axe listxy / mxy valmax i valaxe dl intxy xy_inter
                                 j a b c d intersect ordre mxy_inter k
                                 y1 w reste f point1 point2 point2b point3
                                 point3b pnt11 pnt22 ang ang1 textrep)

(if (= axe "X")
   (setq dl dx)
   (setq dl dy))
;;
;; Placement des reperes de coordonnees en x ou en y
;;
(setq mxy (nth 0 listxy))
(setq valmax (nth 0 listxy))
(setq i 0)
(while (< i (length listxy))
       (setq mxy (min (nth i listxy) mxy))
       (setq valmax (max (nth i listxy) valmax))
       (setq i (1+ i))
)
       
(setq valaxe (/ mxy dl))
(if (< valaxe 0)
       (setq intxy (* (fix valaxe) dl))
       (setq intxy (* (+ (fix valaxe) 1) dl))
)

(while (<= intxy valmax)
       (setq xy_inter nil)
       (setq j 0)
       (while (< j (length sommet))
              (if (= axe "X")
               (progn
               (setq a (list intxy 0))
               (setq b (list intxy 100))
               )
               (progn
               (setq a (list 0 intxy))
               (setq b (list 100 intxy))
               ))
               (setq c (nth j sommet))
               (setq d (nth (cond ((< j (1- (length sommet)))(1+ j))
                                  ((= j (1- (length sommet))) 0)) sommet))
               (if (setq intersect (inters a b c d nil))
                       (if (point_sur_segment c d intersect)
                            (if (= axe "X")
                               (setq xy_inter (append xy_inter (list (nth 1 intersect))))
                               (setq xy_inter (append xy_inter (list (nth 0 intersect)))))
                       )
               )
               (setq j (1+ j))
       ) ; Fin du while (< j (length sommet))
       
;; Remise en ordre de la liste xy_inter
       (setq ordre nil)
       (while (>= (length xy_inter) 2)
               (setq mxy_inter (nth 0 xy_inter))
               (setq k 1)
               (while (< k (length xy_inter))
                       (setq y1 (nth k xy_inter))
                       (setq mxy_inter (min y1 mxy_inter))
                       (setq k (1+ k))
               ) ; Fin du while (< k (length xy_inter))
               
               (setq w 0)
               (setq reste nil)
               (while (< w (length xy_inter))
                       (if (/= mxy_inter (nth w xy_inter))
                               (setq reste (append reste (list (nth w xy_inter))))
                               (setq ordre (append ordre (list mxy_inter)))
                       )
                       (setq w (1+ w))
               ) ; Fin du while (< w (length xy_inter))
               
               (setq xy_inter reste)
       ) ; Fin du while (>= (length xy_inter) 2)
       
       (if (/= xy_inter nil)
               (setq xy_inter (append ordre reste))
       )

;; Realisation des traits de repere "horizontaux" ou "verticaux"
;; avec leur texte
       (setq f 0)
       (while (< f (length xy_inter))
               (setq point1 (genere_point axe intxy (nth f xy_inter)))
               (setq point2 (genere_point axe intxy (+ (nth f xy_inter) (/ dl 4))))
               (setq point2b (genere_point axe intxy (+ (nth f xy_inter) (/ (atof hautext) 2))))
               (setq point3 (genere_point axe intxy (- (nth f xy_inter) (/ dl 4))))
               (setq point3b (genere_point axe intxy (- (nth f xy_inter) (/ (atof hautext) 2))))
               (if (= axe "X")
                  (progn
                  (setq pnt11 (trans (list intxy (nth f xy_inter)) 0 1))
                  (setq pnt22 (trans (list intxy (+ (nth f xy_inter) 5)) 0 1))
                  )
                  (progn
                  (setq pnt11 (trans (list (nth f xy_inter) intxy) 0 1))
                  (setq pnt22 (trans (list (+ (nth f xy_inter) 5) intxy) 0 1))
                  ))
               (setq ang (angle pnt11 pnt22))
               (setq ang1 (atof (angtos ang nb 3)))
               (setq textrep (rtos (/ intxy echel) 2 0))
               (if (= extext "1")
               (progn
               (if (= (rem f 2) 0)
                   (progn
                   (command "_line" point1 point2 "")
                   (if (= fixedheight 0)
                   (command "_text" "j" "MD" point3b hautext ang1 textrep)
                   (command "_text" "j" "MD" point3b ang1 textrep))
                   )
                   (progn
                   (command "_line" point1 point3 "")
                   (if (= fixedheight 0)
                   (command "_text" "j" "MG" point2b hautext ang1 textrep)
                   (command "_text" "j" "MG" point2b ang1 textrep))
                   )
                   )
                   )
               )
               
               (if (= intext "1")
               (progn
               (if (= (rem f 2) 0)
                   (progn
                   (command "_line" point1 point2 "")
                   (if (= fixedheight 0)
                   (command "_text" "j" "MG" point2b hautext ang1 textrep)
                   (command "_text" "j" "MG" point2b ang1 textrep))
                   )
                   (progn
                   (command "_line" point1 point3 "")
                   (if (= fixedheight 0)
                   (command "_text" "j" "MD" point3b hautext ang1 textrep)
                   (command "_text" "j" "MD" point3b ang1 textrep))
                   )
               )
               )
               )
               (setq f (1+ f))
       ) ; Fin du while (< f (length xy_inter)
       
       (setq intxy (+ intxy dl))
) ; Fin du while (<= intxy valmax)
)
;;---------------------------------------------------------------------------
;;
;; Corps de la fonction
;;
;;---------------------------------------------------------------------------
;;--- Fichier de deboggage
;;
;(setq df (open "carroy.dat" "w"))
;;---
(setvar "cmdecho" 0)
(setvar "filedia" 0)
(setq nb (getvar "AUNITS"))
(setq oldlayer (getvar "clayer"))
(setq actstyle (getvar "textstyle"))
(setq elmstyle (tblsearch "style" actstyle))
(if (/= (cdr (assoc 40 elmstyle)) 0.0)
   (setq fixedheight 1)
   (setq fixedheight 0)
   )
;; Chargement du fichier contenant la forme (carroy.shx)
(command "_load" "carroy")
       
(carroy_dialog)

(print "Plan:          ") (princ plan)
(print "Echelle:       ") (princ echelle)
(print "Pas en x:      ") (princ pas_x)
(print "Pas en y:      ") (princ pas_y)
(print "Hauteur texte: ") (princ hautext)
(print "Hauteur croix: ") (princ hauteur)
(print)

;; Creation d'un nouveau plan pour le carroyage
(command "_layer" "E" plan "CH" plan "")

;;---
;;--- Decodage de l'echelle
;;---
(setq chaine1 "")
(setq chaine2 "")
(setq k 1)
(while (<= k (strlen echelle))
       (setq mot (substr echelle k 1))
       (if (= mot ":")
               (progn
               (while (<= k (strlen echelle)) 
                       (setq k (1+ k))
                       (setq mot (substr echelle k 1))
                       (setq chaine2 (strcat chaine2 mot))
               )
               )
       (setq chaine1 (strcat chaine1 mot))
       )
       (setq k (1+ k))
)

(setq reel1 (atof chaine1))
(setq reel2 (atof chaine2))
(setq echel (/ reel1 reel2))
;;---
;;---
(setq dx (* (atoi pas_x) echel))
(setq dy (* (atoi pas_y) echel))
(setq i 1) (setq j 0)
(setq closed 0)
(setq haut (atof hauteur))        
(while (= closed 0)
       (setq poly (entget(setq elm (car (entsel "Selectionner la polyligne")))))
       (setq efface elm)
       (setq closed (cdr (assoc 70 poly)))
       (if (= closed 0)
               (alert "La polyligne doit etre fermee! \nVeuillez recommencer.")
       )
)
       
(cond
((= (cdr (assoc 0 poly)) "POLYLINE")
(setq fin (cdr (assoc 0 poly)))
(while (/= fin "SEQEND")
(setq vertex (entget (setq elm (entnext elm))))
(setq fin (cdr (assoc 0 vertex)))
(setq coorx (cadr (assoc 10 vertex)))
(setq coory (caddr (assoc 10 vertex)))
(setq som (cdr (assoc 10 vertex)))
(if (/= som nil)
(setq sommet (append sommet (list som)))
)
(if (/= coorx nil)
(setq listx (append listx (list coorx)))
)
(if (/= coory nil)
(setq listy (append listy (list coory)))
)
)
)
((= (cdr (assoc 0 poly)) "LWPOLYLINE")
(setq
sommet (mapcar
'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10)) poly)
)
)
(setq listx (mapcar 'car sommet))
(setq listy (mapcar 'cadr sommet))
)
(T
(alert
"L'objet sélectionné n'est pas une polyligne (2D ou optimisée)"
)
(exit)
)
)
       
(setq mx (nth 0 listx))
(setq xmax (nth 0 listx))
(setq i 0)
(while (< i (length listx))
       (setq mx (min (nth i listx) mx))
       (setq xmax (max (nth i listx) xmax))
       (setq i (1+ i))
)
       
(setq valx (/ mx dx))
(if (< valx 0)
       (setq intx (* (fix valx) dx))
       (setq intx (* (+ (fix valx) 1) dx))
)

(while (<= intx xmax)
       (setq y_inter nil)
       (setq j 0)
       (while (< j (length sommet))
               (setq a (list intx 0))
               (setq b (list intx 100))
               (setq c (nth j sommet))
               (setq d (nth (cond ((< j (1- (length sommet)))(1+ j))
                                  ((= j (1- (length sommet))) 0)) sommet))
               (if (setq intersect (inters a b c d nil))
                       (if (point_sur_segment c d intersect)
                               (setq y_inter (append y_inter (list (nth 1 intersect))))
                       )
               )
               (setq j (1+ j))
       ) ; Fin du while (< j (length sommet))

       (setq ordre nil)
       (while (>= (length y_inter) 2)
               (setq my_inter (nth 0 y_inter))
               (setq k 1)
               (while (< k (length y_inter))
                       (setq y1 (nth k y_inter)) 
                       (setq my_inter (min y1 my_inter))
                       (setq k (1+ k))
               ) ; Fin du while (< k (length y_inter))
       
               (setq w 0)
               (setq reste nil)
               (while (< w (length y_inter))
                       (if (/= my_inter (nth w y_inter))
                               (setq reste (append reste (list (nth w y_inter))))
                               (setq ordre (append ordre (list my_inter)))
                       )
                       (setq w (1+ w))
               ) ; Fin du while (< w (length y_inter))
               
               (setq y_inter reste)
       ) ; Fin du while (>= (length y_inter) 2)
               
       (setq y_inter (append ordre reste))

;; Nombre d'intervalles a carroyer
       (setq nb_inter (/ (length y_inter) 2))
       (setq i 1)

;; Boucle sur les intervalles a carroyer suivant la droite X = intx
       (while (<= i nb_inter)

;; Recherche du Y de depart pour l'intervalle
               (setq my (nth (* (1- i) 2)  y_inter))
               (setq valy (/ my dy))
               (if (< valy 0)
                       (setq inty (* (fix valy) dy))
                       (setq inty (* (+ (fix valy) 1) dy))
               )
               (setq inty (- inty dy) flag_out 0)
               (while (= flag_out 0)
                       (setq inty (+ inty dy))
                       (if (and (>= inty (nth (* (1- i) 2) y_inter))
                                (<= inty (nth (+ (* (1- i) 2) 1) y_inter)))
                               (progn
                               (setq ptform (trans (list intx inty) 0 1))
                               (setq ptform1 (trans (list (+ intx dx) inty) 0 1))
                               (setq angl (atof (angtos (angle ptform ptform1) nb 3)))
                               (if (or (= crox 1) (= crox 4))
                                       (command "_shape" "crx" ptform haut angl)
                               )
                               (if (or (= crox2 1) (= crox2 4))
                                       (command "_shape" "crx2" ptform haut angl)
                               )
                               )
                               (setq flag_out 1)
                       )
               ) ; Fin du while (= flag_out 0)
               
               (setq i (1+ i))
       ) ; Fin du while (<= i nbinter)
       
       (setq intx (+ intx dx))
) ; Fin du while (<= intx xmax)
;;
;; Placement des reperes de coordonnees en x
;;
(place_repere "X" listx)
;;
;; Placement des reperes de coordonnees en y
;;
(place_repere "Y" listy)


(if (and (= yes "1") (= no "1"))
       (progn
       (alert "Vous avez changé plusieurs fois pour le choix du contour!\nPar defaut, le contour sera existant.")
       (setq no "0")
       )
)

(if (and (= yes "0") (= no "0"))
       (progn
       (alert "Vous n'avez pas effectue de choix pour le contour!\nPar defaut, le contour sera existant.")
       (setq yes "1")
       )
)


(if (= no "1")
(entdel efface)
)

(setvar "cmdecho" 1)
(setvar "filedia" 1)
(setvar "clayer" oldlayer)
(redraw)
;(close df)
(princ)
)

 

 

 

 

le DCL: CARROY.dcl

 

 carroy : dialog {
       label = "OPTIONS POUR LE CARROYAGE";
               : edit_box {
                 label = "PLAN    :";
                 key = "nom_plan";
               }
               : edit_box {
                 label = "ECHELLE :";
                 key = "nb_echel";
               }
               : edit_box {
                 label = "PAS EN X:";
                 key = "nb_pasx";
               }
               : edit_box {
                 label = "PAS EN Y:";
                 key = "nb_pasy";
               }
               : text {
                 label = "TEXTE   :";
               }
      
      : row {         
               : text {
                 label = "Position ";
               }
               : column {
               : radio_button { 
                 label = "Exterieur ";
                 key = "ext";
               }
               : radio_button { 
                 label = "Interieur ";
                 key = "int";
               }
               }
       }
               : edit_box {
                 label = "Hauteur  ";
                 key = "h_text";
               }
      
      : row {         
               : text {
                 label = "CONTOUR :";
               }
               : column {
               : radio_button { 
                 label = "Existant  ";
                 key = "oui";
               }
               : radio_button { 
                 label = "Inexistant";
                 key = "non";
               }
               }
       }
               
               : text {
                 label = "CROIX   :";
               }
               : edit_box {
                 label = "Hauteur  ";
                 key = "nb_haut";
               }
       
       : row {    
               : text {
                 label = "Style";
               }
       : boxed_row {        
               : image_button {
                 key = "croix";
                 width = 3.5;
                 aspect_ratio = 1.0;
                 color = 0;
                 allow_accept = true;
                 }
               : image_button {
                 key = "croix2";
                 width = 3.5;
                 aspect_ratio = 1.0;
                 color = 0;
                 allow_accept = true;
               }
       }
       }
       
       ok_only;
}

Lien vers le commentaire
Partager sur d’autres sites
  • 5 mois après...
zizouspawn Newbie

zizouspawn

Posté(e)
Posté(e)

SAlut

J'ai bien installer les programmes en lsp et dcl

j'ai bien la fenetre avec des trucs à renseigner

 

mais apres j'ai un bug

 

Commande: _carroy

"Plan: " CARROYAGE

"Echelle: " 1:1000

"Pas en x: " 100

"Pas en y: " 100

"Hauteur texte: " 2

"Hauteur croix: " 1

Selectionner la polyligne

Forme CRX non trouvée.

; erreur: Fonction annulée

Entrez le nom de la forme ou [?]:

 

si vous avez la solution je suis preneur

Lien vers le commentaire
Partager sur d’autres sites
  • 1 an après...

Créer un compte ou se connecter pour commenter

Vous devez être membre afin de pouvoir déposer un commentaire

Créer un compte

Créez un compte sur notre communauté. C’est facile !

Créer un nouveau compte

Se connecter

Vous avez déjà un compte ? Connectez-vous ici.

Connectez-vous maintenant
 Partager
Aller sur la liste des sujets
×
×
  • Créer...

Information importante

Nous avons placé des cookies sur votre appareil pour aider à améliorer ce site. Vous pouvez choisir d’ajuster vos paramètres de cookie, sinon nous supposerons que vous êtes d’accord pour continuer. Politique de confidentialité