VB6/ASP - Retrieve email using Gmail/G Suite OAuth 2.0 + IMAP4 protocol in background service (service account)¶

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(GsuiteUser)

    GenerateRequestData = ""

    ' service account email address
    Const serviceAccount = "xxxxxx@xxxxxx.iam.gserviceaccount.com"
    Const scope = "https://mail.google.com/"
    Const aud = "https://oauth2.googleapis.com/token"

    Dim jwt As New EAGetMailObjLib.SimpleJsonParser

    Dim header, playload
    header = jwt.JwtBase64UrlEncode("{""alg"":""RS256"",""typ"":""JWT""}")

    Dim iat, exp
    ' token request timestamp
    iat = jwt.GetCurrentIAT()
    ' token expiration time
    exp = iat + 3600

    playload = "{"
    playload = playload & """iss"":""" & serviceAccount & ""","
    playload = playload & """scope"":""" & scope & ""","
    playload = playload & """aud"":""" & aud & ""","
    playload = playload & """exp"":" & exp & ","
    playload = playload & """iat"":" & iat & ","
    playload = playload & """sub"":""" & GsuiteUser & """"
    playload = playload & "}"

    playload = jwt.JwtBase64UrlEncode(playload)

    Dim cert As New EAGetMailObjLib.Certificate

    ' In web application, use CRYPT_MACHINE_KEYSET
    If Not cert.LoadPFXFromFile("D:\myfolder\myoauth-77dec4d192ec.p12", "notasecret", CRYPT_USER_KEYSET) Then
        Debug.Print "Failed to load service account certificate!"
        Exit Function
    End If

    Dim signature
    signature = jwt.SignRs256(cert, header & "." & playload)
    If signature = "" Then
        Debug.Print "Failed to sign request data!"
        Exit Function
    End If

    Dim dataToPost

    dataToPost = header & "." & playload & "." & signature
    GenerateRequestData = dataToPost

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")

    requestData = "grant_type=urn%3Aietf%3Aparams%3Aoauth%3Agrant-type%3Ajwt-bearer&assertion=" & requestData

    httpRequest.setOption 2, 13056
    httpRequest.Open "POST", "https://oauth2.googleapis.com/token", 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()
    ' GsuiteUser is the full email address of the user in GSuite, user@gsuitedomain
    Dim GsuiteUser As String
    GsuiteUser = "user@mydomainingsuit.com"

    Dim access_token As String
    ' request access token from Google server by service account
    ' withou user interaction
    access_token = RequestAccessToken(GenerateRequestData(GsuiteUser))

    If access_token = "" Then
        Exit Sub
    End If

    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
    ' Gmail IMAP4 Server address
    oServer.Server = "imap.gmail.com"
    ' Use OAUTH 2.0
    oServer.AuthType = MailServerAuthXOAUTH2
    oServer.user = GsuiteUser
    ' Use access token as password
    oServer.Password = access_token
    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