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 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
| 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 = "C:\Users\s\Desktop\"
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 "c'est FINI !"
End Sub
Sub Lister(Chemin$, LeMot$)
Dim NomFich$
Dim LeDoc As Document
NomFich = Dir(Chemin & "*.docx")
'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
End If
'Ferme le document objet de la recherche
LeDoc.Close False
Set LeDoc = Nothing
DoEvents
'Passe au fichier suivant
NomFich = Dir
Loop
End Sub
'Recherche du mot dans le fichier ouvert
Function Chercher(LeMot$) As Boolean
With appWd.Selection.Find
.Text = LeMot
Chercher = .Execute
End With
End Function |