Subject: Create Calendar Entry
Here is a library I created (based on Ike Eagle’s original code which only handled anniversary calendary entries) that can be used to create various types of personal calendar entries in a user’s mailfile, including repeat entries. While the functionality seems to work fine I cannot with any certainty grant assurances that the fidelity of the created calendar entries are 100% compatible with normal calendar entries.
-Ernie
Option Public
Option Declare
%REM
AUTHOR: Ernie Mercer (based on original code by Ike Eagle which only handled
anniversary calendary entries)
CREATED: 7/27/2005
This library can be used to create personal calendar entries in a user’s mailfile,
including repeat entries. For our purposes we needed this to take calendar
related documents such as vacation requests and team room calendar entries
and create appropriate documents in the user’s personal mail file calendar.
Given the right parameters it can create most any type of calendar entry:
appointment, event, reminder, anniversary, or (very limited) even a meeting
(but because of the complexity involved in sending notifications to invitees and rooms/
resources such notifications are not supported - users should then be advised to
manually create such meeting invitations). It can also be used to link to a source
document and/or copy over rich text from a source document.
The following parameters are required for proper processing of an entry:
dbCal As notesdatabase = the database to create the calendar entry in
sUser As String = the full heirarchical name of the person to create the calendar for
sType As String = the type of calendar entry (“Appointment”, “Reminder”, “Even”, “Anniversary”, “Meeting”)
sSubject As String = the title/subject of the calendar entry
vCalStartDates As Variant = a list array containing the start date of the entry (or start dates if a repeat entry)
vCalEndDates As Variant = a list array containing the end date of the entry (or end dates if a repeat entry)
RepeatFlags As Variant = A five element array containing necessary details for repeat entries
'RepeatFlags(0) = RepeatForUnit
'RepeatFlags(1) = RepeatHow
'RepeatFlags(2) = RepeatInterval
'RepeatFlags(3) = RepeatUnit
'RepeatFlags(4) = RepeatWeekends
Comment As String = the comment to be entered in the Body of the calendar entry
docLink As NotesDocument = a document to be linked into the Body of the calendary entry
IncludeLink As Boolean = True/False - specifies whether or not to include a doc link to the docLink document
RTFField As String = an rich text field from the linked doc to be copy into the Body of the calendar entry
Location As String = the location of the appointment/event
%END REM
Function createCalEntry(dbCal As notesdatabase, _
sUser As String, sType As String, sSubject As String, vCalStartDates As Variant, _
vCalEndDates As Variant, RepeatFlags As Variant, Comment As String, _
docLink As NotesDocument, IncludeLink As Boolean, RTFField As String,_
Location As String) As Boolean
Dim wksp As New notesuiworkspace
Dim docNew As NotesDocument
Dim docResp As notesdocument
Dim iAlarm As Integer
Dim docNotice As NotesDocument
Dim EditEntry As Boolean
EditEntry = True
createCalEntry = False
'iRepeat: Number of Entries
'iAlarm: 6 if you want Alarm-Function
Set docNew = dbCal.CreateDocument
Call createCommonFields(docNew, sUser, sType, sSubject, _
vCalStartDates, vCalEndDates, Comment, docLink, IncludeLink, RTFField, Location)
'Create Repeat-Documents
If Ubound(vCalStartDates) > 1 Then
Call createRepeatFields(docNew, vCalStartDates, vCalEndDates, RepeatFlags)
docNew.ApptUNID = docNew.UniversalID
%REM
If EditEntry = True Then
Call wksp.EditDocument(True,docNew)
createCalEntry = True
Exit Function
End If
%END REM
Call docNew.ComputeWithForm(True,False)
Call docNew.Save(True,False)
'Create RESPONSE
Set docResp = dbCal.CreateDocument
Call docResp.MakeResponse( docNew)
Call createCommonFields(docResp, sUser, sType, sSubject, _
vCalStartDates, vCalEndDates, Comment, docLink, IncludeLink, _
RTFField, Location)
Call createRepeatFields(docResp, vCalStartDates, vCalEndDates, RepeatFlags)
docResp.ReplaceItemValue "$CSFlags", "i"
docResp.~$RefOptions = "1"
docResp.ApptUNID = docNew.UniversalID
docResp.tmpOwnerHW = "0"
docResp.WebDateTimeInit = "1"
docResp.OrgState ="x"
docResp.CalendarDateTime = vCalStartDates
docResp.OriginalStartDate = vCalStartDates(0)
docResp.OriginalModTime = vCalStartDates(0)
'Remove Items
Call docResp.RemoveItem( "RepeatDates" )
Call docResp.RemoveItem( "RepeatEndDates" )
Call docResp.RemoveItem( "RepeatFor" )
Call docResp.RemoveItem( "RepeatForUnit" )
Call docResp.RemoveItem( "RepeatHow" )
Call docResp.RemoveItem( "RepeatInterval" )
Call docResp.RemoveItem( "RepeatStartDate" )
Call docResp.RemoveItem( "RepeatUnit" )
Call docResp.RemoveItem( "RepeatWeekends" )
docResp.AdlinkCustomCalendarEntry = "Yes"
Call docResp.ComputeWithForm(True,False)
Call docResp.Save(True,False)
If iAlarm = 6 Then
Call docResp.PutInFolder( "$Alarms" )
End If
'send any required notifications
%REM (but because of the complexity involved in sending notifications to invitees and rooms/
resources such notifications are not supported - users should then be advised to
manually create such meeting invitations).
If Isarray(invitees) Then
Set docNotice = dbCal.CreateDocument()
Call docResp.CopyAllItems(docNotice)
With docNotice
.RemoveItem("$Ref")
.RemoveItem("CalendarDateTime")
.RemoveItem("RepeatInstanceDates")
.EndDateTime = vCalEndDates(0)
.Form = "Notice"
.PostedDate = Now
.RepeatDates = vCalStartDates
.RepeatEndDates = vCalEndDates
.RepeatStartDate = vCalStartDates(0)
.SendTo = invitees
.StartDateTime = vCalStartDates(0)
.~_ViewIcon = 133
Call docNotice.ComputeWithForm(True,False)
Call .Send(False)
End With
Set docNotice = Nothing
With docResp
.PostedDate = Now
Call .Save(True,False)
End With
End If
%END REM
Else
'No Repeat
docNew.CalendarDateTime = vCalStartDates
docNew.AdlinkCustomCalendarEntry = "Yes"
Call docNew.ComputeWithForm(True,False)
Call docNew.Save(True,False)
If iAlarm = 6 Then
Call docNew.PutInFolder( "$Alarms" )
End If
'send any required notifications
%REM (but because of the complexity involved in sending notifications to invitees and rooms/
resources such notifications are not supported - users should be advised to
manually create such meeting invitations).
If Isarray(invitees) Then
Set docNotice = dbCal.CreateDocument()
Call docNew.CopyAllItems(docNotice)
With docNotice
.RemoveItem("$Ref")
.RemoveItem("CalendarDateTime")
.RemoveItem("RepeatInstanceDates")
.EndDateTime = vCalEndDates(0)
.Form = "Notice"
.PostedDate = Now
.RepeatDates = vCalStartDates
.RepeatEndDates = vCalEndDates
.RepeatStartDate = vCalStartDates(0)
.SendTo = invitees
.StartDateTime = vCalStartDates(0)
.~_ViewIcon = 133
Call docNotice.ComputeWithForm(True,False)
Call .Send(False)
End With
Set docNotice = Nothing
With docNew
.PostedDate = Now
Call .Save(True,False)
End With
End If
%END REM
End If
’ If Isarray(invitees) Then
’ Messagebox "The entry has been saved to your calendar and notifications " &_
’ “have been sent the invitees.”, 0, “Calendar Updated Successfully”
’ Else
Messagebox "The entry has been saved to your calendar.",_
0, "Calendar Updated Successfully"
’ End If
createCalEntry = True
End Function
Sub createCommonFields(docNew As NotesDocument, sUser As String, _
sType As String, sSubject As String, vCalStartDates As Variant, vCalEndDates As Variant, _
Comment As String, docLink As NotesDocument, IncludeLink As Boolean, _
RTFField As String, Location As String)
Dim sExclude(1) As String
Dim iAlarm As Integer
sExclude(0) = "D"
sExclude(1) = "S"
With docNew
.~$BusyPriority = "1"
.~$NoPurge = vCalStartDates(0)
.~$PublicAccess = "1"
.Form = "Appointment"
.From = sUser
.Principal = sUser
Select Case sType
Case "Appointment"
.AppointmentType = "0"
.OrgTable="C0"
.~_ViewIcon = 160
Case "Anniversary"
.AppointmentType = "1"
.OrgTable="A0"
.~_ViewIcon = 63
Case "Event"
.AppointmentType = "2"
.OrgTable="P0"
.~_ViewIcon = 9
Case "Meeting"
.AppointmentType = "3"
.OrgTable="C0"
.~_ViewIcon = 158
'.RequiredAttendees = Invitees
Case "Reminder"
.AppointmentType = "4"
.OrgTable="C0"
.~_ViewIcon = 10
End Select
.Subject = sSubject
.Categories=""
.Chair = sUser
.StartDateTime =vCalStartDates
.StartDate = vCalStartDates(0)
.StartTime = vCalStartDates(0)
.EndDateTime = vCalEndDates
.EndDate = vCalEndDates(0)
.EndTime = vCalEndDates(0)
.BookFreeTime=""
.Logo="StdNotesLtr15"
.ExcludeFromView= sExclude
.SequenceNum=1
.Alarms= "" 'Evt. Alarm auch noch einbauen.
.AltChair = sUser
.Location = Location
'.Resources = Resources
'.OrgConfidential =
'.UpdateSeq =
'.Duration=1
'If Isarray(invitees) Then
' .RequiredAttendees = invitees
'End If
'if we are passed a linking document and the name of a rich text field
'then process accordingly, else just write out the comment to the Body field
If Not(docLink Is Nothing) And RTFField <> "" Then
Call handleRichTextItem(docNew, docLink, IncludeLink, RTFField, comment)
Else
.Body = comment$
End If
.IsInfolineEntry = "YES"
If iAlarm = 6 Then
'Alarm
.~$AlarmDescription = sSubject
.~$Alarm = 1
.~$AlarmOffset = -1440
.Alarms = "1"
'.~$AlarmSound = "notify"
End If
End With
End Sub
Sub createRepeatFields(doc As NotesDocument, vCalStartDates As Variant, _
vCalEndDates As Variant, RepeatFlags As Variant)
'RepeatFlags(0) = RepeatForUnit
'RepeatFlags(1) = RepeatHow
'RepeatFlags(2) = RepeatInterval
'RepeatFlags(3) = RepeatUnit
'RepeatFlags(4) = RepeatWeekends
'Fields for Repeat
doc.OrgRepeat = "1"
doc.Repeats = "1"
doc.~$CSFlags = "c"
doc.~$CSVersion = "2"
doc.RepeatDates = vCalStartDates
doc.RepeatEndDates = vCalEndDates
doc.RepeatFor = Ubound(vCalStartDates) 'iRepeat
doc.RepeatForUnit = RepeatFlags(0)
doc.RepeatHow = RepeatFlags(1)
doc.RepeatInterval = RepeatFlags(2)
doc.RepeatInstanceDates = vCalStartDates
doc.RepeatStartDate = vCalStartDates
doc.RepeatUnit = RepeatFlags(3)
doc.RepeatWeekends = RepeatFlags(4)
doc.~$HFFlags = "1"
doc.~$SMTPKeepNotesItem = "1"
Dim atCSWISL (0 To 4) As String
atCSWISL(0)="$S:1"
atCSWISL(1)="$L:1"
atCSWISL(2)="$B:1"
atCSWISL(3)="$R:1"
atCSWISL(4)="$E:1"
doc.ReplaceItemValue "$CSWISL", atCSWISL
Dim atWatched (0 To 4) As String
atWatched(0)="$S"
atWatched(1)="$L"
atWatched(2)="$B"
atWatched(3)="$R"
atWatched(4)="$E"
doc.ReplaceItemValue "$WatchedItems", atWatched
End Sub
Function handleRichTextItem(docTarget As NotesDocument, docLink As Notesdocument,_
IncludeLink As Boolean, RTFField As String, comment As String) As Boolean
HandleRichTextItem = False
Dim rtitem As notesrichtextitem
Dim rtnav As notesrichtextnavigator
'This function will copy a rich text item from a source doc to the new calendar entry,
'and it will also create a doc link to the source document if required.
'Otherwise it will simply append the comment the Body field of the new calendar entry
Set rtitem = docLink.GetFirstItem(RTFField)
If Not(rtitem Is Nothing) Then 'not a new doc, so we can access the rich text body field
If rtitem.GetUnFormattedText <> "" Then 'see if we have data in the field
If IncludeLink = True Then
Call rtitem.CopyItemToDocument(DocTarget, "Body")
Set rtitem = docTarget.GetFirstItem("Body")
Set rtnav=rtitem.CreateNavigator
If Not rtnav Is Nothing Then
Call rtnav.FindFirstElement(RTELEM_TYPE_TEXTPARAGRAPH)
Call rtitem.BeginInsert( rtnav, False ) 'move to beginning of rich text item
Call rtItem.AppendText(comment$ & " -->")
Call rtitem.AppendDocLink( docLink, "Link" )
Call rtitem.AddNewline(2)
Call rtitem.AppendText("---------------------------------------------------------------------------------------")
Call rtitem.AddNewline(2)
Call rtitem.EndInsert()
Call rtitem.update
End If
Else
Call rtitem.CopyItemToDocument(DocTarget, "Body")
Set rtitem = docTarget.GetFirstItem("Body")
Call rtitem.AddNewline(2)
Call rtItem.AppendText(comment$)
End If
Else 'either it's a new document or there are no values in the field
Set rtitem = New NotesRichTextItem( docTarget, "Body" )
If Not(rtitem Is Nothing) Then
If IncludeLink = True Then
Call rtItem.AppendText(comment$ & " -->")
Call rtitem.AppendDocLink( docLink, "Link" )
Call rtitem.addnewline(2)
Call rtItem.AppendText("---------------------------------------------------------")
Call rtitem.update
Else
docTarget.Body = comment$
End If
Else
docTarget.Body = comment$
End If
End If
End If
HandleRichTextItem = True
End Function