＜追記＞
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
