Echap et lisp

Ramses · le 29 mars 2006

Bonjour,

comment faire pour exécuter une commande (copie, delete..) si au cours d'exécution d'une routine lisp, l'utilisateur appuie sur Echap.

est-ce que cela se fait par le biais d'une condition if ou while...

merci de votre aide

bonuscad · le 29 mars 2006

Je ne sais pas si j'ai bien compris la question.

Pour contourner l'appui de la touche "Echapp" en lisp, j'utiliserais la fonction *errror*

Un exemple vaut mieux qu'un discours,

(defun c:test (/)

(defun mon_err (ch)

(cond

((eq ch "Fonction annulée")

(princ "\nRecommencez") (c:test)

)

(T (princ ch))

)

(setq olderr *error* *error* mon_err)

(initget 1)

(setq p1 (getpoint "\n1er point: "))

(initget 1)

(setq p2 (getpoint "\n2ème point: "))

(command "_.line" p1 p2 "")

(setq *error* olderr)

(prin1)

)

Ceci empêchera l'abandon de la fonction/commande TEST, si l'utilisateur "break" lors de l'entrée des données, il devra recommencer au début.

Tramber · le 29 mars 2006

(defun c:routine()
 (initget 1)
 (setq p1 (getpoint "\n1er point: "))
 (initget 1)
 (setq p2 (getpoint "\n2ème point: "))
 (command "_.line" p1 p2 "")
 )

(setq flag T)
(while(and flag(setq errobj(vl-catch-all-apply 'c:routine)))
 (if(=(vl-catch-all-error-message errobj)"Fonction annulée" )(princ "\nRecommencez")(setq flag nil)))

Marche aussi, différemment

[Edité le 29/3/2006 par Tramber]

Ramses · le 29 mars 2006

Bonjour,

Merci beaucoup pour l'aide, mais je m'explique davantage avec un exemple.

supposons que j'ai la routine suivante toute simple:

(defun c:maligne ()

(command "_line")

)

donc une routine qui exécute la commande "ligne". donc si je tape maligne sur la ligne de commande autocad me demande "premier point de la ligne" et il attend une entrée utilisateur. si moi utilisateur au moment ou ce message attend mon entrée j'appuie sur echap, la commande ligne est donc annulée et ainsi la fonction "maligne" prend fin. Ce que je souhaiterais quand moi utilisateur j'appuie sur echap pour annuler la fonction "maligne", la routine exécute une commande bien précise, par exemple (doscopy ....).

j'espère que je suis plus clair, et je m'excuse.

merci pour l'aide

bonuscad · le 30 mars 2006

Les deux réponses conviennent pour ce que tu veux faire.

La seule nuance et que dans la fonction erreur des exemples on te renvoyait sur la procédure "appelante", mais en modifiant le code tu peux renvoyer sur toute autre procédure.?!..?!!

pour mon exemple:

((eq ch "Fonction annulée")

(princ "\nRecommencez") (c:test)

)

deviendrait par exemple:

((eq ch "Fonction annulée")

(princ "\nProcédure d'annulation en cours, patientez.....") (doscopy ....) (....) (restore variables)

)

Ramses · le 30 mars 2006

Merci infiniment,

dois-je insérer ce code à l'intérieur du code de la fonction ou peut importe l'emplacement car je veux qu'il s'exécute uniquement pour une fonction déterminée.

Merci.

Ramses · le 2 avril 2006

Bonjour,

ça marche quand j'utilise ce bout de code tout seul mais avec man fonction j'ai un problème.

Ma fonction est comme la suivante :

(defun c:FixCn (/ Nomfile Nomfile2 PathFdwg ACINS2000 FINS2000 PathFdwgf PathFacad )

(if (or (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) nil) (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) ""))

(alert "FixCAD n'est pas installée sur cet ordinateur.")

(progn

(setq ACINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\Autodesk\\AutoCAD\\R15.0\\ACAD-1001:40C" "AcadLocation"))

(FixVl)

);if

);defun c:FixCn

donc ma fonction c:FixCn fait appel à une autre fonction FixVl qui elle aussi fait appel à d'autres fonctions

Donc ce que j'ai fait :

(defun c:FixCn (/ Nomfile Nomfile2 PathFdwg ACINS2000 FINS2000 PathFdwgf PathFacad )

(defun mon_err (ch)

(cond

((eq ch "Fonction annulée")

(princ "\nProcédure d'annulation en cours, patientez....") (alert "fonction aborted")

)

(T (princ ch))

);cond

);defun

(setq olderr *error* *error* mon_err)

(if (or (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) nil) (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) ""))

(alert "FixCAD n'est pas installée sur cet ordinateur.")

(progn

(setq ACINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\Autodesk\\AutoCAD\\R15.0\\ACAD-1001:40C" "AcadLocation"))

(FixVl)

);if

(setq *error* olderr)

);defun c:FixCn

donc j'ai intégré les deux portions de codes comme précédent.

Autre chose : le bout de code marche avec la version française d'autocad mais avec la version anglaise non!

merci infiniment

(gile) · le 2 avril 2006

Salut

1 - À la fin du (defun mon_err ... tu devrais restituer la fonction *error* originelle avec un (setq *error* olderr olderr nil)

2 -

le bout de code marche avec la version française d'autocad mais avec la version anglaise non!

Normal, le message avec une version anglaise pour "Fonction annulée" c'est : "Function cancelled".

Je te propose donc d'essayer ceci qui devrait fonctionner avec les versions anglaises et françaises :

(defun mon_err (ch)
 (cond
   ((or (eq ch "Fonction annulée")
 (eq ch "Function cancelled")
    )
    (princ "\nProcédure d'annulation en cours, patientez....")
    (alert "fonction aborted")
   )
   (T (princ ch))
 ) ;_ cond
 (setq	*error*	olderr
olderr	nil
 )
) ;_ defun

Tu peux aussi déclarer mon_err comme variable locale (defun c:FixCn (/ mon_err Nomfile ... dans la mesure où la fonction mon_err ne sert qu'à l'intérieur de la fonction c:FixCn elle sera renvoyée à nil à la fin de l'exécution de celle-ci.

(gile) · le 2 avril 2006

Pour de plus amples explications sur la gestion des erreurs en AutoLISP , tu peux consulter l'aide aux développeurs d'AutoCAD -> AutoLISP Developer's guide -> Using theAutoLISP Language -> AutoLISP Basics -> Error Handling in AutoLISP ->Using the *error* Function

On peut aussi, par la fonction redéfinie de *error*, restituer l'environnement initial en cas d'erreur ou d'annulation, au cas où celui-ci aurait été modifié pendant l'exécution du LISP (fermeture du groupe UNDO, restauration des valeurs initiales des variables système, du SCU, du calque courant ...)

À ce propos, tu peux voir les sujets ici, ou encore ici, ou encore là.

Ramses · le 2 avril 2006

Merci gile,

seulement sur le code de Bonuscad, je vois un

(setq olderr *error* *error* mon_err) que tu as sauté et puis j'ai placé le (setq *error* olderr)

mais à la fin juste avant );defun. Je deverais peut être le placer necessairement à la fin de la fonction mon_err?.

Merci aussi pour les liens sur la question, j'étudierais ça de plus près.

(gile) · le 3 avril 2006

Le code que je proposais concerne uniquement la définition de mon_err.

Tu as défini mon_err à l'intérieur de la fonction principale (c'est pour çà que je te proposais de déclarer la fonction avec les variables système), mais cela reste une fonction différente de la fonction principale c:FixCn utilisée par celle-ci au même titre que FixVl à ceci près que FixVl est appelé dans le déroulement "normal" de c:FixCn et que mon_err remplace pendant l'exécution de c:FixCn la fonction originelle*error*.

Donc, au début de c:FixCn on sauvegarde la définition originelle de *error* dans olderr et on affecte celle de mon_err à *error*. c'est donc cette fonction qui sera exécutée en cas d'erreur ou d'annulation, et ce jusqu'à ce que soit restauré la définition originelle de *error* en fin de c:FixCn mais aussi en fin de mon_err (en cas d'annulation).

(defun c:FixCn (/mon_err Nomfile Nomfile2 PathFdwg ACINS2000 FINS2000 PathFdwgf PathFacad )

;;;********** Redéfiniton de *error* **********;;;

(defun mon_err (ch)
(cond
((or (eq ch "Fonction annulée")
(eq ch "Function cancelled")
)
(princ "\nProcédure d'annulation en cours, patientez....")
(alert "fonction aborted")
)
(T (princ (strcat "\nErreur: " ch)))
) ;_ cond
[color=#990000](setq *error* olderr ;_ Restauration de *error*
olderr nil) ;_ Renvoi de olderr à nil[/color]
)
) ;_ defun

;;;********** Fonction principale **********;;;

[color=#990000](setq olderr *error* ;_ Sauvegarde de *error*
*error* mon_err) ;_ Remplacement par mon_err[/color]

(if (or (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) nil) (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) ""))
(alert "FixCAD n'est pas installée sur cet ordinateur.")
(progn
(setq ACINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\Autodesk\\AutoCAD\\R15.0\\ACAD-1001:40C" "AcadLocation"))
(FixVl)
);if

[color=#990000](setq *error* olderr ;_ Restauration de *error*
olderr nil) ;_ Renvoi de olderr à nil[/color]

);defun c:FixCn

On peut aussi definir mon_err à part (dans ce cas on ne la déclare pas, bien sûr) :

;;;********** Redéfiniton de *error* **********;;;

(defun mon_err (ch)
(cond
((or (eq ch "Fonction annulée")
(eq ch "Function cancelled")
)
(princ "\nProcédure d'annulation en cours, patientez....")
(alert "fonction aborted")
)
(T (princ (strcat "\nErreur: " ch)))
) ;_ cond
(setq *error* olderr ;_ Restauration de *error*
olderr nil) ;_ Renvoi de olderr à nil
)
) ;_ defun




;;;********** Fonction c:FixCn **********;;;


(defun c:FixCn (/ Nomfile Nomfile2 PathFdwg ACINS2000 FINS2000 PathFdwgf PathFacad )

(setq olderr *error* ;_ Sauvegarde de *error*
*error* mon_err) ;_ Remplacement par mon_err

(if (or (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) nil) (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) ""))
(alert "FixCAD n'est pas installée sur cet ordinateur.")
(progn
(setq ACINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\Autodesk\\AutoCAD\\R15.0\\ACAD-1001:40C" "AcadLocation"))
(FixVl)
);if

(setq *error* olderr ;_ Restauration de *error*
olderr nil) ;_ Renvoi de olderr à nil

);defun c:FixCn

Ramses · le 3 avril 2006

Merci gile pour le complément d'informations.

Mais ça n'a pas fonctionné chez moi. j'ai fait les deux manières (mon_err définie à part - mon_err insérée dans la fonction).

Dans le premier cas, si je définis mon_err à part et j'ai la fonction c:FixCn qui appelle la fonction FixVl qui appelle la fonction FixVl2 et à l'intérieur de cette dernière j'appuie sur Echapp normalement celà devrait marcher, mais ça ne marche pas je ne sais pas pourquoi.

quand j'appuie sur Echapp rien ne se passe sauf *Cancel* sur la ligne de commande.

Merci

(gile) · le 3 avril 2006

OOOPS !!!

Au temps pour moi, si tu as utilisé le code que je donnais au dessus pour mon_err, il est normal que çà n'ait pas fonctionné : il y a un paranthèse fermante de trop :mad2:

J'ai posté çà ce matin en vitesse sans vérifications. :cool:

Tu aurais dû être averti par un message du style : ; erreur: parenthèse fermante supplémentaire en entrée

Si tu veux re-essayer avec ce petit assemblage, je l'ai testé, il fonctionne que l'on fasse "echap" pendant l'exécution de test1 (spécification des points) ou test2 (spécification du type d'entité).

J'ai rajouté, pour l'exemple, la gestion d'une variable système (BLIPMODE) et la fonction (redraw), tu remarqueras que la fin de la fonction principale (c:test) et la fin de mon_err sont similaires.

(defun mon_err (ch)
 (cond
   ((or (eq ch "Fonction annulée")
 (eq ch "Function cancelled")
    )
    (princ "\nProcédure d'annulation en cours, patientez....")
    (alert "fonction aborted")
   )
   (T (princ (strcat "\nErreur: " ch)))
 ) ;_ cond
 [color=#990000](redraw)
 (setvar "blipmode" old_blip)[/color]
 (setq	*error*	olderr ;_ Restauration de *error*
olderr	nil ;_ Renvoi de olderr à nil
 )
 (princ)
) ;_ defun


(defun test1 (/ pt1 pt2 pt3)
 [color=#990000](setvar "blipmode" 1)[/color]
 (initget 1)
 (setq pt1 (getpoint "\nPremier point: "))
 (initget 1)
 (setq pt2 (getpoint "\nSecond point: "))
 (initget 1)
 (setq pt3 (getpoint "\nTroisième point: "))
 (test2 pt1 pt2 pt3)
)

(defun test2 (p1 p2 p3)
 (initget "Ligne Polyligne")
 (if (= (getkword "\nType d'entité [Ligne/Polyligne] : ")
 "Polyligne"
     )
   (command "_.pline" p1 p2 p3 "_c")
   (command "_.line" p1 p2 p3 "_c")
 )
)

(defun c:test (/ [color=#990000]old_blip[/color])
 (setq	olderr	*error*
*error*	mon_err
 )
 [color=#990000](setq old_blip (getvar "blipmode"))[/color]
 (test1)
 [color=#990000](redraw)
 (setvar "blipmode" old_blip)[/color]
 (setq	*error*	olderr
olderr	nil
 )
 (princ)
)

[Edité le 3/4/2006 par (gile)]

Ramses · le 3 avril 2006

Merci encore une fois gile,

le problème de la parenthèse je l'ai remarqué tout au début et j'y ai remédié. j'ai utilisé le même code avec une simple fonction qui dessine une ligne, ça marche mais avec ma fonction qui fait appel à des fonctions successivement aucun message. Je suppose que le problème vient peut être de ce fait! enfin. ma fonction est identique à superchach qui se trouve dans le fichier sprhach.lsp, c'est au moment d'insertion du bloc pour hachurage que je veux faire intervenir le code pour Echap. Je ferais mieu de te fournir le code, en ce moment je ne suis pas sur le bureau, je le ferais si necessaire demain.

merci

(gile) · le 3 avril 2006

avec ma fonction qui fait appel à des fonctions successivement aucun message. Je suppose que le problème vient peut être de ce fait!

Le test que je te propose fonctionne sur le même principe : c:test fait appel à test1 pour la saisie des points qui fait appel à test2 pour le choix du type d'entité et la création de l'entité.

Ramses · le 4 avril 2006

Voila je te donne le code modifié de sprhach.lsp. La fonction FixCn insère un fichier dwg comme motif de hachurage. tu peux donc créer n'importe quel fichier que tu places sur le chemin de fichiers support. J'ai testé aumoment où j'ai le message "Point d'insertion du dessin " c'est là où je veux taper echapp.

le code complet de FixCn.lsp :

 (defun getgeomextents (en)

;(setq ob (vlax-ename->vla-object en))

;(vla-getboundingbox ob 'll 'ur)

;(setq ret (list

; (list (vlax-safearray-get-element ll 0)

; (vlax-safearray-get-element ll 1)

; (vlax-safearray-get-element ll 2))

; (list (vlax-safearray-get-element ur 0)

; (vlax-safearray-get-element ur 1)

; (vlax-safearray-get-element ur 2)))

;) ;setq

(acet-ent-geomextents en)

);defun getgeomextents

;TFRAMES - Toggles Image and Wipeout frames on and off.

;

(defun c:tframes ( / e1 e2 status)

(acet-error-init

(list (list "cmdecho" 0);list

T

);list

);acet-error-init

(setq e1 (dictsearch (namedobjdict) "ACAD_IMAGE_VARS"));setq

(setq e2 (dictsearch (namedobjdict) "ACAD_WIPEOUT_VARS"));setq

(if (or e1 e2)

(progn

(if (not (member "wipeout.arx" (arx)))

(progn

(if (findfile "wipeout.arx")

(arxload "wipeout.arx");then

(progn

(alert (acet-str-format "Impossible de trouver \"%1\"" "wipeout.arx"))

;(alert "Cannot find \"wipeout.arx\"")

(exit)

);progn

);if

);progn then

);if

(if (and e1

(equal (cdr (assoc 70 e1)) 1)

);and

(setq status "_OFF")

(progn

(if e1

(setq status "_ON")

(progn

(if (and e2

(equal (cdr (assoc 70 e2)) 1)

);and

(setq status "_OFF")

(progn

(if e2

(setq status "_ON")

);if

);progn

);if

);progn

);if

);progn

);if

(if status

(progn

(command "_.imageframe" status)

(command "_.wipeout" "_f" status)

(princ (acet-str-format "\nAlternance des cadres IMAGE/NETTOYER: %1." (substr status 2)))

);progn then

);if

);progn then

(princ "\nLe dessin courant ne contient aucun objet image ou nettoyage.")

);if

(acet-error-restore)

);defun c:tframes

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

(defun c:Superhatch ( / flag lla glst htype ss lst2

)

(acet-error-init

(list (list "cmdecho" 0

"highlight" 0

"osmode" 0

"orthomode" 0

"plinetype" 1

"ucsicon" 0

"cecolor" (getvar "cecolor")

"celtype" (getvar "celtype")

"regenmode" 1

"luprec" (getvar "luprec")

"ucsfollow" 0

"limcheck" 0

);list

T

);list

);acet-error-init

(bns_sprhatch_init_overlap)

(acet-autoload (list "clipit.lsp" "(c_clipit a b)"))

(acet-autoload (list "clipit.lsp" "(wipeout_clipit a b)"))

(acet-autoload (list "isort.lsp" "(isort a b)"))

(acet-autoload (list "ddins2.lsp" "(ddins2)"))

(acet-autoload (list "ai_utils.lsp" "(ai_rtos a)"))

(acet-autoload (list "ai_utils.lsp" "(ai_num a b c)"))

;;(acet-autoload (list "getext.arx" "(getgeomextents na)"))

(reg_it2);ensure that sprhatch is registered as an xdata app

(setq flag (acet-viewport-next-pickable))

(if (and (not (equal 1 (getvar "cvport")))

(not (equal (car flag) (getvar "cvport")))

);and

(progn

(princ "\n Cette commande ne peut pas être activée dans une vue en perspective")

);progn then jump out of this command cuz perspective view is on.

(progn

(setq lla (acet-layer-unlock-all))

(setq glst (bns_groups_unsel));setq

(setq htype (htype_info))

;make absolutely sure that these vars are set.

(setvar "cmdecho" 0)

(setvar "highlight" 0)

(setvar "osmode" 0)

(setvar "orthomode" 0)

(setvar "plinetype" 1)

(setvar "ucsicon" 0)

(setvar "regenmode" 1)

);progn else all is good

);if

(if (and htype

(setq ss (get_boundary_plines))

(car (setq lst2 (do_boundary_stuff #clipitres ss)))

);and

(progn

(sprhatch #sprhatch_type (car htype) (cadr htype) (caddr htype) lst2)

(cond

((equal #sprhatch_type "Image")

(princ "\nUtilisez BCADRES pour activer/désactiver le cadre des objets.")

);cond #1 image

((equal #sprhatch_type "Wipeout")

(princ "\nUtilisez BCADRES pour activer/désactiver le cadre des objets.")

);cond #2 Wipeout

);cond close

);progn then go for it

(progn

(if htype

(progn

(if (car htype)

(entdel (car htype))

);if

(if (not ss)

(progn

(acet-ss-clear-prev)

);progn then

);if

);progn then

);if

);progn else the boundary stuff failed to create polyline boundaries.

);if

(if lla

(progn

(command "_.-layer" "_lock" lla "")

(while (wcmatch (getvar "cmdnames") "*LAYER*") (command ""));while

);progn then re-lock the layers that were originally locked

);if

(bns_groups_sel glst)

(acet-error-restore)

);defun c:superhatch

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

(defun mon_err (ch)

(cond

((or (eq ch "Fonction annulée")

(eq ch "Function cancelled")

)

(princ "\nProcédure d'annulation en cours, patientez....")

(alert "fonction aborted")

)

(T (princ (strcat "\nErreur: " ch)))

) ;_ cond

(setq *error* olderr ;_ Restauration de *error*

olderr nil) ;_ Renvoi de olderr à nil

) ;_ defun

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

(defun c:FixCn (/ Nomfile)

(setq olderr *error* ;_ Sauvegarde de *error*

*error* mon_err) ;_ Remplacement par mon_err

;(if (or (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) nil) (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) ""))

;(alert "FixCAD n'est pas installée sur cet ordinateur.")

(FixVl)

;);if

(setq *error* olderr ;_ Restauration de *error*

olderr nil) ;_ Renvoi de olderr à nil

);defun c:FixCn

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

(defun FixVl ()

(setvar "cmdecho" 0)

(setq Nomfile (getstring "Entrez le nom du dessin de hachurage: "))

(Fhatch)

);defun FixVl

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

(defun Fhatch ( / flag lla glst htype ss lst2

)

(acet-error-init

(list (list "cmdecho" 0

"highlight" 0

"osmode" 0

"orthomode" 0

"plinetype" 1

"ucsicon" 0

"cecolor" (getvar "cecolor")

"celtype" (getvar "celtype")

"regenmode" 1

"luprec" (getvar "luprec")

"ucsfollow" 0

"limcheck" 0

);list

T

);list

);acet-error-init

(bns_sprhatch_init_overlap)

(acet-autoload (list "clipit.lsp" "(c_clipit a b)"))

(acet-autoload (list "clipit.lsp" "(wipeout_clipit a b)"))

(acet-autoload (list "isort.lsp" "(isort a b)"))

(acet-autoload (list "ddins2.lsp" "(ddins2)"))

(acet-autoload (list "ai_utils.lsp" "(ai_rtos a)"))

(acet-autoload (list "ai_utils.lsp" "(ai_num a b c)"))

;;(acet-autoload (list "getext.arx" "(getgeomextents na)"))

(reg_it2);ensure that sprhatch is registered as an xdata app

(setq flag (acet-viewport-next-pickable))

(if (and (not (equal 1 (getvar "cvport")))

(not (equal (car flag) (getvar "cvport")))

);and

(progn

(princ "\n Cette commande ne peut pas être activée dans une vue en perspective")

);progn then jump out of this command cuz perspective view is on.

(progn

(setq lla (acet-layer-unlock-all))

(setq glst (bns_groups_unsel));setq

(setq htype (htype_info2))

;make absolutely sure that these vars are set.

(setvar "cmdecho" 0)

(setvar "highlight" 0)

(setvar "osmode" 0)

(setvar "orthomode" 0)

(setvar "plinetype" 1)

(setvar "ucsicon" 0)

(setvar "regenmode" 1)

);progn else all is good

);if

(if (and htype

(setq ss (get_boundary_plines))

(car (setq lst2 (do_boundary_stuff #clipitres ss)))

);and

(progn

(sprhatch #sprhatch_type (car htype) (cadr htype) (caddr htype) lst2)

(cond

((equal #sprhatch_type "Image")

(princ "\nUtilisez BCADRES pour activer/désactiver le cadre des objets.")

);cond #1 image

((equal #sprhatch_type "Wipeout")

(princ "\nUtilisez BCADRES pour activer/désactiver le cadre des objets.")

);cond #2 Wipeout

);cond close

);progn then go for it

(progn

(if htype

(progn

(if (car htype)

(entdel (car htype))

);if

(if (not ss)

(progn

(acet-ss-clear-prev)

);progn then

);if

);progn then

);if

);progn else the boundary stuff failed to create polyline boundaries.

);if

(if lla

(progn

(command "_.-layer" "_lock" lla "")

(while (wcmatch (getvar "cmdnames") "*LAYER*") (command ""));while

);progn then re-lock the layers that were originally locked

);if

(bns_groups_sel glst)

(acet-error-restore)

);defun Zhatch

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

(defun htype_info2 ( / htype na flag flag2)

(while (not flag2)

;;(if (setq htype (dd_htype_info))

(if (setq htype '("Block" nil))

(progn

(if (not #sprhatch_type) (setq #sprhatch_type "Block"));if

(setq na (cadr htype)

htype (car htype)

);setq

(if #clipitres

(setq a #clipitres)

(setq a (acet-geom-pixel-unit));setq

);if

(setq #clipitres a)

(initget 6)

(setq a (getreal (strcat "\nTolérance d'erreur des courbes <" (ai_rtos #clipitres) ">: ")))

(setq #clipitres a)

(if (not a) (setq a #clipitres))

(cond

((or (equal htype "Block")

(equal htype "Xref")

);or

(setq flag (get_insert_info2 na htype));setq entname, rectang and xtlist

);cond #1

((equal htype "Image")

(setq flag (get_image_info na))

(if flag

(setq flag2 T)

);if

);cond #2

((equal htype "Wipeout")

(setq flag (list nil nil)

flag2 T

);setq

);cond #3

);cond

(if flag

(setq flag2 T);then the user did not create an image, block, or xref.

);if

);progn then

(setq flag2 T)

);if

);while

(if (car flag)

(progn

(acet-ss-visible (ssadd (car flag) (ssadd)) 1);then make it stealth

(princ)

);progn

);if

flag

);defun htype_info2

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

(defun get_insert_info2 ( na2 htype / na na3 fna bna blk lst2 xtlst

uflag zflag ans

)

(setq na3 na2

na (entlast)

);setq

(setvar_rt)

(setq ans "No")

(while (equal ans "No")

(setq ans nil);setq

(if (equal htype "Block")

(progn

(if (not na2)

(progn

;; (ddins2)

(setvar "cmdecho" 0)

(command "_.insert" Nomfile)

(setvar "cmdecho" 1)

(princ)

(princ (strcat "Point d'insertion du dessin " Nomfile " :"))

(while (wcmatch (getvar "cmdnames") "*INSERT*")

(command pause)

);while

(if (not (equal na (entlast)))

(setq na2 (entlast));setq

(setq na2 nil);setq

);if

);progn

);if

);progn

(progn

(if (not na2)

(progn

; (while (not fna)

; (setq fna (acet-ui-getfile "Spécifiez le nom du fichier Xréf" #sprhatch_xref "dwg;dwt" 0))

; (if fna

; (progn

; (setq bna (acet-filename-path-remove (acet-filename-ext-remove fna))

; blk (tblobjname "block" bna)

; );setq

; (if (and blk

; (not (equal 4

; (logand 4 (cdr (assoc 70 (entget blk))))

; );equal

; );not

; );and

; (progn

; (princ "\n*Incorrect*")

; (princ

; (acet-str-format "\n%1 est déjà défini comme bloc dans le dessin courant." bna)

; );princ

; (setq fna nil)

; );progn then

; );if

; );progn

; (setq fna 99)

; );if

; );while

; (if (not (equal fna 99))

; (progn

; (setq #sprhatch_xref fna)

; (command "_.-xref" "_a")

; (setvar "cmdecho" 1)

; (command fna)

; (while (wcmatch (getvar "cmdnames") "*XREF*") (command pause));while

; (setvar "cmdecho" 0)

; (if (not (equal na (entlast)))

; (setq na2 (entlast));setq

; (setq na2 nil)

; );if

; );progn then

; (setq na2 nil);setq else user cancled the acet-ui-getfile dialog.

; );if

; (setq fna nil)

(command "_.xattach")

(setvar "cmdecho" 1)

(while (wcmatch (getvar "cmdnames") "*XATTACH*") (command pause));while

(setvar "cmdecho" 0)

(if (not (equal na (entlast)))

(progn

(setq na2 (entlast));setq

;(setq #sprhatch_xref fna)

);progn then

(setq na2 nil)

);if

);progn

);if

);progn else

);if

(if na2

(progn

(setq uflag T)

(command "_.ucs" "_ob" na2)

(setq xtlst (getblkextents na2));setq

(if (not xtlst)

(progn

(princ "\nImpossible de calculer l'étendue de l'objet. Problème lié à l'objet DEMIDROITE ou DROITE.")

(setq ans "No")

(entdel na2)

(setq na2 nil)

);progn then reject this insert.

);if

);progn then

);if

(if (and (not na3)

na2

);and

(progn

(if (setq zflag (acet-geom-zoom-for-select xtlst))

(command "_.zoom" "_w" (car zflag) (cadr zflag))

);if

(if uflag

(progn

(command "_.ucs" "_p")

(setq uflag nil)

);progn then

);if

(initget "Oui Non _Yes No")

(setq ans (getkword

(acet-str-format "\nLa position de %1 est-elle acceptable? {Oui/Non] : " (strcase htype))

);getkword

);setq

(if (equal ans "No")

(progn

(entdel na2)

(setq na2 nil)

);progn then

);if

(if zflag (command "_.zoom" "_p"))

);progn then

);if

(if uflag

(progn

(command "_.ucs" "_p")

(setq uflag nil)

);progn then

);if

);while

(setvar "osmode" 0)

(if na2

(setq lst2 (get_insert_rectang na2 htype xtlst)

xtlst (cadr lst2)

lst2 (car lst2)

);setq then got an insert

);if

(if lst2

(list na2 lst2 xtlst)

nil

);if

);defun get_insert_info2

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

(defun reg_it2 ( )

(if (not (tblsearch "appid" "BNS_SPRHATCH"))

(if (= (regapp "BNS_SPRHATCH") nil)

(princ "\nImpossible d'enregistrer XDATA pour BNS_SPRHATCH.")

);if

);defun reg_it2

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

(defun htype_info ( / htype na flag flag2)

(while (not flag2)

(if (setq htype (dd_htype_info))

(progn

(setq na (cadr htype)

htype (car htype)

);setq

(cond

((or (equal htype "Block")

(equal htype "Xref")

);or

(setq flag (get_insert_info na htype));setq entname, rectang and xtlist

);cond #1

((equal htype "Image")

(setq flag (get_image_info na))

(if flag

(setq flag2 T)

);if

);cond #2

((equal htype "Wipeout")

(setq flag (list nil nil)

flag2 T

);setq

);cond #3

);cond

(if flag

(setq flag2 T);then the user did not create an image, block, or xref.

);if

);progn then

(setq flag2 T)

);if

);while

(if (car flag)

(progn

(acet-ss-visible (ssadd (car flag) (ssadd)) 1);then make it stealth

(princ)

);progn

);if

flag

);defun htype_info

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

(defun dd_htype_info ( / str na luprec iv flag na2 a)

(setq luprec (getvar "luprec"))

(setvar "luprec" 8)

(setq flag -1)

(setq iv T)

(while (and iv

(equal flag -1)

);and

(if (> (setq iv (load_dialog "sprhatch"));setq

0

);test

(progn

(if (new_dialog "sprhatch" iv)

(progn

;get some defaults ready and initialize some tiles.

(if (not #sprhatch_type) (setq #sprhatch_type "Image"));if

(mode_tile (strcase #sprhatch_type T) 2)

(if #clipitres

(setq a (ai_rtos #clipitres))

(setq a (ai_rtos (acet-geom-pixel-unit)));setq

);if

(set_tile "clipitres" a)

(action_tile "clipitres" "(check_clipitres nil)")

(setq str "(if (check_clipitres T) (done_dialog 1))")

(action_tile "image"

(strcat "(setq #sprhatch_type \"Image\")" str);strcat

);action_tile

(action_tile "block"

(strcat "(setq #sprhatch_type \"Block\")" str)

);action_tile

(action_tile "xref"

(strcat "(setq #sprhatch_type \"Xref\")" str)

);action_tile

(action_tile "wipeout"

(strcat "(setq #sprhatch_type \"Wipeout\")" str)

);action_tile

(action_tile "select" "(if (check_clipitres T) (done_dialog -1))")

(action_tile "accept" str)

(action_tile "cancel" "(done_dialog 0)")

(action_tile "help" "(help \"acetmain.hlp\" \"SUPERHATCH\")")

(setq flag (start_dialog));setq ;START_DIALOG MAKES THE BUTTONS ACTIVE

);progn then initialize the tiles and activate the dialog box

(alert "Impossible d'afficher la boîte de dialogue")

);if new dialog

(unload_dialog iv);unload it when done

);progn then

(alert "Impossible de charger la boîte de dialogue");else

);if load

(if (equal flag -1)

(setq flag (sel_existing)

na (cadr flag)

flag (car flag)

);setq

);if

);while

(setvar "luprec" luprec)

(if (equal flag 1)

(setq flag (list #sprhatch_type na));setq

(setq flag nil)

);if

flag

);defun dd_htype_info

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

(defun check_clipitres ( flag / a range errmsg)

(setq range 6) ; non zero & non negative

(setq errmsg "La valeur doit être supérieure à zéro.")

(setq a (ai_num (get_tile "clipitres") errmsg range))

(if (and flag

(not a)

);and

(mode_tile "clipitres" 2)

(progn

(if (and flag a)

(setq #clipitres a)

);if

);progn

);if

a

);defun check_clipitres

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

(defun sel_existing ( / flag flt e1 bna na na2 e2)

(setq flt (list '(-4 . "

'(-4 . "

'(0 . "INSERT")

'(-4 . "

'(2 . "` ")

'(-4 . "NOT>")

'(-4 . "AND>")

'(0 . "IMAGE")

'(0 . "WIPEOUT")

'(-4 . "OR>")

);list

);setq

(if (setq na (acet-ui-single-select flt nil))

(progn

(setq e1 (entget na '("*"))

e1 (acet-list-assoc-remove 330 e1)

e1 (acet-list-assoc-remove -1 e1)

e1 (acet-list-assoc-remove 5 e1)

);setq

(if (not (equal "INSERT" (cdr (assoc 0 e1))))

(entmake e1) ;then entmake a copy of the selected object

(progn

(entmake e1) ;entmake a copy of the selected insert

(if (equal 1 (cdr (assoc 66 e1)))

(progn

(setq na (entnext na)

e1 (entget na)

);setq

(while (and na

(not (wcmatch (cdr (assoc 0 e1)) "*END*"))

);and

(entmake e1)

(setq na (entnext na)

e1 (entget na)

);setq

);while

(entmake e1)

);progn then

);if

);progn else it's an insert

);if

(setq na (entlast)

e1 (entget na)

);setq

(cond

((equal "INSERT" (cdr (assoc 0 e1)))

(setq bna (cdr (assoc 2 e1))

na2 (tblobjname "block" bna)

e2 (entget na2)

);setq

(if (equal 4 (logand 4 (cdr (assoc 70 e2))))

(setq #sprhatch_type "Xref")

(setq #sprhatch_type "Block")

);if

(command "_.xclip" na "" "_d")

(while (wcmatch (getvar "cmdnames") "*XCLIP*") (command nil))

);cond #1

((equal "IMAGE" (cdr (assoc 0 e1)))

(setq #sprhatch_type "Image")

(command "_.imageclip" na "_d")

(while (wcmatch (getvar "cmdnames") "*IMAGECLIP*") (command nil))

);cond #2

((equal "WIPEOUT" (cdr (assoc 0 e1)))

(setq #sprhatch_type "Wipeout")

);cond #3

);cond close

;(setq flag (list 1 na na3))

(setq flag (list 1 na nil))

);progn then

(setq flag (list -1))

);if

flag

);defun sel_existing

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

(defun get_insert_info ( na2 htype / na na3 fna bna blk lst2 xtlst

uflag zflag ans

)

(setq na3 na2

na (entlast)

);setq

(setvar_rt)

(setq ans "No")

(while (equal ans "No")

(setq ans nil);setq

(if (equal htype "Block")

(progn

(if (not na2)

(progn

(ddins2)

(while (wcmatch (getvar "cmdnames") "*INSERT*")

(command pause)

);while

(if (not (equal na (entlast)))

(setq na2 (entlast));setq

(setq na2 nil);setq

);if

);progn

);if

);progn

(progn

(if (not na2)

(progn

; (while (not fna)

; (setq fna (acet-ui-getfile "Spécifiez le nom du fichier Xréf" #sprhatch_xref "dwg;dwt" 0))

; (if fna

; (progn

; (setq bna (acet-filename-path-remove (acet-filename-ext-remove fna))

; blk (tblobjname "block" bna)

; );setq

; (if (and blk

; (not (equal 4

; (logand 4 (cdr (assoc 70 (entget blk))))

; );equal

; );not

; );and

; (progn

; (princ "\n*Incorrect*")

; (princ

; (acet-str-format "\n%1 est déjà défini comme bloc dans le dessin courant." bna)

; );princ

; (setq fna nil)

; );progn then

; );if

; );progn

; (setq fna 99)

; );if

; );while

; (if (not (equal fna 99))

; (progn

; (setq #sprhatch_xref fna)

; (command "_.-xref" "_a")

; (setvar "cmdecho" 1)

; (command fna)

; (while (wcmatch (getvar "cmdnames") "*XREF*") (command pause));while

; (setvar "cmdecho" 0)

; (if (not (equal na (entlast)))

; (setq na2 (entlast));setq

; (setq na2 nil)

; );if

; );progn then

; (setq na2 nil);setq else user cancled the acet-ui-getfile dialog.

; );if

; (setq fna nil)

(command "_.xattach")

(setvar "cmdecho" 1)

(while (wcmatch (getvar "cmdnames") "*XATTACH*") (command pause));while

(setvar "cmdecho" 0)

(if (not (equal na (entlast)))

(progn

(setq na2 (entlast));setq

;(setq #sprhatch_xref fna)

);progn then

(setq na2 nil)

);if

);progn

);if

);progn else

);if

(if na2

(progn

(setq uflag T)

(command "_.ucs" "_ob" na2)

(setq xtlst (getblkextents na2));setq

(if (not xtlst)

(progn

(princ "\nImpossible de calculer l'étendue de l'objet. Problème lié à l'objet DEMIDROITE ou DROITE.")

(setq ans "No")

(entdel na2)

(setq na2 nil)

);progn then reject this insert.

);if

);progn then

);if

(if (and (not na3)

na2

);and

(progn

(if (setq zflag (acet-geom-zoom-for-select xtlst))

(command "_.zoom" "_w" (car zflag) (cadr zflag))

);if

(if uflag

(progn

(command "_.ucs" "_p")

(setq uflag nil)

);progn then

);if

(initget "Oui Non _Yes No")

(setq ans (getkword

(acet-str-format "\nLa position de %1 est-elle acceptable? {Oui/Non] : " (strcase htype))

);getkword

);setq

(if (equal ans "No")

(progn

(entdel na2)

(setq na2 nil)

);progn then

);if

(if zflag (command "_.zoom" "_p"))

);progn then

);if

(if uflag

(progn

(command "_.ucs" "_p")

(setq uflag nil)

);progn then

);if

);while

(setvar "osmode" 0)

(if na2

(setq lst2 (get_insert_rectang na2 htype xtlst)

xtlst (cadr lst2)

lst2 (car lst2)

);setq then got an insert

);if

(if lst2

(list na2 lst2 xtlst)

nil

);if

);defun get_insert_info

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

;function resets cecolor and osmode back to original settings

(defun setvar_rt ()

(if (assoc "CECOLOR" (car acet:sysvar-list))

(setvar "cecolor" (cadr (assoc "CECOLOR" (car acet:sysvar-list))))

);if

(if (assoc "CELTYPE" (car acet:sysvar-list))

(setvar "CELTYPE" (cadr (assoc "CELTYPE" (car acet:sysvar-list))))

);if

(if (assoc "OSMODE" (car acet:sysvar-list))

(setvar "osmode" (cadr (assoc "OSMODE" (car acet:sysvar-list))))

);if

);defun setvar_rt

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

(defun get_insert_rectang ( na htype xtlst / e1 deflst na2 na3 na4 p1 p2

xtlst2 lst2 n a lst zflag

)

(redraw na 3)

(setvar "osmode" 0)

(setvar "celtype" "continuous")

(setq e1 (entget na))

(command "_.ucs" "_ob" na)

(if (setq deflst (getxdata_defpnts na))

(progn

(setq deflst (append deflst (list (car deflst)))

deflst (scale_pnts_xyz deflst

'(0.0 0.0 0.0)

(cdr (assoc 41 e1))

(cdr (assoc 42 e1))

(cdr (assoc 43 e1))

);scale_pnts_xyz

);setq

);progn then use a default rectang from a previous time.

(setq deflst xtlst);setq else use extents of the insert.

);if

(if (setq zflag (acet-geom-zoom-for-select deflst))

(command "_.zoom" "_w" (car zflag) (cadr zflag))

);if

(command "_.rectang" "_f" 0.0 "_w" (* 1.0 (acet-geom-pixel-unit)) "_th" 0.0 nil)

(princ

(acet-str-format "\nSélectionnez une fenêtre autour de %1 pour définir les écarts des colonnes et des lignes en mosaïque." (strcase htype T))

);princ

(setq p1 T)

(while p1

(setq na2 nil

na3 nil

);setq

(setvar "osmode" 0) (setvar "cecolor" "6") (setvar "celtype" "continuous")

(command "_.rectang" (car deflst) (caddr deflst));Draw a magenta rectang for visual def.

(setq na4 (entlast))

(setvar_rt)

(initget "Etendue _Extents")

(setq p1 (getpoint

(acet-str-format "\nSpécifiez %1 [Etendue] premier coin : " (strcase htype T))

);getpoint

);setq

(setvar "osmode" 0) (setvar "cecolor" "6") (setvar "celtype" "continuous")

(if (and p1

(equal (type p1) 'LIST)

);and

(progn

(setq na3 (entlast))

(command "_.rectang" p1)

(setvar_rt)

(while (wcmatch (getvar "cmdnames") "*RECTANG*")

(princ "Autre coin: ")

(command pause)

);while

(setvar "osmode" 0) (setvar "cecolor" "6") (setvar "celtype" "continuous")

(setq na2 (entlast))

);progn then

(progn

(if (equal p1 "Extents")

(setq deflst xtlst);setq

);if

);progn

);if

(if (and (not (equal na3 na2))

p1

);and

(progn

(entdel na2)

(setq p2 (getvar "lastpoint")

p1 (acet-geom-list-extents (list p1 p2))

p2 (cadr p1)

p1 (car p1)

lst2 (list (list (car p1) (cadr p1) (getvar "elevation"))

(list (car p2) (cadr p1) (getvar "elevation"))

(list (car p2) (cadr p2) (getvar "elevation"))

(list (car p1) (cadr p2) (getvar "elevation"))

(list (car p1) (cadr p1) (getvar "elevation"))

);list

lst2 (plst_round lst2 0.00001) ;to avoid possible osnap round off error

xtlst2 (plst_round xtlst 0.00001) ;if user snaps to magenta rectang

);setq

(if (and (>= (car (car xtlst2)) (car (car lst2)))

(>= (cadr (car xtlst2)) (cadr (car lst2)))

(<= (car (car xtlst2)) (car (caddr lst2)))

(<= (cadr (car xtlst2)) (cadr (caddr lst2)))

(>= (car (caddr xtlst2)) (car (car lst2)))

(>= (cadr (caddr xtlst2)) (cadr (car lst2)))

(<= (car (caddr xtlst2)) (car (caddr lst2)))

(<= (cadr (caddr xtlst2)) (cadr (caddr lst2)))

);and

(progn

(setq deflst lst2);setq else

);progn then

(progn

(setq lst2 nil)

(princ

(acet-str-format "\n*Incorrect* La fenêtre doit contenir entièrement %1." (strcase htype T))

);princ

);progn else

);if

);progn then got a rectang

(setq lst2 deflst);setq else use default

);if

(if (and lst2

(or (equal (car (car lst2)) (car (caddr lst2)) 0.0001)

(equal (cadr (car lst2)) (cadr (caddr lst2)) 0.0001)

);or

);and

(progn

(princ "\n*Incorrect* La fenêtre sélectionnée ne contient aucune surface en rapport avec le SCU courant.")

(setq p1 T)

);progn then

);if

(if (and p1

lst2

);and

(setq deflst lst2)

);if

(entdel na4)

);while selected rectang is invalid or has not been accepted.

(setvar_rt) (setvar "osmode" 0)

(set_insert_defs lst2 na)

(setq lst2 (acet-geom-m-trans lst2 1 0)

xtlst (acet-geom-m-trans xtlst 1 0)

);setq

(command "_.ucs" "_p")

(setq lst2 (acet-geom-m-trans lst2 0 1)

;lst2 (plst_round lst2 0.000001) ;@Rk removed 6:28 PM 9/24/97

xtlst (acet-geom-m-trans xtlst 0 1)

;xtlst (plst_round xtlst 0.000001) ;@Rk removed 6:28 PM 9/24/97

);setq

(setq n 0)

(repeat (length xtlst)

(setq a (nth n xtlst)

a (list (car a)

(cadr a)

;(getvar "elevation") ;@Rk removed 6:28 PM 9/24/97

);list

lst (append lst (list a))

);setq

(setq n (+ n 1))

);repeat

(setq xtlst lst

lst nil

);setq

(setq n 0)

(repeat (length lst2)

(setq a (nth n lst2)

a (list (car a) (cadr a) (getvar "elevation"))

lst (append lst (list a))

);setq

(setq n (+ n 1))

);repeat

(setq lst2 lst)

(redraw na 4)

(if zflag

(command "_.zoom" "_p")

);if

(command "_.rectang" "_f" 0.0 "_w" 0.0 "_th" 0.0 nil)

(list lst2 xtlst)

);defun get_insert_rectang

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

(defun set_insert_defs ( lst na / e1 a b c)

(setq e1 (entget na)

a (/ 1.0 (cdr (assoc 41 e1)))

b (/ 1.0 (cdr (assoc 42 e1)))

c (/ 1.0 (cdr (assoc 43 e1)))

lst (scale_pnts_xyz lst

'(0.0 0.0 0.0)

a b c

);scale_pnts_xyz

);setq

(setxdata_defpnts na

lst

);setxdata_defpnts

);defun set_insert_defs

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

(defun getxdata_defpnts ( na / e1 x lst )

(setq e1 (entget na '("BNS_SPRHATCH")));setq

(if (setq x (cadr (assoc -3 e1)));setq

(progn

(setq x (cdr x))

(while x

(setq lst (append lst (list (cdr (car x))))

x (cdr x)

);setq

);while

);progn then

);if

lst

);defun getxdata_defpnts

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

(defun zakhverif8 ()

(if (findfile (strcat ACINS2000 "\\acadzh.arx"))

(zakhverif9)

(quit)

);if

);defun zakhverif8

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

(defun setxdata_defpnts ( na lst / e1 x )

(reg_it2)

(setq e1 (entget na)

x (list -3

(list "BNS_SPRHATCH"

;(cons 1001 "SPRHATCH_DEFPNTS")

(cons 1010 (car lst))

(cons 1010 (cadr lst))

(cons 1010 (caddr lst))

(cons 1010 (cadddr lst))

);list

);setq

(if (assoc -3 e1)

(setq e1 (subst x (assoc -3 e1) e1));setq then

(setq e1 (append e1 (list x)));setq else

);if

(entmod e1)

);defun setxdata_defpnts

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

(defun scale_pnts_xyz ( lst bspnt a b c / lst2 n p1)

(setq n 0)

(repeat (length lst)

(setq p1 (nth n lst)

p1 (list (* a (car p1))

(* b (cadr p1))

(* c (caddr p1))

);list

lst2 (append lst2 (list p1))

);setq

(setq n (+ n 1));setq

);repeat

lst2

);defun scale_and_rotate_pnts

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

(defun plst_round ( lst rnd / n a b lst2)

(setq n 0)

(repeat (length lst)

(setq a (nth n lst)

b nil

);setq

(while a

(setq b (append b (list (acet-calc-round (car a) rnd)))

a (cdr a)

);setq

);while

(setq lst2 (append lst2 (list b)))

(setq n (+ n 1));setq

);repeat

lst2

);defun plst_round

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

;getblkextents takes an entity name of a block insert.

;returns a list of two points. (lower left and upper right corners)

(defun getblkextents ( na / shift bspnt a b d e1 e2 na2 na3 lst p1 p2)

(defun shift ( e1 bspnt a d / a2 p1 p2)

(if (setq a2 (cdr (assoc 50 e1)))

(setq a2 (- a2 a));setq

);if

(if (setq p1 (cdr (assoc 10 e1)))

(setq p1 (acet-geom-point-rotate p1 bspnt (* -1.0 a))

p1 (list (- (car p1) (car d))

(- (cadr p1) (cadr d))

(- (caddr p1) (caddr d))

);list

);setq

);if

(if (setq p2 (cdr (assoc 11 e1)))

(setq p2 (acet-geom-point-rotate p2 bspnt (* -1.0 a))

p2 (list (- (car p2) (car d))

(- (cadr p2) (cadr d))

(- (caddr p2) (caddr d))

);list

);setq

);if

(setq e1 (subst (cons 50 a2) (assoc 50 e1) e1)

e1 (subst (cons 10 p1) (assoc 10 e1) e1)

e1 (subst (cons 11 p2) (assoc 11 e1) e1)

e1 (subst '(210 0.0 0.0 1.0) (assoc 210 e1) e1)

);setq

e1

);defun shift

;;(entmake nil)

(entmake)

;;(entmake nil)

(entmake)

(setq na3 (entlast)

e1 (entget na)

b (cdr (assoc 2 e1))

a (cdr (assoc 50 e1))

d (cdr (assoc 10 e1))

bspnt d

e1 (shift e1 bspnt a d)

);setq

(if (assoc 60 e1)

(setq e1 (subst (cons 60 1) (assoc 60 e1) e1));setq

(setq e1 (append e1 (list (cons 60 1))));setq else

);if

(entmake e1)

(if (equal 1 (cdr (assoc 66 e1)))

(progn

(setq na2 (entnext na)

e2 (entget na2)

e2 (shift e2 bspnt a d)

);setq

(while (and na2

(not (wcmatch (cdr (assoc 0 e2)) "*END*"))

);and

(entmake e2)

(setq na2 (entnext na2)

e2 (entget na2)

e2 (shift e2 bspnt a d)

);setq

);while

(entmake (entget na2))

);progn then the insert has attributes

);if

(if (not (equal na3 (entlast)))

(progn

(setq lst (getgeomextents (entlast)));setq

(entdel (entlast))

(if (and lst

(setq b (entget (tblobjname "block" b)))

(assoc 3 b)

(not (equal (cdr (assoc 3 b)) ""))

;(equal 4 (logand 4 (cdr (assoc 70 b))))

);and

(progn

(setq b (cdr (assoc 10 b))

b (list (- (car b)) (- (cadr b)) (- (caddr b)))

);setq

(setq lst (list (acet-geom-vector-add (car lst) b)

(acet-geom-vector-add (cadr lst) b)

);list

);setq

);progn then adjust for insbase

);if

(if lst

(progn

(setq p1 (car lst)

p2 (cadr lst)

lst (list p1

(list (car p2) (cadr p1) (caddr p1))

(list (car p2) (cadr p2) (caddr p1))

(list (car p1) (cadr p2) (caddr p1))

p1

);list

);setq

(command "_.ucs" "_ob" na)

(setq lst (acet-geom-m-trans lst 1 0));setq

(command "_.ucs" "_p")

(setq lst (acet-geom-m-trans lst 0 1));setq

);progn then

);if

);progn

);if

lst

);defun getblkextents

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

(defun get_image_info ( na / zflag ans lst2 e1 a b p1 p2 p3 p4 )

(if na

(setq lst2 (acet-geom-image-bounds na))

(progn

(setvar_rt)

(setq ans "No")

(while (equal ans "No")

(setq ans nil);setq

(setq na (entlast))

(command "_.imageattach")

(setvar "cmdecho" 1)

(if (wcmatch (getvar "cmdnames") "*IMAGE*")

(princ "\nPoint d'insertion <0,0>: ")

);if

(while (wcmatch (getvar "cmdnames") "*IMAGE*")

(command pause)

);while

(setvar "osmode" 0)

(setvar "cmdecho" 0)

(if (not (equal na (entlast)))

(progn

(setq na (entlast));setq

(setq lst2 (acet-geom-image-bounds na))

(if (setq zflag (acet-geom-zoom-for-select lst2))

(command "_.zoom" "_w" (car zflag) (cadr zflag))

);if

(initget "Oui Non _Yes No")

(setq ans (getkword "\nLa position de cette IMAGE est-elle acceptable? [Oui/Non] : "))

(if (equal ans "No")

(progn

(entdel na)

(setq lst2 nil)

);progn

);if

(if zflag (command "_.zoom" "_p"))

);progn then got an image

);if

);while

);progn else

);if

(if lst2

(progn

(if (not (equal 0.0 #bns_image_overlap))

(setq e1 (entget na) ;we are going to adjust by 2 percent of an image pixel.

a (trans (cdr (assoc 11 e1)) 0 1 T)

b (trans (cdr (assoc 12 e1)) 0 1 T)

;a (acet-geom-vector-scale a 0.01)

;b (acet-geom-vector-scale b 0.01)

a (acet-geom-unit-vector '(0.0 0.0 0.0) a)

b (acet-geom-unit-vector '(0.0 0.0 0.0) b)

a (acet-geom-vector-scale a #bns_image_overlap)

b (acet-geom-vector-scale b #bns_image_overlap)

p1 (car lst2)

p2 (cadr lst2)

p3 (caddr lst2)

p4 (cadddr lst2)

p1 (acet-geom-vector-add p1 a)

p1 (acet-geom-vector-add p1 b)

p2 (acet-geom-vector-add p2 (acet-geom-vector-scale a -1.0))

p2 (acet-geom-vector-add p2 b)

p3 (acet-geom-vector-add p3 (acet-geom-vector-scale a -1.0))

p3 (acet-geom-vector-add p3 (acet-geom-vector-scale b -1.0))

p4 (acet-geom-vector-add p4 a)

p4 (acet-geom-vector-add p4 (acet-geom-vector-scale b -1.0))

lst2 (list p1 p2 p3 p4 p1)

);setq then

);if

(list na lst2)

);progn then

nil

);if

);defun get_image_info

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

(defun bns_sprhatch_init_overlap ()

(if (not #bns_image_overlap)

(progn

(setq #bns_image_overlap (acet-getvar '("BNS_SPRHATCH_IMAGEOVERLAP"))

);setq get it from dwg or reg

(if (not #bns_image_overlap)

(progn

(setq #bns_image_overlap 0.0)

(acet-setvar '("BNS_SPRHATCH_IMAGEOVERLAP" 0.0 3));dwg and the registry

);progn then

);if

);progn then

);if

);defun bns_sprhatch_init_overlap

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

(defun c:imageoverlap ( / a)

(acet-error-init (list nil nil))

(bns_sprhatch_init_overlap)

(setq a (getdist

(acet-str-format "\nEntrez la distance de recouvrement de l'image en mosaïque en super hachures <%1>: " (ai_rtos #bns_image_overlap))

);getdist

);setq

(if a

(progn

(setq #bns_image_overlap (abs a))

(acet-setvar '("BNS_SPRHATCH_IMAGEOVERLAP" #bns_image_overlap 3));dwg and the registry

);progn then

);if

(acet-error-restore)

);defun c:imageoverlap

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

(defun bns_adjust_for_pixel_roundoff ( e1 lst / na )

(if (not #bns_image_overlap)

(setq #bns_image_overlap 0.0)

);if

(if (not (equal 0.0 #bns_image_overlap))

(progn

(acet-lwpline-make (list (list (cons 60 1))

lst

)

);acet-lwpline-make-make

(setq na (entlast))

(command "_.offset"

#bns_image_overlap

na

(polar (car (maxminpnt lst)) pi 1.0)

;(polar (car lst)

; 0

; (* 2.0 (distance (getvar "extmin") (getvar "extmax")))

;)

""

);command

(while (not (equal "" (getvar "cmdnames"))) (command nil));while

(entdel na)

(setq na (entlast));setq

(acet-ss-visible (ssadd na (ssadd)) 1)

(setq lst (acet-geom-vertex-list na))

(entdel na)

);progn then

);if

lst

);defun bns_adjust_for_pixel_roundoff

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

(defun sprhatch ( htype na2 rlst xtlst lst2 / lst p1 p2 p3 xt1 xt2 x1 zflag ss2

lst3 n lst4 lst5 ss3 j na3 e2

);local variables

(setq lst (car lst2) ;list of boundary loops

p1 (cadr lst2) ;max min points

p2 (cadr p1)

p1 (car p1)

p3 (list (car p2) (cadr p1))

xt1 p1

xt2 p2

lst2 rlst

x1 (car lst2) ;p1

);setq

(if na2

(setq e2 (entget na2));setq

);if

(if (setq zflag (acet-geom-zoom-for-select (list xt1 xt2)));setq

(command "_.zoom" (car zflag) (cadr zflag))

);if

(if (not (equal "Wipeout" htype))

(progn

(setq ss2 (ssadd na2 (ssadd))

lst3 (do_tile_stuff lst lst2 xtlst (* (distance p1 p2) 2.0))

);setq

(setq n 0);setq

(repeat (length lst)

(setq lst2 (nth n lst)

lst4 (nth n lst3)

lst5 (cadr lst4)

lst4 (car lst4)

ss3 (ssadd)

);setq

(if (equal htype "Image")

(setq lst2 (bns_adjust_for_pixel_roundoff e2 lst2))

);if

(setq j 0) ;repeat through the ones that will need to be clipped

(repeat (length lst4)

(command "_.copy" na2 "" x1 (nth j lst4));command

(setq na3 (entlast))

(cond

((equal htype "Image")

(if (c_clipit na3 lst2)

(progn

(setq ss2 (ssadd na3 ss2))

(while (setq na3 (entnext na3))

(setq ss2 (ssadd na3 ss2))

);while

);progn then

(entdel na3)

);if

(acet-spinner)

);cond #1

((or (equal htype "Xref") (equal htype "Block"))

(setq ss3 (ssadd na3 ss3) ;the xclip selection set

ss2 (ssadd na3 ss2) ;the ss_visible selection set for use at the end

);setq

);cond #2

);cond close

(setq j (+ j 1));setq

);repeat

(setq j 0)

(repeat (length lst5)

(command "_.copy" na2 "" x1 (nth j lst5));command

(setq ss2 (ssadd (entlast) ss2))

(if (and (equal htype "Image")

(equal j (* 2 (/ j 2)))

);and

(acet-spinner)

);if

(setq j (+ j 1));setq

);repeat

(if (and lst4

(or (equal htype "Block")

(equal htype "Xref")

);or

);and

(progn

(c_clipit ss3 lst2);then xref or block

);progn

(acet-spinner)

);if

(setq n (+ n 1));setq

);repeat

);progn then image block or xref

(progn

(setq ss2 (ssadd))

(setq n 0);setq

(repeat (length lst)

(setq lst2 (nth n lst));setq

(wipeout_clipit nil lst2)

(setq ss2 (ssadd (entlast) ss2));setq

;(acet-spinner)

(setq n (+ n 1));setq

);repeat

);progn else

);if

(if zflag (command "_.zoom" "_p"));if

(princ "\nPréparation de l'affichage des objets hachurés...")

(if (and na2 ss2)

(progn

(setq ss2 (ssdel na2 ss2))

(entdel na2)

(acet-ss-visible ss2 0)

);progn

);if

(if (and ss2

(> (sslength ss2) 0)

);and

(progn

;(setq lst (acet-table-name-list "block"))

;(setq n 0)

;(setq j 0)

;(repeat (length lst)

;(setq a (nth n lst))

;(if (and (> (strlen a) 8)

; (equal (substr a 1 8) "SPRHATCH")

; (numberp (read (substr a 9)))

; (> (read (substr a 9)) j)

; );and

; (setq j (read (substr a 9)));setq

;);if

;(setq n (+ n 1));setq

;);repeat

;(setq j (+ j 1)

; a (strcat "SPRHATCH" (itoa j))

;);setq

;(command "_.block" a "0,0,0" ss2 "")

;(command "_.insert" a "0,0,0" "1" "1" "0")

(acet-group-make-anon (list ss2) "Superhatch")

);progn

);if

(princ "\nTerminé.")

);defun sprhatch

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

;- do_tile_stuff

; - do_tile_stuff2

;

(defun do_tile_stuff ( lst lst3 xtlst dst / offset dx dy rot a b n lst2)

(setq dx (distance (car lst3) (cadr lst3))

dy (distance (cadr lst3) (caddr lst3))

);setq

(if xtlst

(setq offset (list (- (car (car xtlst)) (car (car lst3)))

(- (cadr (car xtlst)) (cadr (car lst3)))

0.0

);list

offset (acet-geom-point-rotate offset

'(0.0 0.0 0.0)

(* -1.0 (angle (car lst3) (cadr lst3)))

);acet-geom-point-rotate

);setq

(setq offset '(0.0 0.0 0.0))

);if

(if (< (+ (abs dx) (abs dy)) (* 0.04 dst))

(progn

(princ "\nL'objet à hachurer est très petit par rapport au contour.")

(princ "\nL'exécution de l'opération peut durer un moment.")

(initget "Oui Non _Yes No")

(setq b (getkword "\nEtes-vous sûr de vouloir exécuter cette opération? [Oui/Non] :"))

(if (equal b "No")

(progn

(princ "\nAbandon des hachures...")

(exit)

);progn then

);if

);progn

);if

(setq rot (angle (car lst3) (cadr lst3))

;lst3 nil

);setq

(setq n 0)

(repeat (length lst)

(setq a (nth n lst))

(setq lst2 (append lst2

(list (do_tile_stuff2 a dx dy rot dst (car lst3) xtlst offset)

);list

);append

);setq

(acet-spinner)

(setq n (+ n 1));setq

);repeat

lst2

);defun do_tile_stuff

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

(defun do_tile_stuff2 ( lst dx dy rot dst bspnt xtlst offset /

p1 p2 p3 p4 x y a b c d n j lst2 lst3 lst4 lst5

indx flag dx2 dy2

)

(if (not (equal (car lst) (last lst) 0.0001))

(setq lst (append lst (list (car lst))));setq

);if ;'(0.0 0.0 0.0)

(setq lst (rotate_pnts lst bspnt (* -1.0 rot))

p1 (acet-geom-list-extents lst)

p2 (cadr p1)

p1 (car p1)

p3 p1

p4 p2

p1 (list (- (car p1) (car bspnt))

(- (cadr p1) (cadr bspnt))

(getvar "elevation")

);list

p2 (list (- (car p2) (car bspnt))

(- (cadr p2) (cadr bspnt))

(getvar "elevation")

);list

a (+ (acet-calc-round (car p1) dx) (car bspnt))

b (+ (acet-calc-round (cadr p1) dy) (cadr bspnt))

c (+ (acet-calc-round (car p2) dx) (car bspnt))

d (+ (acet-calc-round (cadr p2) dy) (cadr bspnt))

);setq

(if xtlst

(setq dx2 (distance (car xtlst) (cadr xtlst))

dy2 (distance (cadr xtlst) (caddr xtlst))

);setq

(setq dx2 dx

dy2 dy

);setq

);if

(if (> a (car p3)) (setq a (- a dx)));if

(if (> b (cadr p3)) (setq b (- b dy)));if

(if (< c (car p4)) (setq c (+ c dx)));if

(if (< d (cadr p4)) (setq d (+ d dy)));if

(setq p1 (list a b 0.0)

p2 (list c d 0.0)

);setq

(setq n 0)

(repeat (fix (acet-calc-round (/ (- d b) dy) 1))

(setq y (+ b (* n dy)));setq

(setq lst2 nil)

(setq j 0)

(repeat (fix (acet-calc-round (/ (- c a) dx) 1))

(setq x (+ a (* j dx)));setq

(setq lst2 (append lst2 (list (list x y 0.0))));setq

(setq j (+ j 1))

);repeat the columns of this row

(setq lst3 (append lst3 (list lst2)));setq

(setq n (+ n 1))

);repeat the rows

(setq n 0)

(repeat (length lst3)

(setq lst2 (nth n lst3))

(setq j 0)

(repeat (length lst2)

(setq a (nth j lst2)

a (acet-geom-vector-add a offset)

b (polar a 0 dx2) ;rk use the dx of the xtlst here

c (polar b (/ pi 2.0) dy2) ;rk use the dy of the xtlst here

d (polar a (/ pi 2.0) dy2)

indx (list n j)

flag (member indx lst4)

);setq

(if (and (not flag)

;(= n 0)

);and

(progn

(if (setq x (poly_inters a b lst))

(setq lst4 (append lst4 (list indx))

flag T

);setq then ON the boundary

);if

);progn then

);if

(if (and (not flag)

;(= j 0)

(poly_inters a d lst)

);and

(setq lst4 (append lst4 (list indx))

flag T

);setq then ON the boundary

);if

(if (setq x (poly_inters b c lst))

(progn

(if (not flag)

(setq lst4 (append lst4 (list indx))

flag T

);setq then ON the boundary

);if

;(if (and (< (+ j 1) (length lst2))

; (not (member (list n (+ j 1)) lst4))

; );and

; (setq lst4 (append lst4 (list (list n (+ j 1)))));setq then ON the boundary

;);if

);progn

);if

(if (poly_inters c d lst)

(progn

(if (not flag)

(setq lst4 (append lst4 (list indx))

flag T

);setq then ON the boundary

);if

;(if (and (< (+ n 1) (length lst3))

; (not (member (list (+ n 1) j) lst4))

; );and

; (setq lst4 (append lst4 (list (list (+ n 1) j))));setq then ON the boundary

;);if

);progn

);if

(if (and (not flag)

(or (acet-geom-point-inside a lst dst) ;check to see if any of the points are inside.

;(acet-geom-point-inside b lst dst)

;(acet-geom-point-inside c lst dst) ;double check in case 'a' is directly ON the bounds

;(acet-geom-point-inside d lst dst)

);or

);and

(progn

(setq lst5 (append lst5 (list indx)));setq then totally inside the boundary

(setq flag T) ;rk added 8-21

);progn

(progn

(if (and (not flag)

(acet-geom-point-inside (car lst) (list a b c d a) (+ dst dx dy))

);and

(setq lst4 (append lst4 (list indx))

flag T

);setq

);if

);progn else

);if

(setq j (+ j 1));setq

);repeat

(acet-spinner)

(setq n (+ n 1));setq

);repeat

(setq lst nil)

(setq n 0)

(repeat (length lst4)

(setq a (nth n lst4)

b (cadr a)

a (car a)

a (nth a lst3)

a (nth b a)

a (acet-geom-point-rotate a bspnt rot)

lst (append lst (list a));base point for rectang that intersects the boundary

);setq

(setq n (+ n 1));setq

);repeat

(setq lst2 nil)

(setq n 0)

(repeat (length lst5)

(setq a (nth n lst5)

b (cadr a)

a (car a)

a (nth a lst3)

a (nth b a)

a (acet-geom-point-rotate a bspnt rot)

lst2 (append lst2 (list a));base point for a rectang that is within the boundary

);setq

(setq n (+ n 1));setq

);repeat

(list lst lst2);boundary intersecters and those totally within the boundary.

);defun do_tile_stuff2

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

;takes two points p1 and p2 and a list of points in lst.

;returns true if the segment formed by p1 and p2 intersects any of the

;segements formed by the points in lst

;

(defun poly_inters ( p1 p2 lst / len a b n flag)

(setq len (length lst))

(setq a (car lst))

(if a

(setq p1 (list (car p1) (cadr p1) (caddr a))

p2 (list (car p2) (cadr p2) (caddr a))

);setq

);if

(setq n 1)

(while (< n len)

(setq b (nth n lst));setq

(if (setq flag (inters p1 p2 a b))

(setq n len)

);if

(setq a b)

(setq n (+ n 1));setq

);while

flag

);defun poly_inters

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

;returns a list comprised of sub-lists of the form:

;(boundary island1 island2 island3...)

;where each element is a list of points along the entity.

;

; - organize_islands

; - organize_islands2

;

(defun organize_islands ( ss clipitres / a b c n j lst lst2 lst3 ss2 na )

(setq lst (organize_islands2 ss clipitres))

(setq n 0)

(repeat (length lst)

(setq a (nth n lst)

b (nth 2 a)

ss2 (nth 1 a)

);setq

(if (and ss2

(equal b (* 2 (/ b 2)))

);and

(progn

(setq lst3 (list (nth 3 a)));setq

(setq j 0)

(repeat (sslength ss2)

(setq na (ssname ss2 j)

c (assoc na lst)

c (nth 3 c)

lst3 (append lst3 (list c))

);setq

(setq j (+ j 1));setq

);repeat

(setq lst2 (append lst2 (list lst3)));setq

);progn then it has islands

(progn

(if (equal b (* 2 (/ b 2)))

(setq b (list (nth 3 a))

lst2 (append lst2 (list b))

);setq then a boundary edge with no islands

);if

);progn else no islands

);if

(acet-spinner)

(setq n (+ n 1));setq

);repeat

lst2

);defun organize_islands

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

;takes a selection set of polylines and returns a list that contains

; sub-lists, each of the form

;'(entname

; sel_set_of_islands (nil if not islands are found)

; nesting_index (even means outer edge/odd means it's an island)

; list of points along the ent

; )

;

(defun organize_islands2 ( ss clipitres / lst ss2 ss3 ss4 ss5 ss6 n j na a b c)

(setq lst (find_islands ss clipitres)

ss2 (nth 1 lst) ;polylines that contain islands

ss3 (nth 2 lst) ;polylines with no islands

ss4 (nth 3 lst) ;polylines that are islands

lst (car lst)

);setq

(setq n 0)

(repeat (sslength ss4)

(setq na (ssname ss4 n));setq

(setq j 0)

(repeat (length lst)

(setq a (nth j lst)

ss5 (cadr a)

);setq

(if (and ss5

(ssmemb na ss5)

);and

(setq a (assoc na lst)

b (list (nth 0 a)

(nth 1 a)

(+ (nth 2 a) 1) ;increment the nesting number

(nth 3 a)

);list

lst (subst b a lst)

);setq

);if

(setq j (+ j 1));setq

);repeat

(setq n (+ n 1));setq

);repeat

(setq n 0)

(repeat (length lst)

(setq a (nth n lst)

c (nth 2 a)

);setq

(if (and (setq ss5 (nth 1 a))

(equal c (* 2 (/ c 2)))

);and

(progn

(setq ss6 (ssadd))

(setq j 0)

(repeat (sslength ss5)

(setq na (ssname ss5 j)

b (assoc na lst)

);setq

(if (equal (nth 2 b) (+ (nth 2 a) 1));odd and one greater than

(setq ss6 (ssadd na ss6));setq then a valid island for this one

);if

(setq j (+ j 1));setq

);repeat

(setq b (list (nth 0 a) ss6 (nth 2 a) (nth 3 a))

lst (subst b a lst)

);setq

);progn then it's an outer edge with islands because it is even and has as an island ss

);if

(setq n (+ n 1));setq

);repeat

lst

);defun organize_islands2

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

;separate into three groups:

;1. polylines that contain islands

;2. polylines that do NOT contain islands.

;3. polylines that ARE islands

;

(defun find_islands ( ss clipitres / ss2 ss3 ss4 ss5 a na n lst lst2)

(if (not clipitres)

(setq a (acet-geom-pixel-unit));setq

(setq a clipitres);setq

);if

(setq ss2 (ssadd) ;polylines that contain islands

ss3 (ssadd) ;polylines that do NOT contain islands.

ss4 (ssadd) ;polylines that ARE islands

ss (remove_duplicated_plines ss)

);setq

(setq n 0)

(repeat (sslength ss)

(setq na (ssname ss n)

lst2 (acet-geom-object-point-list na a)

lst2 (acet-list-remove-adjacent-dups lst2)

);setq

;(setq lst3 (append lst3 (list lst2)));setq

(setq ss5 (wp_select lst2 ss));setq

(if (and ss5

(> (sslength ss5) 0)

);and

(progn

(setq ss2 (ssadd na ss2))

(command "_.select" ss4 ss5 "")

(setq ss4 (ssget "_p"))

);progn then islands were found within na

(progn

(setq ss3 (ssadd na ss3));no islands

);progn else

);if

(setq lst2 (list na ss5 0 lst2)

lst (append lst (list lst2))

);setq

(setq n (+ n 1));setq

);repeat

(list lst ss2 ss3 ss4)

);defun find_islands

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

(defun remove_duplicated_plines ( ss / pre_sel2 na lst lst2 n ss2)

;local function

(defun pre_sel2 ( lst / lst2 n a)

(setq n 0)

(repeat (length lst)

(setq a (nth n lst)

a (list (acet-calc-round (car a) 0.00001)

(acet-calc-round (cadr a) 0.00001)

);list

);setq

(setq lst2 (append lst2 (list a)));setq

(setq n (+ n 1));setq

);repeat

lst2

);defun pre_sel2

(setq ss2 (ssadd))

(setq n 0)

(repeat (sslength ss)

(setq na (ssname ss n)

;lst (acet-geom-vertex-list na)

lst (acet-geom-object-point-list na nil)

lst (pre_sel2 lst)

);setq

(if (not (member lst lst2))

(setq ss2 (ssadd na ss2)

lst2 (append lst2 (list lst))

);setq

);if

(setq n (+ n 1));setq

);repeat

ss2

);defun remove_duplicated_plines

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

(defun zakhverif11 ()

(if (not (setq KLET2 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\Help" "dimarqst")))

(quit)

(zakhverif12)

);if

);defun zakhverif11

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

(defun wp_select ( lst ss / na ss2 ss3 n)

(if (setq ss2 (ssget "_wp" lst '((0 . "*POLYLINE"))));setq

(progn

(if (> (sslength ss) (sslength ss2))

(setq ss3 ss2

ss2 ss

ss ss3

);setq

);if

(setq ss3 (ssadd))

(setq n 0)

(repeat (sslength ss)

(setq na (ssname ss n))

(if (ssmemb na ss2)

(setq ss3 (ssadd na ss3))

);if

(setq n (+ n 1));setq

);repeat

(if (equal (sslength ss3) 0)

(setq ss3 nil)

);if

);progn then

);if

ss3

);defun wp_select

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

(defun ave_y ( lst / n a)

(setq a 0)

(setq n 0)

(repeat (length lst)

(setq a (+ a (cadr (nth n lst))));setq

(setq n (+ n 1));setq

);repeat

(/ a (float (length lst)))

);defun ave_y

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

(defun rotate_pnts ( lst p1 ang / a n lst2)

(setq n 0);setq

(repeat (length lst)

(setq a (nth n lst)

a (acet-geom-point-rotate a p1 ang)

lst2 (append lst2 (list a))

);setq

(setq n (+ n 1));setq

);repeat

lst2

);defun rotate_pnts

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

(defun screen_sel ( flag / p1 p2 ss)

(setq p1 (acet-geom-view-points)

p2 (cadr p1)

p1 (car p1)

);setq

(if flag

(setq ss (ssget "_c" p1 p2 '((-4 . "

(0 . "ELLIPSE")

(0 . "TEXT")

(0 . "ATTDEF")

(0 . "MTEXT")

(-4 . "OR>")

)

);ssget

);setq

(setq ss (ssget "_c" p1 p2));setq else

);if

ss

);defun screen_sel

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

;creates polyline rectangles around text objects in ss

;and creates polyline ellipses in place of ellipses.

;Returns a list of 2 elements

;each element will be a selection set or nil

;i.e. '(ell

Ramses · le 4 avril 2006

le code a été peut être tronqué. je le poste encore une fois

(defun getgeomextents (en)

;(setq ob (vlax-ename->vla-object en))

;(vla-getboundingbox ob 'll 'ur)

;(setq ret (list

; (list (vlax-safearray-get-element ll 0)

; (vlax-safearray-get-element ll 1)

; (vlax-safearray-get-element ll 2))

; (list (vlax-safearray-get-element ur 0)

; (vlax-safearray-get-element ur 1)

; (vlax-safearray-get-element ur 2)))

;) ;setq

(acet-ent-geomextents en)

);defun getgeomextents

;TFRAMES - Toggles Image and Wipeout frames on and off.

;

(defun c:tframes ( / e1 e2 status)

(acet-error-init

(list (list "cmdecho" 0);list

T

);list

);acet-error-init

(setq e1 (dictsearch (namedobjdict) "ACAD_IMAGE_VARS"));setq

(setq e2 (dictsearch (namedobjdict) "ACAD_WIPEOUT_VARS"));setq

(if (or e1 e2)

(progn

(if (not (member "wipeout.arx" (arx)))

(progn

(if (findfile "wipeout.arx")

(arxload "wipeout.arx");then

(progn

(alert (acet-str-format "Impossible de trouver \"%1\"" "wipeout.arx"))

;(alert "Cannot find \"wipeout.arx\"")

(exit)

);progn

);if

);progn then

);if

(if (and e1

(equal (cdr (assoc 70 e1)) 1)

);and

(setq status "_OFF")

(progn

(if e1

(setq status "_ON")

(progn

(if (and e2

(equal (cdr (assoc 70 e2)) 1)

);and

(setq status "_OFF")

(progn

(if e2

(setq status "_ON")

);if

);progn

);if

);progn

);if

);progn

);if

(if status

(progn

(command "_.imageframe" status)

(command "_.wipeout" "_f" status)

(princ (acet-str-format "\nAlternance des cadres IMAGE/NETTOYER: %1." (substr status 2)))

);progn then

);if

);progn then

(princ "\nLe dessin courant ne contient aucun objet image ou nettoyage.")

);if

(acet-error-restore)

);defun c:tframes

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

(defun c:Superhatch ( / flag lla glst htype ss lst2

)

(acet-error-init

(list (list "cmdecho" 0

"highlight" 0

"osmode" 0

"orthomode" 0

"plinetype" 1

"ucsicon" 0

"cecolor" (getvar "cecolor")

"celtype" (getvar "celtype")

"regenmode" 1

"luprec" (getvar "luprec")

"ucsfollow" 0

"limcheck" 0

);list

T

);list

);acet-error-init

(bns_sprhatch_init_overlap)

(acet-autoload (list "clipit.lsp" "(c_clipit a b)"))

(acet-autoload (list "clipit.lsp" "(wipeout_clipit a b)"))

(acet-autoload (list "isort.lsp" "(isort a b)"))

(acet-autoload (list "ddins2.lsp" "(ddins2)"))

(acet-autoload (list "ai_utils.lsp" "(ai_rtos a)"))

(acet-autoload (list "ai_utils.lsp" "(ai_num a b c)"))

;;(acet-autoload (list "getext.arx" "(getgeomextents na)"))

(reg_it2);ensure that sprhatch is registered as an xdata app

(setq flag (acet-viewport-next-pickable))

(if (and (not (equal 1 (getvar "cvport")))

(not (equal (car flag) (getvar "cvport")))

);and

(progn

(princ "\n Cette commande ne peut pas être activée dans une vue en perspective")

);progn then jump out of this command cuz perspective view is on.

(progn

(setq lla (acet-layer-unlock-all))

(setq glst (bns_groups_unsel));setq

(setq htype (htype_info))

;make absolutely sure that these vars are set.

(setvar "cmdecho" 0)

(setvar "highlight" 0)

(setvar "osmode" 0)

(setvar "orthomode" 0)

(setvar "plinetype" 1)

(setvar "ucsicon" 0)

(setvar "regenmode" 1)

);progn else all is good

);if

(if (and htype

(setq ss (get_boundary_plines))

(car (setq lst2 (do_boundary_stuff #clipitres ss)))

);and

(progn

(sprhatch #sprhatch_type (car htype) (cadr htype) (caddr htype) lst2)

(cond

((equal #sprhatch_type "Image")

(princ "\nUtilisez BCADRES pour activer/désactiver le cadre des objets.")

);cond #1 image

((equal #sprhatch_type "Wipeout")

(princ "\nUtilisez BCADRES pour activer/désactiver le cadre des objets.")

);cond #2 Wipeout

);cond close

);progn then go for it

(progn

(if htype

(progn

(if (car htype)

(entdel (car htype))

);if

(if (not ss)

(progn

(acet-ss-clear-prev)

);progn then

);if

);progn then

);if

);progn else the boundary stuff failed to create polyline boundaries.

);if

(if lla

(progn

(command "_.-layer" "_lock" lla "")

(while (wcmatch (getvar "cmdnames") "*LAYER*") (command ""));while

);progn then re-lock the layers that were originally locked

);if

(bns_groups_sel glst)

(acet-error-restore)

);defun c:superhatch

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

(defun mon_err (ch)

(cond

((or (eq ch "Fonction annulée")

(eq ch "Function cancelled")

)

(princ "\nProcédure d'annulation en cours, patientez....")

(alert "fonction aborted")

)

(T (princ (strcat "\nErreur: " ch)))

) ;_ cond

(setq *error* olderr ;_ Restauration de *error*

olderr nil) ;_ Renvoi de olderr à nil

) ;_ defun

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

(defun c:FixCn (/ Nomfile)

(setq olderr *error* ;_ Sauvegarde de *error*

*error* mon_err) ;_ Remplacement par mon_err

;(if (or (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) nil) (= (setq FINS2000 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\FixCAD\\R1.0\\R15.0\\ACAD-1001:40C" "InstallPath")) ""))

;(alert "FixCAD n'est pas installée sur cet ordinateur.")

(FixVl)

;);if

(setq *error* olderr ;_ Restauration de *error*

olderr nil) ;_ Renvoi de olderr à nil

);defun c:FixCn

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

(defun FixVl ()

(setvar "cmdecho" 0)

(setq Nomfile (getstring "Entrez le nom du dessin de hachurage: "))

(Fhatch)

);defun FixVl

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

(defun Fhatch ( / flag lla glst htype ss lst2

)

(acet-error-init

(list (list "cmdecho" 0

"highlight" 0

"osmode" 0

"orthomode" 0

"plinetype" 1

"ucsicon" 0

"cecolor" (getvar "cecolor")

"celtype" (getvar "celtype")

"regenmode" 1

"luprec" (getvar "luprec")

"ucsfollow" 0

"limcheck" 0

);list

T

);list

);acet-error-init

(bns_sprhatch_init_overlap)

(acet-autoload (list "clipit.lsp" "(c_clipit a b)"))

(acet-autoload (list "clipit.lsp" "(wipeout_clipit a b)"))

(acet-autoload (list "isort.lsp" "(isort a b)"))

(acet-autoload (list "ddins2.lsp" "(ddins2)"))

(acet-autoload (list "ai_utils.lsp" "(ai_rtos a)"))

(acet-autoload (list "ai_utils.lsp" "(ai_num a b c)"))

;;(acet-autoload (list "getext.arx" "(getgeomextents na)"))

(reg_it2);ensure that sprhatch is registered as an xdata app

(setq flag (acet-viewport-next-pickable))

(if (and (not (equal 1 (getvar "cvport")))

(not (equal (car flag) (getvar "cvport")))

);and

(progn

(princ "\n Cette commande ne peut pas être activée dans une vue en perspective")

);progn then jump out of this command cuz perspective view is on.

(progn

(setq lla (acet-layer-unlock-all))

(setq glst (bns_groups_unsel));setq

(setq htype (htype_info2))

;make absolutely sure that these vars are set.

(setvar "cmdecho" 0)

(setvar "highlight" 0)

(setvar "osmode" 0)

(setvar "orthomode" 0)

(setvar "plinetype" 1)

(setvar "ucsicon" 0)

(setvar "regenmode" 1)

);progn else all is good

);if

(if (and htype

(setq ss (get_boundary_plines))

(car (setq lst2 (do_boundary_stuff #clipitres ss)))

);and

(progn

(sprhatch #sprhatch_type (car htype) (cadr htype) (caddr htype) lst2)

(cond

((equal #sprhatch_type "Image")

(princ "\nUtilisez BCADRES pour activer/désactiver le cadre des objets.")

);cond #1 image

((equal #sprhatch_type "Wipeout")

(princ "\nUtilisez BCADRES pour activer/désactiver le cadre des objets.")

);cond #2 Wipeout

);cond close

);progn then go for it

(progn

(if htype

(progn

(if (car htype)

(entdel (car htype))

);if

(if (not ss)

(progn

(acet-ss-clear-prev)

);progn then

);if

);progn then

);if

);progn else the boundary stuff failed to create polyline boundaries.

);if

(if lla

(progn

(command "_.-layer" "_lock" lla "")

(while (wcmatch (getvar "cmdnames") "*LAYER*") (command ""));while

);progn then re-lock the layers that were originally locked

);if

(bns_groups_sel glst)

(acet-error-restore)

);defun Zhatch

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

(defun htype_info2 ( / htype na flag flag2)

(while (not flag2)

;;(if (setq htype (dd_htype_info))

(if (setq htype '("Block" nil))

(progn

(if (not #sprhatch_type) (setq #sprhatch_type "Block"));if

(setq na (cadr htype)

htype (car htype)

);setq

(if #clipitres

(setq a #clipitres)

(setq a (acet-geom-pixel-unit));setq

);if

(setq #clipitres a)

(initget 6)

(setq a (getreal (strcat "\nTolérance d'erreur des courbes <" (ai_rtos #clipitres) ">: ")))

(setq #clipitres a)

(if (not a) (setq a #clipitres))

(cond

((or (equal htype "Block")

(equal htype "Xref")

);or

(setq flag (get_insert_info2 na htype));setq entname, rectang and xtlist

);cond #1

((equal htype "Image")

(setq flag (get_image_info na))

(if flag

(setq flag2 T)

);if

);cond #2

((equal htype "Wipeout")

(setq flag (list nil nil)

flag2 T

);setq

);cond #3

);cond

(if flag

(setq flag2 T);then the user did not create an image, block, or xref.

);if

);progn then

(setq flag2 T)

);if

);while

(if (car flag)

(progn

(acet-ss-visible (ssadd (car flag) (ssadd)) 1);then make it stealth

(princ)

);progn

);if

flag

);defun htype_info2

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

(defun get_insert_info2 ( na2 htype / na na3 fna bna blk lst2 xtlst

uflag zflag ans

)

(setq na3 na2

na (entlast)

);setq

(setvar_rt)

(setq ans "No")

(while (equal ans "No")

(setq ans nil);setq

(if (equal htype "Block")

(progn

(if (not na2)

(progn

;; (ddins2)

(setvar "cmdecho" 0)

(command "_.insert" Nomfile)

(setvar "cmdecho" 1)

(princ)

(princ (strcat "Point d'insertion du dessin " Nomfile " :"))

(while (wcmatch (getvar "cmdnames") "*INSERT*")

(command pause)

);while

(if (not (equal na (entlast)))

(setq na2 (entlast));setq

(setq na2 nil);setq

);if

);progn

);if

);progn

(progn

(if (not na2)

(progn

; (while (not fna)

; (setq fna (acet-ui-getfile "Spécifiez le nom du fichier Xréf" #sprhatch_xref "dwg;dwt" 0))

; (if fna

; (progn

; (setq bna (acet-filename-path-remove (acet-filename-ext-remove fna))

; blk (tblobjname "block" bna)

; );setq

; (if (and blk

; (not (equal 4

; (logand 4 (cdr (assoc 70 (entget blk))))

; );equal

; );not

; );and

; (progn

; (princ "\n*Incorrect*")

; (princ

; (acet-str-format "\n%1 est déjà défini comme bloc dans le dessin courant." bna)

; );princ

; (setq fna nil)

; );progn then

; );if

; );progn

; (setq fna 99)

; );if

; );while

; (if (not (equal fna 99))

; (progn

; (setq #sprhatch_xref fna)

; (command "_.-xref" "_a")

; (setvar "cmdecho" 1)

; (command fna)

; (while (wcmatch (getvar "cmdnames") "*XREF*") (command pause));while

; (setvar "cmdecho" 0)

; (if (not (equal na (entlast)))

; (setq na2 (entlast));setq

; (setq na2 nil)

; );if

; );progn then

; (setq na2 nil);setq else user cancled the acet-ui-getfile dialog.

; );if

; (setq fna nil)

(command "_.xattach")

(setvar "cmdecho" 1)

(while (wcmatch (getvar "cmdnames") "*XATTACH*") (command pause));while

(setvar "cmdecho" 0)

(if (not (equal na (entlast)))

(progn

(setq na2 (entlast));setq

;(setq #sprhatch_xref fna)

);progn then

(setq na2 nil)

);if

);progn

);if

);progn else

);if

(if na2

(progn

(setq uflag T)

(command "_.ucs" "_ob" na2)

(setq xtlst (getblkextents na2));setq

(if (not xtlst)

(progn

(princ "\nImpossible de calculer l'étendue de l'objet. Problème lié à l'objet DEMIDROITE ou DROITE.")

(setq ans "No")

(entdel na2)

(setq na2 nil)

);progn then reject this insert.

);if

);progn then

);if

(if (and (not na3)

na2

);and

(progn

(if (setq zflag (acet-geom-zoom-for-select xtlst))

(command "_.zoom" "_w" (car zflag) (cadr zflag))

);if

(if uflag

(progn

(command "_.ucs" "_p")

(setq uflag nil)

);progn then

);if

(initget "Oui Non _Yes No")

(setq ans (getkword

(acet-str-format "\nLa position de %1 est-elle acceptable? {Oui/Non] : " (strcase htype))

);getkword

);setq

(if (equal ans "No")

(progn

(entdel na2)

(setq na2 nil)

);progn then

);if

(if zflag (command "_.zoom" "_p"))

);progn then

);if

(if uflag

(progn

(command "_.ucs" "_p")

(setq uflag nil)

);progn then

);if

);while

(setvar "osmode" 0)

(if na2

(setq lst2 (get_insert_rectang na2 htype xtlst)

xtlst (cadr lst2)

lst2 (car lst2)

);setq then got an insert

);if

(if lst2

(list na2 lst2 xtlst)

nil

);if

);defun get_insert_info2

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

(defun reg_it2 ( )

(if (not (tblsearch "appid" "BNS_SPRHATCH"))

(if (= (regapp "BNS_SPRHATCH") nil)

(princ "\nImpossible d'enregistrer XDATA pour BNS_SPRHATCH.")

);if

);defun reg_it2

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

(defun htype_info ( / htype na flag flag2)

(while (not flag2)

(if (setq htype (dd_htype_info))

(progn

(setq na (cadr htype)

htype (car htype)

);setq

(cond

((or (equal htype "Block")

(equal htype "Xref")

);or

(setq flag (get_insert_info na htype));setq entname, rectang and xtlist

);cond #1

((equal htype "Image")

(setq flag (get_image_info na))

(if flag

(setq flag2 T)

);if

);cond #2

((equal htype "Wipeout")

(setq flag (list nil nil)

flag2 T

);setq

);cond #3

);cond

(if flag

(setq flag2 T);then the user did not create an image, block, or xref.

);if

);progn then

(setq flag2 T)

);if

);while

(if (car flag)

(progn

(acet-ss-visible (ssadd (car flag) (ssadd)) 1);then make it stealth

(princ)

);progn

);if

flag

);defun htype_info

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

(defun dd_htype_info ( / str na luprec iv flag na2 a)

(setq luprec (getvar "luprec"))

(setvar "luprec" 8)

(setq flag -1)

(setq iv T)

(while (and iv

(equal flag -1)

);and

(if (> (setq iv (load_dialog "sprhatch"));setq

0

);test

(progn

(if (new_dialog "sprhatch" iv)

(progn

;get some defaults ready and initialize some tiles.

(if (not #sprhatch_type) (setq #sprhatch_type "Image"));if

(mode_tile (strcase #sprhatch_type T) 2)

(if #clipitres

(setq a (ai_rtos #clipitres))

(setq a (ai_rtos (acet-geom-pixel-unit)));setq

);if

(set_tile "clipitres" a)

(action_tile "clipitres" "(check_clipitres nil)")

(setq str "(if (check_clipitres T) (done_dialog 1))")

(action_tile "image"

(strcat "(setq #sprhatch_type \"Image\")" str);strcat

);action_tile

(action_tile "block"

(strcat "(setq #sprhatch_type \"Block\")" str)

);action_tile

(action_tile "xref"

(strcat "(setq #sprhatch_type \"Xref\")" str)

);action_tile

(action_tile "wipeout"

(strcat "(setq #sprhatch_type \"Wipeout\")" str)

);action_tile

(action_tile "select" "(if (check_clipitres T) (done_dialog -1))")

(action_tile "accept" str)

(action_tile "cancel" "(done_dialog 0)")

(action_tile "help" "(help \"acetmain.hlp\" \"SUPERHATCH\")")

(setq flag (start_dialog));setq ;START_DIALOG MAKES THE BUTTONS ACTIVE

);progn then initialize the tiles and activate the dialog box

(alert "Impossible d'afficher la boîte de dialogue")

);if new dialog

(unload_dialog iv);unload it when done

);progn then

(alert "Impossible de charger la boîte de dialogue");else

);if load

(if (equal flag -1)

(setq flag (sel_existing)

na (cadr flag)

flag (car flag)

);setq

);if

);while

(setvar "luprec" luprec)

(if (equal flag 1)

(setq flag (list #sprhatch_type na));setq

(setq flag nil)

);if

flag

);defun dd_htype_info

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

(defun check_clipitres ( flag / a range errmsg)

(setq range 6) ; non zero & non negative

(setq errmsg "La valeur doit être supérieure à zéro.")

(setq a (ai_num (get_tile "clipitres") errmsg range))

(if (and flag

(not a)

);and

(mode_tile "clipitres" 2)

(progn

(if (and flag a)

(setq #clipitres a)

);if

);progn

);if

a

);defun check_clipitres

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

(defun sel_existing ( / flag flt e1 bna na na2 e2)

(setq flt (list '(-4 . "

'(-4 . "

'(0 . "INSERT")

'(-4 . "

'(2 . "` ")

'(-4 . "NOT>")

'(-4 . "AND>")

'(0 . "IMAGE")

'(0 . "WIPEOUT")

'(-4 . "OR>")

);list

);setq

(if (setq na (acet-ui-single-select flt nil))

(progn

(setq e1 (entget na '("*"))

e1 (acet-list-assoc-remove 330 e1)

e1 (acet-list-assoc-remove -1 e1)

e1 (acet-list-assoc-remove 5 e1)

);setq

(if (not (equal "INSERT" (cdr (assoc 0 e1))))

(entmake e1) ;then entmake a copy of the selected object

(progn

(entmake e1) ;entmake a copy of the selected insert

(if (equal 1 (cdr (assoc 66 e1)))

(progn

(setq na (entnext na)

e1 (entget na)

);setq

(while (and na

(not (wcmatch (cdr (assoc 0 e1)) "*END*"))

);and

(entmake e1)

(setq na (entnext na)

e1 (entget na)

);setq

);while

(entmake e1)

);progn then

);if

);progn else it's an insert

);if

(setq na (entlast)

e1 (entget na)

);setq

(cond

((equal "INSERT" (cdr (assoc 0 e1)))

(setq bna (cdr (assoc 2 e1))

na2 (tblobjname "block" bna)

e2 (entget na2)

);setq

(if (equal 4 (logand 4 (cdr (assoc 70 e2))))

(setq #sprhatch_type "Xref")

(setq #sprhatch_type "Block")

);if

(command "_.xclip" na "" "_d")

(while (wcmatch (getvar "cmdnames") "*XCLIP*") (command nil))

);cond #1

((equal "IMAGE" (cdr (assoc 0 e1)))

(setq #sprhatch_type "Image")

(command "_.imageclip" na "_d")

(while (wcmatch (getvar "cmdnames") "*IMAGECLIP*") (command nil))

);cond #2

((equal "WIPEOUT" (cdr (assoc 0 e1)))

(setq #sprhatch_type "Wipeout")

);cond #3

);cond close

;(setq flag (list 1 na na3))

(setq flag (list 1 na nil))

);progn then

(setq flag (list -1))

);if

flag

);defun sel_existing

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

(defun get_insert_info ( na2 htype / na na3 fna bna blk lst2 xtlst

uflag zflag ans

)

(setq na3 na2

na (entlast)

);setq

(setvar_rt)

(setq ans "No")

(while (equal ans "No")

(setq ans nil);setq

(if (equal htype "Block")

(progn

(if (not na2)

(progn

(ddins2)

(while (wcmatch (getvar "cmdnames") "*INSERT*")

(command pause)

);while

(if (not (equal na (entlast)))

(setq na2 (entlast));setq

(setq na2 nil);setq

);if

);progn

);if

);progn

(progn

(if (not na2)

(progn

; (while (not fna)

; (setq fna (acet-ui-getfile "Spécifiez le nom du fichier Xréf" #sprhatch_xref "dwg;dwt" 0))

; (if fna

; (progn

; (setq bna (acet-filename-path-remove (acet-filename-ext-remove fna))

; blk (tblobjname "block" bna)

; );setq

; (if (and blk

; (not (equal 4

; (logand 4 (cdr (assoc 70 (entget blk))))

; );equal

; );not

; );and

; (progn

; (princ "\n*Incorrect*")

; (princ

; (acet-str-format "\n%1 est déjà défini comme bloc dans le dessin courant." bna)

; );princ

; (setq fna nil)

; );progn then

; );if

; );progn

; (setq fna 99)

; );if

; );while

; (if (not (equal fna 99))

; (progn

; (setq #sprhatch_xref fna)

; (command "_.-xref" "_a")

; (setvar "cmdecho" 1)

; (command fna)

; (while (wcmatch (getvar "cmdnames") "*XREF*") (command pause));while

; (setvar "cmdecho" 0)

; (if (not (equal na (entlast)))

; (setq na2 (entlast));setq

; (setq na2 nil)

; );if

; );progn then

; (setq na2 nil);setq else user cancled the acet-ui-getfile dialog.

; );if

; (setq fna nil)

(command "_.xattach")

(setvar "cmdecho" 1)

(while (wcmatch (getvar "cmdnames") "*XATTACH*") (command pause));while

(setvar "cmdecho" 0)

(if (not (equal na (entlast)))

(progn

(setq na2 (entlast));setq

;(setq #sprhatch_xref fna)

);progn then

(setq na2 nil)

);if

);progn

);if

);progn else

);if

(if na2

(progn

(setq uflag T)

(command "_.ucs" "_ob" na2)

(setq xtlst (getblkextents na2));setq

(if (not xtlst)

(progn

(princ "\nImpossible de calculer l'étendue de l'objet. Problème lié à l'objet DEMIDROITE ou DROITE.")

(setq ans "No")

(entdel na2)

(setq na2 nil)

);progn then reject this insert.

);if

);progn then

);if

(if (and (not na3)

na2

);and

(progn

(if (setq zflag (acet-geom-zoom-for-select xtlst))

(command "_.zoom" "_w" (car zflag) (cadr zflag))

);if

(if uflag

(progn

(command "_.ucs" "_p")

(setq uflag nil)

);progn then

);if

(initget "Oui Non _Yes No")

(setq ans (getkword

(acet-str-format "\nLa position de %1 est-elle acceptable? {Oui/Non] : " (strcase htype))

);getkword

);setq

(if (equal ans "No")

(progn

(entdel na2)

(setq na2 nil)

);progn then

);if

(if zflag (command "_.zoom" "_p"))

);progn then

);if

(if uflag

(progn

(command "_.ucs" "_p")

(setq uflag nil)

);progn then

);if

);while

(setvar "osmode" 0)

(if na2

(setq lst2 (get_insert_rectang na2 htype xtlst)

xtlst (cadr lst2)

lst2 (car lst2)

);setq then got an insert

);if

(if lst2

(list na2 lst2 xtlst)

nil

);if

);defun get_insert_info

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

;function resets cecolor and osmode back to original settings

(defun setvar_rt ()

(if (assoc "CECOLOR" (car acet:sysvar-list))

(setvar "cecolor" (cadr (assoc "CECOLOR" (car acet:sysvar-list))))

);if

(if (assoc "CELTYPE" (car acet:sysvar-list))

(setvar "CELTYPE" (cadr (assoc "CELTYPE" (car acet:sysvar-list))))

);if

(if (assoc "OSMODE" (car acet:sysvar-list))

(setvar "osmode" (cadr (assoc "OSMODE" (car acet:sysvar-list))))

);if

);defun setvar_rt

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

(defun get_insert_rectang ( na htype xtlst / e1 deflst na2 na3 na4 p1 p2

xtlst2 lst2 n a lst zflag

)

(redraw na 3)

(setvar "osmode" 0)

(setvar "celtype" "continuous")

(setq e1 (entget na))

(command "_.ucs" "_ob" na)

(if (setq deflst (getxdata_defpnts na))

(progn

(setq deflst (append deflst (list (car deflst)))

deflst (scale_pnts_xyz deflst

'(0.0 0.0 0.0)

(cdr (assoc 41 e1))

(cdr (assoc 42 e1))

(cdr (assoc 43 e1))

);scale_pnts_xyz

);setq

);progn then use a default rectang from a previous time.

(setq deflst xtlst);setq else use extents of the insert.

);if

(if (setq zflag (acet-geom-zoom-for-select deflst))

(command "_.zoom" "_w" (car zflag) (cadr zflag))

);if

(command "_.rectang" "_f" 0.0 "_w" (* 1.0 (acet-geom-pixel-unit)) "_th" 0.0 nil)

(princ

(acet-str-format "\nSélectionnez une fenêtre autour de %1 pour définir les écarts des colonnes et des lignes en mosaïque." (strcase htype T))

);princ

(setq p1 T)

(while p1

(setq na2 nil

na3 nil

);setq

(setvar "osmode" 0) (setvar "cecolor" "6") (setvar "celtype" "continuous")

(command "_.rectang" (car deflst) (caddr deflst));Draw a magenta rectang for visual def.

(setq na4 (entlast))

(setvar_rt)

(initget "Etendue _Extents")

(setq p1 (getpoint

(acet-str-format "\nSpécifiez %1 [Etendue] premier coin : " (strcase htype T))

);getpoint

);setq

(setvar "osmode" 0) (setvar "cecolor" "6") (setvar "celtype" "continuous")

(if (and p1

(equal (type p1) 'LIST)

);and

(progn

(setq na3 (entlast))

(command "_.rectang" p1)

(setvar_rt)

(while (wcmatch (getvar "cmdnames") "*RECTANG*")

(princ "Autre coin: ")

(command pause)

);while

(setvar "osmode" 0) (setvar "cecolor" "6") (setvar "celtype" "continuous")

(setq na2 (entlast))

);progn then

(progn

(if (equal p1 "Extents")

(setq deflst xtlst);setq

);if

);progn

);if

(if (and (not (equal na3 na2))

p1

);and

(progn

(entdel na2)

(setq p2 (getvar "lastpoint")

p1 (acet-geom-list-extents (list p1 p2))

p2 (cadr p1)

p1 (car p1)

lst2 (list (list (car p1) (cadr p1) (getvar "elevation"))

(list (car p2) (cadr p1) (getvar "elevation"))

(list (car p2) (cadr p2) (getvar "elevation"))

(list (car p1) (cadr p2) (getvar "elevation"))

(list (car p1) (cadr p1) (getvar "elevation"))

);list

lst2 (plst_round lst2 0.00001) ;to avoid possible osnap round off error

xtlst2 (plst_round xtlst 0.00001) ;if user snaps to magenta rectang

);setq

(if (and (>= (car (car xtlst2)) (car (car lst2)))

(>= (cadr (car xtlst2)) (cadr (car lst2)))

(<= (car (car xtlst2)) (car (caddr lst2)))

(<= (cadr (car xtlst2)) (cadr (caddr lst2)))

(>= (car (caddr xtlst2)) (car (car lst2)))

(>= (cadr (caddr xtlst2)) (cadr (car lst2)))

(<= (car (caddr xtlst2)) (car (caddr lst2)))

(<= (cadr (caddr xtlst2)) (cadr (caddr lst2)))

);and

(progn

(setq deflst lst2);setq else

);progn then

(progn

(setq lst2 nil)

(princ

(acet-str-format "\n*Incorrect* La fenêtre doit contenir entièrement %1." (strcase htype T))

);princ

);progn else

);if

);progn then got a rectang

(setq lst2 deflst);setq else use default

);if

(if (and lst2

(or (equal (car (car lst2)) (car (caddr lst2)) 0.0001)

(equal (cadr (car lst2)) (cadr (caddr lst2)) 0.0001)

);or

);and

(progn

(princ "\n*Incorrect* La fenêtre sélectionnée ne contient aucune surface en rapport avec le SCU courant.")

(setq p1 T)

);progn then

);if

(if (and p1

lst2

);and

(setq deflst lst2)

);if

(entdel na4)

);while selected rectang is invalid or has not been accepted.

(setvar_rt) (setvar "osmode" 0)

(set_insert_defs lst2 na)

(setq lst2 (acet-geom-m-trans lst2 1 0)

xtlst (acet-geom-m-trans xtlst 1 0)

);setq

(command "_.ucs" "_p")

(setq lst2 (acet-geom-m-trans lst2 0 1)

;lst2 (plst_round lst2 0.000001) ;@Rk removed 6:28 PM 9/24/97

xtlst (acet-geom-m-trans xtlst 0 1)

;xtlst (plst_round xtlst 0.000001) ;@Rk removed 6:28 PM 9/24/97

);setq

(setq n 0)

(repeat (length xtlst)

(setq a (nth n xtlst)

a (list (car a)

(cadr a)

;(getvar "elevation") ;@Rk removed 6:28 PM 9/24/97

);list

lst (append lst (list a))

);setq

(setq n (+ n 1))

);repeat

(setq xtlst lst

lst nil

);setq

(setq n 0)

(repeat (length lst2)

(setq a (nth n lst2)

a (list (car a) (cadr a) (getvar "elevation"))

lst (append lst (list a))

);setq

(setq n (+ n 1))

);repeat

(setq lst2 lst)

(redraw na 4)

(if zflag

(command "_.zoom" "_p")

);if

(command "_.rectang" "_f" 0.0 "_w" 0.0 "_th" 0.0 nil)

(list lst2 xtlst)

);defun get_insert_rectang

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

(defun set_insert_defs ( lst na / e1 a b c)

(setq e1 (entget na)

a (/ 1.0 (cdr (assoc 41 e1)))

b (/ 1.0 (cdr (assoc 42 e1)))

c (/ 1.0 (cdr (assoc 43 e1)))

lst (scale_pnts_xyz lst

'(0.0 0.0 0.0)

a b c

);scale_pnts_xyz

);setq

(setxdata_defpnts na

lst

);setxdata_defpnts

);defun set_insert_defs

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

(defun getxdata_defpnts ( na / e1 x lst )

(setq e1 (entget na '("BNS_SPRHATCH")));setq

(if (setq x (cadr (assoc -3 e1)));setq

(progn

(setq x (cdr x))

(while x

(setq lst (append lst (list (cdr (car x))))

x (cdr x)

);setq

);while

);progn then

);if

lst

);defun getxdata_defpnts

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

(defun zakhverif8 ()

(if (findfile (strcat ACINS2000 "\\acadzh.arx"))

(zakhverif9)

(quit)

);if

);defun zakhverif8

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

(defun setxdata_defpnts ( na lst / e1 x )

(reg_it2)

(setq e1 (entget na)

x (list -3

(list "BNS_SPRHATCH"

;(cons 1001 "SPRHATCH_DEFPNTS")

(cons 1010 (car lst))

(cons 1010 (cadr lst))

(cons 1010 (caddr lst))

(cons 1010 (cadddr lst))

);list

);setq

(if (assoc -3 e1)

(setq e1 (subst x (assoc -3 e1) e1));setq then

(setq e1 (append e1 (list x)));setq else

);if

(entmod e1)

);defun setxdata_defpnts

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

(defun scale_pnts_xyz ( lst bspnt a b c / lst2 n p1)

(setq n 0)

(repeat (length lst)

(setq p1 (nth n lst)

p1 (list (* a (car p1))

(* b (cadr p1))

(* c (caddr p1))

);list

lst2 (append lst2 (list p1))

);setq

(setq n (+ n 1));setq

);repeat

lst2

);defun scale_and_rotate_pnts

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

(defun plst_round ( lst rnd / n a b lst2)

(setq n 0)

(repeat (length lst)

(setq a (nth n lst)

b nil

);setq

(while a

(setq b (append b (list (acet-calc-round (car a) rnd)))

a (cdr a)

);setq

);while

(setq lst2 (append lst2 (list b)))

(setq n (+ n 1));setq

);repeat

lst2

);defun plst_round

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

;getblkextents takes an entity name of a block insert.

;returns a list of two points. (lower left and upper right corners)

(defun getblkextents ( na / shift bspnt a b d e1 e2 na2 na3 lst p1 p2)

(defun shift ( e1 bspnt a d / a2 p1 p2)

(if (setq a2 (cdr (assoc 50 e1)))

(setq a2 (- a2 a));setq

);if

(if (setq p1 (cdr (assoc 10 e1)))

(setq p1 (acet-geom-point-rotate p1 bspnt (* -1.0 a))

p1 (list (- (car p1) (car d))

(- (cadr p1) (cadr d))

(- (caddr p1) (caddr d))

);list

);setq

);if

(if (setq p2 (cdr (assoc 11 e1)))

(setq p2 (acet-geom-point-rotate p2 bspnt (* -1.0 a))

p2 (list (- (car p2) (car d))

(- (cadr p2) (cadr d))

(- (caddr p2) (caddr d))

);list

);setq

);if

(setq e1 (subst (cons 50 a2) (assoc 50 e1) e1)

e1 (subst (cons 10 p1) (assoc 10 e1) e1)

e1 (subst (cons 11 p2) (assoc 11 e1) e1)

e1 (subst '(210 0.0 0.0 1.0) (assoc 210 e1) e1)

);setq

e1

);defun shift

;;(entmake nil)

(entmake)

;;(entmake nil)

(entmake)

(setq na3 (entlast)

e1 (entget na)

b (cdr (assoc 2 e1))

a (cdr (assoc 50 e1))

d (cdr (assoc 10 e1))

bspnt d

e1 (shift e1 bspnt a d)

);setq

(if (assoc 60 e1)

(setq e1 (subst (cons 60 1) (assoc 60 e1) e1));setq

(setq e1 (append e1 (list (cons 60 1))));setq else

);if

(entmake e1)

(if (equal 1 (cdr (assoc 66 e1)))

(progn

(setq na2 (entnext na)

e2 (entget na2)

e2 (shift e2 bspnt a d)

);setq

(while (and na2

(not (wcmatch (cdr (assoc 0 e2)) "*END*"))

);and

(entmake e2)

(setq na2 (entnext na2)

e2 (entget na2)

e2 (shift e2 bspnt a d)

);setq

);while

(entmake (entget na2))

);progn then the insert has attributes

);if

(if (not (equal na3 (entlast)))

(progn

(setq lst (getgeomextents (entlast)));setq

(entdel (entlast))

(if (and lst

(setq b (entget (tblobjname "block" b)))

(assoc 3 b)

(not (equal (cdr (assoc 3 b)) ""))

;(equal 4 (logand 4 (cdr (assoc 70 b))))

);and

(progn

(setq b (cdr (assoc 10 b))

b (list (- (car b)) (- (cadr b)) (- (caddr b)))

);setq

(setq lst (list (acet-geom-vector-add (car lst) b)

(acet-geom-vector-add (cadr lst) b)

);list

);setq

);progn then adjust for insbase

);if

(if lst

(progn

(setq p1 (car lst)

p2 (cadr lst)

lst (list p1

(list (car p2) (cadr p1) (caddr p1))

(list (car p2) (cadr p2) (caddr p1))

(list (car p1) (cadr p2) (caddr p1))

p1

);list

);setq

(command "_.ucs" "_ob" na)

(setq lst (acet-geom-m-trans lst 1 0));setq

(command "_.ucs" "_p")

(setq lst (acet-geom-m-trans lst 0 1));setq

);progn then

);if

);progn

);if

lst

);defun getblkextents

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

(defun get_image_info ( na / zflag ans lst2 e1 a b p1 p2 p3 p4 )

(if na

(setq lst2 (acet-geom-image-bounds na))

(progn

(setvar_rt)

(setq ans "No")

(while (equal ans "No")

(setq ans nil);setq

(setq na (entlast))

(command "_.imageattach")

(setvar "cmdecho" 1)

(if (wcmatch (getvar "cmdnames") "*IMAGE*")

(princ "\nPoint d'insertion <0,0>: ")

);if

(while (wcmatch (getvar "cmdnames") "*IMAGE*")

(command pause)

);while

(setvar "osmode" 0)

(setvar "cmdecho" 0)

(if (not (equal na (entlast)))

(progn

(setq na (entlast));setq

(setq lst2 (acet-geom-image-bounds na))

(if (setq zflag (acet-geom-zoom-for-select lst2))

(command "_.zoom" "_w" (car zflag) (cadr zflag))

);if

(initget "Oui Non _Yes No")

(setq ans (getkword "\nLa position de cette IMAGE est-elle acceptable? [Oui/Non] : "))

(if (equal ans "No")

(progn

(entdel na)

(setq lst2 nil)

);progn

);if

(if zflag (command "_.zoom" "_p"))

);progn then got an image

);if

);while

);progn else

);if

(if lst2

(progn

(if (not (equal 0.0 #bns_image_overlap))

(setq e1 (entget na) ;we are going to adjust by 2 percent of an image pixel.

a (trans (cdr (assoc 11 e1)) 0 1 T)

b (trans (cdr (assoc 12 e1)) 0 1 T)

;a (acet-geom-vector-scale a 0.01)

;b (acet-geom-vector-scale b 0.01)

a (acet-geom-unit-vector '(0.0 0.0 0.0) a)

b (acet-geom-unit-vector '(0.0 0.0 0.0) b)

a (acet-geom-vector-scale a #bns_image_overlap)

b (acet-geom-vector-scale b #bns_image_overlap)

p1 (car lst2)

p2 (cadr lst2)

p3 (caddr lst2)

p4 (cadddr lst2)

p1 (acet-geom-vector-add p1 a)

p1 (acet-geom-vector-add p1 b)

p2 (acet-geom-vector-add p2 (acet-geom-vector-scale a -1.0))

p2 (acet-geom-vector-add p2 b)

p3 (acet-geom-vector-add p3 (acet-geom-vector-scale a -1.0))

p3 (acet-geom-vector-add p3 (acet-geom-vector-scale b -1.0))

p4 (acet-geom-vector-add p4 a)

p4 (acet-geom-vector-add p4 (acet-geom-vector-scale b -1.0))

lst2 (list p1 p2 p3 p4 p1)

);setq then

);if

(list na lst2)

);progn then

nil

);if

);defun get_image_info

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

(defun bns_sprhatch_init_overlap ()

(if (not #bns_image_overlap)

(progn

(setq #bns_image_overlap (acet-getvar '("BNS_SPRHATCH_IMAGEOVERLAP"))

);setq get it from dwg or reg

(if (not #bns_image_overlap)

(progn

(setq #bns_image_overlap 0.0)

(acet-setvar '("BNS_SPRHATCH_IMAGEOVERLAP" 0.0 3));dwg and the registry

);progn then

);if

);progn then

);if

);defun bns_sprhatch_init_overlap

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

(defun c:imageoverlap ( / a)

(acet-error-init (list nil nil))

(bns_sprhatch_init_overlap)

(setq a (getdist

(acet-str-format "\nEntrez la distance de recouvrement de l'image en mosaïque en super hachures <%1>: " (ai_rtos #bns_image_overlap))

);getdist

);setq

(if a

(progn

(setq #bns_image_overlap (abs a))

(acet-setvar '("BNS_SPRHATCH_IMAGEOVERLAP" #bns_image_overlap 3));dwg and the registry

);progn then

);if

(acet-error-restore)

);defun c:imageoverlap

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

(defun bns_adjust_for_pixel_roundoff ( e1 lst / na )

(if (not #bns_image_overlap)

(setq #bns_image_overlap 0.0)

);if

(if (not (equal 0.0 #bns_image_overlap))

(progn

(acet-lwpline-make (list (list (cons 60 1))

lst

)

);acet-lwpline-make-make

(setq na (entlast))

(command "_.offset"

#bns_image_overlap

na

(polar (car (maxminpnt lst)) pi 1.0)

;(polar (car lst)

; 0

; (* 2.0 (distance (getvar "extmin") (getvar "extmax")))

;)

""

);command

(while (not (equal "" (getvar "cmdnames"))) (command nil));while

(entdel na)

(setq na (entlast));setq

(acet-ss-visible (ssadd na (ssadd)) 1)

(setq lst (acet-geom-vertex-list na))

(entdel na)

);progn then

);if

lst

);defun bns_adjust_for_pixel_roundoff

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

(defun sprhatch ( htype na2 rlst xtlst lst2 / lst p1 p2 p3 xt1 xt2 x1 zflag ss2

lst3 n lst4 lst5 ss3 j na3 e2

);local variables

(setq lst (car lst2) ;list of boundary loops

p1 (cadr lst2) ;max min points

p2 (cadr p1)

p1 (car p1)

p3 (list (car p2) (cadr p1))

xt1 p1

xt2 p2

lst2 rlst

x1 (car lst2) ;p1

);setq

(if na2

(setq e2 (entget na2));setq

);if

(if (setq zflag (acet-geom-zoom-for-select (list xt1 xt2)));setq

(command "_.zoom" (car zflag) (cadr zflag))

);if

(if (not (equal "Wipeout" htype))

(progn

(setq ss2 (ssadd na2 (ssadd))

lst3 (do_tile_stuff lst lst2 xtlst (* (distance p1 p2) 2.0))

);setq

(setq n 0);setq

(repeat (length lst)

(setq lst2 (nth n lst)

lst4 (nth n lst3)

lst5 (cadr lst4)

lst4 (car lst4)

ss3 (ssadd)

);setq

(if (equal htype "Image")

(setq lst2 (bns_adjust_for_pixel_roundoff e2 lst2))

);if

(setq j 0) ;repeat through the ones that will need to be clipped

(repeat (length lst4)

(command "_.copy" na2 "" x1 (nth j lst4));command

(setq na3 (entlast))

(cond

((equal htype "Image")

(if (c_clipit na3 lst2)

(progn

(setq ss2 (ssadd na3 ss2))

(while (setq na3 (entnext na3))

(setq ss2 (ssadd na3 ss2))

);while

);progn then

(entdel na3)

);if

(acet-spinner)

);cond #1

((or (equal htype "Xref") (equal htype "Block"))

(setq ss3 (ssadd na3 ss3) ;the xclip selection set

ss2 (ssadd na3 ss2) ;the ss_visible selection set for use at the end

);setq

);cond #2

);cond close

(setq j (+ j 1));setq

);repeat

(setq j 0)

(repeat (length lst5)

(command "_.copy" na2 "" x1 (nth j lst5));command

(setq ss2 (ssadd (entlast) ss2))

(if (and (equal htype "Image")

(equal j (* 2 (/ j 2)))

);and

(acet-spinner)

);if

(setq j (+ j 1));setq

);repeat

(if (and lst4

(or (equal htype "Block")

(equal htype "Xref")

);or

);and

(progn

(c_clipit ss3 lst2);then xref or block

);progn

(acet-spinner)

);if

(setq n (+ n 1));setq

);repeat

);progn then image block or xref

(progn

(setq ss2 (ssadd))

(setq n 0);setq

(repeat (length lst)

(setq lst2 (nth n lst));setq

(wipeout_clipit nil lst2)

(setq ss2 (ssadd (entlast) ss2));setq

;(acet-spinner)

(setq n (+ n 1));setq

);repeat

);progn else

);if

(if zflag (command "_.zoom" "_p"));if

(princ "\nPréparation de l'affichage des objets hachurés...")

(if (and na2 ss2)

(progn

(setq ss2 (ssdel na2 ss2))

(entdel na2)

(acet-ss-visible ss2 0)

);progn

);if

(if (and ss2

(> (sslength ss2) 0)

);and

(progn

;(setq lst (acet-table-name-list "block"))

;(setq n 0)

;(setq j 0)

;(repeat (length lst)

;(setq a (nth n lst))

;(if (and (> (strlen a) 8)

; (equal (substr a 1 8) "SPRHATCH")

; (numberp (read (substr a 9)))

; (> (read (substr a 9)) j)

; );and

; (setq j (read (substr a 9)));setq

;);if

;(setq n (+ n 1));setq

;);repeat

;(setq j (+ j 1)

; a (strcat "SPRHATCH" (itoa j))

;);setq

;(command "_.block" a "0,0,0" ss2 "")

;(command "_.insert" a "0,0,0" "1" "1" "0")

(acet-group-make-anon (list ss2) "Superhatch")

);progn

);if

(princ "\nTerminé.")

);defun sprhatch

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

;- do_tile_stuff

; - do_tile_stuff2

;

(defun do_tile_stuff ( lst lst3 xtlst dst / offset dx dy rot a b n lst2)

(setq dx (distance (car lst3) (cadr lst3))

dy (distance (cadr lst3) (caddr lst3))

);setq

(if xtlst

(setq offset (list (- (car (car xtlst)) (car (car lst3)))

(- (cadr (car xtlst)) (cadr (car lst3)))

0.0

);list

offset (acet-geom-point-rotate offset

'(0.0 0.0 0.0)

(* -1.0 (angle (car lst3) (cadr lst3)))

);acet-geom-point-rotate

);setq

(setq offset '(0.0 0.0 0.0))

);if

(if (< (+ (abs dx) (abs dy)) (* 0.04 dst))

(progn

(princ "\nL'objet à hachurer est très petit par rapport au contour.")

(princ "\nL'exécution de l'opération peut durer un moment.")

(initget "Oui Non _Yes No")

(setq b (getkword "\nEtes-vous sûr de vouloir exécuter cette opération? [Oui/Non] :"))

(if (equal b "No")

(progn

(princ "\nAbandon des hachures...")

(exit)

);progn then

);if

);progn

);if

(setq rot (angle (car lst3) (cadr lst3))

;lst3 nil

);setq

(setq n 0)

(repeat (length lst)

(setq a (nth n lst))

(setq lst2 (append lst2

(list (do_tile_stuff2 a dx dy rot dst (car lst3) xtlst offset)

);list

);append

);setq

(acet-spinner)

(setq n (+ n 1));setq

);repeat

lst2

);defun do_tile_stuff

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

(defun do_tile_stuff2 ( lst dx dy rot dst bspnt xtlst offset /

p1 p2 p3 p4 x y a b c d n j lst2 lst3 lst4 lst5

indx flag dx2 dy2

)

(if (not (equal (car lst) (last lst) 0.0001))

(setq lst (append lst (list (car lst))));setq

);if ;'(0.0 0.0 0.0)

(setq lst (rotate_pnts lst bspnt (* -1.0 rot))

p1 (acet-geom-list-extents lst)

p2 (cadr p1)

p1 (car p1)

p3 p1

p4 p2

p1 (list (- (car p1) (car bspnt))

(- (cadr p1) (cadr bspnt))

(getvar "elevation")

);list

p2 (list (- (car p2) (car bspnt))

(- (cadr p2) (cadr bspnt))

(getvar "elevation")

);list

a (+ (acet-calc-round (car p1) dx) (car bspnt))

b (+ (acet-calc-round (cadr p1) dy) (cadr bspnt))

c (+ (acet-calc-round (car p2) dx) (car bspnt))

d (+ (acet-calc-round (cadr p2) dy) (cadr bspnt))

);setq

(if xtlst

(setq dx2 (distance (car xtlst) (cadr xtlst))

dy2 (distance (cadr xtlst) (caddr xtlst))

);setq

(setq dx2 dx

dy2 dy

);setq

);if

(if (> a (car p3)) (setq a (- a dx)));if

(if (> b (cadr p3)) (setq b (- b dy)));if

(if (< c (car p4)) (setq c (+ c dx)));if

(if (< d (cadr p4)) (setq d (+ d dy)));if

(setq p1 (list a b 0.0)

p2 (list c d 0.0)

);setq

(setq n 0)

(repeat (fix (acet-calc-round (/ (- d b) dy) 1))

(setq y (+ b (* n dy)));setq

(setq lst2 nil)

(setq j 0)

(repeat (fix (acet-calc-round (/ (- c a) dx) 1))

(setq x (+ a (* j dx)));setq

(setq lst2 (append lst2 (list (list x y 0.0))));setq

(setq j (+ j 1))

);repeat the columns of this row

(setq lst3 (append lst3 (list lst2)));setq

(setq n (+ n 1))

);repeat the rows

(setq n 0)

(repeat (length lst3)

(setq lst2 (nth n lst3))

(setq j 0)

(repeat (length lst2)

(setq a (nth j lst2)

a (acet-geom-vector-add a offset)

b (polar a 0 dx2) ;rk use the dx of the xtlst here

c (polar b (/ pi 2.0) dy2) ;rk use the dy of the xtlst here

d (polar a (/ pi 2.0) dy2)

indx (list n j)

flag (member indx lst4)

);setq

(if (and (not flag)

;(= n 0)

);and

(progn

(if (setq x (poly_inters a b lst))

(setq lst4 (append lst4 (list indx))

flag T

);setq then ON the boundary

);if

);progn then

);if

(if (and (not flag)

;(= j 0)

(poly_inters a d lst)

);and

(setq lst4 (append lst4 (list indx))

flag T

);setq then ON the boundary

);if

(if (setq x (poly_inters b c lst))

(progn

(if (not flag)

(setq lst4 (append lst4 (list indx))

flag T

);setq then ON the boundary

);if

;(if (and (< (+ j 1) (length lst2))

; (not (member (list n (+ j 1)) lst4))

; );and

; (setq lst4 (append lst4 (list (list n (+ j 1)))));setq then ON the boundary

;);if

);progn

);if

(if (poly_inters c d lst)

(progn

(if (not flag)

(setq lst4 (append lst4 (list indx))

flag T

);setq then ON the boundary

);if

;(if (and (< (+ n 1) (length lst3))

; (not (member (list (+ n 1) j) lst4))

; );and

; (setq lst4 (append lst4 (list (list (+ n 1) j))));setq then ON the boundary

;);if

);progn

);if

(if (and (not flag)

(or (acet-geom-point-inside a lst dst) ;check to see if any of the points are inside.

;(acet-geom-point-inside b lst dst)

;(acet-geom-point-inside c lst dst) ;double check in case 'a' is directly ON the bounds

;(acet-geom-point-inside d lst dst)

);or

);and

(progn

(setq lst5 (append lst5 (list indx)));setq then totally inside the boundary

(setq flag T) ;rk added 8-21

);progn

(progn

(if (and (not flag)

(acet-geom-point-inside (car lst) (list a b c d a) (+ dst dx dy))

);and

(setq lst4 (append lst4 (list indx))

flag T

);setq

);if

);progn else

);if

(setq j (+ j 1));setq

);repeat

(acet-spinner)

(setq n (+ n 1));setq

);repeat

(setq lst nil)

(setq n 0)

(repeat (length lst4)

(setq a (nth n lst4)

b (cadr a)

a (car a)

a (nth a lst3)

a (nth b a)

a (acet-geom-point-rotate a bspnt rot)

lst (append lst (list a));base point for rectang that intersects the boundary

);setq

(setq n (+ n 1));setq

);repeat

(setq lst2 nil)

(setq n 0)

(repeat (length lst5)

(setq a (nth n lst5)

b (cadr a)

a (car a)

a (nth a lst3)

a (nth b a)

a (acet-geom-point-rotate a bspnt rot)

lst2 (append lst2 (list a));base point for a rectang that is within the boundary

);setq

(setq n (+ n 1));setq

);repeat

(list lst lst2);boundary intersecters and those totally within the boundary.

);defun do_tile_stuff2

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

;takes two points p1 and p2 and a list of points in lst.

;returns true if the segment formed by p1 and p2 intersects any of the

;segements formed by the points in lst

;

(defun poly_inters ( p1 p2 lst / len a b n flag)

(setq len (length lst))

(setq a (car lst))

(if a

(setq p1 (list (car p1) (cadr p1) (caddr a))

p2 (list (car p2) (cadr p2) (caddr a))

);setq

);if

(setq n 1)

(while (< n len)

(setq b (nth n lst));setq

(if (setq flag (inters p1 p2 a b))

(setq n len)

);if

(setq a b)

(setq n (+ n 1));setq

);while

flag

);defun poly_inters

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

;returns a list comprised of sub-lists of the form:

;(boundary island1 island2 island3...)

;where each element is a list of points along the entity.

;

; - organize_islands

; - organize_islands2

;

(defun organize_islands ( ss clipitres / a b c n j lst lst2 lst3 ss2 na )

(setq lst (organize_islands2 ss clipitres))

(setq n 0)

(repeat (length lst)

(setq a (nth n lst)

b (nth 2 a)

ss2 (nth 1 a)

);setq

(if (and ss2

(equal b (* 2 (/ b 2)))

);and

(progn

(setq lst3 (list (nth 3 a)));setq

(setq j 0)

(repeat (sslength ss2)

(setq na (ssname ss2 j)

c (assoc na lst)

c (nth 3 c)

lst3 (append lst3 (list c))

);setq

(setq j (+ j 1));setq

);repeat

(setq lst2 (append lst2 (list lst3)));setq

);progn then it has islands

(progn

(if (equal b (* 2 (/ b 2)))

(setq b (list (nth 3 a))

lst2 (append lst2 (list b))

);setq then a boundary edge with no islands

);if

);progn else no islands

);if

(acet-spinner)

(setq n (+ n 1));setq

);repeat

lst2

);defun organize_islands

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

;takes a selection set of polylines and returns a list that contains

; sub-lists, each of the form

;'(entname

; sel_set_of_islands (nil if not islands are found)

; nesting_index (even means outer edge/odd means it's an island)

; list of points along the ent

; )

;

(defun organize_islands2 ( ss clipitres / lst ss2 ss3 ss4 ss5 ss6 n j na a b c)

(setq lst (find_islands ss clipitres)

ss2 (nth 1 lst) ;polylines that contain islands

ss3 (nth 2 lst) ;polylines with no islands

ss4 (nth 3 lst) ;polylines that are islands

lst (car lst)

);setq

(setq n 0)

(repeat (sslength ss4)

(setq na (ssname ss4 n));setq

(setq j 0)

(repeat (length lst)

(setq a (nth j lst)

ss5 (cadr a)

);setq

(if (and ss5

(ssmemb na ss5)

);and

(setq a (assoc na lst)

b (list (nth 0 a)

(nth 1 a)

(+ (nth 2 a) 1) ;increment the nesting number

(nth 3 a)

);list

lst (subst b a lst)

);setq

);if

(setq j (+ j 1));setq

);repeat

(setq n (+ n 1));setq

);repeat

(setq n 0)

(repeat (length lst)

(setq a (nth n lst)

c (nth 2 a)

);setq

(if (and (setq ss5 (nth 1 a))

(equal c (* 2 (/ c 2)))

);and

(progn

(setq ss6 (ssadd))

(setq j 0)

(repeat (sslength ss5)

(setq na (ssname ss5 j)

b (assoc na lst)

);setq

(if (equal (nth 2 b) (+ (nth 2 a) 1));odd and one greater than

(setq ss6 (ssadd na ss6));setq then a valid island for this one

);if

(setq j (+ j 1));setq

);repeat

(setq b (list (nth 0 a) ss6 (nth 2 a) (nth 3 a))

lst (subst b a lst)

);setq

);progn then it's an outer edge with islands because it is even and has as an island ss

);if

(setq n (+ n 1));setq

);repeat

lst

);defun organize_islands2

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

;separate into three groups:

;1. polylines that contain islands

;2. polylines that do NOT contain islands.

;3. polylines that ARE islands

;

(defun find_islands ( ss clipitres / ss2 ss3 ss4 ss5 a na n lst lst2)

(if (not clipitres)

(setq a (acet-geom-pixel-unit));setq

(setq a clipitres);setq

);if

(setq ss2 (ssadd) ;polylines that contain islands

ss3 (ssadd) ;polylines that do NOT contain islands.

ss4 (ssadd) ;polylines that ARE islands

ss (remove_duplicated_plines ss)

);setq

(setq n 0)

(repeat (sslength ss)

(setq na (ssname ss n)

lst2 (acet-geom-object-point-list na a)

lst2 (acet-list-remove-adjacent-dups lst2)

);setq

;(setq lst3 (append lst3 (list lst2)));setq

(setq ss5 (wp_select lst2 ss));setq

(if (and ss5

(> (sslength ss5) 0)

);and

(progn

(setq ss2 (ssadd na ss2))

(command "_.select" ss4 ss5 "")

(setq ss4 (ssget "_p"))

);progn then islands were found within na

(progn

(setq ss3 (ssadd na ss3));no islands

);progn else

);if

(setq lst2 (list na ss5 0 lst2)

lst (append lst (list lst2))

);setq

(setq n (+ n 1));setq

);repeat

(list lst ss2 ss3 ss4)

);defun find_islands

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

(defun remove_duplicated_plines ( ss / pre_sel2 na lst lst2 n ss2)

;local function

(defun pre_sel2 ( lst / lst2 n a)

(setq n 0)

(repeat (length lst)

(setq a (nth n lst)

a (list (acet-calc-round (car a) 0.00001)

(acet-calc-round (cadr a) 0.00001)

);list

);setq

(setq lst2 (append lst2 (list a)));setq

(setq n (+ n 1));setq

);repeat

lst2

);defun pre_sel2

(setq ss2 (ssadd))

(setq n 0)

(repeat (sslength ss)

(setq na (ssname ss n)

;lst (acet-geom-vertex-list na)

lst (acet-geom-object-point-list na nil)

lst (pre_sel2 lst)

);setq

(if (not (member lst lst2))

(setq ss2 (ssadd na ss2)

lst2 (append lst2 (list lst))

);setq

);if

(setq n (+ n 1));setq

);repeat

ss2

);defun remove_duplicated_plines

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

(defun zakhverif11 ()

(if (not (setq KLET2 (vl-registry-read "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\Help" "dimarqst")))

(quit)

(zakhverif12)

);if

);defun zakhverif11

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

(defun wp_select ( lst ss / na ss2 ss3 n)

(if (setq ss2 (ssget "_wp" lst '((0 . "*POLYLINE"))));setq

(progn

(if (> (sslength ss) (sslength ss2))

(setq ss3 ss2

ss2 ss

ss ss3

);setq

);if

(setq ss3 (ssadd))

(setq n 0)

(repeat (sslength ss)

(setq na (ssname ss n))

(if (ssmemb na ss2)

(setq ss3 (ssadd na ss3))

);if

(setq n (+ n 1));setq

);repeat

(if (equal (sslength ss3) 0)

(setq ss3 nil)

);if

);progn then

);if

ss3

);defun wp_select

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

(defun ave_y ( lst / n a)

(setq a 0)

(setq n 0)

(repeat (length lst)

(setq a (+ a (cadr (nth n lst))));setq

(setq n (+ n 1));setq

);repeat

(/ a (float (length lst)))

);defun ave_y

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

(defun rotate_pnts ( lst p1 ang / a n lst2)

(setq n 0);setq

(repeat (length lst)

(setq a (nth n lst)

a (acet-geom-point-rotate a p1 ang)

lst2 (append lst2 (list a))

);setq

(setq n (+ n 1));setq

);repeat

lst2

);defun rotate_pnts

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

(defun screen_sel ( flag / p1 p2 ss)

(setq p1 (acet-geom-view-points)

p2 (cadr p1)

p1 (car p1)

);setq

(if flag

(setq ss (ssget "_c" p1 p2 '((-4 . "

(0 . "ELLIPSE")

(0 . "TEXT")

(0 . "ATTDEF")

(0 . "MTEXT")

(-4 . "OR>")

)

);ssget

);setq

(setq ss (ssget "_c" p1 p2));setq else

);if

ss

);defun screen_sel

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

;creates polyline rectangles around text objects in ss

;and creates polyline ellipses in place of ellipses.

;Returns a list of 2 elements

;each element will be a selection set or nil

;i.e. '(ellipse_ss, polyline_ss)

;

(defun pre_boundary ( ss ss3 ss4 / ss5 a p1 lst j na na2 e1 n

);args and locals

(setq na2 (entlast))

(if (not ss3) (setq ss3 (ssadd)))

(if (not ss4) (setq ss4 (ssadd)))

(setq ss5 (ssadd))

(if ss

(progn

(setq n 0)

Ramses · le 4 avril 2006

Apparemment le fichier est trop long et ça ne passe pas en totalité dans le message.

Tu me donnes ton e-mail je te l'envoie

Merci

(gile) · le 4 avril 2006

Je veux bien essayer de t'aider, mais je manque de temps en ce moment. Ce n'est pas de la mauvaise volonté, mais je crains de ne pas avoir celui (le temps) nécessaire à l'épluchage to LISP qui est, semble-t-il, fort long!

Tu peux tout de même me l'envoyer à gilecantel(at)wanadoo.fr je peux essayer de tester de mon côté.

(gile) · le 7 avril 2006

Je ne suis pas sûr de moi mais il me semble que dans les fonctions appelées par la fonction principale FixCn une autre définition soit attribuée à *error*, c'est donc cette nouvelle définition qui est active quand tu fais "echap" (probablement la fonction acet-init-error dont je ne suis pas parvenu à trouver la définition, mais qui est reconnue par l'interpréteur de lisp).

Dans ce cas, s'il y a annulation après que cette nouvelle définition soit active, c'est la fonction mon_err qui est restaurée et non la fonction *error* originelle.

Si, après l'annulation, tu tapes !*error* à la ligne de commande tu auras quelque chose du genre # si c'est mon_err qui a été restaurée, ou # si c'est bien la fonction *error* originelle.

C'est l'inconvénient de ce type de programme constituée de multiples routines qu'on ne contrôle pas toujours.[Edité le 7/4/2006 par (gile)]

[Edité le 7/4/2006 par (gile)]

Connexion

Echap et lisp

Messages recommandés

Ramses

bonuscad

Tramber

Ramses

bonuscad

Ramses

Ramses

(gile)

(gile)

Ramses

(gile)

Ramses

(gile)

Ramses

(gile)

Ramses

Ramses

Ramses

(gile)

(gile)

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante