Attribute VB_Name = "ModuleSendWithGraph"
Option Explicit

#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
#End If

Private Const TENANT_ID As String = "<TENANT_ID>"
Private Const CLIENT_ID As String = "<CLIENT_ID>"

Private Const AUTHORITY As String = _
    "https://login.microsoftonline.com/"

Private Const GRAPH_URL As String = _
    "https://graph.microsoft.com/v1.0"

Private Const GRAPH_SCOPE As String = _
    "https://graph.microsoft.com/Mail.Send " & _
    "https://graph.microsoft.com/User.Read"

'==================================================
' 添付ファイル付きメールを送信
'==================================================
Public Sub SendWithGraph( _
    ByVal fromAddress As String, _
    ByVal toAddress As String, _
    ByVal subjectText As String, _
    ByVal bodyText As String, _
    ByVal attachmentPath As String)

    On Error GoTo ErrorHandler

    If Dir$(attachmentPath) = "" Then
        Err.Raise vbObjectError + 1, , _
            "添付ファイルが見つかりません：" & attachmentPath
    End If

    Dim accessToken As String
    accessToken = SignInWithDeviceCode()

    Dim signedInAddress As String
    signedInAddress = GetSignedInAddress(accessToken)

    If StrComp(Trim$(fromAddress), _
               Trim$(signedInAddress), vbTextCompare) <> 0 Then

        Err.Raise vbObjectError + 3, , _
            "指定した送信元とログインしたアカウントが異なります。" & _
            vbCrLf & _
            "指定：" & fromAddress & vbCrLf & _
            "ログイン：" & signedInAddress
    End If

    Dim fileName As String
    fileName = Mid$(attachmentPath, InStrRev(attachmentPath, "\") + 1)

    Dim json As String

    json = "{""message"":{"
    json = json & """subject"":""" & JsonEscape(subjectText) & ""","
    json = json & """body"":{"
    json = json & """contentType"":""Text"","
    json = json & """content"":""" & JsonEscape(bodyText) & """},"
    json = json & """toRecipients"":[{"
    json = json & """emailAddress"":{"
    json = json & """address"":""" & JsonEscape(toAddress) & """}}],"
    json = json & """attachments"":[{"
    json = json & """@odata.type"":""#microsoft.graph.fileAttachment"","
    json = json & """name"":""" & JsonEscape(fileName) & ""","
    json = json & """contentType"":""application/octet-stream"","
    json = json & """contentBytes"":""" & FileToBase64(attachmentPath) & """"
    json = json & "}]},"
    json = json & """saveToSentItems"":true}"

    Dim statusCode As Long
    Dim responseText As String

    responseText = HttpPost( _
        GRAPH_URL & "/me/sendMail", _
        json, _
        "application/json", _
        statusCode, _
        accessToken)

    If statusCode <> 202 Then
        Err.Raise vbObjectError + 4, , _
            "メール送信に失敗しました。HTTP：" & statusCode & _
            vbCrLf & responseText
    End If

    MsgBox "メールを送信しました。", vbInformation
    Exit Sub

ErrorHandler:

    MsgBox Err.Description, vbCritical

End Sub

'==================================================
' デバイスコード認証
'==================================================
Private Function SignInWithDeviceCode() As String

    Dim statusCode As Long
    Dim responseText As String

    responseText = HttpPost( _
        AUTHORITY & TENANT_ID & "/oauth2/v2.0/devicecode", _
        "client_id=" & UrlEncode(CLIENT_ID) & _
        "&scope=" & UrlEncode(GRAPH_SCOPE), _
        "application/x-www-form-urlencoded", _
        statusCode)

    If statusCode <> 200 Then
        Err.Raise vbObjectError + 10, , _
            "認証コードを取得できません。HTTP：" & statusCode
    End If

    Dim deviceCode As String
    Dim userCode As String
    Dim verificationUrl As String
    Dim intervalSeconds As Long
    Dim expiresInSeconds As Long

    deviceCode = JsonText(responseText, "device_code")
    userCode = JsonText(responseText, "user_code")
    verificationUrl = JsonText(responseText, "verification_uri_complete")

    If verificationUrl = "" Then
        verificationUrl = JsonText(responseText, "verification_uri")
    End If

    intervalSeconds = Val(JsonNumber(responseText, "interval"))
    expiresInSeconds = Val(JsonNumber(responseText, "expires_in"))

    If intervalSeconds < 5 Then intervalSeconds = 5

    CreateObject("Shell.Application").ShellExecute _
        verificationUrl, "", "", "open", 1

    MsgBox _
        "ブラウザーで送信元アカウントにサインインしてください。" & _
        vbCrLf & vbCrLf & _
        "コード：" & userCode, _
        vbInformation

    Dim tokenUrl As String
    Dim tokenBody As String
    Dim expireAt As Date
    Dim errorCode As String

    tokenUrl = AUTHORITY & TENANT_ID & "/oauth2/v2.0/token"

    tokenBody = _
        "grant_type=" & _
        UrlEncode("urn:ietf:params:oauth:grant-type:device_code") & _
        "&client_id=" & UrlEncode(CLIENT_ID) & _
        "&device_code=" & UrlEncode(deviceCode)

    expireAt = DateAdd("s", expiresInSeconds, Now)

    Do While Now < expireAt

        WaitSeconds intervalSeconds

        responseText = HttpPost( _
            tokenUrl, _
            tokenBody, _
            "application/x-www-form-urlencoded", _
            statusCode)

        If statusCode = 200 Then
            SignInWithDeviceCode = _
                JsonText(responseText, "access_token")
            Exit Function
        End If

        errorCode = JsonText(responseText, "error")

        Select Case errorCode
            Case "authorization_pending"
                '認証完了まで待機

            Case "slow_down"
                intervalSeconds = intervalSeconds + 5

            Case Else
                Err.Raise vbObjectError + 11, , _
                    "認証に失敗しました：" & errorCode
        End Select

    Loop

    Err.Raise vbObjectError + 12, , _
        "認証コードの有効期限が切れました。"

End Function

'==================================================
' ログインしたアカウントを確認
'==================================================
Private Function GetSignedInAddress( _
    ByVal accessToken As String) As String

    Dim statusCode As Long
    Dim responseText As String

    responseText = HttpGet( _
        GRAPH_URL & "/me?$select=mail,userPrincipalName", _
        statusCode, _
        accessToken)

    If statusCode <> 200 Then
        Err.Raise vbObjectError + 20, , _
            "ログインアカウントを確認できません。"
    End If

    GetSignedInAddress = JsonText(responseText, "mail")

    If GetSignedInAddress = "" Then
        GetSignedInAddress = _
            JsonText(responseText, "userPrincipalName")
    End If

End Function

'==================================================
' HTTP
'==================================================
Private Function HttpPost( _
    ByVal url As String, _
    ByVal body As String, _
    ByVal contentType As String, _
    ByRef statusCode As Long, _
    Optional ByVal accessToken As String = "") As String

    Dim http As Object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")

    http.Open "POST", url, False
    http.SetRequestHeader "Content-Type", contentType

    If accessToken <> "" Then
        http.SetRequestHeader _
            "Authorization", "Bearer " & accessToken
    End If

    http.Send Utf8Bytes(body)

    statusCode = http.status
    HttpPost = http.responseText

End Function

Private Function HttpGet( _
    ByVal url As String, _
    ByRef statusCode As Long, _
    ByVal accessToken As String) As String

    Dim http As Object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")

    http.Open "GET", url, False
    http.SetRequestHeader _
        "Authorization", "Bearer " & accessToken
    http.Send

    statusCode = http.status
    HttpGet = http.responseText

End Function

'==================================================
' ファイル・文字列変換
'==================================================
Private Function FileToBase64( _
    ByVal filePath As String) As String

    Dim stream As Object
    Dim document As Object
    Dim node As Object
    Dim result As String

    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 1
    stream.Open
    stream.LoadFromFile filePath

    Set document = CreateObject("MSXML2.DOMDocument.6.0")
    Set node = document.createElement("base64")

    node.DataType = "bin.base64"
    node.nodeTypedValue = stream.Read

    result = node.text
    result = Replace(result, vbCr, "")
    result = Replace(result, vbLf, "")
    result = Replace(result, vbTab, "")
    result = Replace(result, " ", "")

    stream.Close
    FileToBase64 = result

End Function

Private Function Utf8Bytes(ByVal text As String) As Variant

    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")

    stream.Type = 2
    stream.Charset = "utf-8"
    stream.Open
    stream.WriteText text

    stream.Position = 0
    stream.Type = 1
    stream.Position = 3

    Utf8Bytes = stream.Read
    stream.Close

End Function

Private Function JsonEscape(ByVal text As String) As String

    text = Replace(text, "\", "\\")
    text = Replace(text, """", "\""")
    text = Replace(text, vbCrLf, "\n")
    text = Replace(text, vbCr, "\n")
    text = Replace(text, vbLf, "\n")
    text = Replace(text, vbTab, "\t")

    JsonEscape = text

End Function

Private Function JsonText( _
    ByVal json As String, _
    ByVal key As String) As String

    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")

    regex.Pattern = _
        """" & key & """\s*:\s*""((?:[^""\\]|\\.)*)"""

    If regex.Test(json) Then
        JsonText = regex.Execute(json)(0).SubMatches(0)
        JsonText = Replace(JsonText, "\/", "/")
    End If

End Function

Private Function JsonNumber( _
    ByVal json As String, _
    ByVal key As String) As String

    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")

    regex.Pattern = _
        """" & key & """\s*:\s*([0-9]+)"

    If regex.Test(json) Then
        JsonNumber = regex.Execute(json)(0).SubMatches(0)
    End If

End Function

Private Function UrlEncode(ByVal text As String) As String

    Dim i As Long
    Dim code As Long
    Dim result As String

    For i = 1 To Len(text)

        code = AscW(Mid$(text, i, 1))

        Select Case code
            Case 48 To 57, 65 To 90, 97 To 122, 45, 46, 95, 126
                result = result & ChrW$(code)
            Case 32
                result = result & "%20"
            Case Else
                result = result & "%" & Right$("0" & Hex$(code), 2)
        End Select

    Next

    UrlEncode = result

End Function

Private Sub WaitSeconds(ByVal seconds As Long)

    Dim endTime As Date
    endTime = DateAdd("s", seconds, Now)

    Do While Now < endTime
        DoEvents
        Sleep 100
    Loop

End Sub