OutlookでVBAを使い、メールの自動転送の転送時間を指定したい。

Question

実現したいこと

代理店から自分が受信したメールを、20人の担当者に自動転送したいと思っています。
なお、その代理店から受信するメールは、メール本文に担当者の名前を含むので、”メール本文に特定の文字を含む”という条件設定で転送することが可能です。

しかし、代理店からメール受信する時間がばらばらで、土日を含む24時間受信する可能性があります。
すると、Outlookを立ち上げたタイミングで、土日を含む24時間20人の担当者にメールが自動転送されてしまうため、労務管理上問題が発生してしまいます。そのため、自動転送する日時を指定したいと思っています。(できれば平日の9:00-17:45の間)

調べたところ、OutlookのVBA機能を使えば対応できるようなのですが、設定フロー、特にコードの書き方がわからずご教授頂ける方を探しております。

ご助言を頂けないでしょうか。

何卒よろしくお願い申し上げます。

発生している問題・分からないこと

OutlookのVBA機能の使い方、特にコードの書き方が分からない。

該当のソースコード

特になし

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

OutlookのVBA機能を使って、自動転送するコードは見つけたが、加えて時間指定する情報を見つけることができなかった。

補足

特になし

Comments

[otn]

今までOutlookのVBAを読み書きしたことが無いということであれば道は果てしないと思いますので、
「転送専用のPCを用意して、一定時間の間だけ、OUTLOOKを起動する」（タスクスケジューラをつかうなどして）
が簡単かと思います。メールがExchangeメールじゃなくてPOP/IMAPでの受信であればOUTLOOK以外でも良いし。

[hirasawonder]

コメントを頂きありがとうございます。頂いたご提案は会社側の問題で難しそうでした。自分はpythonのコードを読み書きすることはでき、Kaggleに参加できるレベルですがVBAは触ったことがないという状態でした。もし可能でしたらコードをご教授頂くことは可能でしょうか。

Answer 1

代理店から自分が受信したメールを、20人の担当者に自動転送したい

その代理店から受信するメールは、メール本文に担当者の名前を含む

自動転送する日時を指定したいと思っています。(できれば平日の9:00-17:45の間)

• NewMailEx イベントの発生時に、受信した個々のメールアイテム（ Outlook.MailItem オブジェクト）を参照し、メール転送の是非を判定する。

• その Outlook.MailItem オブジェクトが転送の条件を満たしていた場合は Forward メソッドを実行し、コピーされたメールアイテム（ Outlook.MailItem オブジェクト）を参照する。

• 転送する Outlook.MailItem オブジェクトの To プロパティ（または CC プロパティや BCC プロパティ）に転送先となるメールアドレスを、DeferredDeliveryTime プロパティに任意の転送日時を設定しておき、Send メソッドを実行する。

'ThisOutlookSession モジュール
Option Explicit

'受信トレイに新しいアイテムを受信する時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

    Dim varEntryIDs As Variant
    Dim objItem As Object
    Dim i As Long
    Dim miForward As Outlook.MailItem
    
    '受信したアイテムのエントリ ID を 1 次元配列に変換
    varEntryIDs = Split(EntryIDCollection, ",")
    
    '全てのエントリIDを1つずつ走査
    For i = LBound(varEntryIDs) To UBound(varEntryIDs)
        '受信したアイテムを参照
        Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
        'そのメールを転送すべきと判断される場合
        If ShouldForward(objItem) = True Then
            '転送用のコピーを作成
            Set miForward = objItem.Forward
            'このアイテムが自動転送されたメールであることを示すようにする
            miForward.AutoForwarded = True
            '配信予約の設定
            If ScheduleForwardingMail(miForward) = False Then
                '失敗した場合は作成したメールを削除する
                miForward.Delete
                Set miForward = Nothing
                Set objItem = Nothing
                'このプロシージャを抜ける
                Exit Sub
            End If
            Set miForward = Nothing
        End If
        Set objItem = Nothing
    Next

End Sub

'メール転送の条件を満たしているか否かを判定し、その結果を Boolean 型の値で返す関数
Private Function ShouldForward(Target As Object) As Boolean
    
    ShouldForward = False
    
    If Target Is Nothing Then
        Exit Function
    End If
    
    '以下の条件のいずれかに該当する場合は転送しない
     
    'アイテムの種類がメールアイテムではない
    If Not TypeOf Target Is Outlook.MailItem Then
        Exit Function
    End If
    
    With Target
        
        '送信者アドレスが不一致
        If .SenderEmailAddress <> "代理店の送信者アドレス" Then
            Exit Function
        End If
        
        '本文にキーワードが含まれていない
        If Not .Body Like "*担当者の名前*" Then
            Exit Function
        End If
    
    End With
    
    '以上の全ての判定を抜けたら True を返す
    ShouldForward = True

End Function

