Changer la Casse d\'un ou plusieurs textuels

[fabcad]

Bonsoir,

 

J'avais créé cette routine il y a fort longtemps mais avec un fichier dcl séparé, c'est donc avec l'aide du génialissime Gile que j'ai pu réunir le lisp et le dcl dans un fichier unique.

 

Bonne utilisation :

 

;; SUBST-I
;; Remplace l'élément à l'indice spécifié par un nouvel élément

(defun subst-i (new ind lst)
 (if (or (zerop ind) (null lst))
   (cons new (cdr lst))
   (cons (car lst) (subst-i new (1- ind) (cdr lst)))
 )
)

;---------------------------------------------------------------
;;; sous-fonction permettant de vérifier la catégorie d'un mot suivant les listes de contrôle  et de renvoyer cette catégorie dans le programme principal
(defun verification_mot (mot_a_verifier / outpout_categorie)

(setq LISTE_TYPES (list "Autoroute" "Allée" "Avenue" "Bosquets" "Boulevard" "Canal" "Carré" "Carrefour" "Centre" "Chemin" "Cité" "Communale" "Contour" "Cours" "Cour" "Domaine" "Départementale" "Ecluse" "Esplanade" "Faubourg" "Galeries" "Hameau" "Impasse" "Jardin" "Jardins" "Lotissement" "Lieu-dit" "Mail" "Parc" "Parking" "Passage" "Piste" "Place" "Placis" "Pont" "Porcon" "Porçon" "Pré" "Promenade" "Quai" "Résidence" "Rocade" "Rond-Point" "Route" "Rue" "Ruelle" "Rural" "Square" "Terrain" "Villa" "Village"))
(setq LISTE_ARTICLES (list "d'" "de" "l'" "la" "des" "du" "l'" "le" "au" "aux"))
(setq LISTE_TITRES (list "Abbé" "Abbe" "Amiral" "Capitaine" "Cardinal" "Chanoine" "Capitaine" "Cdt" "Cne" "Colonel" "Commandant" "Docteur" "Docteurs" "Doyen" "Duc" "Duchesse" "Frère" "Freres" "Frères" "General" "Général" "Gouverneur" "Gouverneur-Général" "Gouverneur-General" "Gouv.-Gal." "Lt" "Ltn" "Ltn-Col" "Lieutenant" "Lieutenant_Colonel" "Lieutenant-Colonel" "St-L" "Mme" "Madame" "Marechal" "Maréchal" "Monseigneur" "Marquis" "Monsieur" "Père" "President" "Président" "Professeur" "Professeurs" "Prof." "Recteur" "Roi" "Saint" "Sainte" "Sapeur" "Sergent" "Sir" "Sous-Lieutenant" "Sous_Lieutenant" "Comtesse"))
(setq LISTE_PARTICULES (list "D'" "De" "L'" "La" "Des" "Du" "L'" "Le" "Les"))
(setq LISTE_TEXTES (list "Dit" "DIT" "dit" "qui" "que" "quoi" "dont" "ou" "mais" "ou" "et" "donc" "or" "ni" "car" "Qui" "Que" "Quoi" "Dont" "Ou" "Mais" "Où" "Et" "Donc" "Or" "Ni" "Car"))
(cond
((vl-position mot_a_verifier LISTE_TYPES) (setq outpout_categorie "TYPE_VOIE")); fin member dans LISTE_TYPE
((vl-position mot_a_verifier LISTE_ARTICLES) (setq outpout_categorie "ARTICLE")); fin member dans LISTE_ARTICLE
((vl-position mot_a_verifier LISTE_TITRES) (setq outpout_categorie "TITRE")); fin member dans LISTE_TITRE
((vl-position mot_a_verifier LISTE_PARTICULES) (setq outpout_categorie "PARTICULE")); fin member dans LISTE_PARTICULE
((vl-position mot_a_verifier LISTE_TEXTES) (setq outpout_categorie "TEXTE")); fin member dans LISTE_TEXTE
(T (setq outpout_categorie "INCONNU"))
); fin cond
outpout_categorie
)
; fin defun verification_mot

;; | ----------------------------------------------------------------------------
;; | ST_RepChar
;; | ----------------------------------------------------------------------------
;; | Function : Replace one character in a string with another
;; | Argument : 'oldchar'  - Old Character (source)
;; |            'newchar'  - New Character (replace with)
;; |            'Str'      - String to process
;; | Return   : The string with the specified characters replaced
;; | Updated  : February 5, 1999
;; | e-mail   : rakesh.rao@4d-technologies.com 
;; | Web      : www.4d-technologies.com
;; | ----------------------------------------------------------------------------


