添付ファイルの有無によって本文を変更してメールを作成するVBS

f:id:teali_s:20220111171210p:plain

毎日ほぼ同じ内容を、同じ相手に、同じ場所に保存されていて毎日更新されるファイルを添付し、件名に翌日の日付を入れて送信…
という作業が地味に手間がかかるという話を受け、「メールを作成するVBS」を作成。

添付ファイルの保存場所は固定だが、毎日更新されて名前に日付が入る（完全に固定の名前ではない）
件名に日付（翌日または月曜の日付）を入れる
本文は添付ファイルの有無によって一部変更され、添付ありの場合は『蛍光ペン』で印をつける
毎日必ず送るメールのため、メインの担当者が休んだ日は他の人がメールを送信する（署名が変化）

Option Explicit

Dim olApp: Set olApp = CreateObject("Outlook.Application")

Rem メールを作成---------------------------------
Dim olMail: Set olMail = olApp.CreateItem(0)
olMail.BodyFormat = 2 '文字に装飾を施すのでHTML形式で作成

Rem メール送信先---------------------------------
Rem ※送信先が複数の場合はセミコロンで区切る
Rem 宛先（To）
olMail.To = "aa@aa; bb@bb"

Rem CC
olMail.Cc = "cc@cc"

Rem BCC
olMail.Bcc = "dd@dd"

Rem 添付ファイル---------------------------------
Rem 添付ファイルの名前は「固定名＋日付（毎日変化）」なので、ユーザー定義関数「AttachmentSearch」に「固定名」だけを渡してファイルを検索する
Rem ファイルが存在しない場合は「添付なし」で処理するので、『On Error Resume Next』でエラーを無視して実行する
Dim TFol: TFol = "添付ファイルが入っているフォルダのパス\"

On Error Resume Next
olMail.Attachments.Add (AttachmentSearch(TFol, "ファイルA"))
olMail.Attachments.Add (AttachmentSearch(TFol, "ファイルB"))
On Error GoTo 0

Rem 件名-----------------------------------------
Rem VBS実行日が金曜の場合は月曜の日付、それ以外は次の日を入れる
Dim SubD

If Weekday(Date) = 6 Then '金曜
    SubD = DateAdd("d", 3, Date) '月曜
Else
    SubD = DateAdd("d", 1, Date) '翌日
End If

Rem 「月.日」形式で入れる
olMail.Subject = "件名（" & Month(SubD) & "." & Day(SubD) & "）"

Rem 本文-----------------------------------------
Rem フォントサイズ11、游ゴシックで固定
Rem 添付ファイルの有無をチェックして、あれば「あり」＋蛍光ペン（黄色）、なければ「なし」にする
Rem ユーザー定義関数「VBSIIf」を使用し条件分岐を1行で処理している

Dim mailBody
mailBody = "<span style='font-size:11pt'><span style='font-family:游ゴシック'>" & _
"～添付ファイルの有無～<br>" & _
"・ファイルA（" & VBSIIf(AttachmentSearch(TFol, "ファイルA") <> "", "<span style='background:yellow;mso-highlight:yellow'>あり</span>", "なし") & "）<br>" & _
"・ファイルB（" & VBSIIf(AttachmentSearch(TFol, "ファイルB") <> "", "<span style='background:yellow;mso-highlight:yellow'>あり</span>", "なし") & "）" & _
"</span></span>"

Rem メール作成-----------------------------------
olMail.Display '新規作成したメールに挿入されている署名を取得するために画面を表示

Rem 作成した本文を署名の前に入れる
olMail.HtmlBody = mailBody & olMail.HtmlBody

Rem ※「olMail.Send」を使えば送信できるが、送信前にファイルの確認等を行うため使用しない

Set olMail = Nothing
Set olApp = Nothing


