Wednesday 27 February 2008

VBA Script to create many calendar appointments in Outlook

A while back I was asked to create a few thousand Calendar appointments to help with some testing. I figured the script might be useful in case anyone ever has to do a similar task. I wrote it in Outlook 2003 and for me it works as intended, but it was meant to be quick and cheap (the script was only needed once so I gave it minimal testing and I've included no error handling at all) so you should see my disclaimer before you even think about using it!

Note that I put the items in a Calendar in a PST. This is because I needed to be able to easily share what I'd created, and also because I created the script on my live system (so if I'd written a few thousand Calendar items to the Exchange server I might not have been terribly popular if it had caused problems for other users).

The CreateLotsOfApptsInPST needs to be called with the following parameters:

PSTName - the name of the PST; this is the name it shows with in your folder tree (e.g. "Personal Folders") and not the file path. The PST has to be loaded. I didn't test what happens if there's more than one PST loaded with the same name.
Occurences - How many appointments you want to create
Start - The date and time of the first appointment you want to create
Interval - How far apart, in minutes, you want the start times of each appointment, e.g. if you make the Duration 45 mins and the Interval 60 mins, there will be a 15 mins gap between each appointment.
Duration - The duration of each appointment in minutes.
Subject - The subject you want for each appointment. As it is, the script will append a sequential number to each ("Test Appt 1", "Test Appt 2" etc.) but you could easily amend that.

The second sub is called by the first, but you should be able to see what it's doing.

Sub CreateLotsOfApptsInPST(PSTName As String, Occurrences As Long, _
Start As Date, Interval As Integer, Duration As Integer, _
  Subject As String)

Dim count As Integer

For count = 1 To Occurrences
    CreateApptInPST PSTName, Subject & " " & count, _
      Start + ((count - 1) * (Interval * (1 / 24 / 60))), Duration
Next count

End Sub

Sub CreateApptInPST(PSTName As String, Subject As String, _
  DateTime As Date, Duration As Integer)

Dim olApp As Outlook.Application, objName As NameSpace
Dim PST As MAPIFolder, PSTcal As MAPIFolder

Set olApp = Outlook.Application
Set objName = olApp.GetNamespace("MAPI")
Set PST = objName.Folders(PSTName)
Set PSTcal = PST.Folders("Calendar")

Dim i As AppointmentItem
Set i = PSTcal.Items.Add
i.Subject = Subject
i.Start = DateTime
i.Duration = Duration

End Sub

More seasoned coders will give me zero points for style, but it did the job for me!


  1. Nice stuff... I was juss looking for this today. the fact that i can create in any PST file (not just default calendar) is very helpful.

  2. I know this post has been here years, but all I was looking for was a way to create an appointment in a particular folder.
    Your code worked a treat.

    Many Thanks


  3. This works perfect for my script where I'm trying to add calendar events to tasks automatically. Great job!


Creative Commons License This work by TechieBird is licensed under a Creative Commons Attribution-No Derivative Works 2.0 UK: England & Wales License.