Application.FileSearch in Office 2007?

Question

Hallo,

das folgende Programm, war dazu da, in unserer Firma, einen markierten Bereich in einer Exceltabelle durchzugehen und dann in einem vorher angegebenen Ordner, nach Dateien des selben Names zu suchen.
Ich hoffe ihr könnt mir helfen, da derjenige der das Makro geschrieben hat, nicht mehr hier ist und nun ich diese Aufgabe bekommen habe.

Mit freundlichen Grüßen
Christian Edel

P.S.: Hier das Makro:
Und schonmal VIELEN DANKE für die Hilfe!!!!

Sub VerknüpfungenErstellen_V3()
Dim pfad As String
'in welchem Verzeichnis liegen die Dokumente?
Dim oSh As Object
Dim oFd As Variant
Dim nS As Object

Set oSh = GetObject("", "Shell.Application")
Set oFd = oSh.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "")
Set nS = oFd.Self
pfad = nS.Path

Set oSh = Nothing


If pfad = "" Then Exit Sub

'Markierte Zellen durchgehen
For Each cell In Selection

gefunden = False



With Application.FileSearch
.NewSearch
.LookIn = pfad
.SearchSubFolders = True
.Filename = cell.Value & ".pdf"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then
Select Case .FoundFiles.Count
Case 1
'Verknüpfen
'MsgBox "LINK: " & .FoundFiles(1)
ActiveSheet.Hyperlinks.Add cell, .FoundFiles(1)
gefunden = True
Case Else
MsgBox "Es wurde mehr ale eine passende Datei " & cell.Value & ".pdf gefunden. Bitte manuell verknüpfen."
End Select
Else
'MsgBox "Es wurde keine Datei " & cell.Value & ".pdf gefunden."
End If
End With

If Not (gefunden) Then
'mit verkürztem Suchstring (ohne führende Nullen) nochmal durchgehen, falls nichts gefunden wurde.
'Beispiel cell.Value = DE000004006420C5
' suchstring = DE4006420C5
suchstring = cell.Value
While Mid(suchstring, 3, 1) = "0" And Not (gefunden)

'eine Null entfernen..
suchstring = Left(suchstring, 2) & Right(suchstring, Len(suchstring) - 3)

'..und nochmal suchen
With Application.FileSearch
.NewSearch '
.LookIn = pfad
.SearchSubFolders = True
.Filename = suchstring & ".pdf"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then
Select Case .FoundFiles.Count
Case 1
'Verknüpfen
'MsgBox "LINK: " & .FoundFiles(1)
ActiveSheet.Hyperlinks.Add cell, .FoundFiles(1)
gefunden = True
Case Else
MsgBox "Es wurde mehr ale eine passende Datei " & suchstring & ".pdf gefunden. Bitte manuell verknüpfen."
End Select
Else
MsgBox "Es wurde keine Datei " & suchstring & ".pdf gefunden."
End If
End With

Wend
End If

Next

End Sub

Answer 1

Hallo Christian,

ich habe jetzt den Code umgeschrieben, das mit den 4x0 habe ich einprogrammiert aber nicht getestet.

Option Explicit
' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.
' Der VB Code ist aus dem Beitrag http://www.activevb.de/tipps/vb6tipps/tipp0492.html
' Verweis: Microsoft Scripting Runtime
Dim LogFile As TextStream
Dim FolderCount As Long
Dim FileCount As Long
' Ergänzung Hajo
' Variable für Verzeichnis
Const StOrdner As String = "J:\Eigene Dateien\Hajo\Internet\Test\2010"
Const StTyp As String = "*.PDF" ' Dateityp
Dim RaFound As Range ' Variable Suchergebnis

Sub Start()
Application.ScreenUpdating = False ' Bildschirmaktulalisierung aus
' Zeile aus Originalcode
SearchInFolder StOrdner ' Sub aufrufen
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End Sub

