Datei suchen - Pfad unbekannt - Hyperlink - API...

Frage: Zwei Dinge - zum Einen habe ich eine Liste mit Dateinamen in Spalte A, zum Zweiten möchte ich den Dateinamen in Zelle A1 eingeben. Der Speicherort der jeweiligen Datei ist nicht bekannt. Ein Hyperlink soll in Spalte B eingefügt werden. Optional möchte ich die Dateien in ein Verzeichnis mit Ordnerauswahl kopieren. Wie geht das?

Two things - first I have a list of file names in column A, secondly I would like to enter the file name in cell A1. The location of the file is unknown. A hyperlink will be inserted in column B. Optional I want to copy the files into a folder with folder selection. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Datei suchen - Pfad unbekannt - Hyperlink - API...[ZIP 3 MB]

Code gehört in Sheet1 / Code belongs in Sheet1:

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Sheet1 
' Procedure : Worksheet_Change 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : File Search - location unknown - API... 
'-------------------------------------------------------------------------- 
Private Sub Worksheet_Change(ByVal Target As Range)
    ' Variablendeklaration 
    ' Stringvariable mit Puffer 
    Dim strPathName As String * 255
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Wenn nicht mehr als eine Zelle gewählt wurde, dann... 
    If Not Target.Count > 1 Then
        ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
        With Application
            ' Das Bildschirmaktualisierung wird unterbrochen 
            .ScreenUpdating = False
            ' Ereignisroutinen werden deaktiviert 
            .EnableEvents = False
            ' Auslesen der momentanen Einstellung für die Berechnung 
            lngCalc = .Calculation
            ' Setzen der Berechnung auf "Manuell" 
            .Calculation = xlCalculationManual
            '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
            .DisplayAlerts = False
        End With
        ' Wenn es A1 ist dann... 
        If Target.Address(False, False) = "A1" Then
            ' Wenn A1 nicht leer ist, dann... 
            If Trim(Target.Value) <> "" Then
                ' Variable lngTMP <> 0 - Datei ist vorhanden 
                lngTMP = SearchTreeForFile(ThisWorkbook.Path & _
                    Application.PathSeparator, Target.Text, strPathName)
                ' Variable lngTMP = 0 - Datei nicht vorhanden 
                If lngTMP = 0 Then
                    MsgBox "File not found!", vbInformation, "Info"
                Else
                    ' Puffer zurechtstutzen, überflüssige Leerzeichen weg 
                    strPathName = Left$(strPathName, _
                        InStr(1, strPathName, vbNullChar) - 1)
                    strName = RTrim(strPathName)
                    ' In B1 schreiben 
                    Target.Offset(, 1).Value = strName
                    ' Hyperlink in B1 auf gefundene Datei setzen 
                    Target.Offset(, 1).Hyperlinks.Add _
                        Anchor:=Target.Offset(, 1), Address:=strName
                End If
            Else
                ' sonst - A1 ist leer, also lösche B1 
                Target.Offset(, 1).Clear
            End If
        End If
    End If
Fin:
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code gehört in Sheet2 / Code belongs in Sheet2:

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Sheet2 
' Procedure : Worksheet_Change 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : File Search - location unknown - API... 
'-------------------------------------------------------------------------- 
' Dateierweiterung gegebenenfalls anpassen!!! 
Const strEX As String = ".pdf"
Private Sub Worksheet_Change(ByVal Target As Range)
    ' Variablendeklaration 
    ' Stringvariable mit Puffer 
    Dim strPathName As String * 255
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Wenn nicht mehr als eine Zelle gewählt wurde, dann... 
    If Not Target.Count > 1 Then
        ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
        With Application
            ' Das Bildschirmaktualisierung wird unterbrochen 
            .ScreenUpdating = False
            ' Ereignisroutinen werden deaktiviert 
            .EnableEvents = False
            ' Auslesen der momentanen Einstellung für die Berechnung 
            lngCalc = .Calculation
            ' Setzen der Berechnung auf "Manuell" 
            .Calculation = xlCalculationManual
            '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
            .DisplayAlerts = False
        End With
        ' Wenn es A1 ist dann... 
        If Target.Address(False, False) = "A1" Then
            ' Wenn A1 nicht leer ist, dann... 
            If Trim(Target.Value) <> "" Then
                ' Variable lngTMP <> 0 - Datei ist vorhanden 
                lngTMP = SearchTreeForFile(ThisWorkbook.Path & _
                    Application.PathSeparator, Target.Text & strEX, strPathName)
                ' Variable lngTMP = 0 - Datei nicht vorhanden 
                If lngTMP = 0 Then
                    MsgBox "File not found!", vbInformation, "Info"
                Else
                    ' Puffer zurechtstutzen, überflüssige Leerzeichen weg 
                    strPathName = Left$(strPathName, _
                        InStr(1, strPathName, vbNullChar) - 1)
                    strName = RTrim(strPathName)
                    ' In B1 schreiben 
                    Target.Offset(, 1).Value = strName
                    ' Hyperlink in B1 auf gefundene Datei setzen 
                    Target.Offset(, 1).Hyperlinks.Add _
                        Anchor:=Target.Offset(, 1), Address:=strName
                End If
            Else
                ' sonst - A1 ist leer, also lösche B1 
                Target.Offset(, 1).Clear
            End If
        End If
    End If
