AW: Dateien suchen und Hyperlinks erstellen lassen
03.10.2013 08:24:13
fcs
Hallo Bob,
ich habe jetzt noch ein paar Prüfungen für die Verzeihnisse eingebaut und an verschiedenen Stellen den Parameter "Path" statt "Name".
Wahrscheinlich war das in meiner Test-Umgebung egal - aber bei anderen Verzeichnissen möglicherweise nicht.
Im Ordner-Auswahldialog wählst du den übergeordneten Ordner aus, der alle Unterordner mit den Dokumenten enthält.
Die Unterordner, den Dateifilter und die Spalte in der die Hyperlinks angelegt werden sollen gibst du in diesen Zeilen an.
'Suche von pfd-Dokument im Hauptordner - Hyperlink in Spalte B
If fncMakeHyperlink(strSubfolder:="", _
strFileLike:="*" & strTeileNr & "*.pdf", _
lngSpalte:=2) = False Then GoTo Fehler
'Suche von dwg-Dokument im Unterordner Zeichnung - Hyperlink in Spalte C
If fncMakeHyperlink(strSubfolder:="Zeichnung", _
strFileLike:="*" & strTeileNr & "*.dwg", _
lngSpalte:=3) = False Then GoTo Fehler
'Suche von pdf-Dokument im Unterordner Manual - Hyperlink in Spalte D
If fncMakeHyperlink(strSubfolder:="Manual", _
strFileLike:="*" & strTeileNr & "*.pdf", _
lngSpalte:=4) = False Then GoTo Fehler
Gruß
Franz
'Code in einem allgemeinen Modul
'Erstellt unter Windows Viste, Excel 2010
Option Explicit
Private fsObj As Object, fsFolder As Object
Private wks As Worksheet, lngZeile As Long
Sub HyperlinksEinfuegen()
Dim strOrdner As String
Dim intSpalte As Integer
Dim strTeileNr As String
On Error GoTo Fehler
Set wks = ActiveSheet
'Startordner für Dateisuche - ggf. per Dialog auswählen
strOrdner = "C:\Users\Public\Abteilung D"
'Beispiel für Ordnerstruktur
'C:\Users\Public\Abteilung D
'C:\Users\Public\Abteilung D\Manual
'C:\Users\Public\Abteilung D\Zeichung
' GoTo Weiter01 '
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Haupt-Ordner mit Unterordnern und Dokumenten zu " _
& "Teile-Nummern auswahlen"
.InitialFileName = strOrdner & Application.PathSeparator
If .Show = -1 Then
strOrdner = .SelectedItems(1)
Else
GoTo Fehler
End If
End With
Weiter01:
If Dir(strOrdner, vbDirectory) = "" Then
MsgBox "Ordner" & vbLf & strOrdner & vbLf & "existiert nicht!", _
vbInformation + vbOKCancel, "Hyperlinks anlegen"
GoTo Fehler
End If
Set fsObj = VBA.CreateObject("Scripting.FileSystemObject")
Set fsFolder = fsObj.getfolder(strOrdner)
With wks
'Zeilen in SPalte mit Teilenummern abarbeiten - Hier Spalte A
For lngZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
strTeileNr = .Cells(lngZeile, 1).Text
'Suchmuster für Dateiname ? = 1 beliebiges Zeichen, # = 1 beliebige Ziffer, _
* = beliebige Zeichenkette
'Suche von pfd-Dokument im Hauptordner - Hyperlink in Spalte B
If fncMakeHyperlink(strSubfolder:="", _
strFileLike:="*" & strTeileNr & "*.pdf", _
lngSpalte:=2) = False Then GoTo Fehler
'Suche von dwg-Dokument im Unterordner Zeichnung - Hyperlink in Spalte C
If fncMakeHyperlink(strSubfolder:="Zeichnung", _
strFileLike:="*" & strTeileNr & "*.dwg", _
lngSpalte:=3) = False Then GoTo Fehler
'Suche von pdf-Dokument im Unterordner Manual - Hyperlink in Spalte D
If fncMakeHyperlink(strSubfolder:="Manual", _
strFileLike:="*" & strTeileNr & "*.pdf", _
lngSpalte:=4) = False Then GoTo Fehler
Next
End With
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 76
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "Pfad: " & strOrdner, , "Makro: HyperlinksEinfuegen"
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, , "Makro: HyperlinksEinfuegen"
End Select
End With
'Objektvariablen zurücksetzen
Set wks = Nothing: Set fsObj = Nothing: Set fsFolder = Nothing
End Sub
Function fncMakeHyperlink(strSubfolder As String, strFileLike As String, lngSpalte, _
Optional strNoFile As String = "No File") As Boolean
'strSubfolder = Unterordner in dem gesucht werden soll
'strFileLike = Vergleichsfilter für Like-Operator
'lngSpalte = Spalte in der Hyperlink eingefügt werden soll
'strNoFile = Optionaler Text wenn keine Datei gefunden wurde = "No File"
Dim fsFile As Variant, fsSubFolder As Object
Dim strDatei As String
fncMakeHyperlink = True
If strSubfolder = "" Then
'Suche im Hauptordner
Set fsSubFolder = fsFolder
Else
If Dir(fsFolder.Path & Application.PathSeparator & strSubfolder, _
vbDirectory) = "" Then
If MsgBox("Der Unter-Ordner" & vbLf _
& fsFolder.Path & Application.PathSeparator & strSubfolder & vbLf _
& "existiert nicht!", _
vbQuestion + vbOKCancel, "Hyperlinks anlegen") = vbCancel Then
fncMakeHyperlink = False
End If
Exit Function
End If
'Suche in Unterordner
Set fsSubFolder = fsObj.getfolder(fsFolder.Path & Application.PathSeparator & _
strSubfolder)
End If
'Dateinamen im Ordner mit Suchmuster vergleichen und Hyperlink in Spalte einfügen
strDatei = ""
With wks
.Cells(lngZeile, lngSpalte).ClearContents
For Each fsFile In fsSubFolder.Files
If fsFile.Name Like strFileLike Then
strDatei = fsFile.Path
.Hyperlinks.Add Anchor:=.Cells(lngZeile, lngSpalte), Address:=strDatei, _
TextToDisplay:=fsFile.Name
Exit For
End If
Next fsFile
If strDatei = "" Then
.Cells(lngZeile, lngSpalte).Value = strNoFile
End If
End With
Set fsSubFolder = Nothing
Set fsFile = Nothing
End Function