Script to create text files from Outlook appointments

We have a system that reads certain csv files to create HTML Lists of Appointments. So far this CSV was created manually. I wanted to replace this by a script that is able to read this information directly from Outlook. The script I came up with supports a mustache-like syntax to build templates which are then filled by the program. This allows to generate almost arbitrary text files. Here is an example of such a template: "{{FormatDateTime(currentday,2)}}, {{oAppt.Subject}}"

	'################################################################################
	'# Program: Outlook2Csv.vbs
	'#
	'# Written by Daniel C. Oderbolz (2013-08-07)
	'#
	'# This program reads appointments with a specific Category in a certain
	'# interval from Outlook and writes them to a file.
	'# the user can control the format of the resulting strings via a simple
	'# Mustache-like Template Syntax like {{oAppt.Subject}} or {{FormatDateTime(currentday,2)}}.
	'# In other words, it is supported to use VBScript expressions in the tags.
	'#
	'# By Default, a multiday event is expanded, meaning that for each day,
	'# a line will be printed. Also, we include all recurring events.
	'# Useful variables for templates:
	'# {{oAppt.Subject}} - Subject line
	'# {{currentday}} - Either the start day or the current day when iterating trough a multiday event
	'# {{oAppt.End}} - The End of an appointment
	'# {{oAppt.Location}} - its location
	'################################################################################
	Sub MainProgram()
	Set myOlApp = CreateObject("Outlook.Application")
	' If this is true, we create one line for each day in a multiday Appoinment
	expandMultiDay = true
	' Define constants
	Const olFolderCalendar = 9
	Const olAppointmentItem = 1
	Const olRecursDaily = 0
	ForWriting = 2
	ourDelimiter = ","
	' Default Filename
	defaultOutputFile = ".\Export_Events.csv"
	' Define a Template. Here, note that oAppt.Start should be avoided
	' because of multi-day events. Rather use currentday
	' The Appointment Object is called oAppt
	defaultTemplate = "{{FormatDateTime(currentday,2)}}, {{oAppt.Subject}}"
	' This is a lame default
	ourTemplate = defaultTemplate
	Set myNameSpace = myOlApp.GetNamespace("MAPI")
	Set MyFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
	Set oItems = MyFolder.Items
	' Set Defaults
	defaultCategory = "Export"
	defaultStart = Date
	defaultEnd = Date + 30
	' Get Category from user
	ourCategory = InputBox("Which Category of events should be exported?","Enter Category:",defaultCategory)
	' Get Date range from user
	ourStart = InputBox("Enter the first day of the interval to be exported","Enter First Day:",defaultStart)
	ourEnd = InputBox("Enter the last day of the interval to be exported","Enter Last Day:",defaultEnd)
	' It seems to be difficult to create a saveas dialog nowadays...
	outputFile = defaultOutputFile
	' Filter (http://msdn.microsoft.com/en-us/library/bb220369.aspx)
	' Restrict Date
	strFilter = "[Start] >= " + "'" + ourStart + "'"
	Set oItems = oItems.Restrict(strFilter)
	strFilter = "[End] <= " + "'" + ourEnd + "'"
	Set oItems = oItems.Restrict(strFilter)
	' Restrict Category
	strFilter = "[Categories] = " + "'" + ourCategory + "'"
	Set oItems = oItems.Restrict(strFilter)
	oItems.Sort "[Start]"
	' We want recurring, too (http://www.pcreview.co.uk/forums/get-recurring-appointment-dates-vba-t799214.html)
	oItems.IncludeRecurrences = True
	' Open file
	Set fso = CreateObject("Scripting.FileSystemObject")
	Set fileHandler = fso.OpenTextFile(outputFile,ForWriting,true)
	' See http://msdn.microsoft.com/en-us/library/office/bb176631(v=office.12).aspx
	For Each oAppt In oItems
	' Is it a multiday event? In this case we loop and Print it for each day
	set RecurrencePattern = oAppt.GetRecurrencePattern
	' Duration is in Minutes
	if (expandMultiDay) Then
	' Does it last longer than 1 day?
	if oAppt.Duration > 1440 Then
	startp = oAppt.Start
	endp = oAppt.End
	CurrD = startp
	' Iterate through days
	While (CurrD <= endp)
	fileHandler.Write ExpandTemplate(oAppt,CurrD,ourTemplate) & vbCrLf
	CurrD = DateAdd("d", 1, CurrD)
	Wend
	Else
	' Current day is the start day
	fileHandler.Write ExpandTemplate(oAppt,oAppt.Start,ourTemplate) & vbCrLf
	End If
	Else
	' Current day is the start day
	fileHandler.Write ExpandTemplate(oAppt,oAppt.Start,ourTemplate) & vbCrLf
	End If
	Next
	fileHandler.Close
	End Sub
	Function ExpandTemplate (oAppt, currentday, template)
	' Prepare the line to write using regex.
	' The template contains tags like {{oAppt.this}} that are exapnded
	' here, we construct the new string
	expanded = template
	' Create Regexp to evaluate the template
	Set re = new RegExp
	Const InnerPattern = "(\w+|[_,. ()])+"
	' Add surrounding braces
	re.pattern = "\{\{" + InnerPattern + "\}\}"
	re.Global = True
	' Find all occurences and eval the expressions
	Set tokens = re.Execute(template)
	For Each token In tokens
	' Select the actual match using a second regexp machine
	re.pattern = InnerPattern
	Set matches = re.execute(token)
	For each match in matches
	' Evaluate result
	result = eval(match.value)
	msgbox(result)
	' Now we must inject the result into the original string
	' Do only the first replacement
	expanded=Replace(expanded,"{{" + match.value + "}}",result,1)
	Next ' inner matches (only 1 expected)
	Next
	' Return the value
	ExpandTemplate = expanded
	End Function
	Call MainProgram

view raw Outlook2Csv.vbs hosted with ❤ by GitHub