Private Sub SearchInFolder(ByVal Folderspec As String)
Dim FSO As New FileSystemObject
Dim SearchFolder As Folder
Dim FD As Folder, FI As File
Dim EachFil As Files, EachFold As Folders
Set SearchFolder = FSO.GetFolder(Folderspec)
Set EachFil = SearchFolder.Files ' Dateien in der jeweiligen Root
' für Unterverzeichnis
Set EachFold = SearchFolder.SubFolders ' Unterordner in der Root
' Dateien auslesen
For Each FI In EachFil ' Schleife über alle Dateien
' Prüfen ob Dateiname im Bereich
Set RaFound = Selection.Find(FI.Name, , , xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
' Datei gefunden
' Hyperlink erstellen
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=Range(RaFound.Address), _
Address:=FI.Path, TextToDisplay:=FI.Name
End If
Else
Set RaFound = Selection.Find(Left(FI.Name, 2) & "0000" & Mid(FI.Name, 3), , , _
xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=RaFound, _
Address:=FI.Path, TextToDisplay:=FI.Name
End If
End If
End If
Next FI
Set EachFil = Nothing
Set EachFold = Nothing
Set FSO = Nothing
Set RaFound = Nothing
End Sub

Gruß Hajo

Answer 2

Hallo Hajo,

vielen Dank.
Sobald ich am Montag wieder auf Arbeit bin, werde ich deinen Code testen.
Ein riesen Lob.
Und schönes wochenende =)

Gruß Christian

Answer 3

Hi,

@Christian (C.Edel)

Mir is grad aufgfallen, dass ich a depp bin :)
Warum abfrage, ob es mehrer Dateien gibt. Is ja sinnlos. Ich habe ja die exakten namen der dateien und man kann sowieso nicht mehr als eine datei eines dateinnames haben.

Wenn Du, vom ausgewählten (Root-)Verzeichnis aus, keine Unterverzeichnisse durchsuchen wollen würdest, dann stimmt das. Das "beisst" sich aber mit #4:

2. Dann soll der Ordner der Dateien angegeben werden. + Unterordner

Und auch mit dem Code aus #1:

With Application.FileSearch
.NewSearch
.LookIn = pfad
.SearchSubFolders = True
.
.

Oder habe ich das falsch verstanden?

Ich wollte es nur schreiben, denn der Code von Hajo geht auf Unterverzeichnisse nicht ein, wenn ich ihn beim lesen richtig verstanden habe. (Ich habe den Code von Hajo nur gelesen, nicht getestet.) Wenn also Unterverzeichnisse wirklich notwendig sind, und ich den Code von Hajo nicht missverstanden habe, dann muss wohl nochmal Hand angelegt werden.

bye
malSchauen

Answer 4

Stimmt. jetzt wo dus sagst. Ich bin mir nicht sicher, ob unterverzeichnisse vorhanden sind. das werde ich in der
arbeit sehen.
Ich werde mich am Montag wieder melden.

Gruß Christian

Answer 5

Hallo Christian,

Entschuldigung, die Unterverzeichnisse habe ich gekillt. Jetzt sind Sie aber drin.

Option Explicit
' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.
' Der VB Code ist aus dem Beitrag http://www.activevb.de/tipps/vb6tipps/tipp0492.html
' Verweis: Microsoft Scripting Runtime
Dim LogFile As TextStream
Dim FolderCount As Long
Dim FileCount As Long
' Ergänzung Hajo
' Variable für Verzeichnis
Const StOrdner As String = "J:\Eigene Dateien\Hajo\Internet\Test\2010"
Const StTyp As String = "*.PDF" ' Dateityp
Dim RaFound As Range ' Variable Suchergebnis

Sub Start()
Application.ScreenUpdating = False ' Bildschirmaktulalisierung aus
' Zeile aus Originalcode
SearchInFolder StOrdner ' Sub aufrufen
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End Sub

