Datei suchen - Pfad unbekannt - auslesen - kopieren!

Frage: Wie kann man eine Datei suchen, die irgendwo auf dem PC ist? Der Pfad ist nicht bekannt. Hier bietet sich die API-Funktion "SearchTreeForFile" an. Im folgenden Beispiel wird die Datei "Testdatei.xls" auf Laufwerk "C:\" gesucht. Wird sie gefunden können über die zwei folgenden Codes entweder zwei Zellen hineinkopiert bzw. zwei Zellen herausgelesen werden.

Datei suchen - Pfad unbekannt - auslesen - kopieren...[ZIP, 60 KB]

' Code für auslesen - kommt in Modul1
Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
(ByVal RootPath As String, _
ByVal InputPathName As String, _
ByVal OutputPathBuffer As String) As Long
' Anpassungen eventuell vornehmen!!!
Const strFile As String = "Testdatei.xls"
Const strSheetQ As String = "Tabelle1"
Const strCell1 As String = "E1"
Const strCell2 As String = "E2"
Sub Test()
Dim strPathName As String * 255
Dim strName As String
Dim lngTMP As Long
On Error GoTo Fin
lngTMP = SearchTreeForFile("C:\", strFile, strPathName)
If lngTMP = 0 Then
Debug.Print "Datei nicht vorhanden"
Else
strPathName = Left$(strPathName, _
InStr(1, strPathName, vbNullChar) - 1)
strName = RTrim(strPathName)
With Tabelle1.Cells(1, 1)
.Formula = "='" & Mid(strName, 1, _
InStrRev(strName, "\")) & "[" & _
Mid(strName, InStrRev(strName, "\") + 1) & "]" & _
strSheetQ & "'!" & strCell1
.Value = .Value
End With
With Tabelle1.Cells(1, 2)
.Formula = "='" & Mid(strName, 1, _
InStrRev(strName, "\")) & "[" & _
Mid(strName, InStrRev(strName, "\") + 1) & "]" & _
strSheetQ & "'!" & strCell2
.Value = .Value
End With
End If
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub

' Code für reinkopieren - kommt in Modul2
Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
(ByVal RootPath As String, _
ByVal InputPathName As String, _
ByVal OutputPathBuffer As String) As Long
' Anpassungen eventuell vornehmen!!!
Const strFile As String = "Testdatei.xls"
Const strSheetQ As String = "Tabelle1"
Const strCell1 As String = "E1"
Const strCell2 As String = "E2"
Sub Test_1()
Dim strPathName As String * 255
Dim wkbBook As Workbook
Dim strName As String
Dim lngCalc As Long
Dim lngTMP As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
lngTMP = SearchTreeForFile("C:\", strFile, strPathName)
If lngTMP = 0 Then
Debug.Print "Datei nicht vorhanden"
Else
strPathName = Left$(strPathName, _
InStr(1, strPathName, vbNullChar) - 1)
strName = RTrim(strPathName)
Set wkbBook = Workbooks.Open(strName)
With wkbBook.Worksheets(strSheetQ)
.Cells(1, 1).Value = Tabelle1.Range(strCell1)
.Cells(1, 2).Value = Tabelle1.Range(strCell2)
End With
wkbBook.Close True
End If
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set wkbBook = Nothing
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
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)...