Option Explicit
Option Compare Text
Sub Voorbeeld()
Dim strDemap As String
strDemap = FindDir("2009", "X:\", True)
If Len(strDemap) > 0 Then
MsgBox "het bestand is gevonden : " & strDemap
End If
End Sub
Function FindDir(ByVal strLookFor As String, _
ByVal strPath As String, _
Optional ByVal IncludeSubDirs As Boolean) As String
Dim strFolders As String
Dim strFolderList() As String
Dim strMatch As String
Dim strMatching() As String
Dim msgAnswer As VbMsgBoxResult
Dim i As Long
strFolders = FindFolders(strPath, True)
strFolderList = Split(Mid(strFolders, 2), vbCr)
For i = LBound(strFolderList) To UBound(strFolderList)
If InStr(strFolderList(i), strLookFor) > 0 Then
strMatch = strMatch & strFolderList(i) & vbCr
End If
Next i
On Error GoTo NoFiles
strMatching = Split(Mid(strMatch, 1, Len(strMatch) - 1), vbCr)
If LBound(strMatching) = UBound(strMatching) Then
FindDir = strMatching(0)
Else
'pick one of the files
FindDir = SelectFile(strMatching)
End If
Exit Function
NoFiles:
MsgBox "Geen bestanden gevonden!", vbInformation
End Function
Private Function FindFolders(ByVal strRootDir As String, _
Optional ByVal bolRecurse As Boolean) As String
Dim strFound As String
Dim strNextPath As String
Dim strList As String
Dim strSubfolders() As String
Dim i As Long
strNextPath = Dir(strRootDir, vbDirectory)
Do While strNextPath <> ""
If GetAttr(strRootDir & strNextPath) = vbDirectory And _
InStr(strNextPath, ".") <> 1 Then
strFound = strFound & vbCr & strRootDir & strNextPath
End If
strNextPath = Dir()
Loop
strList = strFound
If bolRecurse Then
strSubfolders = Split(Mid(strFound, 2), vbCr)
For i = LBound(strSubfolders) To UBound(strSubfolders)
strList = strList & FindFolders(strSubfolders(i) & "\", bolRecurse) & vbCr
Next
End If
FindFolders = strList
End Function
Private Function SelectFile(strList() As String) As String
Dim i As Long
Dim strmsg
Dim vAnswer As Variant
If UBound(strList) > 15 Then
MsgBox "Er zijn " & UBound(strList) & " Bestanden gevonden." & vbCr & _
"Probeer uw zoekopdracht te verfijnen. ", vbInformation
Else
For i = LBound(strList) To UBound(strList)
strmsg = strmsg & i + 1 & vbTab & strList(i) & vbCr
Next
vAnswer = InputBox("Geef het nummer op van de juiste map" & vbCr & strmsg)
If vAnswer <> False And _
vAnswer > LBound(strList) And _
vAnswer <= UBound(strList) + 1 Then
SelectFile = strList(vAnswer - 1)
End If
End If
End Function
