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
| Private Sub txtRecherche_AfterUpdate()
Dim dDepart As Double
Dim tabExt() As String
Dim FSO As Scripting.FileSystemObject
Dim sRep As Scripting.Folder
Dim sSubRep As Scripting.Folder
Dim sFichier As Scripting.File
Dim wdapp As Word.Application
Dim lNumWin As Long
Dim bSelected As Boolean
dDepart = Now()
'Purger la table tTrouves
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * FROM tTrouves;"
DoCmd.SetWarnings True
Me.Requery
Set FSO = New Scripting.FileSystemObject
Set sRep = FSO.GetFolder(CurrentProject.Path & "\documents")
Set wdapp = New Word.Application
'Boucle sur les fichiers
For Each sFichier In sRep.Files
'Quelle extension ?
tabExt = Split(sFichier.Name, ".")
If tabExt(UBound(tabExt)) = "docx" Then
With wdapp
.Visible = True
' Ouvrir le document
.Documents.Open CurrentProject.Path & "\documents\" & sFichier.Name
.Selection.HomeKey Unit:=wdStory
.Selection.Find.Execute FindText:=Me.txtRecherche, Forward:=True
bSelected = .Selection.Find.found
.Documents.Close
End With
ElseIf tabExt(UBound(tabExt)) = "PDF" Then
lNumWin = Shell(AdresseAdobe & " " & CurrentProject.Path & "\documents\" & sFichier.Name, vbNormalNoFocus)
DoEvents
' SendKeys "{ENTER}", True 'si pb type de fichier
'copier le texte
SendKeys "^a^c", True
DoEvents
With wdapp
.Documents.Open CurrentProject.Path & "\Martyr.docx"
.Selection.WholeStory
.Selection.Paste
.ActiveDocument.Save
.Selection.HomeKey Unit:=wdStory
.Selection.Find.Execute FindText:=Me.txtRecherche, Forward:=True
bSelected = .Selection.Find.found
.Documents.Close
KillApp (lNumWin)
Sleep 1000
End With
End If
'si sélectionné => ajouter dans la table tTrouves
If bSelected = True Then
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO tTrouves ( NomFichier ) SELECT """ & sFichier.Name & """ AS Expr1;"
DoCmd.SetWarnings True
End If
Next sFichier
'Fermer et libérer les objets
wdapp.Quit
Set wdapp = Nothing
Me.Requery
MsgBox "Recherche terminée en " & Now() - dDepart
End Sub |
Partager