2026/6/30

新しいOutlook対応｜Excel VBAからMicrosoft Graph APIで添付メールを送信する【動作確認済みコード全文】

VBA / Outlook / Microsoft Graph / Microsoft365 / Excel

はじめに

WindowsのExcelやAccessのVBAでメールを送るとき、長く定番だったのが CreateObject("Outlook.Application") でOutlookを操作する方法です。ところが、このCOMによる操作は「新しいOutlook」では使えません。新しいOutlookはCOMのオブジェクトモデルを公開しておらず、Outlook.Application を取得できないためです。

そこで本記事では、メールの送信部分だけを Microsoft Graph API に置き換えます。既存のVBAツールをまるごと作り直す必要はありません。Excelの読み取りやファイル処理といったローカルの処理はそのまま残し、送信の入口だけを差し替えます。

掲載するのは、実際に動作確認した次の2つの関数です。

SendWithOutlook … クラシックOutlookのCOMで送る（従来方式）
SendWithGraph … Microsoft Graph APIで送る（新方式）

どちらも、まったく同じ引数で呼び出せます。

SendWithOutlook fromAddress, toAddress, subjectText, bodyText, attachmentPath
SendWithGraph   fromAddress, toAddress, subjectText, bodyText, attachmentPath

どちらも、添付ファイル付きのメールを1通送ります。送信元アカウントの決め方は方式によって異なり、Outlook版では送信元メールアドレスから登録済みアカウントを選び、Graph版ではサインインしたアカウントが指定した送信元と一致することを確認します。引数の受け渡しは変えず、呼び出す関数名を差し替えるだけで送信方式を変更できます。

SendWithGraph の利点は、Outlookアプリの有無に依存しないことです。HTTPでGraphに直接リクエストするので、新しいOutlookでも動きます。その代わり、事前に Entra ID へのアプリ登録が必要で、実行時にはデバイスコード認証でサインインします。この準備と認証の流れも順に説明します。

なお、Microsoft 365（Exchange Online）をすでに利用している環境であれば、この方式に追加費用はかかりません。

なぜ動かないのか

新しいOutlook（new Outlook for Windows）は、見た目が変わっただけのアップデートではありません。中身は実質的に Outlook on the web（OWA）をデスクトップアプリとして包んだもの、つまりWebアプリのラッパーです。

そして、従来のクラシックOutlookがWin32アプリとして公開していた COMオブジェクトモデル（Outlook Object Model）を、新しいOutlookは持っていません。

VBAからのOutlook操作は、このCOMオブジェクトモデルがあることが大前提でした。CreateObject("Outlook.Application") は、PCに常駐するクラシックOutlookのCOMサーバーに接続し、MailItem を作って .Send する——という仕組みです。土台のCOMが無ければ、コードは動きようがありません。

具体的な問題点

整理すると、ハマりどころは次のあたりです。

1. `CreateObject("Outlook.Application")` が掴む相手がいない

CreateObject("Outlook.Application") は、Outlook.Application というProgIDに対応してCOM登録されたサーバー（＝クラシックOutlookの実行ファイル）を呼び出します。新しいOutlookは、この Outlook.Application のCOMサーバーとして登録されていません。VBAから見ると、新しいOutlookは「最初から存在しない」のと同じです。

つまり挙動を分けるのは、Outlookが起動しているかどうかではなく、そのPCでクラシックOutlookのCOMサーバーが生きているかどうか です。そして、新しいOutlookへ切り替えると、この前提がいつ断たれるかが環境によって変わります。

多くの利用者が報告しているのは、新しいOutlookに切り替えた（トグルをオンにした）時点で、ExcelやAccessからの送信が動かなくなるというパターンです。新しいOutlookを常用するユーザーにとって、VBA経由のメール送信は事実上使えなくなると考えてよいでしょう。
一方で、新しいOutlookを使っていてもクラシックがまだ裏に残っている構成では、CreateObject がそのクラシックを掴んで動き続けることもあります。
クラシックが完全に無い（未インストール／削除済み／新しいOutlookだけのPC）場合は、呼び出す相手のCOMサーバーが存在せず、CreateObject が実行時エラー（429: ActiveXコンポーネントがオブジェクトを作成できません）で落ちます。

