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,

das .pdf-Problem wäre gelöst.
Wenn ich mich recht entsinne gibt es nun nur noch eine Randbedingung zu klären:
- mehrfache Dateien. Leider fällt mir dazu gar nichts ein.
- Wenn mir vieleicht jemand auf die Sprünge helfen könnte, wär ich sehr dankbar

Gruß Chrisian

Answer 2

Kommando zurück .pdf-Problem ist nicht gelöst

Answer 3

Problem mit .pdf nun WIRKLICH gelöst

Answer 4

So,

nach einem weiteren Tag des Grübelns, habe ich nun weitere Randbedingungen abgefangen.
- Doppelte Dateien werden gemeldet
- Wenn Benutzer auf abbrechen klickt wird die Liste nicht verunstaltet
- Alle Unterordner werden Ordnungsgemäß durchsucht

Hier der Code:

Option Explicit ' By C.Edel
Dim FolderCount As Long
Dim FSO As New FileSystemObject
Dim FileCount As Long ' Variable für Verzeichnis
Dim RaFound As Range ' Variable Suchergebnis

Sub Verlinkung_v4_Office2007()
Application.ScreenUpdating = False ' Bildschirmaktualisierung aus
Dim rngCell As Range
For Each rngCell In Selection
rngCell.Value = rngCell.Value & ".pdf"
Next

Dim StOrdner As String
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, "") 'Pfad übergeben
If oFd Is Nothing Then
EndOfSub
Exit Sub
End If
Set nS = oFd.Self
Set oSh = Nothing
StOrdner = nS.Path
SearchInFolder StOrdner ' Sub aufrufen
Cells.Replace What:=".pdf", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ' ".pdf" löschen
End Sub

Private Sub SearchInFolder(ByVal Folderspec As String)
Dim SearchFolder As Folder
Dim RaFoundTemp As Range
Dim FSO As New FileSystemObject
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 RaFoundTemp Is RaFound Then
MsgBox "Es wurde mehr ale eine passende Datei " & FI.Name & " gefunden. Bitte manuell verknüpfen."
Else
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
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
End If
End If
End If
End If
Next FI

Set EachFil = Nothing
Set EachFold = Nothing
Set FSO = Nothing
Set RaFoundTemp = RaFound
Set RaFound = Nothing
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End Sub

Private Sub EndOfSub()
Cells.Replace What:=".pdf", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub

Answer 5

Hi,

Das klingt ja fast so, als ob Du alle Deine Probleme gelöst hättest. Dann beglückwünsche ich Dich mal zu Deinem (kleinen) Erfolg mit Deinem "scheinbar" gut funktionierenden Code.

Aber so richtig ausführlich getestet hast Du ihn wohl noch nicht? Und meine Anmerkung zur "Position" der einzelnen CodeZeilen ist wohl auch nur mangelhaft gewesen. Zumindest hätte ich eine andere Umsetzung erwartet.

[*]Position
Für das "Abbrechen" hast Du das Problem ja auf den ersten Blick gelöst. Nur warum änderst Du zuerst die Zellen in der Selection, wenn der User noch die Möglichkeit zum Abbruch hat? Ich würde erst alle Userentscheidungen abwarten wollen, und erst dann die Werte/Zellen nach meinen Bedürfnissen manipulieren wollen. (Dann kann kein Usereingriff den Ablauf stören, und Du musst Dir (fast) keine Gedanken um das "Aufräumen" machen.)

Aus...

Sub Verlinkung_v4_Office2007()
Application.ScreenUpdating = False ' Bildschirmaktualisierung aus
Dim rngCell As Range
For Each rngCell In Selection
rngCell.Value = rngCell.Value & ".pdf"
Next

Dim StOrdner As String
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, "") 'Pfad übergeben
If oFd Is Nothing Then
EndOfSub
Exit Sub
End If
Set nS = oFd.Self
Set oSh = Nothing
StOrdner = nS.Path
SearchInFolder StOrdner ' Sub aufrufen
Cells.Replace What:=".pdf", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ' ".pdf" löschen
End Sub

...könnte also...

Sub Verlinkung_v4_Office2007()
Application.ScreenUpdating = False ' Bildschirmaktualisierung aus
Dim rngCell As Range
Dim StOrdner As String
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, "") 'Pfad übergeben
If oFd Is Nothing Then
' EndOfSub
Exit Sub
End If

For Each rngCell In Selection
rngCell.Value = rngCell.Value & ".pdf"
Next

Set nS = oFd.Self
Set oSh = Nothing
StOrdner = nS.Path
SearchInFolder StOrdner ' Sub aufrufen
Cells.Replace What:=".pdf", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ' ".pdf" löschen
End Sub

...werden. Wie Du siehst, habe ich die For Each-Schleife nur hinter den Dialog geschoben. Bricht der User den Dialog ab, benötigst Du das Sub EndOfSub nun nicht, da Du die Werte/Zellen ja noch nicht geändert hast.
(Das "Verschieben" des "Aufräumens" (Cells.Replace What:...) aus dem (rekursiven) Sub SearchInFolder heraus, zurück ins aufrufende Sub, hast Du aber gut selbst umgesetzt. So in etwa hatte ich mir das vorgestellt.)


[*]richtig getestet 1
Hast Du im "Ordner suchen"-Dialog schon einmal den Eintrag "Arbeitsplatz", "Netzwerkumgebung" oder "Papierkorb" angewählt und einen Klick auf "OK" folgen lassen? ;-) Daher schrieb ich:

Das ist nicht alles, was es abzufangen gilt, für einen Test reicht es aber.

Da es diese Einträge gibt, wird irgendwann auch ein User diese Anwählen und auf Ok klicken. Und wenn es nur aus Versehen ist. ;-)

[*]richtig getestet 2
Bist Du Dir sicher, dass Du die doppelten Dateien richtig abfängst? Mach Dir doch einmal ein kleines Testverzeichnis mit 2 bis 3 einfach, aber eindeutig benannten PDFs. In diesem Verzeichnis bring dann auch einmal eine Datei "zzz.txt" unter. Nun noch ein Untervereichnis mit 2-3 PDFs. Ein PDF nur im Hauptverzeichnis, eines nur im Unterverzeichnis, eines in beiden Verzeichnissen. Dann evtl. noch je ein PDF in jedem Verzeichnis welches nicht in der Liste (Tabelle/Selection) ist. Nun noch eine kleine Testmappe gebastelt, welche die Dateinamen aufnimmt. Nun lass mal Deinen Code laufen. Passt dann die Meldung bei doppelten Dateien? Zumindest bei mir wird dann die "zzz.txt" als doppelt ausgewiesen, obwohl nur ein einziges Mal vorhanden und zu allem Überfluss auch gar kein Link dafür gefordert wird, denn Du möchtest ja nur PDFs verlinken.

Ich möchte Dir Dein Erfolgserlebnis nicht nehmen oder gar madig machen, nur wollt ich das, was mir auffällt auch nicht unerwähnt lassen. ;-)

bye
malSchauen
... der sich am Wochenende, wenn er Zeit findet, mal an eine eigene Umsetzung machen wird...