But :Rassembler dans un document principal (ThisDocument) les paragraphes contenant un mot de tous les document Word d'un répertoire défini.
Le principe :
Tant qu'un Document existe dans le répertoire :
- Ouverture de chaque Document
- Recherche du mot
- Copie du paragraphe qui le contient
- Collage dans le document principal
- Fermeture du document
Fin Tant que
Les procédures
Sub Appel() :
- Vérifie l'existence du répertoire
- Crée une nouvelle instance de Word
- Lance l'ouverture des documents successifs
Sub Lister(Chemin$, LeMot$) :Tant qu'un document existe dans le répertoire :
- Liste les fichiers du répertoire
- Ouvre chaque fichiers
- Lance la recherche du mot
- Sélectionne et copie le paragraphe dans le document principal
- Crée un lien hypertexte vers le document objet de la recherche
- Ferme ce document
Fin tant que
Fonction Chercher(LeMot$) :
- Vérifie l'existence du mot dans le document ouvert
- Renvoie la réponse à la procédure Lister()
Pour tester, coller ces trois procédures dans une module standard et exécuter la procédure Appel()
Le code :
Liste les fichiers (*.doc) du répertoire
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23 Option Explicit Public appWd As Object Public LeDoc As Object Sub Appel() Dim Chemin$, Tablo As Variant, LeMot$ Set appWd = CreateObject("Word.Application") appWd.Visible = False Chemin = "D:\Doc\Essai\" If Not Dir(Chemin) <> "" Then MsgBox "Répertoire inexistant" Exit Sub End If LeMot = InputBox("Saisir le mot à chercher", "RECHERCHE", "Le mot") CreateObject("Wscript.shell").Popup "Minute papillon, je bosse !", 1, "PATIENCE, ÇA VIENT !" If Trim(LeMot) <> "" Then Lister Chemin, LeMot End If appWd.Quit Set appWd = Nothing MsgBox "èf' I... FI, èn' i... NI c'est FINI !" End Sub
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49 Sub Lister(Chemin$, LeMot$) Dim NomFich$ Dim LeDoc As Document NomFich = Dir(Chemin & "*.doc") 'Vérification de l'existence de fichiers dans le répertoire If NomFich = "" Then MsgBox "Aucun fichier dans le répertoire " & Chemin Exit Sub End If 'Ouverture des fichiers du répertoire Do While NomFich <> "" Set LeDoc = appWd.Documents.Open(Chemin & NomFich) DoEvents 'Lance la recherche If Chercher(LeMot) Then 'Insère un saut de ligne avant de coller le paragraphe ThisDocument.Range.InsertAfter vbCrLf 'renvoie en début de ligne appWd.Selection.HomeKey Unit:=wdLine 'Sélectionne le paragraphe appWd.Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend 'Copie le paragraphe appWd.Selection.Copy 'Colle le paragraphe dans le document principal ThisDocument.Select Selection.EndKey Unit:=wdStory Selection.PasteAndFormat (wdPasteDefault) 'Insère un saut de ligne ThisDocument.Range.InsertAfter vbCrLf 'Crée un lien hypertexte vers le document contenant le mot ThisDocument.Hyperlinks.Add Address:=Chemin & "\" & NomFich, _ Anchor:=Selection.Range End If 'Ferme le document objet de la recherche LeDoc.Close False Set LeDoc = Nothing DoEvents 'Passe au fichier suivant NomFich = Dir Loop End SubLe but d'ouvrir une nouvelle instance de Word :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7 'Recherche du mot dans le fichier ouvert Function Chercher(LeMot$) As Boolean With appWd.Selection.Find .Text = LeMot Chercher = .Execute End With End Function
- Accélérer appréciablement la procédure.
- Eviter accessoirement les mouvements de feuilles
Partager