Sub GetInboxMessages()
    'Set Error Handling
    On Error GoTo Fehler
 
' Create a CDOEX Person object. This will be used to determine
' the URL of the user's Inbox.
 
    Dim iPerson As New CDO.Person
 
' Create an ADO Recordset object. This will be used to
' hold the message items that are in the users Inbox.
 
    Dim rstInbox As New ADODB.Recordset
 
' Create an ADO Connection object. This will be used to
' make a connection to the Exchange Store using the
' the EXOLEDB data provider.
 
    Dim conInbox As New ADODB.Connection
 
' Create a mailbox interface. This will be used to get the
' user's Inbox URL.
 
    Dim iMailbox As CDO.iMailbox ' iMailbox
 
    Dim strEmail As String
    Dim strInboxQuery As String
 
    strEmail = "mailto:" & strEmailAddress
 
' Get data for the Person object. This will be used to get
' the users Inbox url.
 
    iPerson.DataSource.Open strEmail
 
    If Err.Number <> 0 Then
        MsgBox "Error opening mailbox.  Did you enter a valid e-mail address?"
        Exit Sub
    End If
 
' Get the Mailbox interface from the Person object for the
' user.
 
    Set iMailbox = iPerson.GetInterface("IMailbox")
    MsgBox (iMailbox.Inbox)
 
' Set up a query to get all the items in the user's Inbox
' that are not hidden or a folder.
 
    strInboxQuery = "select " & """DAV:href""" & "from scope('shallow traversal" & _
      "of """ & iMailbox.Inbox & """')" & "where ""DAV:ishidden"" = false and" _
      & "      ""DAV:isfolder"" = false"
 
' Set the ADO Connection object properties to open the
' user's Inbox.
 
    With conInbox
        .Provider = "exoledb.datasource"
        .Open iMailbox.Inbox
    End With
 
' Use the ADO Connection object and the Query mentioned
' above to get the items that are located in the user's
' Inbox.
 
    rstInbox.Open strInboxQuery, conInbox
 
    If rstInbox.RecordCount = 0 Then
        lstInbox.AddItem "No items in Inbox!"
        btnReply.Enabled = False
        btnForward.Enabled = False
        lblInboxFrom.Caption = ""
        lblInboxSubject.Caption = ""
        lblInboxBody.Caption = ""
    Else
        While Not rstInbox.EOF
            lstInbox.AddItem rstInbox(0)
            rstInbox.MoveNext
        Wend
    End If
 
    rstInbox.Close
 
    ' Clean up.
    Set rstInbox = Nothing
    Set iPerson = Nothing
    Set conInbox = Nothing
    Set iMailbox = Nothing
 
    btnForward.Enabled = False
    btnReply.Enabled = False
    Exit Sub
    Resume
Fehler:
    Debug.Print Err.Description
    MsgBox (Err.Description)
    Debug.Assert False
    Resume Next
End Sub