Fonction AutoLISP de gestion de textuels.

[fabcad]

Voivi une fonction AutoLISP que j'utilise beaucoup dans mon domaine de cartographie pour la gestion de mes textuels :

 

; ID-TXT.LSP

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

; MODIFIE LES PROPRIETES D'UN OU PLUSIEURS TEXTES

; A PARTIR D'UN TEXTE.

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

; Creee le 13.02.1996

; Modifiee le 19.02.1999

; Modifiee le 12.06.1999 justification avec des MTEXT ou des TEXT

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

(defun justif (nom /)

 

(setq lst-nom (entget nom))

(setq typ-nom (cdr (assoc 0 lst-nom)))

 

(cond

((= typ-nom "MTEXT")

(cond

((= 1 (cdr (assoc 71 lst-nom)))

(progn

(prompt "\n Justification de type Haut-Gauche !!!\n")

(setq res-lst (list (cons 71 1) (cons 72 0) (cons 73 3)))

);fin progn

);fin si cdr egal à 1

 

((= 2 (cdr (assoc 71 lst-nom)))

(progn

(prompt "\n Justification de type Haut-Centre !!!\n")

(setq res-lst (list (cons 71 2) (cons 72 1) (cons 73 3)))

);fin progn

);fin si cdr egal à 2

 

((= 3 (cdr (assoc 71 lst-nom)))

(progn

(prompt "\n Justification de type Haut-Droite !!!\n")

(setq res-lst (list (cons 71 3) (cons 72 2) (cons 73 3)))

);fin progn

);fin si cdr egal à 3

 

((= 4 (cdr (assoc 71 lst-nom)))

(progn

(prompt "\n Justification de type Milieu-Gauche !!!\n")

(setq res-lst (list (cons 71 4) (cons 72 0) (cons 73 2)))

);fin progn

);fin si cdr egal à 4

 

((= 5 (cdr (assoc 71 lst-nom)))

(progn

(prompt "\n Justification de type Milieu-Centre !!!\n")

(setq res-lst (list (cons 71 5) (cons 72 1) (cons 73 2)))

);fin progn

);fin si cdr egal à 5

 

((= 6 (cdr (assoc 71 lst-nom)))

(progn

(prompt "\n Justification de type Milieu-Droite !!!\n")

(setq res-lst (list (cons 71 6) (cons 72 2) (cons 73 2)))

);fin progn

);fin si cdr egal à 6

 

((= 7 (cdr (assoc 71 lst-nom)))

(progn

(prompt "\n Justification de type Bas-Gauche !!!\n")

(setq res-lst (list (cons 71 7) (cons 72 0) (cons 73 0)))

);fin progn

);fin si cdr egal à 4

 

((= 8 (cdr (assoc 71 lst-nom)))

(progn

(prompt "\n Justification de type Bas-Centre !!!\n")

(setq res-lst (list (cons 71 8) (cons 72 1) (cons 73 0)))

);fin progn

);fin si cdr egal à 5

 

((= 9 (cdr (assoc 71 lst-nom)))

(progn

(prompt "\n Justification de type Bas-Droite !!!\n")

(setq res-lst (list (cons 71 9) (cons 72 2) (cons 73 0)))

);fin progn

);fin si cdr egal à 6

 

);fin 2eme cond

 

); fin obj egal a MTEXT

 

((= typ-nom "TEXT")

(cond

 

((and (= 0 (cdr (assoc 72 lst-nom))) (= 3 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Haut-Gauche !!!\n")

(setq res-lst (list (cons 71 1) (cons 72 0) (cons 73 3)))

);fin progn

);fin

 

((and (= 1 (cdr (assoc 72 lst-nom))) (= 3 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Haut-Centre !!!\n")

(setq res-lst (list (cons 71 2) (cons 72 1) (cons 73 3)))

);fin progn

);fin

 

((and (= 2 (cdr (assoc 72 lst-nom))) (= 3 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Haut-Droite !!!\n")

(setq res-lst (list (cons 71 3) (cons 72 2) (cons 73 3)))

);fin progn

);fin

 

((and (= 0 (cdr (assoc 72 lst-nom))) (= 2 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Milieu-Gauche !!!\n")

(setq res-lst (list (cons 71 4) (cons 72 0) (cons 73 2)))

);fin progn

);fin

 

((and (= 1 (cdr (assoc 72 lst-nom))) (= 2 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Milieu-Centre !!!\n")

(setq res-lst (list (cons 71 5) (cons 72 1) (cons 73 2)))

);fin progn

);fin

 

((and (= 2 (cdr (assoc 72 lst-nom))) (= 2 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Milieu-Droite !!!\n")

(setq res-lst (list (cons 71 6) (cons 72 2) (cons 73 2)))

);fin progn

);fin

 

((and (= 0 (cdr (assoc 72 lst-nom))) (= 1 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Bas-Gauche !!!\n")

(setq res-lst (list (cons 71 7) (cons 72 0) (cons 73 1)))

);fin progn

);fin

 

((and (= 1 (cdr (assoc 72 lst-nom))) (= 1 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Bas-Centre !!!\n")

(setq res-lst (list (cons 71 8) (cons 72 1) (cons 73 1)))

);fin progn

);fin

 

((and (= 2 (cdr (assoc 72 lst-nom))) (= 1 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Bas-Droite !!!\n")

(setq res-lst (list (cons 71 9) (cons 72 2) (cons 73 1)))

);fin progn

);fin

 

((and (= 0 (cdr (assoc 72 lst-nom))) (= 0 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Bas-Gauche !!!\n")

(setq res-lst (list (cons 71 7) (cons 72 0) (cons 73 0)))

);fin progn

);fin

 

((and (= 1 (cdr (assoc 72 lst-nom))) (= 0 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Bas-Centre !!!\n")

(setq res-lst (list (cons 71 8) (cons 72 1) (cons 73 0)))

);fin progn

);fin

 

((and (= 2 (cdr (assoc 72 lst-nom))) (= 0 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Bas-Droite !!!\n")

(setq res-lst (list (cons 71 9) (cons 72 2) (cons 73 0)))

);fin progn

);fin

 

((and (= 4 (cdr (assoc 72 lst-nom))) (= 0 (cdr (assoc 73 lst-nom))))

(progn

(prompt "\n Justification de type Milieu-Centre !!!\n")

(setq res-lst (list (cons 71 5) (cons 72 4) (cons 73 0)))

);fin progn

);fin

 

);fin cond

); fin obj egal a TEXT

 

);fin 1er cond

res-lst

);fin defun

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

(defun id-index (js / c1 i chn nbr er chx2)

(setq cnt2 T)

(while cnt2

(initget "Global Element")

(setq chx2 (getkword "\n Quel type de travail [Global/Element] "))

(cond

((= chx2 "Global")

(progn

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil));fin select er

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(setq chn (cdr (assoc 1 (entget (car er)))))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq ent (subst (cons 1 chn) (assoc 1 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin 1er while

);fin progn

);fin si chx2 est egal à Global

((= chx2 "Element")

(progn

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(setq c1 (ssname js i))

(redraw c1 3)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil));fin select er

(setq chn (cdr (assoc 1 (entget (car er)))))

(setq ent (entget c1))

(setq ent (subst (cons 1 chn) (assoc 1 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin 1er while

);fin progn

);fin si chx2 est egal à Element

(T (setq cnt2 nil))

);fin cond

);fin while cnt2

(setvar "cmdecho" 1)

)

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

(defun id-ang (js / c1 i ang nbr er chx2)

(setq cnt2 T)

(while cnt2

(initget "Global Element")

(setq chx2 (getkword "\n Quel type de travail [Global/Element] "))

(cond

((= chx2 "Global")

(progn

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil));fin select er

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(setq ang (cdr (assoc 50 (entget (car er)))))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq ent (subst (cons 50 ang) (assoc 50 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin 1er while

);fin progn

);fin si chx2 est egal à Global

((= chx2 "Element")

(progn

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(setq c1 (ssname js i))

(redraw c1 3)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil));fin select er

(setq ang (cdr (assoc 50 (entget (car er)))))

(setq ent (entget c1))

(setq ent (subst (cons 50 ang) (assoc 50 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin 1er while

);fin progn

);fin si chx2 est egal à Element

(T (setq cnt2 nil))

);fin cond

);fin while cnt2

(setvar "cmdecho" 1)

)

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

(defun id-just (js / c1 i just just2 pti nbr er)

(while (= (setq er (car (entsel "\n Choisir le texte de reference : "))) nil)

);fin 1er while

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(if (= (cdr (assoc 0 (entget (ssname js i)))) "TEXT")

(progn

(setq lst-er (justif er))

(setq just (cdr (assoc 72 lst-er)))

(setq just2 (cdr (assoc 73 lst-er)))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq pti (cdr (assoc 10 (entget c1))))

(setq ent (subst (cons 72 just) (assoc 72 ent) ent))

(setq ent (subst (cons 73 just2) (assoc 73 ent) ent))

(setq ent (subst (cons 11 pti) (assoc 11 ent) ent))

(entmod ent)

);fin progn

(progn

(setq lst-er (justif er))

(setq just (cdr (assoc 71 lst-er)))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq pti (cdr (assoc 10 (entget c1))))

(setq ent (subst (cons 71 just) (assoc 71 ent) ent))

(setq ent (subst (cons 11 pti) (assoc 11 ent) ent))

(entmod ent)

);fin progn

 

);fin if

 

(setq i (+ i 1))

); fin while

(setvar "cmdecho" 1)

)

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

(defun id-ht (js / c1 i htr nbr er)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil)

);fin 1er while

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(setq htr (cdr (assoc 40 (entget (car er)))))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq ent (subst (cons 40 htr) (assoc 40 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin while

(setvar "cmdecho" 1)

)

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

(defun id-incli (js / c1 i inc nbr er)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil)

);fin 1er while

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(if (/= (cdr (assoc 0 (entget (ssname js i)))) "MTEXT")

(progn

(setq inc (cdr (assoc 51 (entget (car er)))))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq ent (subst (cons 51 inc) (assoc 51 ent) ent))

(entmod ent)

);fin progn

(prompt "\n Objet de type MTEXT Impossible de le modifier !!!")

);fin if

(setq i (+ i 1))

); fin while

(setvar "cmdecho" 1)

)

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

(defun id-style (js / c1 i sty htr nbr er)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil)

);fin 1er while

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(setq sty (cdr (assoc 7 (entget (car er)))))

(setq htr (cdr (assoc 40 (entget (car er)))))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq ent (subst (cons 7 sty) (assoc 7 ent) ent))

(setq ent (subst (cons 40 htr) (assoc 40 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin while

(setvar "cmdecho" 1)

)

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

(defun id-facteur (js / c1 i fact nbr er)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil)

);fin 1er while

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(if (/= (cdr (assoc 0 (entget (ssname js i)))) "MTEXT")

(progn

(setq fact (cdr (assoc 41 (entget (car er)))))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq ent (subst (cons 41 fact) (assoc 41 ent) ent))

(entmod ent)

);fin progn

(prompt "\n Objet de type MTEXT Impossible de le modifier !!!")

);fin if

(setq i (+ i 1))

); fin while

(setvar "cmdecho" 1)

)

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

(defun id-calque (js / c1 i pla nbr er)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil)

);fin 1er while

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(setq pla (cdr (assoc 8 (entget (car er)))))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq ent (subst (cons 8 pla) (assoc 8 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin while

(setvar "cmdecho" 1)

)

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

(defun id-masque (js / c1 i typ-masq masq taille-masq nbr er)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil)

);fin 1er while

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(setq typ-masq (cdr (assoc 90 (entget (car er)))))

(setq masq (cdr (assoc 63 (entget (car er)))))

(setq taille-masq (cdr (assoc 45 (entget (car er)))))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq ent (subst (cons 90 typ-masq) (assoc 90 ent) ent))

(setq ent (subst (cons 63 masq) (assoc 63 ent) ent))

(setq ent (subst (cons 45 taille-masq) (assoc 45 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin while

(setvar "cmdecho" 1)

)

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

(defun id-pash (js / c1 i ang sty htr pla nbr er)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil)

);fin 1er while

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

;(setq chn (cdr (assoc 1 (entget (car er)))))

(setq ang (cdr (assoc 50 (entget (car er)))))

(setq sty (cdr (assoc 7 (entget (car er)))))

(setq pla (cdr (assoc 8 (entget (car er)))))

(setq htr (cdr (assoc 40 (entget (car er)))))

(setq c1 (ssname js i))

 

(setq ent (entget c1))

;(setq ent (subst (cons 1 chn) (assoc 1 ent) ent))

(setq ent (subst (cons 50 ang) (assoc 50 ent) ent))

(setq ent (subst (cons 7 sty) (assoc 7 ent) ent))

(setq ent (subst (cons 40 htr) (assoc 40 ent) ent))

(setq ent (subst (cons 8 pla) (assoc 8 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin while

(setvar "cmdecho" 1)

)

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

(defun id-SCalque (js / c1 i sty htr pla nbr er)

(while (= (setq er (nentsel "\n Choisir le texte de reference : ")) nil)

);fin 1er while

(setq nbr (sslength js))

(setq i 0)

(while (<= i (- nbr 1))

(setq sty (cdr (assoc 7 (entget (car er)))))

(setq htr (cdr (assoc 40 (entget (car er)))))

(setq pla (cdr (assoc 8 (entget (car er)))))

(setq c1 (ssname js i))

(setq ent (entget c1))

(setq ent (subst (cons 7 sty) (assoc 7 ent) ent))

(setq ent (subst (cons 40 htr) (assoc 40 ent) ent))

(setq ent (subst (cons 8 pla) (assoc 8 ent) ent))

(entmod ent)

(setq i (+ i 1))

); fin while

(setvar "cmdecho" 1)

)

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

; FONCTION MAITRE

(defun c:id-txt ( / chx cnt)

(setvar "cmdecho" 0)

 

(setq js (ssget

'(

(-4 . "

(-4 . "

(0 . "TEXT")

 

(-4 . "AND>")

(-4 . "

(0 . "MTEXT")

 

(-4 . "AND>")

(-4 . "OR>")

)

);ssget

);fin setq js

 

(setq cnt T)

(prompt (strcat "\nNombre de textes : " (rtos (setq nbr (sslength js)) 2 0)))

(while cnt

(initget "Angle Calque Facteur Hauteur Inclinaison Justification Masque STyle SCalque Pash INDex")

(setq chx (getkword "\n Propriete identique [Angle/Calque/Fact/Hauteur/Inclin/Justif/Masque/Pash/STyle/SCalque/INDex] "))

(cond

((= chx "Angle") (id-ang js))

((= chx "Justification") (id-just js))

((= chx "INDex") (id-index js))

((= chx "Facteur") (id-facteur js))

((= chx "Hauteur") (id-ht js))

((= chx "Inclinaison") (id-incli js))

((= chx "Calque") (id-calque js))

((= chx "STyle") (id-style js))

((= chx "SCalque") (id-SCalque js))

((= chx "Pash") (id-pash js))

((= chx "Masque") (id-masque js))

(T (setq cnt nil))

);fin 1 cond

);fin while

(prompt "\n---COPYRIGHT 03/97 par Fabrice DEMIEL---")

nil

(prin1)

);fin c:id-txt

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

(prompt "\nPour lancer tapez : id-txt ")

(prin1)