指定日の予定の５分くらい前にメール送信予約したい

＜追記＞
outlookのアカウントはhotmailのを使った。他のサービスのメアドでうまくいくのかは不明
＜／追記＞

snack.elve.club

ファイルを開くと予定表リストができて、チェックつけた予定の５分前にメールを送信予約してくれるマクロだよー
開くとこうなって↓

sheet2はこんな感じ*1

チェックつけてボタンを押す↓

↓メール送信予約できちゃった*2

ThisWorkbookのコード

Private Sub Workbook_Open()
    Sheet1.clrMain
    If Sheet2.chkParameter Then
        Sheet1.getSchedule
        Sheet1.addMailButton
    Else
        MsgBox ("送信先と時間を指定してください")
        Sheet2.Select
    End If
    Range("A1").Select
End Sub

Sheet1のコード

Sub clrMain()
    Dim e As Long: e = Range("A1").CurrentRegion.Item(Range("A1").CurrentRegion.Count).Row
    If e > 1 Then
        Range("2:" & e).Delete
        Dim s As Shape

    End If
    For Each s In Me.Shapes
        s.Delete
    Next
End Sub
Sub addChkbox(r As Range)
    If r Is Nothing Then Exit Sub
    
    Dim t As Long: t = r.Top
    Dim l As Long: l = r.Left
    Dim w As Long: w = r.Width
    Dim h As Long: h = r.Height
    
    Me.CheckBoxes.Add(l, t, w, h).Select
    
    With Selection
        .Value = xlOff
        .Name = "Chk" & r.Row
        .Characters.Text = ""
        .Text = ""
        .LinkedCell = r.Address
    End With
End Sub
Sub addMailButton()
    Dim r As Range: Set r = Range("F1:H3")
    
    Dim t As Long: t = r.Top
    Dim l As Long: l = r.Left
    Dim w As Long: w = r.Width
    Dim h As Long: h = r.Height
    
    Me.Buttons.Add(l, t, w, h).Select
    
    With Selection
        .Name = "SendMail"
        .Characters.Text = "SendMail"
        .Text = "SendMail"
        .OnAction = "Sheet1.sendMail"
    End With
End Sub
Sub sendMail()
    Dim ap As Outlook.Application
    Set ap = Outlook.Application
    Dim e As Long: e = Range("A1").CurrentRegion.Item(Range("A1").CurrentRegion.Count).Row
    If e = 1 Then Exit Sub
    
    Dim i As Long
    For i = 2 To e
        If Cells(i, 1).Value = True Then
            Dim mItem As Outlook.MailItem: Set mItem = ap.CreateItem(olMailItem)
            mItem.DeferredDeliveryTime = Cells(i, 3)
            mItem.Subject = Cells(i, 4)
            mItem.Body = Cells(i, 4)
            mItem.To = Sheet2.getMailAddress
            mItem.Send
        End If
    Next
    MsgBox ("送信完了")
End Sub
Sub getSchedule()
    Dim ap As Outlook.Application
    Set ap = Outlook.Application
    
    Dim tdystart As String
    Dim tdyend As String
    
    Dim myAppointments As Outlook.Items
    Dim currentAppointment As Outlook.AppointmentItem
    
    
    tdystart = Format(Date, "yyyy/m/d 0:00")
    tdyend = Format(Date + 1, "yyyy/m/d 23:59")
    
    Set myAppointments = _
     ap.Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar).Items
    
    myAppointments.Sort "[Start]"
    myAppointments.IncludeRecurrences = True
    
    Set currentAppointment = myAppointments.Find("[Start] >= """ & _
    tdystart & """ and [Start] <= """ & tdyend & """")

    Dim i As Long: i = 2
    Dim j As Long

    While TypeName(currentAppointment) <> "Nothing"
        j = 1
        addChkbox (Cells(i, j)): j = j + 1
        If currentAppointment.AllDayEvent Then
            Cells(i, j) = Format(currentAppointment.Start, "yyyy/m/d 9:00")
        Else
            Cells(i, j) = currentAppointment.Start
        End If
        j = j + 1
        Cells(i, j) = Cells(i, j - 1) - Sheet2.getDelayTime: j = j + 1
        Cells(i, j) = currentAppointment.Subject: j = j + 1
        Cells(i, j) = currentAppointment.Body
        i = i + 1
        Set currentAppointment = myAppointments.FindNext
    Wend
End Sub

Sheet2のコード

Function getMailAddress() As String
    getMailAddress = Range("A2").Value
End Function
Function getDelayTime() As String
    getDelayTime = Range("B2").Value
End Function

Function chkParameter() As Boolean
    If Range("A2") = "" Or Range("B2") = "" Then
        chkParameter = False
    Else
        chkParameter = True
    End If

End Function

*1:変更したら保存して閉じて再度開くと反映される

*2:たぶんOUTLOOK開いてないと送信されない