挙動がブレるので「うちは動いているから大丈夫」という判断は危険です。今日たまたま動いていても、トグルの切り替え、クラシックの削除、新しいOutlookだけのPCへの入れ替え——どこかのタイミングで、ある日突然ツールが動かなくなります。「新しいOutlookに乗った人からは、VBAのOutlook自動化は当てにできない」を前提に置くのが安全です。

2. COMアドイン・VBAそのものが非対応

新しいOutlookは、クラシックOutlookで使えていたCOMアドインをサポートしません。Outlook側のVBA（VbaProject.OTM）を新しいOutlookに引き継ぐこともできません。「Outlookマクロを作り込んで運用してきた」系の資産は、新しいOutlookには持っていけない、という前提で考える必要があります。

3. 段階移行で、いずれクラシックは既定から外れる

新しいOutlookへの移行は、Microsoftによって opt-in → opt-out → cutover という3段階で進められています。

opt-in（現在）：新しいOutlookは既定オフ。クラシックの右上に出る「新しいOutlookを試す」トグルで、使いたい人が自分でオンにする段階です。気に入らなければクラシックに戻せます。
opt-out：新しいOutlookが既定オンになり、自動的に新しい体験へ移されます。それでも手動でクラシックに戻すことは可能です。
cutover：もうクラシックには戻せません。新規展開されるOutlookは新しいOutlookだけになります。

opt-outとcutoverの前には管理者向けに最低12か月の予告があるとされ、既存のクラシックOutlook自体も、永続／サブスクリプションライセンスでは少なくとも2029年までサポートが続く予定です。スケジュールは何度か後ろ倒しされていますが、「最終的にクラシックは既定から外れ、新規はすべて新しいOutlookになる」という方向は一貫しています。

つまり、いま動いているツールも安泰ではありません。PCの入れ替えやキッティングの世代交代といったタイミングで、組織として順次この移行に巻き込まれていく、という前提に立っておくべきです。

4. ありがちな回避策（クラシック据え置き／Power Automate）が、この用途に向かない

「クラシックに戻せばいい」「Power Automateでやればいい」という案はよく出ます。

前者は延命でしかありません。問題3の移行に飲み込まれるまでの時間を稼いでいるだけです。

後者のPower Automateも、今回の用途には素直に向きません。理由はシンプルで、この手のVBAツールの本質が「ローカルとの連携」だからです。いま開いているExcelブックの行を読み、ローカルや共有フォルダにあるPDFを添付し、本文にインライン画像を差し込み、送信元アカウントを出し分ける——こうした処理は、Excelと同じPC上・同じプロセスで動くVBAだからこそ素直に書けます。

クラウド側で動くPower Automateから、利用者の手元のExcelやローカルフォルダのファイルに同じように手を伸ばすのは、できなくはなくても回りくどく、ロジックを丸ごとローコードのフローへ作り直す手間に対して、得られる柔軟性とメンテ性が見合いません。定型の通知やトリガー連携には便利なツールですが、それとこれとは別の話です。

結局、現場の要求は「ツールごと作り直す」ことではなく、「ローカル連携の部分はVBAのまま残し、メールを送る部分だけを最小の書き換えで生き残らせたい」——この一点に尽きます。次章以降は、まさにこれを実現していきます。

移行の前提：Entra IDのアプリ登録（と、場合によっては管理者の一手）

COM版は「クラシックOutlookが入っていれば動く」もので、追加の準備は要りませんでした。Graph版はその手軽さの代わりに、Microsoft Entra ID（旧Azure AD）へのアプリ登録が前提になります。ModuleSendWithGraph の先頭にある2つの定数は、ここで発行される値です。

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

アプリ登録でやること

Microsoft Entra管理センターの「アプリの登録」から、概ね次の設定をします。

新規登録：名前を付けて登録します（名前は任意。例：GraphMailSender）。アカウントの種類は、自組織だけで使うなら単一テナントでかまいません。登録すると「アプリケーション（クライアント）ID」と「ディレクトリ（テナント）ID」が発行されます。これがコードの CLIENT_ID / TENANT_ID です。
パブリッククライアントフローを許可：左メニューの「Authentication（認証）」を開き、「設定」タブにある「パブリッククライアントフローを許可する」のトグルを有効にします。今回のデバイスコード認証はクライアントシークレットを持たないパブリッククライアントなので、これが必要です。
APIのアクセス許可：「Microsoft Graph」→「委任されたアクセス許可」で Mail.Send と User.Read を追加します。コードの送信スコープと一致させる形です。（将来、受信メールの読み取りや添付ファイルの保存までやりたい場合は、Mail.ReadWrite も足しておくと使い回せます。今回の送信だけなら不要です。）

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