'メールの配信予約を行う関数
Private Function ScheduleForwardingMail(Target As Outlook.MailItem) As Boolean
On Error GoTo Err_ScheduleForwardingMail

    ScheduleForwardingMail = False

    If Target Is Nothing Then
        Exit Function
    End If

    Dim dtDelivery As Date
    
    With Target
        
        '宛先の設定
        .To = "転送先メールアドレス"
        
        '（念のため）現在のシステム日時の 10 分後を既定の配信日時とする
        dtDelivery = DateAdd("n", 10, Now())
'        'テスト用の日時
'        dtDelivery = #2/9/2024 5:45:00 PM#
        '更に配信日時の補正を行う
        dtDelivery = CorrectDeliveryTime(dtDelivery)
        'メールアイテムの配信日時を設定
        .DeferredDeliveryTime = dtDelivery
        Debug.Print "配信日時:" & Format(.DeferredDeliveryTime, "yyyy/mm/dd hh:nn:ss")
        
        'メールを送信（配信日時以降に送受信が実行されるまでは送信トレイに留め置かれる）
        .Send
    
    End With
    
    '送信に成功したら True を返す
    ScheduleForwardingMail = True
    
Exit_ScheduleForwardingMail:
    
    Exit Function

'エラー時処理
Err_ScheduleForwardingMail:
        
    Dim strErrTitle As String
    Dim strErrMsg As String
    
    strErrTitle = "実行時エラー (ThisOutlookSession.ScheduleForwardingMail)"
    strErrMsg = "自動転送メールの作成処理中に以下の実行時エラーが発生しました。" & vbCrLf & _
                Err.Number & ": " & Err.Description & vbCrLf & _
                "このメッセージボックスが閉じられるまで、全てのコードは中断されます。"
    
    Debug.Print strErrMsg
    
    MsgBox strErrMsg, vbCritical, strErrTitle
        
End Function

'配信日時を補正した結果を返す
Private Function CorrectDeliveryTime(InitialDateTime As Date) As Date

    Dim dtDeliveryDate As Date
    Dim dtDeliveryTime As Date

    '配信日付の取得
    dtDeliveryDate = DateValue(InitialDateTime)
    '配信日時の取得
    dtDeliveryTime = TimeValue(InitialDateTime)
    
    '配信時刻により条件分岐
    Select Case dtDeliveryTime
        '9時00分よりも早い時刻の場合
        Case Is < #9:00:00 AM#
            '当日の9時00分に変更する
            dtDeliveryDate = #9:00:00 AM#
        '17時45分以降の時刻の場合
        Case Is >= #5:45:00 PM#
            '翌日の9時00分に変更する
            dtDeliveryDate = DateAdd("d", 1, dtDeliveryDate)
            dtDeliveryTime = #9:00:00 AM#
        Case Else
            '何もしない
    End Select
        
    Dim lngWeekday As Long
        
    '配信日付の曜日（月曜始まり）を取得
    lngWeekday = Weekday(dtDeliveryDate, vbMonday)
       
    '土日のいずれかである場合
    If lngWeekday > 5 Then
        '直近の月曜日の9時00分に変更する
        dtDeliveryDate = DateAdd("d", 8 - lngWeekday, dtDeliveryDate)
        dtDeliveryTime = #9:00:00 AM#
    End If
    
    '補正した配信日時を戻り値として返す
    CorrectDeliveryTime = dtDeliveryDate + dtDeliveryTime

End Function

Comments

[otn]

> DeferredDeliveryTime プロパティ
こんなものがあるんですね。送る時に送る動作をしないといけないと思ってました。

[sk.exe]

「送る時に送る動作をしないといけない」のはおっしゃる通りです。
あくまで[すべて送受信]アクションや[すべて送信]アクションが実行されても、設定された配信日時に達していなければ送信されないようにしているだけですので。

実際に送信されるタイミングは配信日時を過ぎてから、ユーザーが上記の送受信アクションを実行した時か、もしくは Outlook によって自動送受信が実行された時のいずれかです。
後者の場合は Outlook 側で設定された自動送受信間隔に依存するため、その間隔が極端に長すぎれば、メールに設定された配信日時をかなり過ぎてから送信されてもおかしくはありません。

[hirasawonder]

具体的に教えて頂きありがとうございます。ぜひ参考にさせてください。

[sk.exe]

例示した手法において留意すべき点としては、前述の通り「メールが配信されるタイミングを一定の日時まで遅らせている」だけであり、厳密な意味において「平日9:00～17:45以外の曜日/時間帯にメールを送信しない」ようにしているわけではない、ということです。

例えば、配信日時が2024年2月9日（金）17時40分に設定されたメールが送信トレイに存在している状態で、同日の17時35分に Outlook を一旦終了させ、同日17時50分に再び Outlook を起動させた場合、送信トレイ上のメールに設定された配信日時を既に過ぎているため、Outlook の起動に伴って実行される送受信アクションによってそのメールは送信されることになります。

常時 PC や Outlook を起動しっぱなしにしているならともかく、そのような運用は現実的に難しいかと思います。上記のような事態を回避して「営業時間外には絶対にメールが自動送信されないようにする」には、更に工夫を重ねる必要があるでしょう。

