Outlook - neueste Mail mit bestimmtem Betreff - Informationen ausgeben...

Frage: Im Ordner Posteingang sind mehrere Mails mit dem gleichen Betreff. Von diesen Mails benötige ich die Neueste. Im folgenden Beispiel wird die Mailadresse und der Name des Absenders angezeigt. Zusätzlich noch die Empfangszeit der Mail.

In the Inbox folder are several emails with the same subject. Of these mails I need the latest. In the following example, the email address and the name of the sender is displayed. In addition the time of receipt of mail.

Hier noch eine Beispieldatei / Here's a sample file:
Outlook - neueste Mail mit bestimmtem Betreff - Informationen ausgeben...[XLS 50 KB]

Option Explicit
' Variable um bei schon geöffnetem Outlook dieses nicht zu schliessen
Dim blnTMP As Boolean
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 09.04.2014
' Purpose   : Outlook Subject mehrere gleiche neueste Infos ausgeben...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim objNameSpace As Object
    Dim objFolder As Object
    Dim objItem As Object
    Dim strTMP As String
    Dim objApp As Object
    Dim datTime As Date
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Objektvariable mit Outlookapplikation belegen
    Set objApp = OffApp("Outlook")
    ' Wenn die Applikation vorhanden ist...
    If Not objApp Is Nothing Then
        ' Eine Outlook-Sitzung anlegen
        ' GetNamespace("MAPI") und Session sind austauschbar
        Set objNameSpace = objApp.Session 'GetNamespace("MAPI")
        ' Konstante für Posteingang
        Const olFolderInbox = 6
        ' Objektvariable mit Posteingang belegen
        Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
        ' Wenn Mails im Posteingang sind, dann...
        If objFolder.Items.Count > 0 Then
            ' Temporäre Zeit vorgeben
            datTime = "01.01.1900 00:00:00"
            ' Jede Mail im Ordner Posteingang durchgehen
            For Each objItem In objFolder.Items
                With objItem
                    ' Wenn der Betreff mit "Test" beginnt und
                    ' irgendwie weitergeht, dann...
                    If .Subject Like "Test*" Then
                        ' Wenn die Empfangszeit > der
                        ' temporären Zeit ist, dann...
                        If .ReceivedTime > datTime Then
                            ' Setze die temporäre Zeit neu
                            datTime = .ReceivedTime
                            ' Hole Informationen in Stringvariable
                            ' Hier Mailadresse und Name des Senders
                            ' dann noch die Empfangszeit
                            strTMP = .SenderEmailAddress & " / " & _
                                .SenderName & " / " & .ReceivedTime
                        End If
                    End If
                End With
            ' Nächste Mail
            Next objItem
            ' Wenn die temporäre Zeit unterschiedlich ist, dann...
            If datTime <> "01.01.1900 00:00:00" Then
                ' Gib die gesammelten Informationen aus
                MsgBox strTMP
            End If
        Else
            ' Es sind keine Mails im Posteingang
            MsgBox "There are " & objFolder.Items.Count & " message(s) in your inbox."
        End If
    Else
        ' Kein Outlook installiert
        MsgBox "Application not installed!"
    End If
Fin:
    ' Wenn die Applikation nicht offen war, schliesse sie
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    ' Setze die Objektvariablen auf Nothing
    Set objFolder = Nothing
    Set objNameSpace = Nothing
    Set objApp = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...