Mail.Sendはログインしたユーザー自身としてメールを送るため、User.Readはログインアカウントを確認して「指定した送信元＝サインインした本人」かを照合するために使っています。

管理者（テナント管理者）の手が要る場合

ここが、組織で使うときに一番引っかかるポイントです。上の作業は、テナントの設定によっては自分一人では完結しません。

そもそもアプリ登録ができないことがある：テナントで「ユーザーはアプリケーションを登録できる」がオフになっていると、一般ユーザーはアプリ登録できません。管理者に登録してもらうか、登録できる権限（アプリケーション開発者ロールなど）を付けてもらう必要があります。
管理者の同意（admin consent）が要ることがある：ここは少し分かりにくいところです。アクセス許可の一覧を見ると、Mail.Send も User.Read も「管理者の同意が必要」列は いいえ と表示されます。つまり、これらの権限は本来「管理者同意が必須」ではありません。

それでも、テナント側がユーザーによる同意操作そのものを無効化している場合は、ユーザーが自分で同意できません。結果として、列が「いいえ」でも管理者が「管理者の同意を与える」を実行しないと使えない、という状態になります。実際、私の環境（統制の固い組織）では、この「いいえ」のままでは動かず、管理者に「管理者の同意を与える」を一度押してもらって初めて送信できるようになりました。

つまりGraph方式は、「コードを書けば終わり」ではなく、入口で一度だけ、管理者に話を通す工程が挟まることがあります。ここを見込まずに進めると、コードは完成しているのに同意関連のエラー（consent_required など）で止まって動かない、という詰まり方をします。

依頼するときは、「何のために・どの権限を・どこまでの範囲で使うのか」を添えると話が早いです。具体的には、(1) アプリ名とアプリID、(2) 付与してほしい委任権限、(3) できることの範囲（＝本人がサインインして本人として送るだけで、他人のメールボックスを覗いたりなりすましたりはできない／パスワードやシークレットをツール側に保存しない）、(4) 操作（「Entra > 当該アプリ > APIのアクセス許可 > 管理者の同意を与える」を1回）、を一通り書いておくと、管理者側も判断しやすくなります。

逆に言えば、ここを一度通してしまえば後はラクです。ツールごとにアプリを乱立させず、共有アプリを1つ登録して、社内のVBAツール群で CLIENT_ID / TENANT_ID を使い回す運用にしておくと、管理者との調整も1回で済み、管理もシンプルになります。

ここまで準備できれば、あとはコードです。次章では、まず比較対象として従来のCOM版（SendWithOutlook）を確認し、それを同じインターフェイスのままGraph版（SendWithGraph）へ置き換えていきます。

① 置き換え前：従来のCOM版（`SendWithOutlook`）

まず、置き換え前の姿を確認します。これが、新しいOutlookで動かなくなる従来のCOM版です。送信元・宛先・件名・本文・添付ファイルのパスを渡して呼び出します。

Public Sub SendWithOutlook( _
    ByVal fromAddress As String, _
    ByVal toAddress As String, _
    ByVal subjectText As String, _
    ByVal bodyText As String, _
    ByVal attachmentPath As String)

    Dim outlookApp As Object
    Dim mailItem As Object
    Dim sendAccount As Object
    Dim account As Object

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

    Set outlookApp = CreateObject("Outlook.Application")

    For Each account In outlookApp.Session.Accounts
        If StrComp(Trim$(account.SmtpAddress), _
                   Trim$(fromAddress), vbTextCompare) = 0 Then
            Set sendAccount = account
            Exit For
        End If
    Next

    If sendAccount Is Nothing Then
        Err.Raise vbObjectError + 2, , _
            "Outlookに送信元アカウントがありません：" & fromAddress
    End If

    Set mailItem = outlookApp.CreateItem(0)

    With mailItem
        Set .SendUsingAccount = sendAccount
        .To = toAddress
        .subject = subjectText
        .body = bodyText
        .attachments.Add attachmentPath
        .Send
    End With
End Sub

やっていることは素直です。CreateObject("Outlook.Application") でOutlookのCOMサーバーに接続し、Session.Accounts から送信元アドレス（SmtpAddress）に一致するアカウントを探して、CreateItem でメールを作り、Attachments.Add で添付を付けて Send する——という流れです。

