Option Explicit
Sub neue_mail(sID As String)
On Error Resume Next
Dim mIt As Outlook.MailItem
Dim sIt As String
Dim sPos As String
Dim i As Long
Dim a As Long
Dim n As Long
Dim sAnr As String
Dim sPfad As String
Dim sOrdner As String
Dim Gültig As Boolean
If NS Is Nothing Then
Set NS = Outlook.GetNamespace("MAPI")
End If
Stmp = TypeName(NS.GetItemFromID(sID))
If Stmp = "MailItem" Then
Set mIt = NS.GetItemFromID(sID)
Else
MsgBox "Die neue Mail ist vom unerwarteten Typ " & vbLf & Stmp & vbLf & " und kann mit dem existierenden Makro nicht verarbeitet werden.", vbCritical, "Abbruch"
Exit Sub
End If
Gültig = False
sIt = Mid(mIt.SenderEmailAddress, InStr(mIt.SenderEmailAddress, "@"))
sIt = LCase(sIt)
Select Case sIt
Case "@aaa.de"
If mIt.Attachments.Count > 0 Then
For i = 1 To mIt.Attachments.Count
Datei = mIt.Attachments.Item(i).FileName
msgbox Datei
Next
End If
Case "@bbb.de"
Gültig = True
sOrdner = "aaa"
Case "@ccc.de"
Gültig = True
sOrdner = "bbb"
Case "@ddd.com"
Gültig = True
sOrdner = "ccc"
Case "@eee.de"
Gültig = True
sOrdner = "ccc"
End Select
Select Case sordner
Case "aaa"
Set oFldr = Ns.GetDefaultFolder(olFolderInbox)
Case "bbb"
Set oFldr = NS.Folders("aaa").Folders("abc")
Case "ccc"
Set oFldr = NS.Folders("aaa").Folders("bcd")
Case "ddd"
Set oFldr = NS.Folders("ddd").Folders("abc")
Case "eee"
Set oFldr = NS.Folders("eee").Folders("Posteingang")
Case Else
Set oFldr = Ns.GetDefaultFolder(olFolderInbox)
End Select
Set mIt = Nothing
For Each oMessage In oFldr.Items
With oMessage
.move oFdldr
End With
Next
End Sub