今日の予定スケジュールを取得したい

f:id:elve:20210821095949p:plain
会社で使用しているスケジュール管理のがOutlookなんだが、ようわからんが何をどう頑張ってもポップアップが出ないようにされているようだ。
ノートパソコン持ち歩くようになったので顧客に別の顧客の個人情報見えたらやばいってことかな？

で、内勤のワタクシ。何を隠そうめちゃくちゃ物忘れが激しいわけですよ。何を頼まれても３回は忘れるんですよ！！！（その度依頼者と互いに嫌な思いをして習慣化する）

これはいかん、と思いまして、今日と明日のスケジュールを取得したい、と。（次のステップとしては選択したスケジュールを送信時間指定してメールしたい）
エクセルちゃんから参照設定でOutlookを追加しておいてね。

こちらを参考に
[Outlook マクロ] 予定表に登録されている予定を取得する – Tk2Kpdn Wiki

コンナンエクセル方に書いて

Public Sub CreateDailyMail()
    Dim ap As Outlook.Application
    Set ap = Outlook.Application
    
    Dim l_calendar As Outlook.Folder
    Set l_calendar = ap.Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)
 
    Dim l_appointments As Outlook.Items
    Set l_appointments = l_calendar.Items
 
    Dim s As String: s = Format(Date, "yyyy/m/d 0:00")
    Dim e As String: e = Format(Date, "yyyy/m/d 23:59")
 
    Set l_appointments = l_appointments.Restrict( _
        "(([Start] = '" & s & "') And ([AllDayEvent] = True)) Or " & _
        "(([Start] >= ' & s & ') And ([End] < ' & e & '))")
 
    Dim l_appointment As Outlook.AppointmentItem
 
    Dim i As Long: i = 1
    Dim j As Long
    For Each l_appointment In l_appointments
         j = 1
        Cells(i, j) = l_appointment.Start: j = j + 1
        Cells(i, j) = l_appointment.Subject: j = j + 1
        Cells(i, j) = l_appointment.Body: j = j + 1
        Cells(i, j) = l_appointment.AllDayEvent
        i = i + 1
    Next
 End Sub

こうかな？　と

こんな感じの予定表があるとするじゃないですか。
f:id:elve:20210821094128p:plain

RUN！

f:id:elve:20210821094356p:plain
なんでやねん！！！

こ、公式～！！　助けてよぉ～

定期的な予定を含め、今日と明日に発生する予定の件名を表示します
https://docs.microsoft.com/ja-jp/office/vba/api/outlook.items.includerecurrences

RestrictじゃなくてFindとFindNextでぐるぐるしろってことか？

Sub DemoFindNext()
    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 = 1
    Dim j As Long

    While TypeName(currentAppointment) <> "Nothing"
         j = 1
        Cells(i, j) = currentAppointment.Start: j = j + 1
        Cells(i, j) = currentAppointment.Subject: j = j + 1
        Cells(i, j) = currentAppointment.Body: j = j + 1
        Cells(i, j) = currentAppointment.AllDayEvent
        i = i + 1
        Set currentAppointment = myAppointments.FindNext
    Wend
End Sub