Sub mail_finden()
Dim olApp As Object
Dim olFolder As Object
Dim olMail As Object
Dim i As Integer
Set olApp = CreateObject("outlook.application")
Set olFolder = olApp.GetNamespace("Mapi").Folders("XXX").Folders("YYY").Folders(Application.UserName)
i = 1
For Each olMail In olFolder.Items
With ThisWorkbook.Worksheets("Tabelle2").Range("A1")
If olMail.Class = 43 Then
.Offset(0, 0).Value = "Betreff"
.Offset(i, 0).Value = olMail.Subject
.Offset(0, 1).Value = "EntryID"
.Offset(i, 1).Value = olMail.entryid
i = i + 1
End If
End With
Next
End Sub
Sub antworten()
Dim olApp As Object
Dim myAnswer As Object
Dim Betreff As String
Dim BtrAnz As Integer
Set olApp = CreateObject("Outlook.Application")
With ThisWorkbook.Worksheets("Tabelle2")
Betreff = .Range("C1")
BetrAnz = Application.WorksheetFunction.CountIf(.Range("A:B"), Betreff)
If BtrAnz > 1 Or BetrAnz = 0 Then GoTo ende
ID = Application.WorksheetFunction.VLookup(Betreff, .Range("A:B"), 2, 0)
End With
With olApp.GetNamespace("MAPI").GetItemfromID(ID)
Set myAnswer = .ReplyAll
.Close False
End With
With myAnswer
.SentOnBehalfOfName = Application.UserName
.Subject = .Subject
.htmlbody = "Text" & .htmlbody
.display
End With
Exit Sub
ende:
MsgBox ("Der Betreff ist mehrfach oder gar nicht vorhanden!")
Set myAnswer = Nothing
Set olApp = Nothing
End Sub