(defun ST_RepChar (oldchar newchar Str / len cnt nstr cchar)
(setq
len (strlen str)
nstr ""
cnt 1
)
(repeat len
(setq
	cchar (substr str cnt 1)
	cnt (1+ cnt)
)
(if (/= cchar oldchar)
	(setq nstr (strcat nstr cchar))
	(setq nstr (strcat nstr newchar))
)
)
nstr
); fin defun ST_RepChar

;; str2lst (gile)
;; Transforme un chaine avec séparateur en liste de chaines
;; Arguments
;; str : la chaine à transformer en liste
;; sep : le séparateur
;; Exemples
;; (str2lst "a b c" " ") -> ("a" "b" "c")
;; (str2lst "1,2,3" ",") -> ("1" "2" "3")
;; (mapcar 'read (str2lst "1,2,3" ",")) -> (1 2 3)

(defun str2lst (str sep / pos)
(if (setq pos (vl-string-search sep str))
	(cons (substr str 1 pos)
		(str2lst (substr str (+ (strlen sep) pos 1)) sep)
	);fin cons
   (list str)
);fin if
);fin defun str2lst

;; lst2str (gile)
;; Concatène une liste et un séparateur en une chaine
;; Arguments
;; lst : la liste à transformer en chaine
;; sep : le séparateur
;; Exemples
;; (lst2str '("1" "2" "3") ",") -> "1,2,3"
;; (lst2str '("a" "b" "c") " ") -> "a b c"

(defun lst2str (lst sep)
(if (cdr lst)
	(strcat (car lst) sep (lst2str (cdr lst) sep))
	(car lst)
);fin if cdr lst
);fin defun lst2str

;;; Il suffit ensuite d'appeler ces deux fonctions :
(defun casse_nom_propre (input_mot)
(lst2str
(mapcar
	(function
		(lambda (x)
			(strcat (strcase (substr x 1 1)) (strcase (substr x 2) T))
		);fin lamda
	);fin function
	(str2lst input_mot "-")
   );fin mapcar
"-"
 );fin defun lst2str
);fin defun casse_nom_propre

(defun minuscule (input_mot /)
(if input_mot
	(setq output_mot (strcase input_mot T))
);fin if
output_mot
);fin defun minuscule

(defun changer_casse_par_categorie (input_mot / outpout_casse_mot)
(setq categorie_mot (verification_mot input_mot))
(print categorie_mot)
(cond
;début cond categorie_mot est égale à INCONNU
((= categorie_mot "INCONNU")
	(setq outpout_casse_mot (casse_nom_propre input_mot))
);fin cond categorie_mot est égal à INCONNU

;début cond categorie_mot est égale à TITRE
((= categorie_mot "TITRE")
	(setq outpout_casse_mot (casse_nom_propre input_mot))
);fin cond categorie_mot est égal à TITRE

;début cond categorie_mot est égale à TEXTE
((= categorie_mot "TEXTE")
	(setq outpout_casse_mot (minuscule input_mot))
);fin cond categorie_mot est égal à TEXTE

;début cond categorie_mot est égale à ARTICLE
((= categorie_mot "ARTICLE")
	(setq outpout_casse_mot (minuscule input_mot))
);fin cond categorie_mot est égal à ARTICLE

;début cond categorie_mot est égal à PARTICULE
((= categorie_mot "PARTICULE")
	(setq outpout_casse_mot (casse_nom_propre input_mot))
);fin cond categorie_mot est égal à PARTICULE

;début cond categorie_mot est égal à TYPE_VOIE
((= categorie_mot "TYPE_VOIE")
	(if
		(= (strcase input_mot) "ROND-POINT")
		(setq outpout_casse_mot "Rond-Point")
			(progn
				(setq outpout_casse_mot
					(strcat
						(strcase (substr input_mot 1 1))
						(strcase (substr input_mot 2) T)
					)
				)
			)
	)
);fin cond categorie_mot est égal à TYPE_VOIE
); fin cond
outpout_casse_mot
);fin defun changer_casse_par_categorie

;---------------------------------------------------------------
; sous-fonction permettant la suppression des espaces superflus
; paramètre global : ch
; paramètres locaux : n i bul a b
;---------------------------------------------------------------
(defun SUP_ES (ch / n i bul a b)
  (setq n (strlen ch) b "") 
  (if (/= n 0)
     (progn
        (setq i 1 bul t)
        (while (<= i n)
            (setq a (substr ch i 1))
            (if (/= a " ")
              (progn
               (setq b (strcat b a))
               (setq bul nil)
              );fin progn
              (if (= bul nil)
                (progn
                  (setq b (strcat b a))
                  (setq bul t)
                ); fin progn
              );fin if
            );fin if
            (setq i (+ 1 i))
        ); fin while
        (if (= (substr b (strlen b) 1) " ")
            (setq b (substr b 1 (- (strlen b) 1)))
        ); fin if
     ); fin progn
  ); fin if
  b
); fin

;; OptionBox (gile)
;; Boite de dialogue permettant de choisir une ou plusieurs options
;;
;; Arguments
;; title : le titre de la boite de dialogue (chaîne)
;; msg ; message (chaîne), "" ou nil por aucun
;; keylab : une liste d'association du type ((key1 . label1) (key2 . label2) ...)
;; mult : T (choix multiple) ou nil (choix unique)
;;
;; Retour : la clé de l'option (mult = nil) ou la liste des clés des options (mult = T)
;;
;; Exemples d'utilisations
;; (OptionBox "Type de fichier" nil '(("lin" . "Type de ligne") ("pat" . "Motif de hachure")) nil)
;; (OptionBox "Types d'entités" "Choisir les types d'entité" '(("LINE" . "Lignes") ("CIRCLE" . "Cercles")) T)

(defun OptionBox (title msg keylab mult / tmp file dcl_id choice)
(setq
	tmp (vl-filename-mktemp "tmp.dcl")
	file (open tmp "w")
)

(write-line
	(strcat "OptionBox:dialog{label=\"" title "\";")
	file
)
(write-line
	(strcat
		(if mult
			":boxed_column{"
			":boxed_radio_column{key=\"choice\";"
		)
	)
	file
)

(if (and msg (/= msg ""))
(write-line (strcat "label=\"" msg "\";") file)
)
(mapcar
(function
(lambda (p)
(write-line
(strcat (if mult
":toggle{key=\""
":radio_button{key=\""
)
(car p)
"\";label=\""
(cdr p)
"\";}"
)
file
)
)
)
keylab
)
(if mult
(write-line
"spacer;:button{label=\"Tout sélectionner\";
key=\"all\";fixed_width=true;alignment=centered;}"
file
)
)
(write-line "}spacer;ok_cancel;}" file)
(close file)
(setq dcl_id (load_dialog tmp))
(if (not (new_dialog "OptionBox" dcl_id))
(exit)
)
(if mult
(progn
(action_tile
"all"
"(foreach k (mapcar 'car keylab)
(set_tile k\"1\"))"
)
(action_tile
"none"
"(foreach k (mapcar 'car keylab)
(set_tile k\"0\"))"
)
(action_tile
"accept"
"(foreach k (mapcar 'car keylab)
(if (= \"1\" (get_tile k))
(setq choice (cons k choice))))
(setq choice (reverse choice))
(done_dialog)"
)
)
(progn
(set_tile "choice" (caar keylab))
(action_tile
"accept"
"(setq choice (get_tile \"choice\")) (done_dialog)"
)
)
)
(start_dialog)
(unload_dialog dcl_id)
(vl-file-delete tmp)
choice
)

;;;------------------------------------------------------------
;;; conversion MAJUSCULE en MINUSCULE et vice-versa
;;;------------------------------------------------------------
(defun majuscule_minuscule (option_strcase js / nbr i obj_acad index_texte index_texte_modifie)
(setq nbr (sslength js))
(setq i 0)
(while (<= i (- nbr 1))
	(setq obj_acad (ssname js i))
	(setq obj_vl (vlax-ename->vla-object obj_acad))
	(setq index_texte (vlax-get-property obj_vl 'TextString))
	(setq index_texte_modifie (strcase (vl-string-trim " " index_texte) option_strcase))
	(vla-put-textstring obj_vl index_texte_modifie)
	(vlax-release-object obj_vl)
	(setq i (+ i 1))
)
(setvar "cmdecho" 1)
);fin defun majuscule_minuscule
;;;------------------------------------------------------------------

;;;------------------------------------------------------------
;;; Première lettre de la phrase en Majuscule majuscule_au_debut
;;;------------------------------------------------------------
(defun majuscule_au_debut (js / nbr i obj_acad index_texte index_texte_modifie)
(setq nbr (sslength js))
(setq i 0)
(while (<= i (- nbr 1))
	(setq obj_acad (ssname js i))
	(setq obj_vl (vlax-ename->vla-object obj_acad))
	(setq index_texte (vlax-get-property obj_vl 'TextString))
	(setq index_texte_modifie (vl-string-trim " " index_texte))
		; si les deux premiers caractères du mot ne sont pas dans la liste
		(if (= (member (substr index_texte_modifie 1 2) '("D'" "L'" "l'" "d'" "\\L" "\\P")) nil)
			; faire une casse normale
			(progn
				(setq index_texte_modifie (strcat (strcase (substr index_texte_modifie 1 1))
				(strcase (substr index_texte_modifie 2) T))); fin setq index_texte_modifie
			);fin 1er progn
			; sinon faire une casse en prévoyant l'apostrophe
			(progn
				(setq index_texte_modifie (strcat (strcase (substr index_texte_modifie 1 2) T)
				(strcase (substr index_texte_modifie 3 1)) (strcase (substr index_texte_modifie 4) T))
				); fin setq index_texte_modifie
			);fin 2eme progn
		);fin if
	(vla-put-textstring obj_vl index_texte_modifie)
	(vlax-release-object obj_vl)
	(setq i (+ i 1))
); fin while
(setvar "cmdecho" 1)
); fin defun majuscule_debut
;;;------------------------------------------------------------

;;;------------------------------------------------------------
;;; Première lettre de la phrase en Majuscule casse_titre
;;;------------------------------------------------------------
(defun casse_titre (js / nbr i j index_texte_retourne mot_en_cours_modifie)
(setq nbr (sslength js))
(setq i 0)
(while (<= i (- nbr 1))
	(setq index_texte_modifie nil)
	(setq obj_acad (ssname js i))
	(setq obj_vl (vlax-ename->vla-object obj_acad))
	(setq index_texte (vlax-get-property obj_vl 'TextString))
	(setq index_texte (vl-string-trim " " index_texte))
	;;; Contrôle de l'existence d'apostrophe
		(if (= 	(wcmatch index_texte "*' *") T)
			; Alors rien
				(setq index_texte_modifie index_texte)
			;;; Sinon
			(progn
				; Remplacer l'apostrophe par un apostrophe+espace
				(setq index_texte_modifie (ST_RepChar "'" "' " index_texte))
			); fin progn wcmatch
		); fin if wcmatch

	;;; Séparation en plusieurs mots de la phrase en cours 
	(setq liste_mots (str2lst index_texte_modifie " "))
	(setq liste_mots (vl-remove "" liste_mots))
	;;; Comptage du nombre de mots dans la liste créee par str2lst
	(setq nombre_mots (length liste_mots))
		(setq index_texte_retourne " ")
		(setq j 0)
		(while (<= j (- nombre_mots 1))
			(setq mot_en_cours_modifie (changer_casse_par_categorie (nth j liste_mots)))
			(setq index_texte_retourne (strcat index_texte_retourne " " mot_en_cours_modifie))
			(princ index_texte_retourne)
		(setq j (+ j 1))
		index_texte_retourne
		); fin while
	(vla-put-textstring obj_vl (vl-string-left-trim " " index_texte_retourne))
	(vlax-release-object obj_vl)
	(setq i (+ i 1))
); fin while
(setvar "cmdecho" 1)
);fin defun casse_titre
;;;------------------------------------------------------------------

;;;------------------------------------------------------------------
; DDCHCASE.LSP
;---------------------------------------------------------------
; Permet de changer la casse d'un ou plusieurs textes
;---------------------------------------------------------------
; Le 24.02.99 - Fabrice DEMIEL.
;---------------------------------------------------------------
(defun c:ddchcase (/ fic cou Ok)
(vl-load-com)
(setq j-sel (ssget
 '(
	(-4 . "
	  (-4 . "")
	  (-4 . "")
	  (-4 . "")

	(-4 . "OR>")
  )
);ssget
);fin setq j-sel

;lancement du dialogue OptionBox de Gile
(setq choice (OptionBox "Changer la casse" "Changer la casse" '(("CHX1" . "Majuscule en début de phrase")("CHX2" . "Tout en minuscules")("CHX3" . "Tout en MAJUSCULES")("CHX4" . "1ere lettre des mots en majuscule"))nil))

(if choice
(cond
	((= choice "CHX1")
		(progn
		   (princ "\n---Majuscule en début de phrase")
		   (majuscule_au_debut j-sel)
		);fin progn
	)

	((= choice "CHX2")
		(progn
		   (princ "\n---Tout en minuscules")
		   (majuscule_minuscule T j-sel)
		);fin progn
	)
	((= choice "CHX3")
		(progn
		   (princ "\n---Tout en MAJUSCULES")
		   (majuscule_minuscule nil j-sel)
		);fin progn
	)
	((= choice "CHX4")
		(progn
		   (princ "\n---1ere lettre des mots en majuscule")
		   (casse_titre j-sel)
		);fin progn
	)
);fin cond
);fin if
(prompt "\n---COPYRIGHT Octobre 2010 par Fabrice DEMIEL---")
(princ)
);fin defun c:ddchcase

(prompt "\nFonction chargée- Pour lancer tapez : ddchcase")
(prin1)