Private Sub SearchInFolder(ByVal Folderspec As String)
Dim FSO As New FileSystemObject
Dim SearchFolder As Folder
Dim FD As Folder, FI As File
Dim EachFil As Files, EachFold As Folders
Set SearchFolder = FSO.GetFolder(Folderspec)
Set EachFil = SearchFolder.Files ' Dateien in der jeweiligen Root
' für Unterverzeichnis
Set EachFold = SearchFolder.SubFolders ' Unterordner in der Root
' Unterordner des Verzeichnisses feststellen und in Datei schreiben
For Each FD In EachFold
' Funktion rekursiv aufrufen weitere Unterverzeichnisse
SearchInFolder CStr(FD)
Next FD
' Dateien auslesen
For Each FI In EachFil ' Schleife über alle Dateien
' Prüfen ob Dateiname im Bereich
Set RaFound = Selection.Find(FI.Name, , , xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
' Datei gefunden
' Hyperlink erstellen
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=Range(RaFound.Address), _
Address:=FI.Path, TextToDisplay:=FI.Name
End If
Else
Set RaFound = Selection.Find(Left(FI.Name, 2) & "0000" & Mid(FI.Name, 3), , , _
xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=RaFound, _
Address:=FI.Path, TextToDisplay:=FI.Name
End If
End If
End If
Next FI
Set EachFil = Nothing
Set EachFold = Nothing
Set FSO = Nothing
Set RaFound = Nothing
End Sub

Gruß Hajo

Answer 6

Hallo Hajo,
danke, dass du noch dieSubfolders integriert hast.
Nun stoße ich jedoch auf ein Problem.
1. Wieso, kann ich den Code nicht bearbeiten, wenn ich ihn gespeichert habe?
2. Er bringt mir eine Fehlermeldung.:

Fehler beim Kompilieren:
Benutzerdefinierter Typ nicht definiert.

Dim LogFile As TextStream

Danke

Gruß Christian

Answer 7

Hallo Christian,

den Hinweis
' Verweis: Microsoft Scripting Runtime
hast Du schon beachtet? (Extra, Verweise)

Gruß Hajo

Answer 8

Tut mir leid ich habe das mit der Microsoft Script Runtime überlesen.
Aber eine Frage: wie kann ich das wieder einbinden?
FSO.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "")

Answer 9

Hallo Christian,

das verstehe ich nicht. Du hastr schon Extra, Verweise geklickt und es da ausgewählt?

Gruß Hajo

Answer 10

Hallo Hajo,

ignoriere bitte meine Posts von vorhin, es war schlicht weg nicht genau hingeschaut ;)

Hier ist nun mal mein Abgeänderter Code:
Aber er will nicht so wie ich will.
Er frägt mich zwar nach dem Ordner etc. Aber es passiert irgentwie nichts.

Option Explicit
Dim FolderCount As Long
Dim FSO As New FileSystemObject
Dim FileCount As Long
' Variable für Verzeichnis
Dim nS As Object
Dim StOrdner As String
Const StTyp As String = "*.PDF" ' Dateityp
Dim RaFound As Range ' Variable Suchergebnis

Sub Start()
Dim oSh As Object
Dim oFd As Variant
Set oSh = GetObject("", "Shell.Application")
Set oFd = oSh.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "")
Set nS = oFd.Self
Set oSh = Nothing
StOrdner = nS.Path
Application.ScreenUpdating = True ' Bildschirmaktulalisierung aus
SearchInFolder StOrdner ' Sub aufrufen
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End Sub

Private Sub SearchInFolder(ByVal Folderspec As String)
Dim FSO As New FileSystemObject
Dim SearchFolder As Folder
Dim FD As Folder, FI As File
Dim EachFil As Files, EachFold As Folders
Set SearchFolder = FSO.GetFolder(Folderspec)
Set EachFil = SearchFolder.Files ' Dateien in der jeweiligen Root
' für Unterverzeichnis
Set EachFold = SearchFolder.SubFolders ' Unterordner in der Root
' Unterordner des Verzeichnisses feststellen und in Datei schreiben
For Each FD In EachFold
' Funktion rekursiv aufrufen weitere Unterverzeichnisse
SearchInFolder CStr(FD)
Next FD
' Dateien auslesen
For Each FI In EachFil ' Schleife über alle Dateien
' Prüfen ob Dateiname im Bereich
Set RaFound = Selection.Find(FI.Name, , , xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
' Datei gefunden
' Hyperlink erstellen
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=Range(RaFound.Address), _
Address:=FI.Path, TextToDisplay:=FI.Name
End If
Else
Set RaFound = Selection.Find(Left(FI.Name, 2) & "0000" & Mid(FI.Name, 3), , , _
xlWhole, xlByRows, xlNext)
If Not RaFound Is Nothing Then
If Range(RaFound.Address).Hyperlinks.Count = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=RaFound, _
Address:=FI.Path, TextToDisplay:=FI.Name
End If
End If
End If
Next FI
Set EachFil = Nothing
Set EachFold = Nothing
Set FSO = Nothing
Set RaFound = Nothing
End Sub