Outlook 2013 - Auto Create Appointments a week away 1

[tqeonline]

I've spent some time looking around the forums and haven't found what I'm looking for. Figured I'd post here to see if anyone has some insight.

I want to get out of the "Email = Work" habit and effectively schedule my time each day/week to do email. What i'd like to do is have a script that runs once a day (Outlook open?) that will look out a week and schedule 30 minutes on that day for email.

Pseudo code

Public Sub ScheduleEmail()
  If NotRunYet = False Then
    If Today(+7) != Holiday Then
      For Each 30MinuteSlot
        If 30MinuteSlot == Free && 30MinuteSlot > 8am PST && 30MinuteSlot < 5pm PST Then
          AvailableSlots += 30MinuteSlot
        End If
      Next
    End If
    If AvailableSlots != 0 Then
      Rnd = Rand(1,AvailableSlots.Count)
      Appointment.Schedule(AvailableSlots(Rnd))
    End If
  End If
  NotRunYet = True
End Sub

I've pretty well versed with Excel VBA but a noob at Outlook VBA. The goal is that every day it looks out a week and goes ahead and blocks 30 minutes (or an hour...) for that day if there is time.

- Matt

"If I must boast, I will boast of the things that show my weakness

 

[SkipVought]

Why not a recurring "infinite" appointment? One time manual task!

By "infinite" I mean a way, way, way out end date.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[tqeonline]

I have that today and I've noticed that I'm constantly shuffling it around to make higher priority meetings. Ideally I'd set this thing to be a day/two beforehand and just let it do it's magic - additionally having it do a random time makes it less monotonous for me on a day-to-day basis.

- Matt

"If I must boast, I will boast of the things that show my weakness

 

[tqeonline]

I have made some progress from additional searching. The below will get me the next available 30 minute window... getting closer

Sub GetFreeBusy()
 Dim oCurrentUser As ExchangeUser
 Dim FreeBusy As String
 Dim BusySlot As Long
 Dim DateBusySlot As Date
 Dim i As Long
 Const SlotLength = 30
 
 'Get ExchangeUser for CurrentUser
 If Application.Session.CurrentUser.AddressEntry.Type = "EX" Then
     Set oCurrentUser = Application.Session.CurrentUser.AddressEntry.GetExchangeUser
     FreeBusy = oCurrentUser.GetFreeBusy(Now, SlotLength)
     For i = 1 To Len(FreeBusy)
        If CLng(Mid(FreeBusy, i, 1)) = 0 Then
           'get the number of minutes into the day for free interval
           BusySlot = (i - 1) * SlotLength
           'get an actual date/time
           DateBusySlot = DateAdd("n", BusySlot, Date)
           'To refine this function, substitute actual
           'workdays and working hours in date/time comparison
           If TimeValue(DateBusySlot) >= TimeValue(#9:00:00 AM#) And TimeValue(DateBusySlot) <= TimeValue(#5:00:00 PM#) And Not (Weekday(DateBusySlot) = vbSaturday Or Weekday(DateBusySlot) = vbSunday) Then
              MsgBox (oCurrentUser.name & " first open interval:" & vbCrLf & Format$(DateBusySlot, "dddd, mmm d yyyy hh:mm AMPM"))
              Exit For
           End If
        End If
     Next
 End If
End Sub

- Matt

"If I must boast, I will boast of the things that show my weakness

 

[tqeonline]

Ok! Here is a working version. On Application_Startup it is called, it stores the last run date in Settings and will only run if dates are different, it isn't random (yet) it just takes the earliest available slot.

Future Fixes:
- Catch up missed days
- Random slot in the day
- Integration with Tasks (If > X for given day then do 60 minutes vs. 30)

Private Sub Application_Startup()
    ScheduleEmail
End Sub

Sub ScheduleEmail()
 Dim oCurrentUser As ExchangeUser
 Dim FreeBusy As String
 Dim BusySlot As Long
 Dim DateBusySlot As Date
 Dim i As Long
 Const SlotLength = 30
 Set myOlApp = CreateObject("Outlook.Application")
 Set myNameSpace = myOlApp.GetNamespace("MAPI")
 Set MyFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
 
 'Get Stored Setting
 Dim setting As String
 setting = GetSetting("LastScheduleEmail", "Automation", "Date", "1/1/1900")
 
 'Compare Values for Daily Run
 If DateValue(setting) <> DateValue(Now) Then
     'Get ExchangeUser for CurrentUser
     If Application.Session.CurrentUser.AddressEntry.Type = "EX" Then
         Set oCurrentUser = Application.Session.CurrentUser.AddressEntry.GetExchangeUser
         FreeBusy = oCurrentUser.GetFreeBusy(Now, SlotLength)
         For i = 1 To Len(FreeBusy)
            If CLng(Mid(FreeBusy, i, 1)) = 0 Then
               'get the number of minutes into the day for free interval
               BusySlot = (i - 1) * SlotLength
               
               'get an actual date/time
               DateBusySlot = DateAdd("n", BusySlot, Date)
               
               'To refine this function, substitute actual
               'workdays and working hours in date/time comparison
               If TimeValue(DateBusySlot) >= TimeValue(#9:00:00 AM#) And TimeValue(DateBusySlot) <= TimeValue(#5:00:00 PM#) And _
                    DateValue(DateBusySlot) >= DateAdd("d", 7, Now) And _
                    Not (Weekday(DateBusySlot) = vbSaturday Or Weekday(DateBusySlot) = vbSunday) Then
                    
                    MsgBox (oCurrentUser.name & " first open interval:" & vbCrLf & Format$(DateBusySlot, "dddd, mmm d yyyy hh:mm AMPM"))
    
                    'Set the Appointment
                    Set olAppt = MyFolder.Items.Add(olAppointmentItem)
                    With olAppt
                        'Define calendar item properties
                        .Start = DateBusySlot
                        .End = DateAdd("n", 30, DateBusySlot)
                        .Subject = "Email"
                        .Location = "Office"
                        .Body = ""
                        .BusyStatus = olBusy
                        .ReminderMinutesBeforeStart = 10
                        .ReminderSet = True
                        .Categories = "Think & Prep Time"
                        .Save
                    End With
                    
                    'Save date to registry so it doesn't run again
                    SaveSetting "LastScheduleEmail", "Automation", "Date", Now
                    
                  Exit For
               End If
            End If
         Next
     End If
 End If
End Sub

- Matt

"If I must boast, I will boast of the things that show my weakness

 

[SkipVought]

Good for you! Not only boasting in your weakness, but also bearing your own burden. And then you'll no doubt experience perils on missed days, perils at random and perils among tasks. ;-)

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]