Outlookから直近の予定一覧を取得してメール（VBScript/Excelマクロ）

これは何かというと

Outlookの予定表から今日・明日・明後日の予定を取得して、
新規メールとして書き出す、というために作ったちょっとしたマクロです。
Teams会議のURLを併せて取得するのがポイント（実はそれがもともとの目的）です。

コード

AppointmentListMail.vbs

Option Explicit
Dim oApp, oItems, oRegExp

'VBScript用（Excelマクロではコメントアウト）
Call Main

'メイン処理
Sub Main()
    Const DAYS = 3
    Dim wSt, wEn, wList, wBody
    wSt = FormatDT(Int(Now))            '今日から
    wEn = FormatDT(Int(Now) + DAYS)     'ｘ日後までの
    wList = ApoList(wSt, wEn).Items     '予定を取得
    
    wBody = Join(wList, vbLf & vbLf)    '結果を
    wBody = Replace(wBody, vbTab, vbLf) '成形して
    
    '予定一覧を本文とした新規メールを作成
    Call NewMail("Schedule " & Int(Now), "[e-mail]", wBody)   
End Sub

'OutLookを準備
Function App()  
    On Error Resume Next
    If IsEmpty(oApp) Then Set oApp = GetObject(, "Outlook.Application")
    If IsEmpty(oApp) Then Set oApp = CreateObject("Outlook.Application")
    If oApp.Explorers.Count = 0 Then oApp.GetNamespace("MAPI").GetDefaultFolder(9).Display '9: olFolderCalendar
    Set App = oApp
End Function

'新規メールを作成
Function NewMail(pSubject, pTo, pBody)
    Set NewMail = App.CreateItem(0) '0: olMailItem
    With NewMail
        .Display
        .BodyFormat = 1
        .Subject = pSubject
        .To = pTo
        .Body = pBody
    End With
End Function

'Outlookの予定を期間で絞り込む
Function SelectedItems(st, en)
    If IsEmpty(oItems) Then
        Set oItems = App.GetNamespace("MAPI").GetDefaultFolder(9).Items '9: olFolderCalendar
        With oItems
            .Sort "[Start]"                 '開始時刻でSort
            .IncludeRecurrences = True      '繰り返し予定を含める
        End With
    End If
    Dim f
    f = "[Start]>='$st' AND [Start]<'$en'"
    f = Replace(f, "$st", st)
    f = Replace(f, "$en", en)
    Set SelectedItems = oItems.Restrict(f)  '期間で絞り込む
End Function

'順に予定を取得して情報を辞書に格納
Function ApoList(st, en)
    Set ApoList = CreateObject("Scripting.Dictionary")  '結果格納用の辞書を準備
    Dim apo, val(3)
    For Each apo In SelectedItems(st, en)               '取得した予定群を順次処理
        val(0) = FormatDT(apo.Start)                    '必要な
        val(1) = apo.Subject                            '項目を
        val(2) = apo.Location                           '適宜
        val(3) = GetURL(apo)                            '見繕って
        ApoList.Add ApoList.Count, Join(val, vbTab)     '辞書に格納
    Next
End Function

'予定アイテムからTeams会議のURLを取得（いくつかの方法で）
Function GetURL(apo)
    Const URL_PATTERN = "https://teams.microsoft.com/l/meetup-join/"
    With apo
        Dim h   'HyperLinkから取得
        For Each h In apo.GetInspector.WordEditor.Hyperlinks
            GetURL = h.Address
            If InStr(GetURL, URL_PATTERN) = 1 Then Exit Function
        Next
        Dim m   'Bodyから取得
        For Each m In RegMatch(apo.Body, "<(http.+?)>")
            GetURL = m.SubMatches(0)
            If InStr(GetURL, URL_PATTERN) = 1 Then Exit Function
        Next
        Dim u   'UserPropertyから取得
        For Each u In .UserProperties
            If u.Name = "SkypeTeamsMeetingUrl" Then
                GetURL = u.Value
                If InStr(GetURL, URL_PATTERN) = 1 Then Exit Function
                Exit For
            End If
        Next
        For Each u In .UserProperties
            If u.Name = "OnlineMeetingExternalLink" Then
                GetURL = u.Value
                If InStr(GetURL, URL_PATTERN) = 1 Then Exit Function
                Exit For
            End If
        Next
    End With
End Function

'正規表現で検索（URL取得で利用）
Function RegMatch(sourceString, pPattern)
    If IsEmpty(oRegExp) Then Set oRegExp = CreateObject("VBScript.RegExp")
    With oRegExp
        .Global = True
        .Pattern = pPattern
        Set RegMatch = .Execute(sourceString)
    End With
End Function

'日付の編集（yyyy/mm/dd hh:nn）
Function FormatDT(dt)
    FormatDT = Join(Array(FormatDateTime(dt, 2), FormatDateTime(dt, 4)))    '2: vbShortDate, 4: vbShortTime
End Function