Outlook Holiday Form

[rklalli]

Hey,

Some of you may have come across the Transmit Holiday Form created by Sue Mosher. I am currently using this and it works fine. However, I also need to populate the Body of the appointment with text from the calendar. For e.g. I have 170 calendar entries, each one marks a specific religious date in the calendar and each one has a brief decription. I have managed to slightly manipulate the code but I can only manage to add the first holiday. I'm a complete beginner to this so any help would be appreciated. Here is my code:

' ******************************************************
' DECLARATIONS
' ******************************************************
Option Explicit


' ******************************************************
' Module-level variables
' ******************************************************

Dim m_blnVersionOK ' Correct VBScript version
Dim m_chkHoliday ' checkbox for Holiday
Dim m_strHolidayCat ' "Holiday" or ""


' ******************************************************
' Outlook Constants
' ******************************************************

Const olAppointmentItem = 1


' ******************************************************
' PROCEDURES
' ******************************************************

' ******************************************************
' Item-level events
' ******************************************************

Function Item_Open()
' this script requires version 2.0 or later of VBScript
' because we use the Split() function
Dim strURL
Dim strMsg
If Item.Size > 0 Then
If ScriptEngineMajorVersion < 2 Then
strURL = "

http://www.microsoft.com/msdownload/"

strURL = strURL & "vbscript/scripting.asp"
strMsg = "This utility needs VBScript 2.0 or later."
strMsg = strMsg & "Please see " & strURL & "."
MsgBox strMsg,," Cannot Install Holidays"
m_blnVersionOK = False
Else
m_blnVersionOK = True
Call SetHolidayCat()
End If
End If
End Function


' ******************************************************
' Command-button events
' ******************************************************

Sub cmdGenerate_Click()
Dim objNS
Dim objFolder
Dim objAppt
Dim objItems
Dim objYearItems
Dim strYear
Dim strBody
Dim strWhen

' get folder where holidays are stored
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
If Not objFolder Is Nothing Then
If objFolder.DefaultItemType = olAppointmentItem Then
' loop through folder to get information about each holiday
' and write to the body of the item.
strYear = GetYear()
If strYear <> "" Then
Set objItems = objFolder.Items
objItems.Sort "[Start]"
objItems.IncludeRecurrences = True
strWhen = "[Start] >= ""January 1, " & strYear & " 12:00 AM"" AND " & _
"[End] <= ""December 31, " & strYear & " 11:59 PM"""
Set objYearItems = objItems.Restrict(strWhen)
Item.Body = FillBody(objYearItems)
Item.Subject = "Year " & strYear & " Company Holidays"
End If
Else
Msgbox "You did not choose a calendar folder. Please try again."
End If
End If
End Sub


Sub cmdAddHolidays_Click()
Dim strBody ' body containing appointment parameters
Dim intStart ' starting position for body search
Dim intBreak ' position where CrLfs are found
Dim strLine ' one line of text
Dim strResult ' info returned by AddAppt()
Dim strMsg ' message built to show user what we did
Dim intAdded ' number of items added

If m_blnVersionOK = True Then
m_strHolidayCat = HolidayCat()
strBody = Item.Body
intStart = 1
intBreak = InStr(intStart, strBody, vbCrLf)
Do Until intBreak = 0
strLine = Mid(strBody, intStart, intBreak - intStart)
If strLine <> "" Then
strResult = AddAppt(strLine)
strMsg = strMsg & vbCrLf & strResult
intAdded = intAdded + 1
Else
Exit Do
End If
intStart = intBreak + 2 ' looking for vbCrLf
intBreak = InStr(intStart, strBody, vbCrLf)
Loop
Call TellUser(strMsg, intAdded)
End If
End Sub


Sub TellUser(strMsg, intAdded)
strMsg = intAdded & " items processed:" & vbCrLf & strMsg & vbCrLf & vbCrLf
strMsg = strMsg & "Items listed as Added are now in your Calendar folder. "
strMsg = strMsg & "Do not click Add Holidays again or you will create duplicate items."
MsgBox strMsg, , "Operation Complete"
End Sub

' ******************************************************
' Other procedures
' ******************************************************

Function FillBody(objItems)
Dim objAppt
Dim strBody
objItems.SetColumns "Subject, Start, End, AllDayEvent, " & _
"ReminderSet, ReminderMinutesBeforeStart, BusyStatus"
For Each objAppt In objItems
strBody = strBody & GetApptData(objAppt) & vbCrLf
Next
FillBody = strBody
End Function


Function GetApptData(olAppt)
GetApptData = olAppt.Subject & "%" & _
FormatDaMoYr(olAppt.Start) & "%" & _
FormatDateTime(olAppt.Start, vbLongTime) & "%" & _
FormatDaMoYr(olAppt.End) & "%" & _
FormatDateTime(olAppt.End, vbLongTime) & "%" & _
CStr(olAppt.AllDayEvent) & "%" & _
CStr(olAppt.ReminderSet) & "%" & _
CStr(olAppt.ReminderMinutesBeforeStart) & "%" & _
CStr(olAppt.BusyStatus) & "%" & _
CStr(olAppt.Body)
End Function


Function FormatDaMoYr(dteDate)
FormatDaMoYr = Day(dteDate) & " " & _
MonthName(Month(dteDate), True) & _
" " & Year(dteDate)
End Function


Sub SetHolidayCat()
Dim objPage
Dim objCtrl
Set objPage = Item.GetInspector.ModifiedFormPages _
("Message")
Set m_chkHoliday = objPage.Controls("chkHolidayCat")
m_chkHoliday.Value = True
End Sub


Function HolidayCat()
If m_chkHoliday.Value Then
HolidayCat = "Holiday"
Else
HolidayCat = ""
End If
End Function

Function GetYear()
Dim strYear
strYear = InputBox("Generate holiday message for what year?", _
"Create Holiday Message", _
CStr(DatePart("yyyy", Now) + 1))
If IsDate("1/1/" & strYear) Then
GetYear = strYear
Else
MsgBox "Cannot get appointments for the year " & strYear & _
". Please try again."
GetYear = ""
End If
End Function


Function AddAppt(strParams)
Dim objAppt
Dim arrParams

Set objAppt = Application.CreateItem(olAppointmentItem)
arrParams = Split(strParams, "%")
objAppt.Subject = arrParams(0)
objAppt.AllDayEvent = arrParams(5)
objAppt.Body = arrParams(9)
If objAppt.AllDayEvent = True Then
objAppt.Start = CDate(arrParams(1) & " 12:00 AM")
Else
objAppt.Start = CDate(arrParams(1) & " " & arrParams(2))
objAppt.End = CDate(arrParams(3) & " " & arrParams(4))
End If
objAppt.ReminderSet = arrParams(6)
If objAppt.ReminderSet = True Then
objAppt.ReminderMinutesBeforeStart = arrParams(7)
End If
objAppt.BusyStatus = arrParams(8)
objAppt.Categories = m_strHolidayCat
objAppt.Save
AddAppt = "Added: " & arrParams(0)

End Function

The only parts I have added are objAppt.Body

Thanks in advance!