OUTLOOKVBAで新規送信時に自動的に日付を付ける

Outlook2016で送信する際に日付の入った本文や署名を送りたい時はないでしょうか?

署名として定型を入れておけば新規送信の際に6か月後の何時いつまでに破棄してくださいとか・・・の日付が自動で入ります。

ひと手間ですが、毎日沢山のメールを送るときには重宝すると思います。

それをVBAを使って実現します。

Outlookの準備

マクロをオンにします。

「ファイル」→ 「オプション」を選択します。


「トラストセンター」から「トラストセンターの設定」を選択します。


「マクロの設定」から「すべてのマクロを有効にする」を選択します。

これでVBAを受け付けるようになります。

※この設定は問答無用にマクロが実行されてしまうので安全なネットワークで実施しましょう。

署名側の設定

「ファイル」→「オプション」→「メール」から「署名」を選択します。


署名で署名本文に日付で

%%yyyy%%.%%mm%%.%%dd%%

今回は現在日付の6か月後

を入れると 送信時に 「2022.3.10」のように整形されて送信されます。

署名を作成して保存します。

VBAの記述

開発タブのVBAで以下のようなプログラムを「ThisOutlookSession」へ記述します。


実際のVBA(プログラム)です。

Dim WithEvents myInspectors As Inspectors
' 起動時に上記のオブジェクトに設定
Private Sub Application_Startup()
    Set myInspectors = Application.Inspectors
End Sub
' 新しいインスペクタが開かれた場合の処理
Private Sub myInspectors_NewInspector(ByVal Inspector As Inspector)
    Dim strBody As String
    Dim objItem
    ' 開かれたアイテムを取得
    Set objItem = Inspector.CurrentItem
    If objItem.MessageClass = "IPM.Note" Then ' アイテムがメール
        If objItem.Sent = False Then ' アイテムが送信前
            strBody = objItem.Body
      ' %%yyyy%% は 4 桁の年+6月
            strBody = Replace(strBody, "%%yyyy%%", Year(DateSerial(Year(Now), Month(Now) + 6, Day(Now)))) 
      ' %%mm%% は現在+6月
            strBody = Replace(strBody, "%%mm%%", Right("0" & Month(DateSerial(Year(Now), Month(Now) + 6, Day(Now))), 2)) 
           ' %%dd%% は日
       strBody = Replace(strBody, "%%dd%%", Right("0" & Day(Now), 2)) 
            If objItem.Body <> strBody Then objItem.Body = strBody
        End If
    End If
End Sub

実 行

作成後、いったんOutlookを再起動して「新規メール」を作成します。

署名欄には「 %%yyyy%%.%%mm%%.%%dd%% 」が記載されています。


送信先、件名、本文を入れて「送信」をします。


送信されたメールを見ると「 %%yyyy%%.%%mm%%.%%dd%% 」が変換されているのが分かります。

これで毎回、6か月後の日付を手入力でいれる必要がなくなります。

コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です