You can retrieve email using traditional user/password authentication from Office 365 account by EWS/IMAP4/POP3 Protocol.
However Microsoft has disabled traditional user authentication in many tenants, switching to Microsoft OAuth (Modern Authentication) is strongly recommended now.
In this topic, I will introduce how to retrieve email using VB6 and Microsoft OAuth (Modern Authentication) in background service.
Sections:
Before you can use the following sample codes, you should download the EAGetMail Installer and install it on your machine at first. Full sample projects are included in this installer.
To use EAGetMail POP3 & IMAP4 ActiveX Object in your project,
the first step is Add reference of EAGetMail to your project
.
Please go to menu
-> Project
-> References
-> and select EAGetMailObj ActiveX Object
, click OK
,
the reference will be added to your project, and you can start to use it to retrieve email and parse email in your project.
Open VBA IDE by press Alt+F11
, Please select menu -> Tools
-> References
-> and select EASendMailObj ActiveX Object
,
click OK, the reference will be added to current VBA project, and you can start to use it to retrieve email and parse email in your VBA project.
To better demonstrate how to retrieve email and parse email, let’s create a VB 6.0 Standard EXE project at first, then add a CommandButton on the Form, double-click this button. It is like this
Normal OAuth requires user to input user and password in browser for authentication. Obviously, it is not suitable for background service.
The solution is granting admin consent
to the azure application, then the application
can use the client secret value to request the access token directly.
This way doesn’t require user attending, it is suitable for background service.
This tutorial introduces how to register application for background service
in Azure Portal,
then assign the Graph API/EWS/SMTP/POP/IMAP API permission to the application and add the access right to the mailbox of specific user.
Sign in to the Azure Portal using the Microsoft account of the Office 365 administrator
.
If your account gives you access to more than one tenant, select your account in the top right corner, and set your portal session to the Azure AD tenant that you want.
Search Microsoft Entra ID
(old name “Azure Active Directory”) and go to this service:
In the left-hand navigation pane, select the Microsoft Entra ID
service, and then select App registrations -> New registration.
Input a name to to register the application:
After the application is registered, you can click Overview
to find the client id
and tenant id
.
These are required parameters for requesting access token.
Now you need to assign API permission to the application by clicking API Permission
-> Add a permission
.
You don’t have to assign all the API permissions below to the application, just assign the API permission(s) you need.
Protocol | Permission | Scope | |
Graph API | Mail.Send, Mail.ReadWrite | https://graph.microsoft.com/.default | |
EWS | full_access_as_app | https://outlook.office365.com/.default | |
SMTP | SMTP.AccessAsApp | https://outlook.office365.com/.default | |
POP | POP.AccessAsApp | https://outlook.office365.com/.default | |
IMAP | IMAP.AccessAsApp | https://outlook.office365.com/.default |
Go to Microsoft APIs
->
Microsoft Graph
-> Application Permission
->
Go to APIs in my organization uses
->
Office 365 Exchange Online
-> Application Permission
->
To use the application to access the user mailbox in Office365 domain, you should grant admin consent by Office365 domain administrator.
In API Permission -> Click grant admin consent for ...
to grant admin consent to the application.
Now we need to create a client secret for the application,
click Certificates and secrets
-> client secrets
and add a new client secret.
After client secret is created, store the client secret value
to somewhere. It is another required parameter
for requesting access token.
Important
Please store client secret value
by yourself, because it is hidden when you view it at next time.
Now you can use the client id
, tenant id
and client secret value
to request access token.
But to use SMTP/POP/IMAP protocol, you need to Register SMTP/POP/IMAP service principals in Exchange as well.
Important
You should create your client id
and client secret
, do not use the client id
from example codes in production environment,
it is used for test purpose. If you got "This app isn't verified"
information, please click "Advanced"
-> Go to ...
for test.
Now you can use the following example codes to retrieve email with Graph API or EWS protocol:
Option Explicit
Const MailServerPop3 = 0
Const MailServerImap4 = 1
Const MailServerEWS = 2
Const MailServerDAV = 3
Const MailServerMsGraph = 4
Const MailServerAuthLogin = 0
Const MailServerAuthCRAM5 = 1
Const MailServerAuthNTLM = 2
Const MailServerAuthXOAUTH2 = 3
Const GetMailInfos_All = 1
Const GetMailInfos_NewOnly = 2
Const GetMailInfos_ReadOnly = 4
Const GetMailInfos_SeqRange = 8
Const GetMailInfos_UIDRange = 16
Const GetMailInfos_PR_ENTRYID = 32
Const GetMailInfos_DateRange = 64
Const GetMailInfos_OrderByDateTime = 128
Const CRYPT_MACHINE_KEYSET = 32
Const CRYPT_USER_KEYSET = 4096
Private Function GenerateRequestData()
Const client_id = "b22194da-44d6-4320-a067-e86a275d6fa4"
Const client_secret = "VTO8Q~eo0JCXc291jcM4wnhZ_GXyKMu."
Const scope = "https://graph.microsoft.com/.default"
GenerateRequestData = "client_id=" & client_id & "&client_secret=" & client_secret & "&scope=" & scope & "&grant_type=client_credentials"
End Function
Private Function RequestAccessToken(requestData)
RequestAccessToken = ""
If requestData = "" Then
Exit Function
End If
On Error GoTo ErrorHandle
Dim httpRequest
Set httpRequest = CreateObject("MSXML2.ServerXMLHTTP")
' If your application is not created by Office365 administrator,
' please use Office365 directory tenant id, you should ask Offic365 administrator to send it to you.
' Office365 administrator can query tenant id in https://portal.azure.com/ - Azure Active Directory.
Const tenant_id = "2ea4955d-830e-4aa7-8ab5-661a6b9aa84d"
Dim tokenUri
tokenUri = "https://login.microsoftonline.com/" & tenant_id & "/oauth2/v2.0/token"
httpRequest.setOption 2, 13056
httpRequest.Open "POST", tokenUri, True
httpRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
httpRequest.Send requestData
Do While httpRequest.ReadyState <> 4
DoEvents
httpRequest.waitForResponse (1)
Loop
Dim Status
Status = httpRequest.Status
If Status < 200 Or Status >= 300 Then
Debug.Print "Failed to get access token from server."
Debug.Print httpRequest.responseText
Exit Function
End If
Dim result
result = httpRequest.responseText
Dim oauthParser As New EAGetMailObjLib.OAuthResponseParser
oauthParser.Load result
Dim accessToken
accessToken = oauthParser.accessToken
If accessToken = "" Then
Debug.Print "Failed to parse access token from server response."
Exit Function
End If
RequestAccessToken = accessToken
Exit Function
ErrorHandle:
Debug.Print "Failed to request access token." & Err.Description
End Function
Public Sub RetrieveEmail()
Dim accessToken As String
accessToken = RequestAccessToken(GenerateRequestData())
If accessToken = "" Then
Exit Sub
End If
Dim Office365User As String
Office365User = "user@mydomain.onmicrosoft.com"
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
Dim oServer As New EAGetMailObjLib.MailServer
' Office 365 Graph API Server address
oServer.Server = "graph.microsoft.com"
' Use OAUTH 2.0
oServer.AuthType = MailServerAuthXOAUTH2
oServer.user = Office365User
' Use access token as password
oServer.Password = accessToken
' Use Graph API Protocol
oServer.Protocol = MailServerMsGraph
' Enable SSL/TLS connection
oServer.SSLConnection = True
On Error GoTo ErrorHandle:
Dim oClient As New EAGetMailObjLib.MailClient
oClient.LicenseCode = "TryIt"
Debug.Print "Connecting " & oServer.Server & "..."
oClient.Connect oServer
Debug.Print "Connected"
' Get new email only, if you want to get all emails, please remove this line
oClient.GetMailInfosParam.GetMailInfosOptions = GetMailInfos_NewOnly
Dim infos As EAGetMailObjLib.MailInfoCollection
Set infos = oClient.GetMailInfoList()
Debug.Print infos.Count & " emails"
Dim i As Long
For i = 0 To infos.Count - 1
Dim info As EAGetMailObjLib.MailInfo
Set info = infos.Item(i)
Debug.Print "Index: " & info.Index & "; Size: " & info.Size & _
"; UIDL: " & info.UIDL
' Receive email from IMAP4 server
Dim oMail As EAGetMailObjLib.Mail
Set oMail = oClient.GetMail(info)
Debug.Print "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
' Mark email as read to prevent retrieving this email again.
oClient.MarkAsRead info, True
' If you want to delete current email, please use Delete method instead of MarkAsRead
' oClient.Delete info
Next
' Quit and expunge emails marked as deleted from IMAP4 server.
oClient.Quit
Exit Sub
ErrorHandle:
Debug.Print Err.Description
End Sub
Option Explicit
Const MailServerPop3 = 0
Const MailServerImap4 = 1
Const MailServerEWS = 2
Const MailServerDAV = 3
Const MailServerMsGraph = 4
Const MailServerAuthLogin = 0
Const MailServerAuthCRAM5 = 1
Const MailServerAuthNTLM = 2
Const MailServerAuthXOAUTH2 = 3
Const GetMailInfos_All = 1
Const GetMailInfos_NewOnly = 2
Const GetMailInfos_ReadOnly = 4
Const GetMailInfos_SeqRange = 8
Const GetMailInfos_UIDRange = 16
Const GetMailInfos_PR_ENTRYID = 32
Const GetMailInfos_DateRange = 64
Const GetMailInfos_OrderByDateTime = 128
Const CRYPT_MACHINE_KEYSET = 32
Const CRYPT_USER_KEYSET = 4096
Private Function GenerateRequestData()
Const client_id = "b22194da-44d6-4320-a067-e86a275d6fa4"
Const client_secret = "VTO8Q~eo0JCXc291jcM4wnhZ_GXyKMu."
Const scope = "https://outlook.office365.com/.default"
GenerateRequestData = "client_id=" & client_id & "&client_secret=" & client_secret & "&scope=" & scope & "&grant_type=client_credentials"
End Function
Private Function RequestAccessToken(requestData)
RequestAccessToken = ""
If requestData = "" Then
Exit Function
End If
On Error GoTo ErrorHandle
Dim httpRequest
Set httpRequest = CreateObject("MSXML2.ServerXMLHTTP")
' If your application is not created by Office365 administrator,
' please use Office365 directory tenant id, you should ask Offic365 administrator to send it to you.
' Office365 administrator can query tenant id in https://portal.azure.com/ - Azure Active Directory.
Const tenant_id = "2ea4955d-830e-4aa7-8ab5-661a6b9aa84d"
Dim tokenUri
tokenUri = "https://login.microsoftonline.com/" & tenant_id & "/oauth2/v2.0/token"
httpRequest.setOption 2, 13056
httpRequest.Open "POST", tokenUri, True
httpRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
httpRequest.Send requestData
Do While httpRequest.ReadyState <> 4
DoEvents
httpRequest.waitForResponse (1)
Loop
Dim Status
Status = httpRequest.Status
If Status < 200 Or Status >= 300 Then
Debug.Print "Failed to get access token from server."
Debug.Print httpRequest.responseText
Exit Function
End If
Dim result
result = httpRequest.responseText
Dim oauthParser As New EAGetMailObjLib.OAuthResponseParser
oauthParser.Load result
Dim accessToken
accessToken = oauthParser.accessToken
If accessToken = "" Then
Debug.Print "Failed to parse access token from server response."
Exit Function
End If
RequestAccessToken = accessToken
Exit Function
ErrorHandle:
Debug.Print "Failed to request access token." & Err.Description
End Function
Public Sub RetrieveEmail()
Dim accessToken As String
accessToken = RequestAccessToken(GenerateRequestData())
If accessToken = "" Then
Exit Sub
End If
Dim Office365User As String
Office365User = "user@mydomain.onmicrosoft.com"
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
Dim oServer As New EAGetMailObjLib.MailServer
' Office 365 Server address
oServer.Server = "outlook.office365.com"
' Use OAUTH 2.0
oServer.AuthType = MailServerAuthXOAUTH2
oServer.user = Office365User
' Use access token as password
oServer.Password = accessToken
' Use EWS Protocol
oServer.Protocol = MailServerEWS
' Enable SSL/TLS connection
oServer.SSLConnection = True
On Error GoTo ErrorHandle:
Dim oClient As New EAGetMailObjLib.MailClient
oClient.LicenseCode = "TryIt"
Debug.Print "Connecting " & oServer.Server & "..."
oClient.Connect oServer
Debug.Print "Connected"
' Get new email only, if you want to get all emails, please remove this line
oClient.GetMailInfosParam.GetMailInfosOptions = GetMailInfos_NewOnly
Dim infos As EAGetMailObjLib.MailInfoCollection
Set infos = oClient.GetMailInfoList()
Debug.Print infos.Count & " emails"
Dim i As Long
For i = 0 To infos.Count - 1
Dim info As EAGetMailObjLib.MailInfo
Set info = infos.Item(i)
Debug.Print "Index: " & info.Index & "; Size: " & info.Size & _
"; UIDL: " & info.UIDL
' Receive email from IMAP4 server
Dim oMail As EAGetMailObjLib.Mail
Set oMail = oClient.GetMail(info)
Debug.Print "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
' Mark email as read to prevent retrieving this email again.
oClient.MarkAsRead info, True
' If you want to delete current email, please use Delete method instead of MarkAsRead
' oClient.Delete info
Next
' Quit and expunge emails marked as deleted from IMAP4 server.
oClient.Quit
Exit Sub
ErrorHandle:
Debug.Print Err.Description
End Sub
Although the application is consented by the tenant admin, but to access SMTP/POP/IMAP service, the tenant administrator still need to register your application as service principal in Exchange via Exchange Online PowerShell. This is enabled by the New-ServicePrincipal cmdlet.
New-ServicePrincipal -AppId <APPLICATION_ID> -ServiceId <OBJECT_ID>
You should find your APPLICATION_ID
and OBJECT_ID
before running above cmdlet.
Go to Overview
-> Managed application in local directory
:
After you click your application name in Managed application in l...
,
you can see Application ID
and Object ID
for New-ServicePrincipal cmdlet.
Now you need to open Exchange Online PowerShell to run the cmdlet. If you have not installed the module, you can use the Install-Module cmdlet to install the module from the PowerShell Gallery.
Install-Module -Name ExchangeOnlineManagement
After you’ve installed the module, open a PowerShell window and load the module by running the following command:
Import-Module ExchangeOnlineManagement
Connect-ExchangeOnline -UserPrincipalName "admin@yourdomain.onmicrosoft.com"
After Exchange Online PowerShell is connected successfully, run the following cmdlet to create a new service principal:
The ServiceId is the OBJECT_ID
and the AppId is APPLICATION_ID
found in Find APPLICATION_ID and OBJECT_ID
New-ServicePrincipal -AppId "b22194da-44d6-4320-a067-e86a275d6fa4" -ServiceId "71941e67-ef24-45e8-bd22-dfd53790bb77"
After you create the service principal, you can query it by:
Get-ServicePrincipal
You can now add the specific mailboxes in the tenant that will be allowed to be access by your application. This is done with the Add-MailboxPermission cmdlet.
Add-MailboxPermission -Identity <mailboxIdParameter> -User <SecurityPrincipalIdParameter|OBJECT_ID> -AccessRights <MailboxRights[]>
For example:
Add-MailboxPermission -Identity "grant-test@emailarchitect.net" -User "71941e67-ef24-45e8-bd22-dfd53790bb77" -AccessRights FullAccess
You can also query the permission by:
Get-MailboxPermission -Identity "grant-test@emailarchitect.net"
Now you can use IMAP or POP3 protocol to retrieve email by the following codes:
Option Explicit
Const MailServerPop3 = 0
Const MailServerImap4 = 1
Const MailServerEWS = 2
Const MailServerDAV = 3
Const MailServerMsGraph = 4
Const MailServerAuthLogin = 0
Const MailServerAuthCRAM5 = 1
Const MailServerAuthNTLM = 2
Const MailServerAuthXOAUTH2 = 3
Const GetMailInfos_All = 1
Const GetMailInfos_NewOnly = 2
Const GetMailInfos_ReadOnly = 4
Const GetMailInfos_SeqRange = 8
Const GetMailInfos_UIDRange = 16
Const GetMailInfos_PR_ENTRYID = 32
Const GetMailInfos_DateRange = 64
Const GetMailInfos_OrderByDateTime = 128
Const CRYPT_MACHINE_KEYSET = 32
Const CRYPT_USER_KEYSET = 4096
Private Function GenerateRequestData()
Const client_id = "b22194da-44d6-4320-a067-e86a275d6fa4"
Const client_secret = "VTO8Q~eo0JCXc291jcM4wnhZ_GXyKMu."
Const scope = "https://outlook.office365.com/.default"
GenerateRequestData = "client_id=" & client_id & "&client_secret=" & client_secret & "&scope=" & scope & "&grant_type=client_credentials"
End Function
Private Function RequestAccessToken(requestData)
RequestAccessToken = ""
If requestData = "" Then
Exit Function
End If
On Error GoTo ErrorHandle
Dim httpRequest
Set httpRequest = CreateObject("MSXML2.ServerXMLHTTP")
' If your application is not created by Office365 administrator,
' please use Office365 directory tenant id, you should ask Offic365 administrator to send it to you.
' Office365 administrator can query tenant id in https://portal.azure.com/ - Azure Active Directory.
Const tenant_id = "2ea4955d-830e-4aa7-8ab5-661a6b9aa84d"
Dim tokenUri
tokenUri = "https://login.microsoftonline.com/" & tenant_id & "/oauth2/v2.0/token"
httpRequest.setOption 2, 13056
httpRequest.Open "POST", tokenUri, True
httpRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
httpRequest.Send requestData
Do While httpRequest.ReadyState <> 4
DoEvents
httpRequest.waitForResponse (1)
Loop
Dim Status
Status = httpRequest.Status
If Status < 200 Or Status >= 300 Then
Debug.Print "Failed to get access token from server."
Debug.Print httpRequest.responseText
Exit Function
End If
Dim result
result = httpRequest.responseText
Dim oauthParser As New EAGetMailObjLib.OAuthResponseParser
oauthParser.Load result
Dim accessToken
accessToken = oauthParser.accessToken
If accessToken = "" Then
Debug.Print "Failed to parse access token from server response."
Exit Function
End If
RequestAccessToken = accessToken
Exit Function
ErrorHandle:
Debug.Print "Failed to request access token." & Err.Description
End Function
Public Sub RetrieveEmail()
Dim accessToken As String
accessToken = RequestAccessToken(GenerateRequestData())
If accessToken = "" Then
Exit Sub
End If
Dim Office365User As String
Office365User = "grant-test@emailarchitect.net"
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
Dim oServer As New EAGetMailObjLib.MailServer
' Office 365 Server address
oServer.Server = "outlook.office365.com"
' Use OAUTH 2.0
oServer.AuthType = MailServerAuthXOAUTH2
oServer.user = Office365User
' Use access token as password
oServer.Password = accessToken
' Use IMAP Protocol
oServer.Protocol = MailServerImap4
' Enable SSL/TLS connection
oServer.SSLConnection = True
' Set IMAP SSL Port
oServer.Port = 993
On Error GoTo ErrorHandle:
Dim oClient As New EAGetMailObjLib.MailClient
oClient.LicenseCode = "TryIt"
Debug.Print "Connecting " & oServer.Server & "..."
oClient.Connect oServer
Debug.Print "Connected"
' Get new email only, if you want to get all emails, please remove this line
oClient.GetMailInfosParam.GetMailInfosOptions = GetMailInfos_NewOnly
Dim infos As EAGetMailObjLib.MailInfoCollection
Set infos = oClient.GetMailInfoList()
Debug.Print infos.Count & " emails"
Dim i As Long
For i = 0 To infos.Count - 1
Dim info As EAGetMailObjLib.MailInfo
Set info = infos.Item(i)
Debug.Print "Index: " & info.Index & "; Size: " & info.Size & _
"; UIDL: " & info.UIDL
' Receive email from IMAP4 server
Dim oMail As EAGetMailObjLib.Mail
Set oMail = oClient.GetMail(info)
Debug.Print "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
' Mark email as read to prevent retrieving this email again.
oClient.MarkAsRead info, True
' If you want to delete current email, please use Delete method instead of MarkAsRead
' oClient.Delete info
Next
' Quit and expunge emails marked as deleted from IMAP4 server.
oClient.Quit
Exit Sub
ErrorHandle:
Debug.Print Err.Description
End Sub
You don’t have to request access token
every time. By default,
access token
expiration time is 3600 seconds, you can reuse the access token
repeatedly before it is expired.
TLS is the successor of SSL, more and more SMTP servers require TLS 1.2
encryption now.
If your operating system is Windows XP/Vista/Windows 7/Windows 2003/2008/2008 R2/2012/2012 R2
, you need to
enable TLS 1.2 protocol in your operating system like this:
Enable TLS 1.2 on Windows XP/Vista/7/10/Windows 2008/2008 R2/2012
If you are not the tenant administrator and you don’t have the permission to create or grant the application in Azure, or if your code is too complex or out of maintenance, and you don’t want to change anything in your source codes, then you can have a try with EA Oauth Service for Offic365. It provides an easy way for the legacy email application that doesn’t support OAUTH 2.0 to send and retrieve email from Office 365 without changing any codes. SMTP, POP, IMAP and SSL/TLS protocols are supported.
Appendix
Comments
If you have any comments or questions about above example codes, please click here to add your comments.