Public Sub Ordnersuche()
m_Find = LCase$(m_Find)
m_Find = Replace(m_Find, "%", "*")
m_Wildcard = (InStr(m_Find, "*"))
If Not SubFolder = "" Then
FullFolderPath = SearchFolderPath & "\" & SubFolder
Else
FullFolderPath = SearchFolderPath
End If
Set Folders = GetFolderPath(FullFolderPath).Folders
LoopFolders Folders, 0
If Not m_Folder Is Nothing Then
End Sub
Private Sub LoopFolders(Folders As Outlook.Folders, Level As Integer)
Dim F As Outlook.MAPIFolder
Dim Found As Boolean
For Each F In Folders
If m_Wildcard Then
Found = (LCase$(F.Name) Like m_Find)
Else
Found = (LCase$(F.Name) = m_Find)
End If
If Not Found Then
Found = (Replace(LCase$(F.Name), ".", vbNullString) Like Replace(m_Find, ".", vbNullString))
End If
If Found Then
If StopAtFirstMatch = False Then
If MsgBox("Gefunden: " & vbCrLf & F.Name & vbCrLf & vbCrLf & "Verwenden?", vbQuestion Or vbYesNo) = vbNo Then
Found = False
End If
End If
End If
If Found Then
Set m_Folder = F
Exit For
Else
LoopFolders F.Folders, (Level + 1)
If Not m_Folder Is Nothing Then Exit For
End If
Next
End Sub
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function