返信不要メールを弾くのが肝心。Outlook VBAでAI返信支援を作った話
- 伊賀上真左彦
- 3 日前
- 読了時間: 14分
本日はOutlook VBAからOpenAIのAPIを呼び出し、メールを自動で下書き、もしくは送信する方法に関してご説明します。
なぜ作ったのか
これは、私のOutlookセミナーで、複数の参加者からのご要望です。管理職、経営者など多くの方から、メールの多さに困っている、AIを使えば自動で返信なり下書きをできないか、とお話をいただきました。私も最近新しい本が書き上がり、時間ができたので作ってみました。
日本人はメールに毎日130分を消費しているとされます。それを半分程度に短縮できる可能性があります。また若い方など敬語やメールの書き方に不慣れな方も役に立つでしょう。
本記事の対象者
・ITエンジニアを想定しています
これはリスクがありますし、APIなど、難し目の機能を使うためです。誰でも簡単、ではないことをご理解ください。そのために書籍ではなく、Web記事で公開しています。
ITエンジニアでない方でも、対応できるとは思いますが、結果トラブルが起こっても当方は責任をとれません。Outlook VBAに関しては、以前私が執筆したこちらの本もあります。初心者向けにしていますので、まずはこちらを読んだ後にチャレンジいただくと良いと思います。
Copilotの自動下書きとどう違うか？
MicrosoftのCopilotでもメールの自動下書きは可能です。しかし、今回のプログラムは以下のメリットがあります。
・運用コストが安い→Copilotが月に5千円弱に対して、APIの利用コストだけで、メールの量に夜が月に数円～数百円程度で済む
・Copilotの場合、メールの下書きに数十秒程度の待ち時間が発生→今回のプログラムにはまだその機能をつけていませんが、人間がいない状態で自動下書きが可能で、待ち時間が発生しない。
Copilotと異なり、メール下書きの機能しかありませんが、だいぶお安くできます。
なぜVBAか？
今回はOpenAIのAPIを呼び出して自動で下書きします。アウトルックVBAはクラシックOutlookでしか動かない、という課題があります。クラシックOutlookは2029年にサポートが切れます。
それでもこれを使ったのは以下の理由です。
・Outlookにメール下書きボタンを追加できる（利便性）
・2029年は今の世の中の変化速度からすると無限に近い
・Outlookの保守期限は延長され続けており、今後も延長される可能性がある
・仮に2029年に保守が切れる場合、Microsoftが代替手段をそれまでに公開する
つまり、今回の仕組みが永遠に使えるものではないことをご理解ください。
個人情報保護法に注意！
個人情報保護法では、ビジネスで知りえた他人の個人情報を他社に提供した場合、本人の同意が必要なケースがあります。いわゆる「第三者提供」です。
相手の合意なく別の会社に個人情報を提供すると、個人情報保護法に反することになります。これはAIであっても同じです。AIに他人の個人情報をア知りえたドするのは、おそらく多くの人が普通に行っている事です。これを企業が、ビジネス上で知った情報に対して行うと、違法となるケースがあるのです。
これに関しては、これから、AI時代に適する形での法改正が行われる見込みですが、2026年3月の現時点ではまだ違法、ということを忘れないでください。
よって本記事は、だれでも使ってよい、というものではなく、会社内で確認をとり、ある程度のスキルがある人が自分の判断で、限られた状況下で使うもの、と認識してください。
このマクロでできること
今回のプログラムでは、以下の処理を行います。
①返信したいメールをOutlook（クラシック）で選ぶ
②マクロを起動する
③10秒程度待つと、最適な返信メールが下書きされる
また本マクロは、メールの判断機能も搭載しています。以下のようなメールは下書きを行いません。
・広告
・詐欺
・相手が返信を求めていない
・担当が自分以外
これまでメールを返信すべきかの判断は、人間が行うしかありませんでした。それをAIを用いて自動化します。AIに任せきりというより、人間とAIでのダブルチェックだと考えてください。
日本では、返信が必要なメールを見逃した場合、最悪は始末書ものの大事故となります。それを避けるために、今までは人間がダブルチェックすることで行ったでしょうが、AIと人間のダブルチェックに変更します。
処理の流れ
以下の手順で行います。非エンジニアの方にとっては難しいと思いますが、可能なら私の本を読む。そうでない場合、AIのサポートを受ければ十分可能とは考えます。いずれにせよ、効果が大きい反面、リスクも大きいプログラムですので十分考えて使用してください。
①OpenAIのAPIキーを取得する
まず、OpenAIのアカウントを持っている必要があります。ない方は取得しましょう。APIキーの発行方法は、GPTに聞けばよいのでここでは割愛します。
忘れないでいただきたいのが、APIは重量課金で、使った分だけお金が必要、という点です。月額課金していない方でも使えますし、月額課金している方は別に支払う必要があります。
私はまず、10ドル（約1500円）を課金しましたが、まだ0.02ドルしか消費していません。ほぼ0です。このプログラムでは文字情報しか扱いませんし、軽量の安いAIでも問題なく稼働します。そのため、運用コストはほぼゼロ円と考えてよいと思います。
②クラシックOutlookのVBEを開き、標準モジュールにプログラムを貼り付ける
ここに関しては長くなり、それだけで1つの記事が書けるため、今回は省略します。AIに聞くか、私の本をお読みください。
③コードを2か所、修正する
コード内で赤く塗った4か所を、皆さんの条件に合うように修正ください。
・APIキー
・皆さんの名前（3か所にあります）
また、AI用のプロンプトを皆さん用に修正することもおススメします。この部分です。
④Outlookにマクロの実行ボタンを追加する
Outlookの画面一番上、「クイックアクセスツールバーのユーザー設定（下矢印）」から、「その他コマンド」を選択します。
図の順番に操作して、先ほどVBEに登録したマクロをボタンとして登録してください。
こんな感じで、簡単に機能追加を行えるのがクラシックOutlookのメリットです。新しいOutlookにはない機能で、ぜひ追加をお願いしたいです。
あとは、メールを1件選択した状態で先ほど追加したボタンをクリックしましょう。10秒程度末と、メールがポップアップされます。
プロンプト設計で工夫した点
AI用のプロンプト、今回は1回の処理で、①返信すべきメールか判断する、②返信すべきメールと判断した場合、返信文を考える、という2つの処理を入れています。通常は2回に分けた方がAIの動作が安定し、ミスが減りますが、あえて1つにしました。これは以下の理由があります。
・AIの性能が上がっており、2回に分けないでも安定して処理を行えるようになった
・AIの利用コストと、処理待ちの時間を半分にできる
AIはアップロードした文字数と、AIからダウンロードされる文字数で値段が決まります。これを1回のアップロードとダウンロードで済ますことで、コストと時間を半分にできます。
改善するとしたらどこか
今回は実験用に、人間がボタンを押したときに下書きされるようにしてます。実用性を考えた場合、受信したメールに対して無人状態で自動処理するのも手です。Outlook VBAはそれが可能です。
また、「広告」など返信不要とAIが判断した場合、メールに分類項目で「広告」と自動で入れることもできます。これが本マクロの完成形ですね。効果が大きい反面リスクも高いマクロで、今回は実験的に、機能を制限した形でご紹介しています。
コードの中身
以下をコピーして、赤く塗った個所を4か所、修正して使ってください。
Option Explicit
Private Const OPENAI_URL As String = "https://api.openai.com/v1/chat/completions"
Private Const OPENAI_MODEL As String = "gpt-5-mini"
Private Const OPENAI_API_KEY As String = "sk-proj-XXX-XXX" 'ご自分のOpenAI・APIキーを
Public Sub CreateAiReplyDraft()
On Error GoTo ErrHandler
Dim explorer As Outlook.explorer
Dim sel As Outlook.Selection
Dim srcMail As Outlook.MailItem
Dim replyMail As Outlook.MailItem
Dim titleText As String
Dim bodyText As String
Dim senderName As String
Dim aiReply As String
Set explorer = Application.ActiveExplorer
If explorer Is Nothing Then
MsgBox "Outlookのメール一覧を開いてください。", vbExclamation
Exit Sub
End If
Set sel = explorer.Selection
If sel Is Nothing Or sel.Count = 0 Then
MsgBox "メールを1件選択してください。", vbExclamation
Exit Sub
End If
If Not TypeOf sel.Item(1) Is Outlook.MailItem Then
MsgBox "選択中のアイテムはメールではありません。", vbExclamation
Exit Sub
End If
Set srcMail = sel.Item(1)
Debug.Print "--- Selected Mail ---"
Debug.Print "Subject: " & Nz(srcMail.Subject)
titleText = CleanForPrompt(srcMail.Subject)
bodyText = CleanForPrompt(srcMail.Body)
bodyText = RemoveUrlStrings(bodyText)
bodyText = LimitText(bodyText, 3000)
senderName = ExtractSenderName(srcMail)
Debug.Print "<Title>"
Debug.Print titleText
Debug.Print "<Body>"
Debug.Print bodyText
aiReply = CallOpenAI(titleText, bodyText, senderName)
Debug.Print "<Reply>"
Debug.Print aiReply
Select Case Trim$(aiReply)
Case ""
MsgBox "返信不要と判定されたため、下書きは作成しませんでした。", vbInformation
Exit Sub
Case "広告"
MsgBox "広告メールと判定されたため、下書きは作成しませんでした。", vbInformation
Exit Sub
Case "詐欺"
MsgBox "詐欺メールと判定されたため、下書きは作成しませんでした。", vbExclamation
Exit Sub
Case "返信不要"
MsgBox "返信不要と判定されたため、下書きは作成しませんでした。", vbInformation
Exit Sub
Case "自分以外"
MsgBox "自分宛てではないと判定されたため、下書きは作成しませんでした。", vbInformation
Exit Sub
Case "情報不足"
MsgBox "情報不足と判定されたため、下書きは作成しませんでした。", vbInformation
Exit Sub
End Select
Set replyMail = srcMail.Reply
replyMail.BodyFormat = olFormatPlain
replyMail.Body = aiReply & vbCrLf & vbCrLf & replyMail.Body
replyMail.Display
Exit Sub
ErrHandler:
Debug.Print "CreateAiReplyDraft error: " & Err.Description
MsgBox "エラー: " & Err.Description, vbCritical
End Sub
Private Function CallOpenAI(ByVal mailTitle As String, ByVal mailBody As String, ByVal senderName As String) As String
Dim payload As String
Dim http As Object
If Trim$(OPENAI_API_KEY) = "" Then
MsgBox "OPENAI_API_KEY が未設定です。", vbExclamation
CallOpenAI = ""
Exit Function
End If
payload = BuildOpenAIPayload(mailTitle, mailBody, senderName)
Debug.Print "--- HTTP Request ---"
Debug.Print "URL: " & OPENAI_URL
Debug.Print "API key prefix: " & Left$(OPENAI_API_KEY, 12)
Debug.Print "Payload length: " & Len(payload)
Debug.Print Left$(payload, 3000)
Set http = CreateObject("MSXML2.XMLHTTP.6.0")
On Error GoTo ErrHandler
http.Open "POST", OPENAI_URL, False
http.setRequestHeader "Content-Type", "application/json; charset=utf-8"
http.setRequestHeader "Authorization", "Bearer " & OPENAI_API_KEY
http.Send ConvertToUTF8(payload)
Debug.Print "--- HTTP Response ---"
Debug.Print "Status: " & http.Status
Debug.Print http.responseText
If http.Status >= 200 And http.Status < 300 Then
CallOpenAI = ExtractAssistantContent(http.responseText)
Else
MsgBox "OpenAI API エラー: " & http.Status, vbExclamation
CallOpenAI = ""
End If
Exit Function
ErrHandler:
Debug.Print "CallOpenAI error: " & Err.Description
CallOpenAI = ""
End Function
Private Function BuildOpenAIPayload(ByVal mailTitle As String, ByVal mailBody As String, ByVal senderName As String) As String
Dim systemPrompt As String
Dim userPrompt As String
systemPrompt = BuildSystemPrompt()
userPrompt = BuildUserPrompt(mailTitle, mailBody, senderName)
BuildOpenAIPayload = _
"{" & _
"""model"":""" & OPENAI_MODEL & """," & _
"""messages"":[" & _
"{""role"":""system"",""content"":""" & JsonEscape(systemPrompt) & """}," & _
"{""role"":""user"",""content"":""" & JsonEscape(userPrompt) & """}" & _
"]" & _
"}"
End Function
Private Function BuildSystemPrompt() As String
Dim p As String
p = ""
p = p & "あなたは日本語の業務メール返信文を作成するアシスタントです。" & vbLf
p = p & "まず、返信すべきメールかどうかを判定してください。次の場合は返信文を作成せず、指定された語だけを返してください。" & vbLf
p = p & "1. 広告メール、販促メール、メルマガ、案内配信の場合は「広告」" & vbLf
p = p & "2. 詐欺メール、不審メール、なりすまし、危険な誘導を含むメールの場合は「詐欺」" & vbLf
p = p & "3. 相手が返信を求めていないメール。単なる通知、共有、報告のみのメールの場合は「返信不要」" & vbLf
p = p & "4. メールの●●（自分の名前）以外で、自分が主担当ではないと読み取れる場合は「自分以外」" & vbLf
p = p & "5. 返信を作るのに必要な情報が不足しており、安全に返信できないメールの場合は「情報不足」" & vbLf & vbLf
p = p & "返信文を作成する場合の必須ルール:" & vbLf
p = p & "1. 出力は返信メールの本文だけにする。説明、見出し、補足、JSONは出力しない。" & vbLf
p = p & "2. 文体は丁寧で自然なビジネス日本語にする。" & vbLf
p = p & "3. 事実関係は入力された件名と本文に含まれる内容だけを使う。推測で予定、金額、期限、約束を書かない。" & vbLf
p = p & "4. 改行は必須とする。読みやすさを優先し、1行は全角50文字以内を目安に必ず改行する。" & vbLf
p = p & "5. 文頭に相手の名前を書く。" & vbLf
p = p & "6. 相手の名前の次の行は空行にする。" & vbLf
p = p & "7. 相手からの要求・依頼・確認事項がある場合は、それらを箇条書きで整理して記載する。" & vbLf
p = p & "8. 各要求の行の直後には、必ず空行を1行入れる。" & vbLf
p = p & "9. その空行の次の行に、その要求に対する了承文を1行で記載する。" & vbLf
p = p & "10. 要求が複数ある場合は、すべての要求について「要求1行 → 空行1行 → 了承1行」の組を省略せず書く。" & vbLf
p = p & "11. 要求が明確でない場合は、無理に箇条書きを作らず、通常の短い返信文にする。" & vbLf
p = p & "12. 文末の一番下には必ず伊賀上と書く。" & vbLf
p = p & "13. 署名は最終行の●●（自分の名前）だけにする。" & vbLf
p = p & "14. 相手の名前が本文や件名から特定できない場合は、本文中の自然な呼称を優先し、分からない場合は宛名を推測せずに書き始める。" & vbLf & vbLf
p = p & "重要:" & vbLf
p = p & "上記5つのいずれかに該当する場合は、返信文を書かず、指定された語だけを返すこと。" & vbLf
p = p & "それ以外の場合のみ、返信メール本文を作成すること。"
p = p & "出力形式の例:" & vbLf
p = p & "田中様" & vbLf
p = p & "" & vbLf
p = p & "ありがとうございます。以下の点、承知いたしました。" & vbLf
p = p & "・新規に3個発注したい" & vbLf
p = p & "・色を黒にしてほしい" & vbLf
p = p & "" & vbLf
p = p & "承知いたしました。直ちに手配させていただきます。" & vbLf
p = p & "" & vbLf
p = p & "今後ともよろしくお願いいたします。" & vbLf
p = p & "" & vbLf
p = p & "私の名前（ご自分の名前を入れてください）" & vbLf & vbLf
p = p & "上記の形式・見た目にできるだけ寄せて出力すること。" & vbLf
BuildSystemPrompt = p
End Function
Private Function BuildUserPrompt(ByVal mailTitle As String, ByVal mailBody As String, ByVal senderName As String) As String
Dim p As String
p = ""
p = p & "相手名:" & vbLf & senderName & vbLf & vbLf
p = p & "件名:" & vbLf & mailTitle & vbLf & vbLf
p = p & "本文:" & vbLf & mailBody
BuildUserPrompt = p
End Function
Private Function ExtractAssistantContent(ByVal jsonText As String) As String
Dim re As Object
Dim q As String
Dim rawText As String
Set re = CreateObject("VBScript.RegExp")
q = Chr$(34)
re.Global = False
re.Multiline = True
re.IgnoreCase = False
re.pattern = q & "role" & q & ":\s*" & q & "assistant" & q & "[\s\S]*?" & q & "content" & q & ":\s*" & q & "((?:\\.|[^" & q & "])*)" & q
If re.Test(jsonText) Then
rawText = re.Execute(jsonText)(0).SubMatches(0)
ExtractAssistantContent = JsonUnescape(rawText)
Else
ExtractAssistantContent = ""
End If
End Function
Private Function JsonEscape(ByVal s As String) As String
Dim i As Long
Dim ch As String
Dim code As Long
Dim result As String
result = ""
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
code = AscW(ch)
Select Case code
Case 34
result = result & "\" & Chr$(34)
Case 92
result = result & "\\"
Case 8
result = result & "\b"
Case 9
result = result & "\t"
Case 10
result = result & "\n"
Case 12
result = result & "\f"
Case 13
result = result & "\r"
Case 0 To 31
result = result & "\u" & Right$("0000" & Hex$(code), 4)
Case Else
result = result & ch
End Select
Next i
JsonEscape = result
End Function
Private Function JsonUnescape(ByVal s As String) As String
Dim i As Long
Dim ch As String
Dim result As String
Dim esc As Boolean
Dim hex4 As String
result = ""
esc = False
i = 1
Do While i <= Len(s)
ch = Mid$(s, i, 1)
If esc Then
Select Case ch
Case """"
result = result & """"
Case "\"
result = result & "\"
Case "/"
result = result & "/"
Case "b"
Case "f"
Case "n"
result = result & vbCrLf
Case "r"
Case "t"
result = result & vbTab
Case "u"
If i + 4 <= Len(s) Then
hex4 = Mid$(s, i + 1, 4)
If hex4 Like "[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]" Then
result = result & ChrW$(CLng("&H" & hex4))
i = i + 4
End If
End If
Case Else
result = result & ch
End Select
esc = False
Else
If ch = "\" Then
esc = True
Else
result = result & ch
End If
End If
i = i + 1
Loop
JsonUnescape = Trim$(result)
End Function
Public Function CleanForPrompt(ByVal s As String) As String
Dim t As String
t = s
t = HtmlDecodeBasic(t)
t = CleanupMailTo(t)
t = Replace(t, "??", "")
t = NormalizeNewlines(t)
t = CollapseBlankLines(t)
t = Replace(t, "<", "（")
t = Replace(t, ">", "）")
t = Replace(t, "--", "")
CleanForPrompt = Trim$(t)
End Function
Private Function HtmlDecodeBasic(ByVal s As String) As String
Dim t As String
t = s
t = Replace(t, "<", "<")
t = Replace(t, ">", ">")
t = Replace(t, "&", "&")
HtmlDecodeBasic = t
End Function
Private Function CleanupMailTo(ByVal s As String) As String
Dim t As String
t = s
t = RegexReplace(t, "<\s*mailto:([^>\s]+)\s*>", "$1")
t = RegexReplace(t, "([A-Za-z0-9._%+\-]+@[A-Za-z0-9.\-]+\.[A-Za-z]{2,})\s*<\s*mailto:\1\s*>", "$1")
t = RegexReplace(t, "([A-Za-z0-9._%+\-]+@[A-Za-z0-9.\-]+\.[A-Za-z]{2,})\s*<\s*\1\s*>", "$1")
t = RegexReplace(t, "<\s*([A-Za-z0-9._%+\-]+@[A-Za-z0-9.\-]+\.[A-Za-z]{2,})\s*>", "$1")
t = RegexReplace(t, "\s{2,}", " ")
CleanupMailTo = t
End Function
Private Function NormalizeNewlines(ByVal s As String) As String
Dim t As String
t = s
t = Replace(t, vbCrLf, vbLf)
t = Replace(t, vbCr, vbLf)
t = Replace(t, vbLf, vbCrLf)
NormalizeNewlines = t
End Function
Private Function CollapseBlankLines(ByVal s As String) As String
CollapseBlankLines = RegexReplace(s, "(\r\n){3,}", vbCrLf & vbCrLf)
End Function
Private Function RegexReplace(ByVal text As String, ByVal pattern As String, ByVal replacement As String) As String
Dim re As Object
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.Multiline = True
re.IgnoreCase = True
re.pattern = pattern
RegexReplace = re.Replace(text, replacement)
End Function
Private Function RemoveUrlStrings(ByVal s As String) As String
Dim re As Object
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.IgnoreCase = True
re.pattern = "htt[^\s ]*"
RemoveUrlStrings = re.Replace(s, "")
End Function
Private Function ConvertToUTF8(ByVal str As String) As Variant
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
stream.Type = 2
stream.Charset = "UTF-8"
stream.WriteText str
stream.Position = 0
stream.Type = 1
stream.Position = 3
ConvertToUTF8 = stream.Read
stream.Close
End Function
Private Function LimitText(ByVal s As String, ByVal maxLen As Long) As String
If Len(s) <= maxLen Then
LimitText = s
Else
LimitText = Left$(s, maxLen) & vbCrLf & "(本文は途中で省略)"
End If
End Function
Private Function ExtractSenderName(ByVal mail As Outlook.MailItem) As String
Dim n As String
n = Trim$(Nz(mail.senderName))
If Len(n) = 0 Then
n = Trim$(Nz(mail.SenderEmailAddress))
End If
ExtractSenderName = n
End Function
Private Function Nz(ByVal v As Variant) As String
If IsNull(v) Then
Nz = ""
Else
Nz = CStr(v)
End If
End Function
コメント