Worddateien durchsuchen - auch mit Passwort!

Einen älteren Blogeintrag etwas angepasst. In Worddateien - optional auch in Unterordnern - soll ein bestimmter Begriff gesucht werden. Wird der Begriff im Worddokument gefunden, soll das Dokument aufgelistet und mit einem Hyperlink versehen werden. Die Worddokumente können auch ein Kennwort haben, dass beim Öffnen verlangt wird.

Worddateien durchsuchen - auch mit Passwort...[ZIP, 280 KB]

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" _
(ByVal lpPathName$) As Long
Const strSearchTMP As String = "Calculation"
Const strEXT As String = "*.doc*"
Private strList() As String
Private objWDApp As Object
Private lngCount As Long
Private objFSO As Object
Public Sub Test()
Dim strListing As String
Dim strDirOld As String
lngCount = 0
On Error GoTo Fin
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, _
InStr(1, strDirOld$, vbNullChar) - 1)
If funcDirectory(strListing) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWDApp = CreateObject("Word.Application")
Select Case MsgBox _
("Mit Unterordner ""Ja"" klicken, sonst ""Nein""!", _
vbYesNo Or vbQuestion Or vbDefaultButton1, "Unterordner")
Case vbYes
SearchFiles strListing, strEXT, True
Case vbNo
SearchFiles strListing, strEXT
End Select
If lngCount = 0 Then
MsgBox "No file with the search value found."
Else
With Sheet1
.Cells.Clear
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strList)
End With
Call HyLink(Sheet1)
End If
End If
Fin:
If Not objWDApp Is Nothing Then objWDApp.Quit
Call SetCurrentDirectory(strDirOld$)
Set objWDApp = Nothing
Set objFSO = Nothing
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
Optional blnTMP As Boolean = False)
Dim objFolder As Object
Dim objFile As Object
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
objWDApp.Documents.Open objFile.Path, _
PasswordDocument:="12345"
With objWDApp.Selection.Find
.Forward = True
.Text = strSearchTMP
If .Execute = True Then
ReDim Preserve strList(lngCount)
strList(lngCount) = objFile.Path
lngCount = lngCount + 1
objWDApp.ActiveDocument.Close False
End If
End With
End If
Next
If blnTMP = True Then
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, _
strFileName, blnTMP
Next
End If
End Sub
Private Function funcDirectory(strDirectory As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Directory"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strDirectory = .SelectedItems(1)
If Right(strDirectory, 1) <> "\" _
Then strDirectory = strDirectory & "\"
funcDirectory = strDirectory
Else
funcDirectory = ""
End If
End With
End Function
Private Sub HyLink(objSheet As Object)
Dim lngRow As Long
With objSheet
lngRow = .Range("A" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
Address:=.Cells(lngRow, 1), _
TextToDisplay:=Mid(.Cells(lngRow, 1), _
InStrRev(.Cells(lngRow, 1), "\", -1) + 1)
Next lngRow
.Columns("A:B").AutoFit
End With
End Sub

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...