そして、この CreateObject("Outlook.Application") の一行こそが、記事の前半で見た「新しいOutlookで動かなくなる」当の本人です。ここから先は、この入口（引数の形）を保ったまま、中身だけをGraphに入れ替えていきます。

② 置き換え後：Graph版の全体像（`SendWithGraph`）

こちらが置き換え後です。呼び出し方はCOM版とまったく同じ（fromAddress, toAddress, subjectText, bodyText, attachmentPath）に揃えてあるので、呼び出し側のコードは原則そのままで済みます。

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

大きな流れは次の3ステップです。

トークンを取得する：SignInWithDeviceCode でユーザーとしてサインインし、アクセストークンを得る。
送信元を確認する：GetSignedInAddress で「いまサインインしているアカウント」を取得し、指定した fromAddress と一致するかを照合する（取り違え・なりすまし防止）。
メールを組み立てて送る：件名・本文・宛先・添付（Base64）を載せたJSONを、Graphの /me/sendMail にPOSTする。成功すると HTTP 202 が返る。

以降の節で、この3つの部品を順に見ていきます。

認証：デバイスコードフロー（`SignInWithDeviceCode`）

ここがGraph化の山場です。VBAのようにブラウザを内蔵しないアプリでも、安全にOAuthサインインを行うための仕組みがデバイスコードフローです。流れはこうなります。

アプリがテナントの devicecode エンドポイントに client_id と scope を投げ、ユーザーコードと確認用URLを受け取る。
そのURLをブラウザで開き、ユーザーがコードを入力して、いつものMicrosoftサインイン（多要素認証を含む）を済ませる。
その間、アプリは token エンドポイントを一定間隔でポーリングし続け、サインインが完了した瞬間にアクセストークンを受け取る。

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

ポーリング部分のポイントは、トークンエンドポイントが返す error の扱いです。authorization_pending（まだサインインが終わっていない）の間は待機を続け、slow_down が返ったらポーリング間隔を延ばし、expires_in を過ぎたら打ち切る——という制御を入れています。ここを雑に書くと、認証サーバーにレート制限をかけられたり、永久に待ち続けたりします。

💡 ポイントは、ブラウザ側でユーザーがサインインしている間、アプリは裏でトークンエンドポイントを叩き続ける、という非同期のやり取りになっていることです。

送信元の確認（`GetSignedInAddress`）

Graphの /me エンドポイントを叩いて、サインインしたアカウントのアドレス（mail、無ければ userPrincipalName）を取得します。これを指定の送信元と突き合わせることで、「本人がサインインして、本人として送る」以外を弾いています。委任（delegated）方式なので、そもそも他人になりすまして送ることはできませんが、送信元の指定ミスを早い段階で気づけるようにするためのガードです。

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

メール本体の組み立てと送信（`/me/sendMail`）

SendWithGraph の後半では、件名・本文・宛先・添付をJSONに組み立てて /me/sendMail へPOSTしています。VBAならではの注意点が2つあります。

添付ファイルはBase64文字列にして埋め込む：fileAttachment の contentBytes にファイルをBase64エンコードして載せます（後述の FileToBase64）。
本文はUTF-8で送る：日本語が文字化けしないよう、リクエストボディをUTF-8のバイト列にして送信します（後述の Utf8Bytes）。

送信が成功すると、Graphは本文のない HTTP 202 Accepted を返します。200 ではない点に注意です。

補助関数（HTTP・Base64・JSON など）

最後に、上記を支える裏方をまとめておきます。いずれも外部ライブラリを使わず、Windowsに標準で入っているコンポーネントだけで完結させています。

HttpPost / HttpGet：WinHttp.WinHttpRequest.5.1 によるHTTP通信。
FileToBase64：ADODB.Stream でファイルを読み、MSXML2.DOMDocument でBase64化。
Utf8Bytes：本文をUTF-8バイト列に変換（日本語対策）。
JsonEscape / JsonText / JsonNumber：VBAにはJSONパーサが無いため、最小限のエスケープと、正規表現による値の取り出しで対応。
UrlEncode / WaitSeconds：フォームエンコードと、ポーリングの待機。

' Sleep API の宣言（モジュール先頭に置く。WaitSeconds が使用）
#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 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

コピペ用・完成コード

