application.filesearch

Public Sub ReadFromFile_ADO()
Dim Col As ADODB.Field
Dim objFS As FileSearch
Dim objSh As Worksheet
Dim strPath As String
Dim intIndex As Integer
Dim objADO As Object
Dim lngRow As Long, intCol As Integer
Dim blnFirst As Boolean
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.Cursor = xlWait
End With
Set objSh = Sheets("Ausgabe")
objSh.Range("A2:H65536").ClearContents
objSh.Range("A2:A65536").ClearFormats
For intIndex = 1 To .FoundFiles.Count
blnFirst = True
Set objADO = ExcelTable(.FoundFiles(intIndex), "Faxe", "A15:I35")
Do Until objADO.EOF
For Each Col In objADO.fields
If (IsNull(Col.Value) Or Col.Value = "") And intCol = 0 Then Exit For
intCol = intCol + 1
objSh.Cells(lngRow, intCol) = Col.Value
If blnFirst Then
objSh.Hyperlinks.Add Anchor:=objSh.Cells(lngRow, intCol), Address:=.FoundFiles( _
intIndex)
blnFirst = False
End If
Next
If intCol > 0 Then lngRow = lngRow + 1
intCol = 0
objADO.MoveNext
Loop
objADO.Close
Set objADO = Nothing
Next
End If
End With
Set objFS = Nothing
Set objSh = Nothing
ErrExit:
If Err.Number > 0 Then
MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
Err.Clear
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.Cursor = xlDefault
End With
End Sub

Public Function ExcelTable(ByRef Path As String, ByRef Table As String, ByRef SourceRange As  _
String) As ADODB.Recordset
Dim SQL As String
Dim Con As String
SQL = "select * from [" & Table & "$" & SourceRange & "]"
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & Path & ";"
Set ExcelTable = New ADODB.Recordset
ExcelTable.Open SQL, Con, adOpenKeyset, adLockOptimistic
End Function