Rem /////////////////////////////////////////////
Rem ユーザー定義関数-----------------------------
Function AttachmentSearch(FolPath, FileName)
    Rem 指定したフォルダ（FolPath）から指定した名前（FileName）を含むファイルを取得する
    Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")

    Rem 検索対象フォルダを取得
    Dim SFol: Set SFol = FSO.GetFolder(FolPath)

    Rem 検索対象フォルダ内をループし、指定した名前を含むファイルのフルパスを返す
    Rem 存在しない場合は空白（""）を返す
    Dim SFile
    For Each SFile In SFol.Files
        If InStr(1, SFile.Name, FileName) <> 0 Then
            AttachmentSearch = SFile.Path
            Exit Function
        End If
    Next

    Set FSO = Nothing
End Function


Function VBSIIf(expr, truepart, falsepart)
    Rem IIfと同じ
    If expr Then
        VBSIIf = truepart
    Else
        VBSIIf = falsepart
    End If
End Function

本文のHTMLタグ

本文に装飾を付ける方法を色々調べまくったものの、HTMLタグを使う以外のいい手が思いつかなかった。
変数にタグと本文を文字列で入れ（ダブルクォーテーションで挟んで全て文字列として扱う）、最後にolMail.HtmlBodyに入れて反映する。

フォント（游ゴシック）
文字列

フォントサイズ（11pt）
文字列

改行
 

蛍光ペン（黄色）
文字列

ユーザー定義関数の説明

AttachmentSearch

検索対象のフォルダとファイル名を指定し、指定したフォルダ内にファイルがあればフルパスを返し、なければ空白（""）を返す。
指定したファイル名にヒットするものが複数ある場合は一番最初にヒットしたものだけを返す。
「固定名＋日付」など、名前が変化するファイルに有効。

Rem 例：「C:\テスト\」内に「ファイルA」を含むファイルがあるか検索する
Msgbox AttachmentSearch("C:\テスト\", "ファイルA")

Function AttachmentSearch(FolPath, FileName)
    Rem 指定したフォルダ（FolPath）から指定した名前（FileName）を含むファイルを取得する
    Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")

    Rem 検索対象フォルダを取得
    Dim SFol: Set SFol = FSO.GetFolder(FolPath)

    Rem 検索対象フォルダ内をループし、指定した名前を含むファイルのフルパスを返す
    Rem 存在しない場合は空白（""）を返す
    Dim SFile
    For Each SFile In SFol.Files
        If InStr(1, SFile.Name, FileName) <> 0 Then
            AttachmentSearch = SFile.Path
            Exit Function
        End If
    Next

    Set FSO = Nothing
End Function

VBSIIf

VBAのIIfと同じ。IF文を1行で書きたいがために作成した関数。

Rem 例：計算式「1+1=5」が合っているか判定する
Msgbox VBSIIf(1+1=5, "そうだよ", "ちがうよ")

Function VBSIIf(expr, truepart, falsepart)
    Rem IIfと同じ
    If expr Then
        VBSIIf = truepart
    Else
        VBSIIf = falsepart
    End If
End Function

署名について

署名データの保存先はC:\ユーザー\[ユーザー名]\AppData\Roaming\Microsoft\Signaturesで、「各自で署名に付けた名前」でファイルが作成されている。

<mailto:>を消す

メールを新規作成した時に挿入されている署名の前に本文を追加するので、基本はolMail.Body = 本文 & olMail.BodyでOK。
（HTML形式なら.Bodyを.HtmlBodyにする）
しかしテキスト形式（.Body）にした時、署名のメールアドレスにリンクが設定されていると<mailto:>が付く。（プレーンなテキストに変換される際に勝手に付く？）
それが個人的にすごく気になったので除去する処理を作成。

olMail.Display '画面を表示しないと署名が取得できない

Rem 署名のメールアドレスにリンクが設定されていると、メールアドレスの後ろに<mailto:～>が付くので、それがあったら消す
If InStr(1, olMail.Body, "<mailto:") - 1 >= 1 Then
    mailShomei = Left(olMail.Body, InStr(1, olMail.Body, "<mailto:") - 1) & Mid(olMail.Body, InStr(InStr(1, olMail.Body, "<mailto:") - 1, olMail.Body, ">") + 1)
Else
    mailShomei = olMail.Body
End If

Rem 本文と署名を合体
olMail.Body = mailBody & mailShomei