Answer 2

OutlookのVBAを使用して自動転送するプログラムを作成する方法の１つを説明します。
検証していませんので、参考程度にとどめておいてください。

1.Outlookを開き、「開発」タブを選択します。開発タブが表示されていない場合は、Outlookのオプションから有効にする必要があります。
2.「Visual Basic」アイコンをクリックして、Visual Basic for Applications (VBA) エディタを開きます。
3.VBAエディタで、「Insert」メニューから「Module」を選択し、新しいモジュールを挿入します。
4.新しいモジュールに以下のコードを貼り付けます。

Sub ForwardEmails()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olInbox As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim olMail As Object
    Dim olForward As Outlook.MailItem
    Dim i As Integer
    
    ' Outlookアプリケーションを取得
    Set olApp = New Outlook.Application
    ' 名前空間を取得
    Set olNS = olApp.GetNamespace("MAPI")
    ' 受信トレイフォルダを取得
    Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
    ' 受信トレイのアイテムを取得
    Set olItems = olInbox.Items
    
    ' 送信先のメールアドレスを指定
    Dim recipientEmail As String
    recipientEmail = "[e-mail]"
    
    ' 送信先の担当者の名前とメールアドレスのマッピングを作成
    Dim recipientsMapping As Object
    Set recipientsMapping = CreateObject("Scripting.Dictionary")
    recipientsMapping.Add "担当者1の名前", "[e-mail]"
    recipientsMapping.Add "担当者2の名前", "[e-mail]"
    ' 他の担当者も同様に追加します
    
    ' ループしてメールを転送
    For Each olMail In olItems
        ' 特定の条件を満たすメールを転送
        If InStr(1, olMail.Body, "特定の文字列") > 0 Then
            ' 担当者の名前を取得
            Dim recipientName As String
            recipientName = "担当者名"
            ' 名前に対応するメールアドレスを取得
            Dim recipientAddress As String
            recipientAddress = recipientsMapping(recipientName)
            
            ' メールを転送
            Set olForward = olMail.Forward
            olForward.Recipients.Add recipientAddress
            olForward.Send
            ' オリジナルのメールを削除（必要に応じてコメントアウト解除）
            ' olMail.Delete
        End If
    Next olMail
    
    ' リソースを解放
    Set olApp = Nothing
    Set olNS = Nothing
    Set olInbox = Nothing
    Set olItems = Nothing
    Set olMail = Nothing
    Set olForward = Nothing
End Sub

このコードは、受信トレイ内のメールをループして特定の条件（メール本文に特定の文字列が含まれるかどうか）を満たす場合に転送します。転送先は、指定した担当者の名前に基づいて動的に決定されます。コード内のコメントを参考に、必要に応じて変更を加えてください（例：オリジナルのメールを削除するかどうかなど）。

コードを書き換えたら、保存して実行してみてください。自動転送が正しく機能するはずです。

Answer 3

コードをご教授頂くことは可能でしょうか。

ExcelVBAとは異なり、OutlookVBAをリファレンスを引き引きでなく、すらすら書ける人は少ないと思います。つまり、面倒くさい。また、個人的には勤務先ではやむなくOUTLOOKを使ってるのでスクリプトを書いたこともありますが、プライベートではOUTLOOKを使う必要が無いのでテスト環境が無いです。勤務先で書くわけに行かないし。

私が勤務先で必要にせまられて書くなら、VBScriptで書いてタスクスケジューラーから希望時間帯に数分ごとに起動ですかね。
VBScriptでもExcelVBAでもPythonでもRubyでも、Outlook操作は可能です。書き方はOutlookVBAとほぼ同じ。
ググルとPythonだとpywin32とかwin32comとかを使うようです。

プログラミング経験が十分あるなら、（OutlookVBA以外を使う場合はOUTLOOKオブジェクトの作り方だけググル）
https://learn.microsoft.com/ja-jp/office/vba/api/overview/outlook
を見ながらできるかと思います。ちょっと、クラス構成になれる必要がありますが。

・前回処理時刻以降に受信したメール（select構文で抽出可能なはず）を抽出
・それぞれについて、条件にマッチするかチェック
・マッチしたメールを転送
でしょうか。
送信時刻だと前後する可能性がある（送信日時から数時間経って受信するとか）ので、受信時刻で抽出ですね。
境目で取りこぼしや重複が発生しないような工夫も必要かもしれません。
これを、月～金の9:00-17:45に5分毎とかでタスクスケジューラから起動する。祝日どうするかによっては、プログラム冒頭で祝日チェックしてスキップするとかも。月9:00には週末分処理するの5分で終わらない可能性があるなら、そのあたりも工夫要ですね。他の曜日の9:00も夜間分の処理があるので同じく。

Comments

[otn]

ちょうどOutlook使ってる時に、「あ、いま、裏でプログラム動いてOutlookにアクセスしてるな」という感触があったりするので、実行頻度は必要最小限が良いと思います。

[hirasawonder]

再度返信頂きありがとうございます。参考になりました。さっそく試してみます。