Fin:
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : File Search - location unknown - API... 
'-------------------------------------------------------------------------- 
' Dateierweiterung gegebenenfalls anpassen!!! 
Const strEX As String = ".pdf"
Public Sub Main()
    ' Variablendeklaration 
    ' Stringvariable mit Puffer 
    Dim strPathName As String * 255
    Dim lngLastRow As Long
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    ' Sheet3 ist der CODENAME / OBJEKTNAME eines Tabellenblattes 
    ' in einem englischen Excel 
    ' In deutsch dann Tabelle3 
    With Sheet3
        ' Letzte Teile Spalte A ermitteln 
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        ' Schleife über Zeilen 
        For lngLastRow = 1 To lngLastRow
            ' Variable lngTMP <> 0 - Datei ist vorhanden 
            lngTMP = SearchTreeForFile(ThisWorkbook.Path & _
                Application.PathSeparator, .Cells(lngLastRow, 1).Text & _
                strEX, strPathName)
            ' Variable lngTMP = 0 - Datei nicht vorhanden 
            If lngTMP = 0 Then
                ' Text in Spalte B schreiben 
                .Cells(lngLastRow, 2).Value = "File not found!"
            Else
                ' Puffer zurechtstutzen, überflüssige Leerzeichen weg 
                strPathName = Left$(strPathName, _
                    InStr(1, strPathName, vbNullChar) - 1)
                strName = RTrim(strPathName)
                ' In B schreiben 
                .Cells(lngLastRow, 2).Value = strName
                ' Hyperlink in B auf gefundene Datei setzen 
                .Cells(lngLastRow, 2).Hyperlinks.Add _
                    Anchor:=.Cells(lngLastRow, 2), Address:=strName
            End If
        ' Nächste Zeile 
        Next lngLastRow
        ' Spalte A und B optimale Breite einstellen 
        .Columns("A:B").AutoFit
    End With
Fin:
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : File Search - location unknown - API... 
'-------------------------------------------------------------------------- 
' Dateierweiterung gegebenenfalls anpassen!!! 
Const strEX As String = ".pdf"
Public Sub Main_1()
    ' Variablendeklaration 
    ' Stringvariable mit Puffer 
    Dim strPathName As String * 255
    Dim strDestFolder As String
    Dim lngLastRow As Long
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    If fncFolder(strDestFolder) <> "" Then
        ' Sheet3 ist der CODENAME / OBJEKTNAME eines Tabellenblattes 
        ' in einem englischen Excel 
        ' In deutsch dann Tabelle3 
        With Sheet3
            ' Letzte Teile Spalte A ermitteln 
            lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
            ' Schleife über Zeilen 
            For lngLastRow = 1 To lngLastRow
                ' Variable lngTMP <> 0 - Datei ist vorhanden 
                lngTMP = SearchTreeForFile(ThisWorkbook.Path & _
                    Application.PathSeparator, .Cells(lngLastRow, 1).Text & _
                    strEX, strPathName)
                ' Variable lngTMP = 0 - Datei nicht vorhanden 
                If lngTMP = 0 Then
                    ' Text in Spalte B schreiben 
                    .Cells(lngLastRow, 3).Value = "Not copied!"
                Else
                    ' Puffer zurechtstutzen, überflüssige Leerzeichen weg 
                    strPathName = Left$(strPathName, _
                        InStr(1, strPathName, vbNullChar) - 1)
                    strName = RTrim(strPathName)
                    FileCopy strName, strDestFolder & Mid(strName, _
                        InStrRev(strName, "\", -1) + 1)
                End If
            ' Nächste Zeile 
            Next lngLastRow
            ' Spalte A, B und C optimale Breite einstellen 
            .Columns("A:C").AutoFit
        End With
    End If
Fin:
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : fncFolder 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : Folder selection... 
'-------------------------------------------------------------------------- 
Private Function fncFolder(strTMPFolder As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .Title = "Folder"
        .ButtonName = "Choice..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strTMPFolder = .SelectedItems(1)
            strTMPFolder = IIf(Right(strTMPFolder, 1) <> "\", _
                strTMPFolder & "\", strTMPFolder)
        Else
            fncFolder = ""
        End If
    End With
    fncFolder = strTMPFolder
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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