Aller au contenu

création d\'intersection et reconstitution de contour


doy

Messages recommandés

Bonjour à tous,

 

Je développe toujours mon programme de création des boîtes suivant une trajectoire.

 

j'ai réussi à sélectionner mes blocs et à les décomposer mais maintenant je bloque.

 

je me retouve avec mes blocs décomposés et mes limites de corridor,

ces deux éléments étant respectivement dans des calques différents.

 

je me pose la question de savoir si je dois reselectionner les divers éléments pour les mettre dans un même calque ou si je peux les laisser dans des calques différents,

 

le but tant à partir de ces entités " blocs" et "polyligne = limites corridor" de créer des boîtes.

 

ces boîtes doivent être des contours ( polylignes ) fermés que l'on pourra par la suite extraire séparément.

 

SEULEMENT je ne sais pas comment écrire tous ceci en langage lisp !!!!!!!

 

Par avance un grand merci à tous ceux qui m'ont aidé.

 

à + doy.

 

je joins le programme que j'ai déjà écris.

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

;;; ; CORRIDOR.LSP

;;; ;

;;; ; Création des boîtes le long de la Trajectoire de vol de l'hélicoptère.

;;; ; Ces boîtes correspondent aux limites du Perimètre du Corridor.

;;; ; Ces limites sont composées de boîtes juxtaposées toujours perpendiculaires à la trajectoire,

;;; ; dont les paramètres de longueur des boîtes et de largeur du corridor sont réglables,

;;; ; par une simple entrée au clavier dans la ligne de commande d'AutoCAD.

;;; ; Après chargement, l'exécution de la fonction "boite" est obtenu par :

;;; ; -> commande : (boite)

;;; ; selection polyligne, coordonnées des sommet & calcul longueur

;;;

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Boite DCL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

 

