Option Explicit
Const m_Path As String = "V:\0101"
Const m_IncludeFolder As String = "Rahmenvertrag, Abrechnung"
Const m_IncludeFiles As String = "_Planung, Testfile"
Const m_DATA As Variant = "aktuell"
Const m_FileType As String = "Microsoft Excel"
Const m_Turbo As Boolean = False
Dim objFso As Object
Dim oQueue As Object
Dim objSortedList As Object
Dim IsLimited As Boolean
Dim ArrLimited() As String
Dim strDATA As String
Sub DoIt()
If Len(m_IncludeFiles) = 0 Then Exit Sub
If m_FileType <> "Microsoft Excel" Then Exit Sub
strDATA = InputBox("gesuchter Wert = ", , m_DATA)
If strDATA = "" Then Exit Sub
Set oQueue = CreateObject("System.Collections.Queue")
If Len(m_IncludeFolder) > 0 Then
ArrLimited = Split(m_IncludeFolder, ",")
IsLimited = True
End If
Call FolderTest
If oQueue.Count > 0 Then Call FilesTest
If oQueue.Count > 0 Then
If m_Turbo = True Then
Call HitOLEDB
Else
Call HitOpen
End If
End If
Call MsgBox("Fertig", vbExclamation, "")
Set oQueue = Nothing
End Sub
Private Sub HitOLEDB()
Dim strPath As String
Dim blnHit As Boolean, lngCnt As Long
Application.ScreenUpdating = False
Sheets(1).Columns(1).ClearHyperlinks
Sheets(1).Columns(1).ClearContents
Do While oQueue.Count > 0
blnHit = False
strPath = oQueue.Dequeue
blnHit = FindItOnce(strPath, strDATA)
If blnHit = True Then
lngCnt = lngCnt + 1
Cells(lngCnt, 1).Hyperlinks.Add anchor:=Cells(lngCnt, 1), Address:=strPath
End If
Loop
Application.ScreenUpdating = True
End Sub
Private Sub HitOpen()
Dim strPath As String
Dim oWs As Excel.Worksheet, Rng As Excel.Range, hRng As Excel.Range
Dim blnHit As Boolean, lngCnt As Long
Application.ScreenUpdating = False
Sheets(1).Columns(1).ClearHyperlinks
Sheets(1).Columns(1).ClearContents
Do While oQueue.Count > 0
blnHit = False
strPath = oQueue.Dequeue
Workbooks.Open (strPath)
For Each oWs In Workbooks(2).Sheets
Set Rng = oWs.UsedRange
Set hRng = Rng.Find(strDATA)
If Not hRng Is Nothing Then blnHit = True
Next oWs
Workbooks(2).Close False
If blnHit = True Then
lngCnt = lngCnt + 1
Cells(lngCnt, 1).Hyperlinks.Add anchor:=Cells(lngCnt, 1), Address:=strPath
End If
Loop
Application.ScreenUpdating = True
End Sub
Private Sub FilesTest()
Dim fldStart As Object
Dim fld As Object
Dim fl As Object
Dim strPath As String, strFull As String, lngCnt As Long
Set objFso = CreateObject("scripting.FileSystemObject")
Set objSortedList = CreateObject("System.Collections.Sortedlist")
Do While oQueue.Count > 0
strPath = oQueue.Dequeue
Set fldStart = objFso.getfolder(strPath)
Set fld = fldStart.Files
For Each fl In fld
If InStr(fl.Name, Chr(126)) = 0 Then
If InStr(fl.Type, m_FileType) > 0 Then
strFull = fl
If HitFile(fl.Name) = True Then _
objSortedList.Add strFull, 0
End If
End If
Next fl
Loop
oQueue.Clear
For lngCnt = 0 To objSortedList.Count - 1
oQueue.Enqueue objSortedList.GetKey(lngCnt)
Next lngCnt
Set objFso = Nothing
Set fld = Nothing
Set fl = Nothing
Set objSortedList = Nothing
End Sub
Private Sub FolderTest()
Dim fldStart As Object
Dim fld As Object
Dim str As String, lngCnt As Long
Set objFso = CreateObject("scripting.FileSystemObject")
Set fldStart = objFso.getfolder(m_Path)
Set objSortedList = CreateObject("System.Collections.Sortedlist")
For Each fld In fldStart.subFolders
str = fld
If IsLimited Then
If HitLimit(str) Then _
objSortedList.Add str, 0
Else
objSortedList.Add str, 0
End If
Call sbFolderTest(fld)
Next fld
For lngCnt = 0 To objSortedList.Count - 1
oQueue.Enqueue objSortedList.GetKey(lngCnt)
Next lngCnt
Set objFso = Nothing
Set fldStart = Nothing
Set objSortedList = Nothing
End Sub
Private Function sbFolderTest(sFolder As Object)
Dim sbfld As Object
Dim sbStr As String
For Each sbfld In sFolder.subFolders
sbStr = sbfld
If IsLimited Then
If HitLimit(sbStr) Then _
objSortedList.Add sbStr, 0
Else
objSortedList.Add sbStr, 0
End If
Call sbFolderTest(sbfld)
Next sbfld
End Function
Private Function HitLimit(ByVal strHit As String) As Boolean
Dim varE As Variant
For Each varE In ArrLimited
If InStr(strHit, Trim(varE)) > 0 Then HitLimit = True
Next varE
End Function
Function HitFile(ByVal strHit As String) As Boolean
Dim Arr() As String, ustrHit As String, varE As Variant
ustrHit = UCase(strHit)
Arr = Split(m_IncludeFiles, ",")
For Each varE In Arr
If InStr(ustrHit, UCase(Trim(varE))) > 0 Then HitFile = True
Next varE
End Function
Private Function FindItOnce(ByVal strFullName As String, Optional ByVal ToDo As Variant) As Boolean
Const SEL_FROM As String = "SELECT * FROM "
Dim oConn As Object
Dim oTblRs As Object, oRs As Object, oFld As Object
Dim sSQL As String
Dim strFnd As String
Dim oList As Object
On Error GoTo nix
Set oList = CreateObject("System.Collections.ArrayList")
Set oConn = CreateObject("ADODB.Connection")
Set oTblRs = CreateObject("ADODB.Recordset")
With oConn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & strFullName & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"""
.Open
End With
Set oTblRs = oConn.OpenSchema(20)
If Not oTblRs.EOF Then
sSQL = SEL_FROM & Chr(91) & oTblRs.Fields(2).Value & Chr(93)
Set oRs = CreateObject("ADODB.Recordset")
oRs.Open sSQL, oConn, 3, 1, 1
If Not oRs.EOF Then
For Each oFld In oRs.Fields
oRs.MoveFirst
strFnd = oFld.Name & " = " & Chr(39) & ToDo & Chr(39)
oRs.Find strFnd
If oRs.EOF = False Then oList.Add strFullName
Next oFld
End If
End If
If oList.Count > 0 Then FindItOnce = True
nix:
Set oConn = Nothing
Set oTblRs = Nothing
Set oList = Nothing
End Function