ここまでの内容を、モジュール単位の完成形としてまとめます。VBE（Alt+F11）で標準モジュールを3つ追加し、それぞれに以下を貼り付けてください。

`ModuleSendWithOutlook`

従来のCOM版です。比較用・フォールバック用として残しておくと便利です。

Option Explicit


Public Sub SendWithOutlook( _
    ByVal fromAddress As String, _
    ByVal toAddress As String, _
    ByVal subjectText As String, _
    ByVal bodyText As String, _
    ByVal attachmentPath As String)

    Dim outlookApp As Object
    Dim mailItem As Object
    Dim sendAccount As Object
    Dim account As Object

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

    Set outlookApp = CreateObject("Outlook.Application")

    For Each account In outlookApp.Session.Accounts
        If StrComp(Trim$(account.SmtpAddress), _
                   Trim$(fromAddress), vbTextCompare) = 0 Then
            Set sendAccount = account
            Exit For
        End If
    Next

    If sendAccount Is Nothing Then
        Err.Raise vbObjectError + 2, , _
            "Outlookに送信元アカウントがありません：" & fromAddress
    End If

    Set mailItem = outlookApp.CreateItem(0)

    With mailItem
        Set .SendUsingAccount = sendAccount
        .To = toAddress
        .subject = subjectText
        .body = bodyText
        .attachments.Add attachmentPath
        .Send
    End With
End Sub

`ModuleSendWithGraph`

本命のGraph版です。貼り付けたら、先頭の TENANT_ID と CLIENT_ID を、自分のアプリ登録で発行された値に必ず書き換えてください。

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

`ModuleTest`

動作確認用の呼び出しです。宛先・送信元・添付パスを自分の環境に合わせて書き換えて使います。

Option Explicit

Public Sub TestSend()

    SendWithOutlook _
        "sender@example.com", _
        "recipient@example.com", _
        "テストメール", _
        "添付ファイル付きメールです。", _
        "C:\Test\sample.pdf"

End Sub

Public Sub TestGraphSend()

    SendWithGraph _
        "sender@example.com", _
        "recipient@example.com", _
        "テストメール", _
        "Graphから送信したメールです。", _
        "C:\Test\sample.pdf"

End Sub

動作確認手順

上の3モジュールを標準モジュールとして取り込む。
ModuleSendWithGraph の TENANT_ID / CLIENT_ID を、自分のアプリ登録の値に書き換える。
ModuleTest の TestGraphSend 内の送信元・宛先・件名・本文・添付ファイルのパスを、自分の環境に合わせて書き換える。
TestGraphSend を実行する。
初回はブラウザが開く（開かなければ、表示されたURLを手動で開く）。画面に出たユーザーコードを入力し、送信元アカウントでサインインする（多要素認証があればそれも済ませる）。
「指定した送信元」と「サインインしたアカウント」が一致していれば、メールが送信され、HTTP 202 が返って完了。

うまくいかないときの主な切り分け：

同意関連のエラー（consent_required など）で止まる：アプリに対する管理者の同意がまだ。管理者に「管理者の同意を与える」を実行してもらう（前述）。
「指定した送信元とログインしたアカウントが異なります」：TestGraphSend の送信元と、ブラウザでサインインしたアカウントが食い違っている。どちらかを合わせる。
202 以外が返る：レスポンス本文にGraphからのエラー内容が入っているので、まずそれを確認する。

完成コードをダウンロード

まとめ

新しいOutlookで Outlook.Application のCOM操作が使えなくなっても、メールの送信部分をMicrosoft Graph APIに置き換えれば、Excelの読み取りやファイル処理といった既存のローカル処理はそのまま活かせます。本記事の SendWithOutlook と SendWithGraph は同じ引数で呼び出せるので、置き換えの影響は送信の入口だけに収まります。

送信元アドレスの扱いは、2つの方式で少し異なります。クラシック版は、Outlookに登録済みのアカウントから、送信元アドレスに一致するものを選んで送ります。Graph版は、サインインした本人として送るため、送信元アドレスは「サインインしたアカウントと一致するか」の確認に使い、食い違えばエラーにします。

Graph版を動かすには、事前に Entra ID のアプリ登録を済ませ、実行時にデバイスコード認証でサインインする必要があります。掲載したコードは、添付ファイル付きのメールを1通送る最小構成です。

まずはテスト用のブックで一連の動作を確認し、問題なく送れることを見届けてから、既存のツールに組み込むことをおすすめします。