(defun c:corridor ()

 

(setq dcl_id (load_dialog "Boite de dialogue corridor.dcl"))

(if

(not (new_dialog "boite_de_dialogue_corridor" dcl_id))

(exit)

)

;si il n'y a pas de boite de dialogue alors on lance le programme sans elle

 

 

;image en .sld

 

(setq x1 (dimx_tile "img1") ;coordonnées x du coin inférieur droit de l'image nom de l'image que l'on donne dans la boite de dialogue

y1 (dimy_tile "img1")) ;coordonnées y du coin inférieur droit de l'image

(start_image "img1") ;Début du traitement d'un controle image

(fill_image 0 0 (dimx_tile "img1") (dimy_tile "img1") 0)

(slide_image 0 0 x1 y1 "corridor_image") ;centrage de la diapo

(end_image)

 

 

(action_tile "inverse0" "(setq inverse \"0\")"); affecte donc l'action inverse = 2 à évaluer lorsque nous sélectionnons la variable inverse2 .

(action_tile "inverse1" "(setq inverse \"1\")"); affecte donc l'action inverse = 3 à évaluer lorsque nous sélectionnons la variable inverse3 .

 

 

;j'établit la liste des blocs qui seront insérés dans les listes déroulantes

(setq liste_bloc '("b600" "b600 1" "li3" "lib"))

 

;; initialiser les variables

;;;(if (not largeur_corridor) (setq largeur_corridor "1500")).

;;;;;;(if (not cas) (setq cas "cas0"))

;;;(if (not position_liste) (setq position_liste "0")).

;;;

;;;;; initialiser la boite de dialogue.

;;;(set_tile "larg_corridor" largeur_corridor).

;;;(set_tile "cas" cas).

;;;(set_tile "bloc" position_liste).

 

 

 

 

 

;largeur du corridor.

 

(action_tile "larg_corridor" "(setq largeur_corridor $value)")

; " action_tile " affecte l'action " larg_corridor " à évaluer lorsque nous sélectionnons le composant " largeur_corridor ".

 

;largeur des boites.

 

(action_tile "cas0" "(setq cas \"0\")"); affecte donc l'action cas = 0 à évaluer lorsque nous sélectionnons la variable cas0 .

(action_tile "cas1" "(setq cas \"1\")"); affecte donc l'action cas = 1 à évaluer lorsque nous sélectionnons la variable cas1 .

 

(start_list "bloc"); lance la création d'une liste " bloc " dans la zone de liste.

(mapcar 'add_list liste_bloc); mapcar renvoie la liste " liste_bloc " en résultat de l'execution de la fonction " add_list ".

; la fonction " add_list "ajoute et modifie dans la liste de la boîte de dialogue les éléments de " liste_bloc ".

(end_list); met fin au traitement de la liste de la boîte de dialogue courante.

 

 

(action_tile "bloc" "(setq position_liste $value)"); affecte l'action " cas " à évaluer lorsque nous sélectionnons le composant " cas ".

 

(action_tile "accept" "(done_dialog 1)") ;1 pour OK ;

(action_tile "cancel" "(done_dialog 0)") ;o pour Cancel ;

 

(setq what_next (start_dialog)); démarre la boîte de dialogue.

(unload_dialog dcl_id)

 

(if

(= what_next 1) ;; ok

(progn

(setq bloc_largeur (nth (atoi position_liste) liste_bloc)); " atoi " convertit la chaîne de caractère " position_liste " en un nombre entier.

;;;(alert (strcat "Largeur corridor : " largeur_corridor))

;;;(alert (strcat "Cas : " (itoa cas)))

;;;(alert (strcat "Largeur bloc : " bloc_largeur))

 

)

)

(boite) ; on lance le programme boite

 

(princ)

)

 

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

(defun boite ()

 

 

(setvar "attdia" 0) ;Détermine si la commande INSERT utilise une boîte de dialogue

;pour la saisie de la valeur d'attribut. Voir la section "INSERT, ligne de commande",.

;Variables système

;0 Affiche les messages sur la ligne de commande

;1 Utilise une boîte de dialogue

 

(setvar "osmode" 0) ;gère l'accrochage aux objets ici mode 0 donc désactivé.

(setvar "cmdecho" 0) ;gère le mode d'écho des commandes dans l'environnement d'AutoCAD, ici mode 0 donc désactivé.

 

(setq largeur_corridor (atoi largeur_corridor)); " atoi " convertit la chaîne de caractère " largeur_corridor " en un nombre entier.

(setq cas (atoi cas))

(setq inverse (atoi inverse))

 

 

(command "-calque" "e" "LIMITE" "co" "bleu" "LIMITE" ""); définit les paramètres du calque " LIMITE ".

(command "-calque" "e" "pk" "co" "magenta" "pk" "ch" "pk" ""); définit les paramètres du calque " Pk ".

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

;inversion du sens de la trajectoire fonction reverse LWPOLYLINE"

 

(if

(= inverse 3)

(progn

 

;;; R_PLINE Fonction d'appel

 

;;; (defun r_pline (/ ent)

(while (not (setq ent (car (entsel)))))

(if

(or (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")

(and (= (cdr (assoc 0 (entget ent))) "POLYLINE")

(zerop (logand 240 (cdr (assoc 70 (entget ent)))))

)

)

(reverse_pline ent)

(prompt "\nEntité non valide")

)

(princ)

;;; )

 

 

(defun reverse_pline (ent / e_lst vtx v_lst p_lst l_vtx)

(setq e_lst (entget ent))

(cond

((= (cdr (assoc 0 e_lst)) "POLYLINE")

(setq vtx (entnext ent))

(while (= (cdr (assoc 0 (entget vtx))) "VERTEX")

(setq v_lst (cons (entget vtx) v_lst)

vtx (entnext vtx)

)

)

)

((= (cdr (assoc 0 e_lst)) "LWPOLYLINE")

(setq p_lst (vl-remove-if-not

'(lambda (x)

(member (car x) '(10 40 41 42))

)

e_lst

)

e_lst (vl-remove-if

'(lambda (x)

(member x p_lst)

)

e_lst

)

)

(while p_lst

(setq v_lst (cons

(list (car p_lst) (cadr p_lst) (caddr p_lst) (cadddr p_lst))

v_lst

)

p_lst (member (assoc 10 (cdr p_lst)) (cdr p_lst))

)

)

)

)

(setq l_vtx (last v_lst)

l_vtx (subst (cons 40 (cdr (assoc 41 (car v_lst))))

(assoc 40 l_vtx)

l_vtx

)

l_vtx (subst (cons 41 (cdr (assoc 40 (car v_lst))))

(assoc 41 l_vtx)

l_vtx

)

l_vtx (subst (cons 42 (- (cdr (assoc 42 (car v_lst)))))

(assoc 42 l_vtx)

l_vtx

)

)

(setq v_lst

(mapcar

'(lambda (x y)

(setq x (subst (cons 40 (cdr (assoc 41 y))) (assoc 40 x) x)

x (subst (cons 41 (cdr (assoc 40 y))) (assoc 41 x) x)

x (subst (cons 42 (- (cdr (assoc 42 y)))) (assoc 42 x) x)

)

)

v_lst

(cdr v_lst)

)

)

(if (= (logand 1 (cdr (assoc 70 e_lst))) 1)

(setq v_lst (append (list l_vtx) v_lst))

(setq v_lst (append v_lst (list l_vtx)))

)

(cond

((= (cdr (assoc 0 e_lst)) "POLYLINE")

(mapcar 'entmake

(append (list e_lst) v_lst (list (entget vtx)))

)

(entdel ent)

)

((= (cdr (assoc 0 e_lst)) "LWPOLYLINE")

(setq e_lst (append e_lst (apply 'append v_lst)))

(entmod e_lst)

)

)

)

 

 

 

(command "-calque" "ch" "LIMITE" ""); Choix du calque " LIMITE ".

 

; double décalage à gauche et à droite.

;(attribut du double décalage (ddllpp) (/ Vdist entité1 pt1 pt2 entitépoints anglepl PtGauche PtDroite)

 

; la largeur du corridor = distance de decalage.

(setq

trajectoire (entget

(car (entsel "Selectionner la ligne ou la polyligne représentant la trajectoire:")); demande de sélectionner l'objet " trajectoire "

; en spécifiant un point.

)

)

(if

(eq (cdr (assoc 0 trajectoire)) "LINE"); " assoc " recherche l'élément " trajectoire " dans la liste d'association " LINE " ou " entitétrajectoire "

; et renvoie l'entrée correspondante.

;;; determine si l'objet est ligne ou polyligne.

(progn (Setq P1 (cdr (assoc 10 trajectoire)))

(setq P2 (cdr (assoc 11 trajectoire)))

)

(progn (setq entitétrajectoire

(mapcar 'cdr

(vl-remove-if-not '(lambda (x) (= (car x) 10)) trajectoire)

); " mapcar " permet l'application de la fonction " lambda " [ qui elle même définis une fonction sans nom

; ( pour éviter d'encombrer la mémoire ) et lambda retourne la valeur de sa dernière expression " entitétrajectoire "]

; aux éléments successifs de la liste " trajectoire " de " P1 " à " P2 " qu'elle fournies comme arguments à la fonction " lambda ".

)

(progn (progn (setq P1 (car entitétrajectoire))); " car " renvoie le premier élément de la liste " entitétrajectoire ".

(progn (setq P2 (cadr entitétrajectoire))); " cadr " renvoie le deuxième élément de la liste " entitétrajectoire ".

)

)

)

(setq anglepl (angle P1 P2)); définis l'angle entre les points P1 et p2.

(setq PtGauche (polar P1 (+ anglepl (/ pi 2)) largeur_corridor)); détermine le coté gauche de décalage par rapport à la trajectoire par le ptGauche.

(setq PtDroite (polar P1 (- anglepl (/ pi 2)) largeur_corridor)); détermine le coté droit de décalage par rapport à la trajectoire par le ptDroite.

;;; commande appelant la fonction " decaler ".

 

(command "_offset" (/ largeur_corridor 2) P1 PtGauche ""); commande de décalage à gauche de la polyligne par rapport à la polyligne trajectoire.

(command "_.chprop" (entlast) "" "_layer" "LIMITE" "_color" "_blue" ""); définition des paramètres du calque de destination de la polyligne décalée.

 

(command "_offset" (/ largeur_corridor 2) P1 PtDroite ""); commande de décalage à droite de la polyligne par rapport à la polyligne trajectoire.

(command "_.chprop" (entlast) "" "_layer" "LIMITE" "_color" "_blue" ""); définition des paramètres du calque de destination de la polyligne décalée.

 

;;; (princ)

; fin de la fonction de double décalage.

 

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

 

; selection des limites.

 

;;; (setq e (entget (car (entsel)))) ;......................................... obtenir la liste de l'entité

(setq len (length trajectoire)) ;.................................................... longueur de la liste

(setq n 0)

(setq liste nil) ;......................................................... compteur à zero

(repeat len ;.............................................................. repeter pour chaque element de la liste

(setq e1 (car (nth n trajectoire))) ;.............................................. prendre chaque element de la liste et en retirer le code (1 er item)

(if (= e1 10) ;.......................................................... tester le code 10

(progn ;............................................................... si c'est le groupe 10 alors faire

(terpri) ;........................................................... nouvelle ligne

(princ (cdr (nth n trajectoire)))

(setq liste (cons (cdr (nth n trajectoire)) liste))

;........................................................................... ecriture des coordonnées

;(princ (cadr (nth n e)));.................................................. ecrit les valeurs de X

;(princ (caddr (nth n e)));................................................. ecrit les valeurs de Y

;........................................................................... (nth n e) : sort l'element n de la liste e (n=0,1,2,...)

) ;.................................................................... fin de progn

) ;...................................................................... fin de if

(setq n (+ n 1)) ;......................................................... incrementer le compteur

) ;........................................................................ fin repeat

(setq nbsommets (length liste))

(setq long 0)

(repeat (- nbsommets 1)

(setq P1 (car liste))

(setq P2 (cadr liste))

(setq D (distance P1 P2))

(setq long (+ D long))

(setq liste (cdr liste))

)

(prin1 long)

(princ)

 

(command "-calque" "ch" "pk" "")

 

 

(setq point_fin_trajectoire (car (reverse entitétrajectoire)))

;;;(setq point_fin (car liste1))

 

(cond

((= cas 0) (command "mesurer" pause "b" bloc_largeur "o" 1000 ""))

((= cas 1) (command "mesurer" pause "b" bloc_largeur "o" 5000 ""))

)

 

 

(setq

limite1 (entget

(car (entsel "Selectionner la polyligne de la limite du corridor:"))

)

)

(if

(eq (cdr (assoc 0 entitélimite1)) "LINE")

;;; determine si l'objet est ligne ou polyligne

(progn (Setq P3 (cdr (assoc 10 limite1)))

(setq P4 (cdr (assoc 11 limite1)))

)

(progn (setq entitélimite1

(mapcar 'cdr

(vl-remove-if-not '(lambda (x) (= (car x) 10)) limite1)

)

)

(progn (progn (setq P3 (car entitélimite1)))

(progn (setq P4 (cadr entitélimite1)))

)

)

)

 

(setq point_fin_limite1 (car (reverse entitélimite1)))

 

 

(setq

limite2 (entget

(car (entsel "Selectionner la polyligne de l'autre limite du corridor:"))

)

)

(if

(eq (cdr (assoc 0 entitélimite2)) "LINE")

;;; determine si l'objet est ligne ou polyligne

(progn (Setq P5 (cdr (assoc 10 limite2)))

(setq P6 (cdr (assoc 11 limite2)))

)

(progn (setq entitélimite2

(mapcar 'cdr

(vl-remove-if-not '(lambda (x) (= (car x) 10)) limite2)

)

)

(progn (progn (setq P5 (car entitélimite2)))

(progn (setq P6 (cadr entitélimite2)))

)

)

)

 

(setq point_fin_limite2 (car (reverse entitélimite2)))

 

 

(setq angle_debut (angle P2 P3))

(setq angle_fin (angle point_fin_trajectoire point_fin_limite1))

 

 

(command "ligne" P3 P5 "")

(command "ligne" point_fin_limite2 point_fin_limite1 "")

; (nom de la commande / retour à covadis / b pour bloc / position orthogonale / grandeur numérique de la longueur de la boîte.

 

 

(princ)

 

) ;Fin si OUI

 

 

 

 

 

 

 

 

(progn

(command "-calque" "ch" "LIMITE" ""); Choix du calque " LIMITE ".

 

; double décalage à gauche et à droite.

;(attribut du double décalage (ddllpp) (/ Vdist entité1 pt1 pt2 entitépoints anglepl PtGauche PtDroite)

 

; la largeur du corridor = distance de decalage.

(setq

trajectoire (entget

(car (entsel "Selectionner la trajectoire:")); demande de sélectionner l'objet " trajectoire "

; en spécifiant un point.

)

)

(if

(eq (cdr (assoc 0 trajectoire)) "LINE"); " assoc " recherche l'élément " trajectoire " dans la liste d'association " LINE " ou " entitétrajectoire "

; et renvoie l'entrée correspondante.

;;; determine si l'objet est ligne ou polyligne.

(progn (Setq P1 (cdr (assoc 10 trajectoire)))

(setq P2 (cdr (assoc 11 trajectoire)))

)

(progn (setq entitétrajectoire

(mapcar 'cdr

(vl-remove-if-not '(lambda (x) (= (car x) 10)) trajectoire)

); " mapcar " permet l'application de la fonction " lambda " [ qui elle même définis une fonction sans nom

; ( pour éviter d'encombrer la mémoire ) et lambda retourne la valeur de sa dernière expression " entitétrajectoire "]

; aux éléments successifs de la liste " trajectoire " de " P1 " à " P2 " qu'elle fournies comme arguments à la fonction " lambda ".

)

(progn (progn (setq P1 (car entitétrajectoire))); " car " renvoie le premier élément de la liste " entitétrajectoire ".

(progn (setq P2 (cadr entitétrajectoire))); " cadr " renvoie le deuxième élément de la liste " entitétrajectoire ".

)

)

)

(setq anglepl (angle P1 P2)); définis l'angle entre les points P1 et p2.

(setq PtGauche (polar P1 (+ anglepl (/ pi 2)) largeur_corridor)); détermine le coté gauche de décalage par rapport à la trajectoire par le ptGauche.

(setq PtDroite (polar P1 (- anglepl (/ pi 2)) largeur_corridor)); détermine le coté droit de décalage par rapport à la trajectoire par le ptDroite.

;;; commande appelant la fonction " decaler ".

 

(command "_offset" (/ largeur_corridor 2) P1 PtGauche ""); commande de décalage à gauche de la polyligne par rapport à la polyligne trajectoire.

(command "_.chprop" (entlast) "" "_layer" "LIMITE" "_color" "_blue" ""); définition des paramètres du calque de destination de la polyligne décalée.

 

(command "_offset" (/ largeur_corridor 2) P1 PtDroite ""); commande de décalage à droite de la polyligne par rapport à la polyligne trajectoire.

(command "_.chprop" (entlast) "" "_layer" "LIMITE" "_color" "_blue" ""); définition des paramètres du calque de destination de la polyligne décalée.

 

(princ)

; fin de la fonction de double décalage.

 

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

 

; selection des limites.

 

;;; (setq e (entget (car (entsel)))) ;......................................... obtenir la liste de l'entité

(setq len (length trajectoire)) ;.................................................... longueur de la liste

(setq n 0)

(setq liste nil) ;......................................................... compteur à zero

(repeat len ;.............................................................. repeter pour chaque element de la liste

(setq e1 (car (nth n trajectoire))) ;.............................................. prendre chaque element de la liste et en retirer le code (1 er item)

(if (= e1 10) ;.......................................................... tester le code 10

(progn ;............................................................... si c'est le groupe 10 alors faire

(terpri) ;........................................................... nouvelle ligne

(princ (cdr (nth n trajectoire)))

(setq liste (cons (cdr (nth n trajectoire)) liste))

;........................................................................... ecriture des coordonnées

;(princ (cadr (nth n e)));.................................................. ecrit les valeurs de X

;(princ (caddr (nth n e)));................................................. ecrit les valeurs de Y

;........................................................................... (nth n e) : sort l'element n de la liste e (n=0,1,2,...)

) ;.................................................................... fin de progn

) ;...................................................................... fin de if

(setq n (+ n 1)) ;......................................................... incrementer le compteur

) ;........................................................................ fin repeat

(setq nbsommets (length liste))

(setq long 0)

(repeat (- nbsommets 1)

(setq P1 (car liste))

(setq P2 (cadr liste))

(setq D (distance P1 P2))

(setq long (+ D long))

(setq liste (cdr liste))

)

(prin1 long)

(princ)

 

(command "-calque" "ch" "pk" "")

 

 

(setq point_fin_trajectoire (car (reverse entitétrajectoire)))

;;;(setq point_fin (car liste1))

 

(cond

((= cas 0) (command "mesurer" pause "b" bloc_largeur "o" 1000 ""))

((= cas 1) (command "mesurer" pause "b" bloc_largeur "o" 5000 ""))

)

 

 

 

 

(setq

limite1 (entget

(car (entsel "Selectionner la limite du corridor:"))

)

)

(if

(eq (cdr (assoc 0 entitélimite1)) "LINE")

;;; determine si l'objet est ligne ou polyligne

(progn (Setq P3 (cdr (assoc 10 limite1)))

(setq P4 (cdr (assoc 11 limite1)))

)

(progn (setq entitélimite1

(mapcar 'cdr

(vl-remove-if-not '(lambda (x) (= (car x) 10)) limite1)

)

)

(progn (progn (setq P3 (car entitélimite1)))

(progn (setq P4 (cadr entitélimite1)))

)

)

)

 

(setq point_fin_limite1 (car (reverse entitélimite1)))

 

 

(setq

limite2 (entget

(car (entsel "Selectionner l'autre limite du corridor:"))

)

)

(if

(eq (cdr (assoc 0 entitélimite2)) "LINE")

;;; determine si l'objet est ligne ou polyligne

(progn (Setq P5 (cdr (assoc 10 limite2)))

(setq P6 (cdr (assoc 11 limite2)))

)

(progn (setq entitélimite2

(mapcar 'cdr

(vl-remove-if-not '(lambda (x) (= (car x) 10)) limite2)

)

)

(progn (progn (setq P5 (car entitélimite2)))

(progn (setq P6 (cadr entitélimite2)))

)

)

)

 

(setq point_fin_limite2 (car (reverse entitélimite2)))

 

 

(setq angle_debut (angle P2 P3))

(setq angle_fin (angle point_fin_trajectoire point_fin_limite1))

 

;;;(command "-inserer" bloc_largeur P2 1 1 angle_debut "")

;;;(command "-inserer" bloc_largeur point_fin_trajectoire 1 1 angle_fin "")

 

(command "ligne" P3 P5 "")

(command "ligne" point_fin_limite2 point_fin_limite1 "")

; (nom de la commande / retour à covadis / b pour bloc / position orthogonale / grandeur numérique de la longueur de la boîte.

 

(princ)

 

) ;Fin si NON

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

 

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;

; Routine pour Sélectionner et Exploser tous les blocs.

;

; Permet d'exploser tous les blocs d'un dessin (même imbriqués) dans tout le dessin.

 

; (defun c:XB (/ layouts jeu n j i cmd)

(progn

 

(setq cmd (getvar "cmdecho"))

(setvar "cmdecho" 0)

 

(command "_.undo" "_group")

(setq expl (getvar "explmode"))

(setvar "explmode" 1)

(setq ESP (getvar "CTAB"))

 

 

(if (vl-position "Model" layouts)

(setq layouts (cons "Model" (layoutlist)))

)

(setq i 0)

(foreach n layouts

(while

(setq jeu (ssget "x" (list (cons 0 "INSERT") (cons 410 n))))

(setq j 0)

(command "_.layout" "_set" n)

(while (ssname jeu j)

(setq NB (sslength JEU))

(sssetfirst nil JEU)

(setq j (+ NB j))

)

(setq i (+ i j))

 

)

 

)

(setvar "CTAB" ESP)

(setvar "explmode" expl)

 

(command "_.undo" "_end")

(setvar "cmdecho" cmd)

(prompt "\n ")

(print i)

(if (<= i 1)

(prompt " bloc décomposé")

(prompt " blocs décomposés")

)

(prin1)

 

) ;fin de la routine de sélection et décomposition des blocs.

(prompt "\nXB : tous les blocs ont été Exploser")

 

(princ)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; fin temporaire du programme ;;;;;;;;;;;;;;;;;

 

PS : j'y pense, comment puis je faire en sorte de numéroter ses boîtes sachant que j'ai une fonction d'inversion de sens de la polyligne trajectoire.

 

je ne sais pas écrire la routine qui me permettrais de numéroter automatiquement mes boîtes.

 

encore merci pour tous les conseil que l'on trouve sur ce forum.

 

 

 

 

Lien vers le commentaire
Partager sur d’autres sites

salut

 

le but du programme c'est quoi ???

 

 

tu veux vérifier si un camion, voiture, symbolisé par un rectangle passe bien sur une route que tu auras de délimiter par deux polylignes ???

 

si un brancard passe bien dans un couloir et par la porte de l'escalier ??

 

 

tout ca en faisant dessiner automatiquement ( la voiture, le brancard ) a differentes etapes ???

 

 

Autodesk Architecture 2023 sous windows 11 64

24 pouces vertical + 30 pouces horizontal + 27 pouces horizontal

Lien vers le commentaire
Partager sur d’autres sites

e but du programme c'est quoi ???

tu veux vérifier si un camion, voiture, symbolisé par un rectangle passe bien sur une route que tu auras de délimiter par deux polylignes ???

si un brancard passe bien dans un couloir et par la porte de l'escalier ??

 

Presque on dirait ...

Création des boîtes le long de la Trajectoire de vol de l'hélicoptère.

 

Et pour traduire Patrick_35 (je pense) :

Je ne comprends pas ta demande...

Tu n'aurais pas un exemple ? (image ...)

Si vous êtes persuadés de tout savoir sur un sujet, c''est que vous en ignorez quelque chose...

Lien vers le commentaire
Partager sur d’autres sites

rebonjour,

 

Pour vous répondre voici quelques explications.

 

je dois construire des boîtes qui se suivent et qui soient indépandente les une des autres,

afin de pouvoir selectionner ses boîtes ( contours ) pour y charger un semis de points topographiques. Ce semis de points topo est volumineux se qui nous oblige à fragmenter ce semis de points en plusieurs tronçons que nous appelons boites.

ces boîtes sont composées des deux lignes ( blocs décomposés ) aux extrémités de notre boite et des deux morceaux de limites du corridor

 

pour le dessin j'aimerais bien mais je ne sais pas comment on fait sur ce forum pour insérer ou copier ou mettre en pièce jointe un dessin.

 

à + et merci de m'avoir répondu.

 

 

Lien vers le commentaire
Partager sur d’autres sites

je crois que j'ai à peu près compris ce que tu veux

si j'ai bien compris, à partir d'une trajectoire (en rouge), tu définis un coridor (en jaune) par sa largeur et tu veux découper çà en zones que tu appelles des boites et qui doivent être des polylignes fermées (et numérotées)

http://xs116.xs.to/xs116/07263/Image4.jpg

si c'est çà, je dois avoir les outils qui vont bien

 

Lien vers le commentaire
Partager sur d’autres sites

Bonjour à tous,

 

 

Quelle n'a pas été ma surprise en consultant mes emails

de voir autant de sollicitude pour mon programme.

 

avant toute chose je tient a remercier tout particulièrement

et pour ne citer qu'eux "patrick_35", "PHILPHIL", "Bred",

et "Didier-AD", "et les autres ........" pour leur intérêt et leur aide.

 

Effectivement au vue du dessin que tu m'a envoyé il correspond tout à fait

semble t il à mes besoins.

 

je dois pouvoir générer automatiquement des contours fermés et indépendant les uns des autres.

 

 

à + doy.

 

PS : je suis impatient de voir la suite.

 

Lien vers le commentaire
Partager sur d’autres sites

Salut,

 

Je t'avais proposé de regarder du côté des fonction vlax-curve.

 

Voilà un exemple de ce qu'on peut faire en utilisant ces fonctions.

 

EDIT : conservation des largeurs de polylignes dans CutPlineAtPoint (ce qui n'apporte rien dans le cas présent).

 

EDIT 2 : ajout d'une gestion des erreur dans corridor et correction de dysfonctionnements dans cutPlineAtPoint

 

(defun c:corridor (/	 erreur	     acDoc Space ent   pl0   long
	   larg	 pl1   pl2   nb	   l0	 cut1  cut2  n
	   pt	 pt0   pt1   pt2   l1
	  )

 (vl-load-com)

 (defun erreur (msg)
   (if	(= msg "Fonction annulée")
     (princ)
     (princ (strcat "\nErreur: " msg))
   )
   (vla-endundomark
     (vla-get-activedocument (vlax-get-acad-object))
   )
   (setq *error* m:err
  m:err	nil
   )
   (princ)
 )

 (setq	AcDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
Space	(if (= (getvar "CVPORT") 1)
	  (vla-get-PaperSpace AcDoc)
	  (vla-get-ModelSpace AcDoc)
	)
m:err	*error*
*error*	erreur
 )
 (if (and
(setq ent (car (entsel "\nSélectionner une polyligne: ")))
(setq long (getdist "\nLongueur des boites : "))
(setq larg (getdist "\nlargeur des boites: "))
     )
   (progn
     (vla-StartUndoMark AcDoc)
     (setq pl0	(vlax-ename->vla-object ent)
    pl1	(car (vlax-invoke pl0 'Offset (/ larg 2.0)))
    pl2	(car (vlax-invoke pl0 'Offset (/ larg -2.0)))
    nb
	(fix
	  (/ (vlax-curve-getDistAtParam pl0 (vlax-curve-getEndParam pl0))
	     long
	  )
	)
    l0	(vla-addLine
	  Space
	  (vlax-3d-point (vlax-curve-getStartPoint pl1))
	  (vlax-3d-point (vlax-curve-getStartPoint pl2))
	)
    n	1
     )
     (repeat nb
(setq pt0  (vlax-curve-getPointAtDist pl0 (* n long))
      pt1  (vlax-curve-getClosestPointTo pl1 pt0)
      pt2  (vlax-curve-getClosestPointTo pl2 pt0)
      l1   (vla-addLine
	     Space
	     (vlax-3d-Point pt1)
	     (vlax-3d-Point pt2)
	   )
      cut1 (CutPlineAtPoint pl1 pt1)
      cut2 (CutPlineAtPoint pl2 pt2)
)
(vlax-invoke
  space
  'addRegion
  (list (car cut1) (car cut2) l0 l1)
)
(mapcar 'vla-Delete (list l0 (car cut1) (car cut2)))
(setq n	  (1+ n)
      l0  l1
      pl1 (cadr cut1)
      pl2 (cadr cut2)
)
     )
     (setq l1
     (vla-addLine
       Space
       (vlax-3d-point (vlax-curve-getEndPoint pl1))
       (vlax-3d-point (vlax-curve-getEndPoint pl2))
     )
     )
     (vlax-invoke space 'addRegion (list pl1 pl2 l0 l1))
     (mapcar 'vla-Delete (list pl1 pl2 l0 l1))
     (vla-EndUndoMark AcDoc)
   )
 )
 (setq	*error*	m:err
m:err nil
 )
 (princ)
)

;;; Sous routines (qui pouraient servir dans d'autre LISP)

;;; Angle2Bulge
;;; Retourne le bulge correspondant à un angle
(defun Angle2Bulge (a)
 (/ (sin (/ a 4.0)) (cos (/ a 4.0)))
)

;;; ArcCenterBy3Points
;;; Retourne le centre de l'arc décrit par 3 points
(defun ArcCenterBy3Points (p1 p2 p3)
 ((lambda (mid1 mid2)
    (inters mid1
     (polar mid1 (+ (angle p1 p2) (/ pi 2)) 1.0)
     mid2
     (polar mid2 (+ (angle p2 p3) (/ pi 2)) 1.0)
     nil
    )
  )
   (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p1 p2)
   (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p2 p3)
 )
)

;;; SUBLST Retourne une sous-liste
;;; Premier élément : 1
;;; (sublst '(1 2 3 4 5 6) 3 2) -> (3 4)
;;; (sublst '(1 2 3 4 5 6) 3 -1) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 12) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 nil) -> (3 4 5 6)

(defun sublst (lst start leng / rslt)
 (or (    (setq leng (- (length lst) (1- start)))
 )
 (repeat leng
   (setq rslt	(cons (nth (1- start) lst) rslt)
  start	(1+ start)
   )
 )
 (reverse rslt)
)

;;; CutPlineAtPoint
;;; Coupe la polyligne au point spécifié et retourne la liste des deux objets générés
;;; (ename ou vla-object selon le type de l'argument pl)
;;; 
;;; Arguments
;;; pl : la polyligne à couper (ename ou vla-object)
;;; pt ; le point de coupure sur la polyligne (coordonnées SCG)

(defun CutPlineAtPoint
	       (pl  pt	/   en	no  pa	p0  p1	pn  cl	l0  l1
		l2  ce	b0  b1	b2  bp	a1  a2	n   wp	w0  w1
		w2
	       )
 (vl-load-com)
 (or (= (type pl) 'VLA-OBJECT)
     (setq pl (vlax-ename->vla-object pl)
    en T
     )
 )
 (setq	no (vlax-get pl 'Normal)
pa (fix (vlax-curve-getParamAtPoint pl pt))
p0 (vlax-curve-getPointAtparam pl pa)
p1 (vlax-curve-getPointAtParam pl (1+ pa))
pn (reverse (cdr (reverse (trans pt 0 no))))
cl (vla-Copy pl)
l0 (vlax-get pl 'Coordinates)
l1 (append (sublst l0 1 (* 2 (1+ pa))) pn)
l2 (append pn (sublst l0 (1+ (* 2 (1+ pa))) nil))
ce (if (not (equal pt p0 1e-9))
     (ArcCenterBy3Points (trans p0 0 no) pn (trans p1 0 no))
   )
 )
 (repeat (setq n (fix (1+ (vlax-curve-getendParam pl))))
   (setq b0 (cons (vla-getBulge pl (setq n (1- n))) b0))
   (vla-GetWidth pl n 'StartWidth 'EndWidth)
   (setq w0 (cons (list StartWidth EndWidth) w0))
 )
 (setq bp (nth pa b0))
 (if ce
   (progn
     (setq a1 (- (angle ce pn) (angle ce (trans p0 0 no)))
    a2 (- (angle ce (trans p1 0 no)) (angle ce pn))
     )
     (if (minusp bp)
(foreach a '(a1 a2)
  (if (	    (set a (- (eval a) (* 2 pi)))
  )
)
(foreach a '(a1 a2)
  (if (	    (set a (+ (eval a) (* 2 pi)))
  )
)
     )
   )
 )
 (setq	b1 (append
     (if (zerop pa)
       nil
       (sublst b0 1 pa)
     )
     (if ce
       (list (Angle2Bulge a1))
       (list bp)
     )
   )
b2 (append
     (if ce
       (list (Angle2Bulge a2))
       (list bp)
     )
     (sublst b0 (+ 2 pa) nil)
   )
wp (if (equal pt p0 1e-9)
     (car (nth pa w0))
     (+	(car (nth pa w0))
	(* (- (cadr (nth pa w0)) (car (nth pa w0)))
	   (/ (- (vlax-curve-getDistAtPoint pl pt)
		 (vlax-curve-getDistAtParam pl pa)
	      )
	      (- (vlax-curve-getDistAtParam pl (1+ pa))
		 (vlax-curve-getDistAtParam pl pa)
	      )
	   )
	)
     )
   )
w1 (append (if (zerop pa)
	     nil
	     (sublst w0 1 pa)
	   )
	   (list (list (car (nth pa w0)) wp))
   )
w2 (append (list (list wp (cadr (nth pa w0))))
	   (sublst w0 (+ 2 pa) nil)
   )
 )
 (vlax-put pl 'Coordinates l1)
 (repeat (setq n (length b1))
   (vla-SetBulge pl (setq n (1- n)) (nth n b1))
 )
 (vlax-put cl 'Coordinates l2)
 (repeat (setq n (length b2))
   (vla-SetBulge cl (setq n (1- n)) (nth n b2))
 )
 (repeat (setq n (length w1))
   (vla-SetWidth
     pl
     (setq n (1- n))
     (car (nth n w1))
     (cadr (nth n w1))
   )
 )
 (repeat (setq n (length w2))
   (vla-SetWidth
     cl
     (setq n (1- n))
     (car (nth n w2))
     (cadr (nth n w2))
   )
 )
 (if en
   (list (vlax-vla-object->ename pl)
  (vlax-vla-object->ename pl)
   )
   (list pl cl)
 )
)

[Edité le 27/6/2007 par (gile)]

 

[Edité le 28/6/2007 par (gile)]

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

Lien vers le commentaire
Partager sur d’autres sites

Je pense que çà devrait te convenir

les boites sont tracées, ce sont des polylignes fermées

par contre, je te laisse gérer les couleurs et les calques.

 

je n'ai pas choisi de créer des blocs et des lignes comme giles mais plutôt de générer directement les boites ; pour çà j'ai ressorti des vieux outils que j'ai remis au gout du jour vlax...

 

notamment pour ceux que çà interesse comment isoler "en mémoire" un morceau de polyligne entre deux points en gérant ce que j'appelle des listes de points courbure (voir la fonction l_out_morcopt)

 

;----------------------------------------------------------------------------
;; diverses fonctions sur les listes
;----------------------------------------------------------------------------
;               retourne le car du dernier élément
(defun l_out_carl (l) (car (last l)))


;               retourne une liste sauf le dernier
(defun l_out_rdc (l) (reverse (cdr (reverse l))))


;               retourne l'avant dernier d'une liste
(defun l_out_rdac (l)  (cadr (reverse l)))

;               fonction tangente
(defun L_out_tang (alpha)
  (if (= (abs alpha) (/ pi 2))
      10000.0
      (/ (sin alpha) (cos alpha))
  )
)
;----------------------------------------------------------------------------

;;---Début---------------------------------------------------l_out_defaut------------
;; << retourne le second élément si le premier est nil>>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 1 octobre 1997  à 08:27
;;
;; Admet : 
;; =======
;;   
;;   prem          : varaiant
;;   defaut
;;
;; Retourne : liste 
;; ==========
;-------------------------------------------------------------------------------
(defun l_out_defaut (prem defaut)
 (if prem prem defaut)
)  
;;---Fin---------------------------------------------------l_out_defaut------------

;;---Début---------------------------------------------------l_out_xy------------
;; << retourne les deux premiers émémnts d'une liste>>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 1 octobre 1997  à 08:27
;;
;; Admet : 
;; =======
;;   
;;   lst          : liste 
;;
;; Retourne : liste 
;; ==========
;-------------------------------------------------------------------------------
(defun l_out_xy (lst)
 (list (car lst) (cadr lst))
)  
;;---Fin---------------------------------------------------l_out_xy------------

;;---Début---------------------------------------------------l_out_snoc------------
;; << inverse de cons     >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 1 octobre 1997  à 08:27
;;
;; Admet : 
;; =======
;;   dern         : variant
;;   lst          : liste 
;;
;; Retourne : liste avec dern comme dernier élément
;; ==========
;-------------------------------------------------------------------------------
(defun l_out_snoc (dern lst)
 (append lst (list dern))
)  
;;---Fin---------------------------------------------------l_out_snoc------------

;;---Début---------------------------------------------------l_out_ext------------
;; << extrait une information d'un handle, une entité ou une liste (entget)    >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 1 octobre 1997  à 08:27
;;
;; Admet : 
;; =======
;;   e          : Nom d'entité = entuité considérée
;;
;; Retourne : Booléen = T si OK
;; ==========
;-------------------------------------------------------------------------------
(defun L_out_ext (cle ent / xx)
 (if (= 'STR (type ent)) (setq ent (handent ent))) 
 (setq xx (if (= 'ENAME (type ent))
           (cdr (assoc cle (entget ent)))
           (cdr (assoc cle ent))
          )
 )
 xx
);
;;---fin---------------------------------------------------l_out_ext------------

;;---Début---------------------------------------------------l_out_estpol------------
;; << vérifie qu'une entité est du type polyligne ou LWplyligne                >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 1 octobre 1997  à 08:27
;;
;; Admet : 
;; =======
;;   e          : Nom d'entité = entuité considérée
;;
;; Retourne : Booléen = T si OK
;; ==========
;-------------------------------------------------------------------------------
(Defun l_out_estpol ( e / )
 (member (cdr (assoc 0 (entget e))) (list "POLYLINE" "LWPOLYLINE"))
)
;;---fin-----------------------------------------------------l_out_estpol------------ 

;;---Début---------------------------------------------------l_out_analpol------------
;; << etablit une liste de points courbure à partir d'une polyligne                >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 1 octobre 1997  à 08:27
;;
;; Admet : 
;; =======
;;   e          : Nom d'entité = entuité considérée
;;
;; Retourne : Booléen = T si OK
;; ==========
;-------------------------------------------------------------------------------
(defun l_out_analpol (pol / e ent ll alti ptcrb)

 (setq ll '() e pol)
 (cond
  ((= "POLYLINE" (l_out_ext 0 pol))
   (while (/= "SEQEND" (l_out_ext 0 (setq ent (entget (setq e (entnext e))))))
     (setq ll (cons (list (trans (l_out_ext 10 ent) pol 1) (l_out_ext 42 ent)) ll))
   )
  )
  ((= "LWPOLYLINE" (l_out_ext 0 pol))
   (setq ent (entget pol) ptcrb nil alti 0.0)
   (while ent
     (if (= 38 (caar ent)) (setq alti (cdar ent)) )
     (if (= 10 (caar ent)) (setq ptcrb (l_out_defaut
				  (trans (l_out_snoc alti (l_out_xy (cdar ent))) pol 1)
				  (trans (l_out_snoc alti (l_out_xy (cdar ent))) 0 1)
				)
		    )
     )
     (if (= 42 (caar ent)) (setq ll (cons (list ptcrb (cdar ent)) ll)))
     (setq ent (cdr ent))
   )
  )
 )
 (if (and $ferferme (= 1 (logand (l_out_ext 70 pol) 1)))
     (l_out_snoc (last ll) (reverse ll))
     (setq ll (reverse ll)
    ll (l_out_snoc (list (l_out_carl ll) 0.0) (l_out_rdc ll))
     ) 	    
 )  
);...........
;;---Fin---------------------------------------------------l_out_analpol------------

;;---Début---------------------------------------------------l_out_transpol--------
;; << inverse une liste point courbure                                             >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 27 juin 2007  à 21:28
;;
;; Admet : 
;; =======
;;   pol         : liste point courbure
;;
;; Retourne : liste point courbure inversée
;; ==========
;-------------------------------------------------------------------------------
(defun l_out_transpol (pol / l)
 (setq l (mapcar (function (lambda (x1 x2)
                             (list (car x1) (* (cadr x2) -1))
                           )
                 )
                 (reverse pol)
                 (l_out_snoc (last pol) (cdr (reverse pol)))
         )
 )
 l
)
;;---fin---------------------------------------------------l_out_transpol--------

;;---Début---------------------------------------------------l_out_centre--------
;; << centre d'un arc de polyligne                                             >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 27 juin 2007  à 21:28
;;
;; Admet : 
;; =======
;;   p1         : Point    = premier point
;;   p2         : Point    = second point
;;   alpha      : Réel     = courbure associée au premier point
;;
;; Retourne : Point = centre de l'arc
;; ==========
;-------------------------------------------------------------------------------
(Defun l_out_centre ( p1 p2 alpha / signe ang pt ang1 ang2)
 (setq pt (if (equal 1.0 (abs alpha) 0.00001)
              (l_milieu p1 p2)
              (progn
                (setq signe (/ alpha (abs alpha))
                      ang1  (+ (angle p1 p2) (* signe 0.5 (- pi (abs(* 4 (atan alpha))))))
                      ang2  (- (angle p2 p1) (* signe 0.5 (- pi (abs(* 4 (atan alpha))))))
                )
                (inters p1 (polar p1 ang1 10) p2 (polar p2 ang2 10) nil)
              )
          )
 )
 pt
)
;;---fin-----------------------------------------------------l_out_centre--------

;;---Début---------------------------------------------------l_out_rayon---------
;; << trouve le rayon d'un arc de polyligne                                    >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 19 novembre 1997  à 17:06
;;
;; Admet : 
;; =======
;;   p1         : Point    = premier point
;;   p2         : Point    = point suivant
;;   courb      : Réel     = courbure
;;
;; Retourne : Réel = rayon
;; ==========
;-------------------------------------------------------------------------------
(Defun l_out_rayon ( p1 p2 courb / d alpha)
 (setq d (/ (distance p1 p2) 2.0)
alpha (* (atan (abs courb)) 2.0)
 )
 (/ d (if (zerop (sin alpha)) 1.0 (sin alpha)))
);...........
;;---fin-----------------------------------------------------l_out_rayon---------

;;---Début---------------------------------------------------l_out_longsegpol----
;; << calcule la longueur d'un segment de polyligne                            >>
;; << droit ou courbe                                                          >>
;;
;;  créée le :  mercredi 27 juin 2007  à 21:24
;;
;; Admet : 
;; =======
;;   ptc1       : Point courbure = premier point courbure
;;   ptc2       : Point courbure = point suivant
;;
;; Retourne : Réel = longueur
;; ==========
;-------------------------------------------------------------------------------
(Defun l_out_longsegpol ( ptc1 ptc2 / long centre0 rayon)

  (if (equal (cadr ptc1) 0.0 0.0000001)
      (setq long (distance (car ptc1) (car ptc2)))
      (setq centre0 (l_out_centre (car ptc1) (car ptc2) (cadr ptc1))
            rayon (distance (car ptc1) centre0)
            long (abs (* 4 rayon (atan (cadr ptc1))))
      )
  )
      long
)
;;---fin-----------------------------------------------------l_out_longsegpol----

;;---Début---------------------------------------------------l_out_longpol-------
;; << longueur d'une liste point courbure                                      >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 27 juin 2007  à 21:40
;;
;; Admet : 
;; =======
;;   pol        : Liste points courbure = ou entité polyligne
;;
;; Retourne : Réel = longueur
;; ==========
;-------------------------------------------------------------------------------
(Defun l_out_longpol ( pol / n longcour )
 (if (= 'ENAME (type pol))
     (setq pol (l_out_analpol pol))
 )
 (setq n 0 longcour 0)
 (repeat (- (length pol) 1)
    (setq longcour (+ longcour (l_out_longsegpol (nth n pol) (nth (+ 1 n) pol))))
    (setq n (+ 1 n))
 )
 longcour
)
;;---fin-----------------------------------------------------l_out_longpol-------

;;---Début---------------------------------------------------l_out_pointsurseg---
;; << positionne un point sur un segment à une distance donnée du premier point >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 27 juin 2007  à 21:34
;;
;; Admet : 
;; =======
;;   lon        : Réel     = longueur à partir du premir point
;;   ptc1       : Point courbure = premier point et sa courbure
;;   ptc2       : Point courbure = second point et sa courbure
;;
;; Retourne : Liste = (point  angle_orthogonal_au_segment)
;; ==========
;-------------------------------------------------------------------------------
(Defun l_out_pointsurseg ( lon ptc1 ptc2 / ang angr ang0 pt centre rayon signe)
  (if (zerop (cadr ptc1))
      (setq ang (angle (car ptc1) (car ptc2))
            pt (polar (car ptc1) ang lon)
            angr (+ ang (/ pi 2))
      )
      (setq centre (l_out_centre (car ptc1) (car ptc2) (cadr ptc1))
            rayon (distance (car ptc1) centre)
            ang0 (angle centre (car ptc1))
            signe (/ (cadr ptc1) (abs (cadr ptc1)))
            ang (* signe (/ lon rayon))
            pt (polar centre (+ ang0 ang) rayon)
            angr (+ ang0 ang)
            angr (if (minusp signe) angr (+ angr pi))
      )
 )
 (list pt (rem angr (* 2 pi)))
)
;;---fin-----------------------------------------------------l_out_pointsurseg---

;;---Début---------------------------------------------------l_out_morcopt-------
;; << donne une sous liste de points courbure                                  >>
;; << entre deux points quelconque situés sur la polyligne associée            >>
;;
;;  créée le :  lundi 22 décembre 2003  à 19:06
;;
;; Admet : 
;; =======
;;   pol        : objet polyligne
;;   ptdeb      : Point    = debut
;;   ptfin      : Point    = fin
;;
;; Retourne : Liste points courbure 
;; ==========
;-------------------------------------------------------------------------------
(Defun l_out_morcopt ( pol ptdeb ptfin / lg1 lg2 lpc)
 (setq lg1 (if ptdeb (vlax-curve-getDistAtPoint pol  ptdeb))
lg2 (if ptfin (vlax-curve-getDistAtPoint pol  ptfin))
lpc (l_out_analpol (vlax-vla-object->ename pol))
 )
 (l_out_morco lpc (l_out_defaut  lg1 0) (l_out_defaut lg2 (l_out_longpol lpc)))
)
;;---fin-----------------------------------------------------l_out_morcopt-------

;;---Début---------------------------------------------------l_Out_Ptc&Dc--------
;; << constitue une liste pointcourbure_distance cumulée                       >>
;; <<                                                                          >>
;;
;;  créée le :  jeudi 14 novembre 1996  à 18:37
;;
;; Admet : POL : nom d'entité ou liste point courbure
;; =======
;;
;; Retourne : Liste = ((pt courb dc) (....)....)
;; ==========
;-------------------------------------------------------------------------------
(Defun l_Out_Ptc&Dc (Pol / poldc n  long longtot )
 (if (= 'ENAME (type pol))
     (setq pol (l_out_analpol pol))
 )
 (setq poldc (list (append (car pol) (list 0.0)))  longtot 0.0 n 1)
 (repeat (- (length pol) 1)
    (setq long (l_out_longsegpol (nth (- n 1) pol) (nth n pol))
          longtot (+ longtot long)
          poldc (l_out_snoc (append  (nth n pol) (list longtot)) poldc)
          n (+ 1 n)
    )
 )
 poldc
);...........
;;---fin-----------------------------------------------------l_Out_Ptc&Dc--------

;;---Début---------------------------------------------------l_Out_Insere--------
;; << insere un point courbure distance_cumulée                                >>
;; << dans une liste point courbure distance cumulée                           >>
;;
;;  créée le :  jeudi 14 novembre 1996  à 21:35
;;
;; Admet : 
;; =======
;;   pol        : Liste    = liste point courbure distance cumuée
;;   dist       : Réel     = distance cumulée
;;
;; Retourne : Liste = liste point courbure distance cumulée
;; ==========
;-------------------------------------------------------------------------------
(Defun l_Out_Insere ( pol dist / OK n lp1 n1)
 (setq Ok nil n 0 lp1 nil)
 (while (<= n (- (length pol) 1))
    (if (and (not OK) (> (caddr (nth (1+ n) pol)) dist))
        (setq OK t
       n1 n
              lp1 (append lp1 (l_Out_Unbout (nth n pol) (nth (1+ n) pol) dist))
        ) 
        (setq lp1 (l_out_snoc (nth n pol) lp1))
    )  
    (setq n (1+ n))
 )
 (if (/= n1 (- (length pol) 1)) lp1 (ad_snoc (last pol) lp1)  )
);...........
;;---fin-----------------------------------------------------l_Out_Insere--------

;;---Début---------------------------------------------------l_Out_Unbout--------
;; << insere un point courbure distance entre deux autres                      >>
;; <<                                                                          >>
;;
;;  créée le :  jeudi 14 novembre 1996  à 21:45
;;
;; Admet : 
;; =======
;;   pcd1       : Liste    = premier point courbure distance 
;;   pcd2       : Liste    = second point courbure distance
;;   dist       : Réel     = distance cumulée où placer le point
;;
;; Retourne : Liste = ((pt1 c1 d1) (ptnouv cnouv dist)) c1 est modifié
;; ==========
;-------------------------------------------------------------------------------
(Defun l_Out_Unbout ( pcd1 pcd2 dist / ang ang1 ang2 pt bidon )
 (if (zerop (cadr pcd1))
     (list pcd1 
           (list (polar (car pcd1) 
                        (angle (car pcd1) (car pcd2)) 
                        (- dist (caddr pcd1))
                 )
                 0.0
                 dist
           )
     ) 
     (setq ang  (* 4 (atan (cadr pcd1))) ;; on travaille en rapport d'angle donc pas besoin de * 4
           ang1 (* ang (/ (- dist (caddr pcd1)) (- (caddr pcd2) (caddr pcd1))))
           ang2 (- ang ang1)
           pt (l_out_pointsurseg (- dist (caddr pcd1)) (l_out_xy pcd1) (l_out_xy pcd2))
    
           bidon (list (list (car pcd1)(l_out_tang (/ ang1 4.0)) (caddr pcd1))
                       (list (car pt) (l_out_tang (/ ang2 4.0)) dist)
                 )
     )
 )
);...........
;;---fin-----------------------------------------------------l_Out_Unbout--------

;;---Début---------------------------------------------------l_Out_Allonge-------
;; << allonge à son extrémité une liste point courbure                         >>
;; <<                                                                          >>
;;
;;  créée le :  vendredi 24 octobre 1997  à 15:56
;;
;; Admet : 
;; =======
;;   pol        : Liste    = points courbure
;;   delta      : Réel     = longueur
;;
;; Retourne : Liste = points courbure modifiée
;; ==========
;-------------------------------------------------------------------------------
(Defun l_Out_Allonge ( pol delta / ptc ang dist centre ray ang1 alpha pt)
 (setq ptc (last (l_out_rdc pol)))
 (if (zerop (cadr ptc))
    (progn
      (setq ang (angle (car ptc) (car (last pol)))
     dist (+ (distance (car ptc) (car (last pol))) delta)
      )
      (append (l_out_rdc pol) (list (list (polar (car ptc) ang dist) 0.0)))
    )
    (progn
      (setq centre (l_out_centre (car ptc) (car (last pol)) (cadr ptc))
     ray (distance centre (car ptc))
     ang (* 4 (atan (cadr ptc)))
     dist (+ delta (* ray (abs ang)))
     ang1 (* (/ dist ray  ang) (abs ang))
     alpha (l_out_tang (/ ang1 4))
     pt (polar centre (+ (angle centre (car ptc)) ang1) ray)
      )
      (append (l_out_rdc (l_out_rdc pol))
       (list (list (car ptc) alpha))
       (list (list pt 0.0))
      )
    )  
 )  
);...........
;;---fin-----------------------------------------------------l_Out_Allonge-------

;;---Début---------------------------------------------------l_Out_Morco---------
;; << donne une sous liste de point courbure                                   >>
;; << entre une distance cumulée et une autre                                  >>
;; << ces distances peuvent être en dehors de la plage--->> allngée dans ce cas>>
;;
;;  créée le :  jeudi 14 novembre 1996  à 18:43
;;
;; Admet : 
;; =======
;;   pol        : Nom d'entité = entité ou liste point courbure distance cumulée
;;   debut      : Réel     = abscisse curviligne de début
;;   fin        : Réel     = abscisse curviligne de fin
;;
;; Retourne : Liste = liste point courbure 
;; ==========
;-------------------------------------------------------------------------------
(Defun l_Out_Morco ( pol debut fin / pol1 tmp long )
 (mapcar 'set (list 'debut 'fin) (vl-sort (list debut fin) '<))
 (if (> fin (setq long (l_out_longpol pol)))
     (setq pol (l_out_allonge pol (- fin long)))
 )
 (if (< debut 0.0)
     (setq pol (l_out_transpol (l_out_allonge (l_out_transpol pol) (abs debut)))
    fin (- fin debut)
    debut 0.0
     )
 )
 (setq tmp (l_out_longpol pol))
 (setq pol (l_Out_Ptc&Dc pol))
 (setq pol (l_Out_Insere Pol debut)
       pol (l_Out_Insere Pol fin)
       pol1 nil
 )
 (foreach elm pol
   (if (and (>= (caddr elm) (- debut 0.001))
            (<= (caddr elm) (+ fin 0.001))
       )
       (setq pol1 (cons (l_out_xy elm) pol1))
   ) 
 )
 (setq pol1 (reverse pol1))
 (while (equal (l_out_xy (caar pol1)) (l_out_xy (caadr pol1)) (/ 0.001))
     (setq pol1 (cdr pol1))
 )  
 (setq pol1 (l_out_transpol pol1))
 (while (equal (l_out_xy (caar pol1)) (l_out_xy (caadr pol1)) (/ 0.001))
     (setq pol1 (cdr pol1))
 )
 (l_out_transpol pol1)
)  ;...........
;;---fin-----------------------------------------------------l_Out_Morco---------

;;---Début---------------------------------------------------l_traceptcrb--------
;; << trace une LWpolyligne à partir d'une liste point courbure                  >>
;; <<                                                                          >>
;;
;;  créée le :  mardi 7 octobre 1997  à 22:21
;;
;; Admet : 
;; =======
;;   pol        : Liste    = de points courbure
;;   plan       : Chaine   = calque
;;   epais      : Réel     = épaisseur
;;
;; Retourne : Nom d'entité = polyligne créée
;; ==========
;-------------------------------------------------------------------------------
(Defun l_out_traceptcrb ( pol plan epais /  l lp)
   (setq lp (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity")
                  (cons 67 0)(cons 8 plan)
                  (cons 100 "AcDbPolyline") (cons 90 (length pol))
                  (cons 70 0) (cons 43 (if (minusp epais) 0 epais))
                  (cons 38 0.0) (cons 39 0.0) (cons 60 (if (minusp epais) 1 0))
                  
            ) 
   )
   (foreach vert pol
      (setq lp (append lp (list (cons 10 (trans (car vert) 1 0)) ;; correction alain le 06/01/2001 si SCU /= SCG
                                ;(cons 40 epais)(cons 41 epais)
                                (cons 42 (cadr vert))
                          )
               )
      )
                                                  
   )
   (setq lp (append lp (list (cons 210 (list 0.0 0.0 1.0)))))
   (entmake lp)
   (entlast) 
)
;;---fin-----------------------------------------------------l_out_traceptcrb--------

;;---Début---------------------------------------------------l_cor_trace1boite---
;; << trace une boite                                                          >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 27 juin 2007  à 21:54
;;
;; Admet : 
;; =======
;;   pt1        : point       
;;   pt2        : point    
;;   limd       : Liste points courbure = limite droite du corridor
;;   limg       : Liste points courbure = limite gauche du corridor
;;
;; Retourne : Nom d'entité = nom de la polyligne boite
;; ==========
;-------------------------------------------------------------------------------
(Defun l_cor_trace1boite ( pt1 pt2 limd limg / ptdd ptdf ptgd ptgf lpcd lpcg)
 (setq ptdd (vlax-curve-getClosestPointTo limd pt1)
ptdf (vlax-curve-getClosestPointTo limd pt2)
ptgd (vlax-curve-getClosestPointTo limg pt1)
ptgf (vlax-curve-getClosestPointTo limg pt2)
lpcd (l_out_morcopt limd ptdd ptdf)                  ;; liste pointcourbure en limite droite de la boite
lpcg (l_out_transpol (l_out_morcopt limg ptgd ptgf)) ;; liste pointcourbure en limite gauche de la boite
 )
 (setq boite (l_out_traceptcrb (append
		          (l_out_snoc (list (l_out_carl lpcd) 0) (l_out_rdc lpcd))
		          (l_out_snoc (list (l_out_carl lpcg) 0) (l_out_rdc lpcg))
		        )
                        (getvar "clayer")
                        0
      )  
 )
 (setq entboite (entget boite))
 (entmod (subst (cons 70 1) (assoc 70 entboite) entboite))
)
;;---fin-----------------------------------------------------l_cor_trace1boite---

;;---Début---------------------------------------------------l_cor_traceboites---
;; << trace les boites                                                         >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 27 juin 2007  à 21:15
;;
;; Admet : 
;; =======
;;   lpc        : Liste points courbure = axe du tracé
;;   limd       : Liste points courbure = limite droite du corridor
;;   limg       : Liste points courbure = limite gauche du corridor
;;   long       : Réel     = longueur de la boite
;;
;; Retourne : Sans intéret = 
;; ==========
;-------------------------------------------------------------------------------
(Defun l_cor_traceboites ( lpc limd limg long / cumul lgtotal pt1 pt2 )
 (setq cumul 0 lgtotal (vlax-curve-getDistAtParam lpc (vlax-curve-getEndParam lpc))
)
 (while  (> (- lgtotal cumul) 0.01)
   (setq pt1 (vlax-curve-getPointAtDist  lpc cumul)
	  pt2 (vlax-curve-getPointAtDist lpc (setq cumul (min lgtotal (+ long cumul))))
   )
   (l_cor_trace1boite pt1 pt2 limd limg)
 )  
)
;;---fin-----------------------------------------------------l_cor_traceboites---

;;---Début---------------------------------------------------c:corridor----------
;; << tracé du corridor et des boites                                          >>
;; <<                                                                          >>
;;
;;  créée le :  mercredi 27 juin 2007  à 18:37
;;
;; Admet : 
;; =======
;;
;; Retourne : Sans intéret = 
;; ==========
;-------------------------------------------------------------------------------
(Defun c:corridor ( / larg long ep lpc oep limd limg)
 (setq ep (car (entsel "\n pointez l'axe du corridor")))
 (if (l_out_estpol ep)
   (progn
     (setq lpc (l_out_analpol ep))
     (setq larg (getdist (caar lpc) "\ndemi largeur du corridor"))
     (setq long (getdist (caar lpc) "\n longueur des boites "))
     (setq oep (vlax-ename->vla-object ep))
     (setq limd (car (vlax-invoke oep 'Offset larg)))
     (setq limg (car (vlax-invoke oep 'Offset (* -1 larg))))
     
     (l_cor_traceboites oep limd limg long)
   )
 )
 (princ)
)

(alert "commande CORRIDOR chargée")
;;---fin-----------------------------------------------------c:corridor----------

 

[Edité le 27/6/2007 par Didier-AD]

Lien vers le commentaire
Partager sur d’autres sites

Bonjour à tous,

 

Je viens de télécharger vos deux réponses.

 

Je suis actuellement en phase d'essai et de comprehension de vos proses.

 

à ce sujet dans le programme de gile, je ne comprend pas l'utilisation de "" unwind ""

 

en plus quand je lance ce programme pour le tester il me retourne ce message :

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; 5 feuilles chargé à partir de #

_$ (c:bcorridor)

; erreur: une exception s'est produite: 0xC0000005 (Violation d'accès)

; avertissement: fonction unwind ignorée erreur inconnue

_$

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

que signifit ceci ???????

 

je continue à étudier le reste

 

et encore merci pour ces réponces riche en informations.

 

à + doy

Lien vers le commentaire
Partager sur d’autres sites

Une nouvelle version qui crée des polylignes femées au lieu de régions.

 

(defun c:corridor (/	  erreur JoinPlines    AcDoc  Space  ent
	   pl0	  long	 larg	pl1    pl2    nb     cut1
	   cut2	  n	 pt	pt0    pt1    pt2
	  )

 (vl-load-com)

 ;; Redéfintion de *error* (fermeture du groupe d'annulation)
 (defun erreur	(msg)
   (if	(= msg "Fonction annulée")
     (princ)
     (princ (strcat "\nErreur: " msg))
   )
   (vla-endundomark
     (vla-get-activedocument (vlax-get-acad-object))
   )
   (setq *error* m:err
  m:err	nil
   )
   (princ)
 )

 ;; Joint deux polylignes en une polyligne fermée
 (defun JoinPlines (p1 p2 / v1 v2 i lst pl)
   (setq v1 (fix (vlax-curve-getEndParam p1))
  v2 (fix (vlax-curve-getEndParam p2))
  i  0
   )
   (repeat v1
     (setq lst	(cons (cons i (vla-getBulge p1 i)) lst)
    i	(1+ i)
     )
   )
   (setq i (1+ i))
   (repeat v2
     (setq lst	(cons (cons i (- (vla-GetBulge p2 (setq v2 (1- v2))))) lst)
    i	(1+ i)
     )
   )
   (setq pl
   (vlax-invoke
     Space
     'addLightWeightPolyline
     (append (vlax-get p1 'Coordinates)
	     (apply 'append
		    (reverse (split-list (vlax-get p2 'Coordinates) 2))
	     )
     )
   )
   )
   (vla-put-Closed pl :vlax-true)
   (mapcar '(lambda (x) (vla-SetBulge pl (car x) (cdr x))) lst)
   (vla-put-Normal pl (vla-get-Normal p1))
   (vla-put-Elevation pl (vla-get-Elevation p1))
   (vla-delete p1)
   (vla-delete p2)
   pl
 )

 ;; Fonction principale
 (setq	AcDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
Space	(if (= (getvar "CVPORT") 1)
	  (vla-get-PaperSpace AcDoc)
	  (vla-get-ModelSpace AcDoc)
	)
m:err	*error*
*error*	erreur
 )
 (if (and
(setq ent (car (entsel "\nSélectionner une polyligne: ")))
(setq long (getdist "\nLongueur des boites : "))
(setq larg (getdist "\nlargeur des boites: "))
     )
   (progn
     (vla-StartUndoMark AcDoc)
     (setq pl0	(vlax-ename->vla-object ent)
    pl1	(car (vlax-invoke pl0 'Offset (/ larg 2.0)))
    pl2	(car (vlax-invoke pl0 'Offset (/ larg -2.0)))
    nb	(fix
	  (/ (vlax-curve-getDistAtParam
	       pl0
	       (vlax-curve-getEndParam pl0)
	     )
	     long
	  )
	)
    n	1
     )
     (repeat nb
(setq pt0  (vlax-curve-getPointAtDist pl0 (* n long))
      pt1  (vlax-curve-getClosestPointTo pl1 pt0)
      pt2  (vlax-curve-getClosestPointTo pl2 pt0)
      cut1 (CutPlineAtPoint pl1 pt1)
      cut2 (CutPlineAtPoint pl2 pt2)
)
(JoinPlines (car cut1) (car cut2))
(setq n	  (1+ n)
      pl1 (cadr cut1)
      pl2 (cadr cut2)
)
     )
     (JoinPlines pl1 pl2)
     (vla-EndUndoMark AcDoc)
   )
 )
 (setq	*error*	m:err
m:err nil
 )
 (princ)
)

;;;************************* SOUS ROUTINES *************************;;;

;;; Angle2Bulge
;;; Retourne le bulge correspondant à un angle
(defun Angle2Bulge (a)
 (/ (sin (/ a 4.0)) (cos (/ a 4.0)))
)

;;; ArcCenterBy3Points
;;; Retourne le centre de l'arc décrit par 3 points
(defun ArcCenterBy3Points (p1 p2 p3)
 ((lambda (mid1 mid2)
    (inters mid1
     (polar mid1 (+ (angle p1 p2) (/ pi 2)) 1.0)
     mid2
     (polar mid2 (+ (angle p2 p3) (/ pi 2)) 1.0)
     nil
    )
  )
   (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p1 p2)
   (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p2 p3)
 )
)

;;; SUBLST Retourne une sous-liste
;;; Premier élément : 1
;;; (sublst '(1 2 3 4 5 6) 3 2) -> (3 4)
;;; (sublst '(1 2 3 4 5 6) 3 -1) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 12) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 nil) -> (3 4 5 6)
(defun sublst (lst start leng / rslt)
 (or (      (setq leng (- (length lst) (1- start)))
 )
 (repeat leng
   (setq rslt	(cons (nth (1- start) lst) rslt)
  start	(1+ start)
   )
 )
 (reverse rslt)
)

;; SPLIT-LIST Retourne une liste de sous-listes
;; Arguments
;; - lst : la liste à fractionner
;; - num : un entier, le nombre d'éléments des sous listes
;; Exemples :
;; (split-list '(1 2 3 4 5 6 7 8) 2) -> ((1 2) (3 4) (5 6) (7 8))
;; (split-list '(1 2 3 4 5 6 7 8) 3) -> ((1 2 3) (4 5 6) (7 8))

(defun split-list (lst n)
 (if lst
   (cons (sublst lst 1 n)
  (split-list (sublst lst (1+ n) nil) n)
   )
 )
)

;;; CutPlineAtPoint
;;; Coupe la polyligne au point spécifié et retourne la liste des deux objets générés
;;; (ename ou vla-object selon le type de l'argument pl)
;;; 
;;; Arguments
;;; pl : la polyligne à couper (ename ou vla-object)
;;; pt : le point de coupure sur la polyligne (coordonnées SCG)

(defun CutPlineAtPoint
	       (pl  pt	/   en	no  pa	p0  p1	pn  cl	l0  l1
		l2  ce	b0  b1	b2  bp	a1  a2	n   wp	w0  w1
		w2
	       )
 (vl-load-com)
 (or (= (type pl) 'VLA-OBJECT)
     (setq pl (vlax-ename->vla-object pl)
    en T
     )
 )
 (setq	no (vlax-get pl 'Normal)
pa (fix (vlax-curve-getParamAtPoint pl pt))
p0 (vlax-curve-getPointAtparam pl pa)
p1 (vlax-curve-getPointAtParam pl (1+ pa))
pn (reverse (cdr (reverse (trans pt 0 no))))
cl (vla-Copy pl)
l0 (vlax-get pl 'Coordinates)
l1 (append (sublst l0 1 (* 2 (1+ pa))) pn)
l2 (append pn (sublst l0 (1+ (* 2 (1+ pa))) nil))
ce (if (not (equal pt p0 1e-9))
     (ArcCenterBy3Points (trans p0 0 no) pn (trans p1 0 no))
   )
 )
 (repeat (setq n (fix (1+ (vlax-curve-getendParam pl))))
   (setq b0 (cons (vla-getBulge pl (setq n (1- n))) b0))
   (vla-GetWidth pl n 'StartWidth 'EndWidth)
   (setq w0 (cons (list StartWidth EndWidth) w0))
 )
 (setq bp (nth pa b0))
 (if ce
   (progn
     (setq a1 (- (angle ce pn) (angle ce (trans p0 0 no)))
    a2 (- (angle ce (trans p1 0 no)) (angle ce pn))
     )
     (if (minusp bp)
(foreach a '(a1 a2)
  (if (	    (set a (- (eval a) (* 2 pi)))
  )
)
(foreach a '(a1 a2)
  (if (	    (set a (+ (eval a) (* 2 pi)))
  )
)
     )
   )
 )
 (setq	b1 (append
     (if (zerop pa)
       nil
       (sublst b0 1 pa)
     )
     (if ce
       (list (Angle2Bulge a1))
       (list bp)
     )
   )
b2 (append
     (if ce
       (list (Angle2Bulge a2))
       (list bp)
     )
     (sublst b0 (+ 2 pa) nil)
   )
wp (if (equal pt p0 1e-9)
     (car (nth pa w0))
     (+	(car (nth pa w0))
	(* (- (cadr (nth pa w0)) (car (nth pa w0)))
	   (/ (- (vlax-curve-getDistAtPoint pl pt)
		 (vlax-curve-getDistAtParam pl pa)
	      )
	      (- (vlax-curve-getDistAtParam pl (1+ pa))
		 (vlax-curve-getDistAtParam pl pa)
	      )
	   )
	)
     )
   )
w1 (append (if (zerop pa)
	     nil
	     (sublst w0 1 pa)
	   )
	   (list (list (car (nth pa w0)) wp))
   )
w2 (append (list (list wp (cadr (nth pa w0))))
	   (sublst w0 (+ 2 pa) nil)
   )
 )
 (vlax-put pl 'Coordinates l1)
 (repeat (setq n (length b1))
   (vla-SetBulge pl (setq n (1- n)) (nth n b1))
 )
 (vlax-put cl 'Coordinates l2)
 (repeat (setq n (length b2))
   (vla-SetBulge cl (setq n (1- n)) (nth n b2))
 )
 (repeat (setq n (length w1))
   (vla-SetWidth
     pl
     (setq n (1- n))
     (car (nth n w1))
     (cadr (nth n w1))
   )
 )
 (repeat (setq n (length w2))
   (vla-SetWidth
     cl
     (setq n (1- n))
     (car (nth n w2))
     (cadr (nth n w2))
   )
 )
 (if en
   (list (vlax-vla-object->ename pl)
  (vlax-vla-object->ename pl)
   )
   (list pl cl)
 )
) 

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

Lien vers le commentaire
Partager sur d’autres sites

salut,

 

je viens juste de l'essayer aussi sur différent poste de travail

et il me renvois toujours le même message d'erreur.

 

en plus je ne comprend pas certaine chose :

 

le " vla-endundomark......."

le " setq *error* m:err......."

le " vla-getBulge ..............."

 

Peux tu m'indiquer un livre ou un site @ où je puisse trouver les informations et un complément de cours sur le langage Lisp et ses fonctions.

 

Par avance merci

 

à + doy.

Lien vers le commentaire
Partager sur d’autres sites

Salut

Ton message d'erreur me fait penser à un confilt entre lisps.

J'ai déjà eu ceci avec des lips travaillant avec des réacteurs.

il suffit de verifier par exemple que deux fonctions lisps n'onty pas le même nom

 

@+

Les Lisps de Patrick

Le but n'est pas toujours placé pour être atteint, mais pour servir de point de mire.

Joseph Joubert, 1754-1824

Lien vers le commentaire
Partager sur d’autres sites

À propos de ton erreur (unwind), j'ai trouvé ce sujet

 

Sinon, as-tu essayé le LISP de Didier-AD ? Il fonctionne bien.

 

Pour ce qui est de l'apprentissage du LISP, j'utilises beaucoup l'aide au dévellopeurs d'AutoCAD, en anglais certes.

 

Les fonctions Visual LISP vl-*, vlax-* et vlr-* sont décrites dans l'aide aux développeurs (AutoLISP Reference). Les fonctions vla- permettent d'utiliser les objets, propriétés et méthodes VBA décrrites dans ActiveX an VBA Reference.

 

Tu trouverars les principales fonctions AutoLISP décrites en français sur Aidacad.

et une "Bible du développeur Visual LISP" (en anglais).

 

 

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

Lien vers le commentaire
Partager sur d’autres sites

Salut gile,

 

et merci pour les infos concernant les cours sur le lisp

 

je viens d'y jeter un rapide coup d'oeil

il ne me reste plus qu'a le traduire mais j'y entrevois déjà

de nombreuses possibilités intéressantes.

 

encore merci pour tous les conseils avisés,

je commence à apprécier le langage lisp et a en entrevoir les formidables débouchés.

 

à + denis.

Lien vers le commentaire
Partager sur d’autres sites

salut gile

 

effectivement je ne parviens pas à executer les routines correctement

et en plus pour ton super programme sur les boîtes je ne comprends pas le début

qui dit je cite :

 

redefinition de error.................

 

mais je continue à l'étudier car il m'apprend plein de choses

que je connaissais pas.

 

à + doy

Lien vers le commentaire
Partager sur d’autres sites

de nouveau sur la brèche salut

 

pour mon programme de création des boîtes, ne pourrait on pas

me dire si l'on peut l'améliorer et si pour le continuer aprés la décomposition des blocs

poursuivre par l'insertion de points par la commande mesurer avec un certain retrait ( par exemple de la moitié de la distance que j'ai utilisé vpour inserer mes blocs et donc utiliser ces points comme référence pour générer les contours dans la zone qui entoure le point.

 

j'espère que j'ai été assez clair.

 

à bientôt et merci.

Lien vers le commentaire
Partager sur d’autres sites

Je ne comprends toujours pas pourquoi tu n'arrives à faire fonctionner aucune des routines données (celle de Didier-AD et les deux miennes fonctionne très bien chez moi)

 

Si quelqu'un d'autre passait par ici et pouvait faire un test sur une polyligne ouverte...

 

Pour ce qu'il en est de la redéfinition de *error*, *error* est une fonction (définie par AutoCAD) qui retourne le message d'errur sur la ligne de commande. Elle pourrait ressembler à ça :

 

(defun *error* (msg)
     (princ (strcat ";erreur :" msg))
     (princ)
   ) 

 

Il est possible de définir une autre fonction et de l'affecter à *error* le temps de l'exécution d'une routine.

C'est, à mon avis, indispensable dans tout LISP qui modifie les variables système ou ouvre un groupe d'annulation de façon à restaurer l'environnement initial en cas d'erreur pendant le déroulement du LISP. Il faut savoir qu'annuler (avec Echap) pendant l'exécution du LISP est considéré par AutoCAD comme une erreur.

 

La fin de la routine de redéfinition de *error* doit restaurer l'environnement initial, tout comme la fin de la fonction principale.

En incluant la routine erreur dans la fonction principale et en la déclarant comme variable locale, on évite tout conflit avec d'autres fonction qui auraient le même nom.

 

Exemple commenté d'utilisation :

 

(defun c:MaFonction (/ erreur echo osmo)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;; Définition d'une fonction de gestion des erreurs
 (defun erreur	(msg)

   (if	(= msg "Fonction annulée")				 ; si la fonction est annulée,
     (princ)							 ; pas de message,
     (princ (strcat "\Erreur: " msg))				 ; sinon, message délivré.
   )

   ;; restauration des variables système
   (setvar "CMDECHO" echo)
   (setvar "OSMODE" osmo)

   ;; restauration de la fonction *error* originale
   (setq *error* m:err
  m:err	nil
   )
   (princ)
 )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;; sauvegarde de la fonction *error* originale dans m:err
 ;; et attribution de erreur à *error*
 (setq	m:err	*error*
*error*	erreur
 )

 ;; sauvegarde de la valeur originale des variables système
 (setq	echo (getvar "CMDECHO")
osmo (getvar "OSMODE")
 )

 ;; attribution des nouvelles valeurs aux variables système
 (setvar "CMDECHO" 0)
 (setvar "OSMODE" 0)

 ;; corps de la routine
 ;;
 ;;
 ;;

 ;; restauration des variables système
 (setvar "CMDECHO" echo)
 (setvar "OSMODE" osmo)

 ;; restauration de la fonction *error* originale
 (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

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
×
×
  • 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é