Macros Word

Word possède un langage de macros fort complet mais pas très bien documenté (manque d'exemples avancés pour ceux qui ne disposent pas du kit de développement), surtout dans sa version française (erreurs de traduction de code). Aussi il peut être utile de partir de scripts déjà écrits. Voici donc les utilitaires que j'ai mis au point depuis l'apparition de Word 2 (NB : les références aux personnes physiques ont été supprimées).

prototypeur de lettres
prototypeur de rapports d'études
utilitaires

Prototypeur de lettres

Pour créer des variétés de lettres, un seul modèle commandé par des macros est encore la meilleure solution pour le gestionnaire qui ne veut pas retrouver dans le service une myriade de modèles incohérents. D'où les automatismes suivants qui remplissent intelligemment les signets d'un proto-modèle (macros Word 95).

NB : si le modèle ne nécessitait pas deux choix et deux passes, il y aurait sans doute eu possibilité d'utiliser le système plus souple de fusion-publipostage de Word.

AutoNew
ChooseAuthor
ChooseTypeDoc
AutoClose
Jpp

AutoNew

Sub MAIN 
ChooseAuthor
ChooseTypeDoc
AffichagePage
DébutDocument
End Sub

ChooseAuthor

Sub MAIN
n_auteurs = 1
Dim choix$(n_auteurs)
Dim signataire_fonction$(n_auteurs)
Dim signataire_nom$(n_auteurs)
Dim auteur_service$(n_auteurs)
Dim auteur_nom$(n_auteurs)
Dim auteur_tel$(n_auteurs)
Dim auteur_code$(n_auteurs)

choix$(0) = "P  Papillon"
signataire_fonction$(0) = "le chef de la division des réseaux de transport et leur environnement"
signataire_nom$(0) = "Jean-Philippe Papillon"
auteur_service$(0) = "DIRTE, division des réseaux de transport et leur environnement"
auteur_nom$(0) = "J.-Ph. Papillon"
auteur_tel$(0) = "04 74 27 53 00"
auteur_code$(0) = "JPP_EN"

choix$(1) = "D Dupond"
signataire_fonction$(1) = "le chef du groupe"
signataire_nom$(1) = "Albert Dupond"
auteur_service$(1) = "DIRTE-GE, groupe économie"
auteur_nom$(1) = "A. Dupond"
auteur_tel$(1) = "04 74 27 53 00"
auteur_code$(1) = "AD_MP"

auteur = Jpp.ChooseInList("Signataire", choix$())

Jpp.AffectBookmark("SignataireFonction", signataire_fonction$(auteur))
Jpp.AffectBookmark("SignataireNom", signataire_nom$(auteur))
Jpp.AffectBookmark("AuteurService", auteur_service$(auteur))
Jpp.AffectBookmark("AuteurNom", auteur_nom$(auteur))
Jpp.AffectBookmark("AuteurTel", auteur_tel$(auteur))
Jpp.AffectBookmark("AuteurCode", auteur_code$(auteur))
End Sub

ChooseTypeDoc

Sub MAIN
n_typedoc = 3
Dim choix$(n_typedoc)
Dim objet$(n_typedoc)
Dim pj$(n_typedoc)
Dim ref$(n_typedoc)
Dim texte$(n_typedoc)

choix$(0) = "0  Standard"

choix$(1) = "1  Devis"
objet$(1) = "Objet :" + Chr$(9) + "Devis d'études"
pj$(1) = "Pièce jointe :" + Chr$(9) + "Détail de l'estimation"
ref$(1) = ""
texte$(1) = "IADevis"

choix$(2) = "2  Facture"
objet$(2) = "Objet :" + Chr$(9) + "Facturation"
pj$(2) = "Pièces jointes :" + Chr$(9) + "1 facture, 1 ordre de versement"
ref$(2) = ""
texte$(2) = "IAFacture"

choix$(3) = "3  Facture titre 9"
objet$(3) = "Objet :" + Chr$(9) + "Facturation"
pj$(3) = "Pièce jointe :" + Chr$(9) + "1 facture"
ref$(3) = ""
texte$(3) =  "IAFacture9"

courrier = Jpp.ChooseInList("Type de courrier", choix$())
If (courrier > 0) Then
	Jpp.AffectBookmark("Objet", objet$(courrier))
	Jpp.AffectBookmark("PJ", pj$(courrier))
	Jpp.AffectBookmark("Ref", ref$(courrier))
	Jpp.AffectBookmark("Texte", texte$(courrier))
EndIf
End Sub

AutoClose

Sub MAIN
Jpp.SaveSelection

DéfinirPropriétéDocument("Organisation", 0, "CETE de Lyon, " + Jpp.GetBookmark$("AuteurService"), 1)
DéfinirPropriétéDocument("Titre", 0, Jpp.GetBookmark$("Objet"), 1)
DéfinirPropriétéDocument("Sujet", 0, Jpp.GetBookmark$("Affaire"), 1)

motsClesOriginaux$ = LitPropriétéDocument$("Motsclés", 1)
If (motsClesOriginaux$ = "") And (Val(LitPropriétéDocument$("NuméroDeRévision", 1)) > 3) Then
	MsgBox "Aucun mot clé n'a été attribué à ce document"
	On Error Resume Next
	FichierPropriétés
	motsClesOriginaux$ = LitPropriétéDocument$("Motsclés", 1)
End If

motsCles$ = CleanKeywords$(motsClesOriginaux$)
If motsCles$ <> motClesOriginaux$ Then
	DéfinirPropriétéDocument("Motsclés", 0, motsCles$, 1)
End If

Jpp.RestoreSelection
End Sub

REM néttoyage des mots clés en gérant plusieurs séparateurs
Function CleanKeywords$(entree$)
motsCles$ = entree$
Dim mots$(30)
indexMot = 0
Dim separateurs$(10)
separateurs$(0) = ","
separateurs$(1) = ";"
separateurs$(2) = "/"
separateurs$(3) = ":"
separateurs$(4) = "."
premierSeparateur = 0

While premierSeparateur < 100
premierSeparateur = 100
For i = 0 To 4
	placeSeparateur = InStr(motsCles$, separateurs$(i))
	If placeSeparateur > 0 And placeSeparateur < premierSeparateur Then
		premierSeparateur = placeSeparateur
	End If
Next
If premierSeparateur < 100 Then
	temp$ = LTrim$(RTrim$(Left$(motsCles$, premierSeparateur - 1)))
	mots$(indexMot) = temp$
	indexMot = indexMot + 1
	motsCles$ = Mid$(motsCles$, premierSeparateur + 1)
End If
Wend
If Len(motsCles$) > 0 Then
	mots$(indexMot) = motsCles$
	indexMot = indexMot + 1
End If
motsCles$ = mots$(0)
For i = 1 To indexMot - 1
	motsCles$ = motsCles$ + " ; " + mots$(i)
Next

CleanKeywords$ = motsCles$
End Function

Jpp

Sub MAIN
REM Seules les fonctions sont utilisées
End Sub

REM *******************************************
REM OBJET : remplace le paragraphe correspondant à un signet
REM signet$ : nom du signet
REM Si le texte commence par "IA", il y a tentative d'insertion automatique.
REM texte$ : valeur du texte de remplacement
REM Si le texte est "", le paragraphe est supprimé ainsi que le signet.
REM EFFET DE BORD : la sélection est déplacée.
REM *******************************************
Sub AffectBookmark(signet$, texte$)
If SignetExistant(signet$) Then
	EditionSignet .Nom = signet$, .Atteindre
	EditionSignet .Nom = "\Para", .Atteindre
	If texte$ <> "" Then
		Insertion texte$
		If (Left$(texte$, 2) = "IA") Then
 			EffectuerInsertionAuto
		Else
			CarGauche Len(texte$), 1
			EditionSignet .Nom = signet$, .Ajouter
		End If
	Else
		EditionCouper
	End If
End If
End Sub

REM *******************************************
REM OBJET : obtenir le texte associé à un signet sans la marque de paragraphe final. Sinon recherche après le texte "signet$ :\t"
REM EFFET DE BORD : déplace la sélection
REM *******************************************
Function GetBookmark$(signet$)
If SignetExistant(signet$) Then
	EditionSignet .Nom = signet$, .Atteindre
	GetBookmark$ = Left$(Sélection$(), Len(Sélection$()) - 1)
Else
	DébutDocument
	EditionRechercher .Rechercher = signet$ + " :" + Chr$(9)
	If EditionRechercherTrouvé() Then
		CarDroite 1, 0
		FinLigne 1
		GetBookmark$ = Left$(Sélection$(), Len(Sélection$()) - 1)
	Else
		GetBookmark$ = ""
	End If
End If
End Function


REM *******************************************
REM OBJET : sauvegarde la sélection
REM *******************************************
Sub SaveSelection
CopierSignet "\Sel", "SauvegardeSel"
End Sub

REM *******************************************
REM OBJET : restaure la sélection
REM Comme la sauvegarde s'effectue dans une "variable" globale et non une pile, c'est la dernière sauvegarde qui est restaurée.
REM *******************************************
Sub RestoreSelection
If SignetExistant("SauvegardeSel") Then
	EditionSignet .Nom = "SauvegardeSel", .Atteindre
	EditionSignet .Nom = "SauvegardeSel", .Supprimer
End If
End Sub

REM *******************************************
REM OBJET : faire choisir l'utilisateur dans une liste
REM titre$ : titre de la boîte de dialogue
REM liste$ : tableau des choix
REM EFFET DE BORD : création d'une variable globale ValeurDlg
REM *******************************************
Dim Shared ValeurDlg
Function FuncDlg(identificateur$, action, valaction)
If identificateur$ = "ZoneDeListe" And action = 2 Then
	ValeurDlg = valaction
End If
End Function
 

Function ChooseInList(titre$, liste$())

Begin Dialog BoiteDlgUtilisateur 600, 200, titre$, .FuncDlg
	ListBox 10, 10, 580, 150, liste$(), .ZoneDeListe
	OKButton 490, 170, 100, 20
End Dialog

Dim boîteDlgExemple As BoiteDlgUtilisateur
bouton = Dialog(boîteDlgExemple)
ChooseInList = ValeurDlg
End Function

Prototypeur de rapports d'études

Après les lettres, les rapports d'études. Leur suivi demande de gérer des numéros de version, comme les programmes informatiques (macros Word 95).

AutoNew
AutoClose
FichierEnvoyer

AutoNew

Sub MAIN
REM ***********************************
REM l'instruction suivante ne fonctionne que dans Word 7
DéfinirPropriétéDocument("Organisation", 0, GetAddress$, 1)

On Error Resume Next
FichierPropriétés

UpdateAllFields

CheckFont
End Sub

REM ***********************************
REM vérifie l'installation de la police CG Oméga
REM ***********************************
Sub CheckFont
bOk = 0
For compte = 1 To ComptePolices()
	If Police$(count) = "CG Omega" Then
		bOk = 1
	End If
Next
If bOk = 0 Then
	MsgBox "Il faut installer la police CG Oméga sur votre ordinateur."
End If
End Sub

REM ***********************************
REM récupère l'information utilisateur
REM et la met à jour si nécessaire
REM ***********************************
Function GetAddress$
Dim dlg As OutilsOptionsInformationUtilisateur
GetCurValues dlg
address$ = dlg.Adresse

standard$ = "CETE de Lyon"
If Left$(address$, Len(standard$)) <> standard$ Then
	address$ = standard$
	OutilsOptionsInformationUtilisateur .Adresse = address$
	MsgBox "La rubrique Adresse des options utilisateur a été mise à jour. C'est elle qui sert à remplir automatiquement le champ organisation du document. Pour tenir compte de votre spécificité, modifiez la directement.",
	"Modification de votre configuration"
End If

GetAddress$ = address$
End Function

REM *********************************
REM mise à jour de tous les champs du document
REM ***********************************
Sub UpdateAllFields
DébutDocument
While ChampSuiv()
	MiseAJourChamps
	CarDroite 1
Wend
EditionAtteindre .Destination = "p2"
AffichageEnTête()
While ChampSuiv()
	MiseAJourChamps
	CarDroite 1
Wend
AffichageEnTête()
EditionAtteindre .Destination = "p3"
End Sub

AutoClose

Sub MAIN
If EstDocModifié() Then

CopierSignet "\Sel", "AutoCloseSauvegardeSel"

REM ***********************************
REM gestion des versions
REM ***********************************
If SignetExistant("Version") Then
	EditionSignet .Nom = "Version", .Atteindre
	EditionSignet .Nom = "\Para", .Atteindre
	espace = InStr(Sélection$(), " ")
	ancienneversion$ = Mid$(Sélection$(), espace + 1, Len(Sélection$()) - espace - 1)
	version$ = ancienneversion$
	
	REM pas une très belle façon de gérer le clic sur annuler...
	On Error Resume Next
	version$ = AskValue$("Numéro de version (format N.N) :", "Qualité des documents", ancienneversion$)
	point = InStr(version$, ".")
	If point > 0 Then
		majeur = Val(Mid$(version$, 1, point - 1))
		mineur = Val(Mid$(version$, point + 1))
		version$ = LTrim$(Str$(majeur)) + "." + LTrim$(Str$(mineur))
	Else
		majeur = Val(version$)
		If majeur > 0 Then
			version$ = LTrim$(Str$(majeur)) + ".0"
		Else
			version$ = ancienneversion$
		End If
	End If
	texte$ = "Version " + version$
	Insertion texte$
	CarGauche Len(texte$), 1
	EditionSignet .Nom = "Version", .Ajouter
Else
	MsgBox "Vous gérez manuellement les numéros de version !", "Qualité des documents"
End If

REM ***********************************
REM gestion des mots clés
REM ***********************************
motsClesOriginaux$ = LitPropriétéDocument$("Motsclés", 1)

If motsClesOriginaux$ = "" Then
	MsgBox "Aucun mot clé n'a été attribué à ce document"
	On Error Resume Next
	FichierPropriétés
	motsClesOriginaux$ = LitPropriétéDocument$("Motsclés", 1)
End If

motsCles$ = CleanKeywords$(motsClesOriginaux$)
If motsCles$ <> motClesOriginaux$ Then
	DéfinirPropriétéDocument("Motsclés", 0, motsCles$, 1)
End If

REM un problème pourrait apparaître lorsque le curseur était déjà sur le paragraphe mentionnant la version
If SignetExistant("AutoCloseSauvegardeSel") Then
	EditionSignet .Nom = "AutoCloseSauvegardeSel", .Atteindre
	EditionSignet .Nom = "AutoCloseSauvegardeSel", .Supprimer
End If

REM fin du test sur modification document
End If
End Sub

REM ***********************************
REM néttoyage des mots clés en gérant plusieurs séparateurs
REM ***********************************
Function CleanKeywords$(entree$)
motsCles$ = entree$
Dim mots$(30)
indexMot = 0
Dim separateurs$(10)
separateurs$(0) = ","
separateurs$(1) = ";"
separateurs$(2) = "/"
separateurs$(3) = ":"
separateurs$(4) = "."
premierSeparateur = 0

While premierSeparateur < 100
premierSeparateur = 100
For i = 0 To 4
	placeSeparateur = InStr(motsCles$, separateurs$(i))
	If placeSeparateur > 0 And placeSeparateur < premierSeparateur Then
		premierSeparateur = placeSeparateur
	End If
Next
If premierSeparateur < 100 Then
	temp$ = LTrim$(RTrim$(Left$(motsCles$, premierSeparateur - 1)))
	mots$(indexMot) = temp$
	indexMot = indexMot + 1
	motsCles$ = Mid$(motsCles$, premierSeparateur + 1)
End If
Wend
If Len(motsCles$) > 0 Then
	mots$(indexMot) = motsCles$
	indexMot = indexMot + 1
End If
motsCles$ = mots$(0)
For i = 1 To indexMot - 1
	motsCles$ = motsCles$ + " ; " + mots$(i)
Next

CleanKeywords$ = motsCles$
End Function

REM ***********************************
Function AskValue$(message$, titre$, defaultValue$)
Begin Dialog BoiteDlgUtilisateur 320, 85, titre$
		Text 10, 10, 300, 12, message$, .Texte1
		TextBox 10, 30, 300, 18, .valeur
		OKButton 230, 55, 80, 20
End Dialog

Dim dlg As BoiteDlgUtilisateur
dlg.valeur = defaultValue$
a = Dialog(dlg)
AskValue$ = dlg.valeur
End Function

FichierEnvoyer

Sub MAIN
If ProtectionDocument() = 0 Then
	MsgBox "Le document n'est pas protégé pour la révision ou l'annotation."
	Dim dlg As OutilsProtégerDocument
	GetCurValues dlg
	If Dialog(dlg) = - 1 Then
		OutilsProtégerDocument .MotDePasseDocument = dlg.MotDePasseDocument, .PasDeRestauration = dlg.PasDeRestauration, .Type = dlg.Type
	End If
End If
FichierEnvoyer
End Sub

Utilitaires

Deux macros à tout faire à placer dans le modèle général NORMAL.DOT.

La première rétablit les styles de tous les paragraphes. Si le créateur n'a utilisé que des styles de caractères ou des redéfinitions locales, le résultat sur la mise en page sera catastrophique et le retour à l'envoyeur inévitable.

La seconde est bien utile quand on référence des variables mathématiques indicées. Attachée à un bouton, elle trouve toute seule quels caractères mettre en indice dans la sélection ou le paragraphe.

RétablirStyles

Sub MAIN
DébutDocument
EditionRechercher .Rechercher = "^p", .Sens = 0
While EditionRechercherTrouvé()
	RétablirPara()
	EditionRechercher .Rechercher = "^p", .Sens = 0
Wend
End Sub

En VBScript pour Word 2000, cela donne :

Sub RetablirStyles()
For Each para In ActiveDocument.Paragraphs
    para.Style = ActiveDocument.Styles(para.Style)
Next para
End Sub

IntelliIndice

Sub MAIN
If SélType() = 1 Then
	If ModeExtension() = 0 Then
		EtendreSélection
		EtendreSélection
		Annuler
	Else
		EtendreSélection
	EndIf
EndIf
If SélType() = 2 Then
	sel$ = Sélection$()
	etat = 0
	CarGauche 1
	longueur = Len(sel$)
	For i = 1 To longueur
		CarDroite 1, 1
		car$ = Mid$(sel$, i, 1)
	
		If (etat = 0) Then
			If ((car$ >= "a" And car$ <= "z") Or (car$ >= "A" And car$ <= "Z")) Then
				etat = 1
			EndIf
		ElseIf (etat = 1) Then
			If (car$ >= "0" And car$ <= "9") Then
				Indice
			ElseIf (car$ = "i" Or car$ = "j" Or car$ = "n" Or car$ = "t") Then
				Indice
			ElseIf (car$ = "+" Or car$ = "-") Then
				Indice
			ElseIf (car$ = " " Or car$ = "=" Or car$ = "(" Or car$ = ")" Or car$ = Chr$(9) Or car$ = Chr$(11) Or car$ = Chr$(13) Then
				etat = 0
			EndIf
		EndIf

	CarDroite 1
	Next i
EndIf
End Sub