Public Sub suchen_speichern()
Dim olapp As New Outlook.Application
Dim olmails As Object
Dim ordner As Object
Dim mails As Outlook.MailItem
anzahl = 0
strPath = Environ("USERPROFILE") & "\Documents\"
Set olapp = CreateObject("Outlook.Application")
Set olmails = olapp.GetNamespace("MAPI")
Set ordner = olmails.GetDefaultFolder(olFolderInbox)
suchbegriff = "$$$$$"
For Each mails In ordner.Items
If InStr(1, mails.Subject, suchbegriff, vbTextCompare) Then
With mails
strText = Replace(.Subject, "/", "_")
strText = Replace(strText, "!", "")
strText = Replace(strText, ".", "_")
strText = Replace(strText, "\", "_")
strText = Replace(strText, ":", "_")
strText = Replace(strText, "(", "")
strText = Replace(strText, ")", "")
strText = Replace(strText, """", "")
.SaveAs strPath & strText & ".msg", olMSG
.Delete
anzahl = anzahl + 1
End With
End If
Next mails
MsgBox "Fertig - " & anzahl & " Mails übertragen"
End Sub