Retrieve Email from Exchange Server with Web Service (EWS) in VB 6.0¶

Option Explicit

Const MailServerPop3 = 0
Const MailServerImap4 = 1
Const MailServerEWS = 2
Const MailServerDAV = 3
Const MailServerMsGraph = 4

Private Sub Command1_Click()
    Dim curpath As String
    Dim mailbox As String
    Dim oTools As New EAGetMailObjLib.Tools

    ' Create a folder named "inbox" under current directory
    ' to save the email retrieved.
    curpath = App.Path
    mailbox = curpath & "\inbox"
    oTools.CreateFolder mailbox

    ' Please use domain\user as the user name
    Dim oServer As New EAGetMailObjLib.MailServer
    oServer.Server = "exch.emailarchitect.net"

    oServer.User = "emailarchitect.net\test"
    oServer.Password = "testpassword"

    oServer.Protocol = MailServerEWS

    ' By default, Exchange Web Service (EWS) requires SSL connection
    ' Please ignore Port property for EWS and WebDAV protocol
    oServer.SSLConnection = True

    On Error GoTo ErrorHandle:
    Dim oClient As New EAGetMailObjLib.MailClient
    oClient.LicenseCode = "TryIt"

    oClient.Connect oServer
    MsgBox "Connected"

    Dim infos As EAGetMailObjLib.MailInfoCollection
    Set infos = oClient.GetMailInfoList()
    MsgBox infos.Count & " emails"

    Dim i As Long
    For i = 0 To infos.Count - 1
        Dim info As EAGetMailObjLib.MailInfo
        Set info = infos.Item(i)

        MsgBox "Index: " & info.Index & "; Size: " & info.Size & _
        "; UIDL: " & info.UIDL

        ' Receive email from Exchange server
        Dim oMail As EAGetMailObjLib.Mail
        Set oMail = oClient.GetMail(info)

        MsgBox "From: " & oMail.From.Address & _
            vbCrLf & "Subject: " & oMail.Subject

        Dim fileName As String
        ' Generate a random file name by current local datetime,
        ' You can use your method to generate the filename if you do not like it
        fileName = mailbox & "\" & oTools.GenFileName(i) & ".eml"

        ' Save email to local disk
        oMail.SaveAs fileName, True

        ' Delete email from Exchange server.
        oClient.Delete info
    Next

    ' Quit from Exchange server.
    oClient.Quit
    Exit Sub

ErrorHandle:
    MsgBox Err.Description
End Sub

Option Explicit

Const MailServerPop3 = 0
Const MailServerImap4 = 1
Const MailServerEWS = 2
Const MailServerDAV = 3
Const MailServerMsGraph = 4

Function FindFolder(ByVal FolderPath As String, ByRef folders As FolderCollection)
    Dim i As Long
    For i = 0 To folders.Count - 1
        Dim oFolder As Imap4Folder
        Set oFolder = folders.Item(i)
        If StrComp(oFolder.LocalPath, FolderPath, 1) = 0 Then
            Set FindFolder = oFolder
            Exit Function
        End If

        Set oFolder = FindFolder(FolderPath, oFolder.SubFolderList)
        If Not (oFolder Is Nothing) Then
            Set FindFolder = oFolder
            Exit Function
        End If
    Next

    Set FindFolder = Nothing
End Function

Private Sub Command1_Click()
    Dim curpath As String
    Dim mailbox As String
    Dim oTools As New EAGetMailObjLib.Tools

    ' Create a folder named "inbox" under current directory
    ' to save the email retrieved.
    curpath = App.Path
    mailbox = curpath & "\inbox"
    oTools.CreateFolder mailbox

    ' Please use domain\user as the user name
    Dim oServer As New EAGetMailObjLib.MailServer
    oServer.Server = "exch.emailarchitect.net"

    oServer.User = "emailarchitect.net\test"
    oServer.Password = "testpassword"

    oServer.Protocol = MailServerEWS

    ' By default, Exchange Web Service (EWS) requires SSL connection
    ' Please ignore Port property for EWS and WebDAV protocol
    oServer.SSLConnection = True

On Error GoTo ErrorHandle:
    Dim oClient As New EAGetMailObjLib.MailClient
    oClient.LicenseCode = "TryIt"

    oClient.Connect oServer
    MsgBox "Connected"

    ' Lookup folder based name,
    Dim folder As Imap4Folder
    ' If you want search sub folder, use parentfolder\subfolder
    ' For example: INBOX\MySubFolder
    Set folder = FindFolder("Deleted Items", oClient.GetFolderList())
    If folder Is Nothing Then
        Err.Raise 2, "ImapFolder", "Folder was not found"
    End If

    ' Select this folder
    oClient.SelectFolder folder

    Dim infos As EAGetMailObjLib.MailInfoCollection
    Set infos = oClient.GetMailInfoList()
    MsgBox infos.Count & " emails"

    Dim i As Long
    For i = 0 To infos.Count - 1
        Dim info As EAGetMailObjLib.MailInfo
        Set info = infos.Item(i)

        MsgBox "Index: " & info.Index & "; Size: " & info.Size & _
        "; UIDL: " & info.UIDL

        ' Receive email from Exchange server
        Dim oMail As EAGetMailObjLib.Mail
        Set oMail = oClient.GetMail(info)

        MsgBox "From: " & oMail.From.Address & _
            vbCrLf & "Subject: " & oMail.Subject

        Dim fileName As String
        ' Generate a random file name by current local datetime,
        ' You can use your method to generate the filename if you do not like it
        fileName = mailbox & "\" & oTools.GenFileName(i) & ".eml"

        ' Save email to local disk
        oMail.SaveAs fileName, True

        ' Delete email from Exchange server.
        oClient.Delete info
    Next

    ' Quit from Exchange server.
    oClient.Quit
    Exit Sub

ErrorHandle:
    MsgBox Err.Description
End Sub