'MiniWebCal: 

Option Public
Option Explicit

%REM
This agent will display the calendar entries in your Notes mail file
in a compact calendar format for use on a web page or on your
Windows Active Desktop. To use this agent, do the following:

1.  Create a new, shared, LotusScript agent in your Notes mail
file, with a runtime target of "None"

2.  Name the agent whatever you want (we'll be using the name
"MiniWebCal" for the sake of example here)

3.  Paste or import all of this code into the agent and save it

4.  YOU MUST HAVE RIGHTS TO RUN RESTRICTED LOTUSSCRIPT
AGENTS, AS DEFINED IN THE SERVER DOCUMENT THAT YOUR
MAIL FILE IS ON. If this is not the case, you should sign the agent with
an ID that does have those rights, along with rights to read your calendar
(usually the server ID will work just fine for this purpose)

5.  Call the agent with a URL similar to this:
http://yourmailserver/mail/yourmailfile.nsf/MiniWebCal?OpenAgent
where "yourmailserver" is the DNS name of your mail server,
"/mail/yourmailfile.nsf" is the path to your mail file, and "MiniWebCal"
is the name you used when you saved this agent

Two obvious uses of this agent are to provide a small calendar on a
web page (probably in an iFrame), or to include your Notes calendar
as a component on your Windows desktop using Active Desktop.
I'm sure there are other clever uses as well.

I've tested this agent lightly with R5 and 6.51. It worked with both versions
for me, although your mileage may vary. One thing this agent doesn't do
is to display events that stretch across multiple days as multiple day events
(it will show it on the first day only). Now that I think about it, I'm not sure if
it shows repeating events or holidays either. This is all due to the view that
I'm using for lookups. If you want to change this functionality, you can just
create your own view and point to it in the GetTag function.

version 1.0 -- 24 July 2004
Julian Robichaux
http://www.nsftools.com
%END REM



'** constants we use to determine what kind of
'** display format to use
Const CAL_MONTHLY = 0
Const CAL_WEEKLY = 1
Const CAL_DAILY = 2

'** the URL reference to this agent, used in several places
Dim agentURL As String

'** names of days and months (populated in Initialize sub)
Dim dayArrayShort As Variant
Dim dayArrayMed As Variant
Dim dayArrayLong As Variant
Dim monthArrayShort As Variant
Dim monthArrayMed As Variant
Dim monthArrayLong As Variant

'** newline character (for convenience)
Const newline = |
|

'** CSS style information used by the HTML pages that are
'** output by this agent. You should be very experimental
'** with the styles below, to get the look and feel you want.
'** You can also just point to a global stylesheet, and keep
'** all the CSS there.
Const css = |
<style>
body, td, tr, th {
	font-family: Verdana, Tahoma, Arial, Helvetica, sans-serif;
	font-size: 10px;
	color: white;
	background-color: black;
	}

td, tr, th {
	text-align: center;
	}

a, a:visited {
	color: #7090ff;
}

a:active, a:hover {
	color: red;
}

.calendarTable {
	}

.calendarTR {
	}

.calendarTitleTR {
	}

.calendarDayTR {
	}

.calendarTodayButtonTR {
	}

.calendarTD {
	}

.calendarTitleTD {
	}

.calendarButtonTD {
	}

.calendarTodayButtonTD {
	}

.calendarDayTD {
	background-color: #333333;
	}

.calendarDayHighlightTD {
	background-color: #222222;
	border: 1px solid #AAAAAA;
	}

.calendarDailyInfoTD {
	background-color: #222222;
	border: 1px solid #AAAAAA;
	text-align: left;
	padding: 5px;
	}

.calendarTitleText {
	font-size: 12px;
	color: gray;
	font-weight: bold;
	}

.calendarDayHighlight {
	color: aaffaa;
	font-weight: bold;
	}

.calendarButton {
	font-family: Verdana, Tahoma, Arial, Helvetica, sans-serif;
	font-size: 10px;
	color: #AAAAAA;
	background: #4060ff;
	font-weight: bold;
	}

.calendarTodayButton {
	font-family: Verdana, Tahoma, Arial, Helvetica, sans-serif;
	font-size: 10px;
	color: #AAAAAA;
	background: #4060ff;
	font-weight: bold;
	}

</style>
|


Sub Initialize
	Dim session As New NotesSession
	Dim requestDoc As NotesDocument
	Dim dt As NotesDateTime
	Dim queryString As String
	Dim displayType As Integer
	Dim highlightDate As Integer
	Dim returnString As String
	
	'** process the Query String (if any) and get the URL of this agent
	Set requestDoc = session.DocumentContext
	If Not (requestDoc Is Nothing) Then
		queryString = requestDoc.Query_String_Decoded(0)
		agentURL = "http://" & requestDoc.Server_Name(0) & _
		requestDoc.Path_Info(0)
		If (Len(queryString) > 0) Then
			agentURL = Left$(agentURL, _
			Len(agentURL) - Len(requestDoc.Query_String(0)) - 1)
		End If
	End If
	
	'** figure out what we're displaying, based on the Query String
	displayType = GetDisplayType(queryString)
	highlightDate = GetHighlightPreference(queryString)
	Set dt = GetQueryDate(queryString)
	
	'** initialize the day and month labels
	dayArrayShort = r5Split("Su;Mo;Tu;We;Th;Fr;Sa", ";")
	dayArrayMed = r5Split("Sun;Mon;Tue;Wed;Thu;Fri;Sat", ";")
	dayArrayLong = r5Split("Sunday;Monday;Tuesday;Wednesday;" & _
	"Thursday;Friday;Saturday", ";")
	monthArrayShort = r5Split("Jan;Feb;Mar;Apr;May;" & _
	"Jun;Jul;Aug;Sep;Oct;Nov;Dec", ";")
	monthArrayMed = r5Split("Jan;Feb;Mar;Apr;May;" & _
	"June;July;Aug;Sept;Oct;Nov;Dec", ";")
	monthArrayLong = r5Split("January;February;March;April;May;" & _
	"June;July;August;September;October;November;December", ";")
	
	'** get the return string, based on what was requested
	Select Case displayType
	Case CAL_MONTHLY :
		returnString = GetMonthlyData(dt, highlightDate)
	Case CAL_WEEKLY :
		returnString = GetWeeklyData(dt, highlightDate)
	Case CAL_DAILY :
		returnString = GetDailyData(dt, highlightDate)
	Case Else :
		returnString = "Unknown format requested"
	End Select
	
	'** and print the return string to the browser to display it 
	'** as a web page
	Print returnString
	
End Sub
Function GetDisplayType (queryString As String) As Integer
	'** figure out what format we should be using
	'** (default to monthly)
	Select Case GetQueryElement(queryString, "display")
	Case "MONTHLY" :
		GetDisplayType = CAL_MONTHLY
	Case "WEEKLY" :
		GetDisplayType = CAL_WEEKLY
	Case "DAILY" :
		GetDisplayType = CAL_DAILY
	Case Else :
		GetDisplayType = CAL_MONTHLY
	End Select
End Function
Function GetHighlightPreference (queryString As String) As Integer
	'** should we highlight the given date (default is yes)
	Select Case GetQueryElement(queryString, "highlight")
	Case "NO", "FALSE", "0" :
		GetHighlightPreference = False
	Case Else :
		GetHighlightPreference = True
	End Select
End Function
Function GetQueryDate (queryString As String) As NotesDateTime
	'** if we got a date on the query string, try to use it
	On Error Goto processError
	
	Dim dt As New NotesDateTime(Today)
	Dim dtString As String
	Dim dtVar As Variant
	
	dtString = GetQueryElement(queryString, "date")
	If (Len(dtString) > 0) Then
		dtVar = Cdat(dtString)
		Set dt = New NotesDateTime(dtVar)
	End If
	
processError:
	Set GetQueryDate = dt
	Exit Function
	
End Function
Function GetMonthlyData (dt As NotesDateTime, highlightDate As Integer) As String
	'** this is the function that will display a monthly calendar,
	'** which is the default calendar format. To adjust the look
	'** and feel of the calendar, you can play with the HTML tags
	'** directly in this code, or modify the CSS styles, as defined in
	'** the Declarations section as a string constant.
	Dim returnString As String
	Dim tag As String
	Dim link As String
	Dim hday As Integer
	Dim dayNum As Integer
	Dim i As Integer
	
	'** hday is the day we're supposed to highlight, if the
	'** highlightDate flag is True
	hday = Day(dt.DateOnly)
	
	'** start with the first day of this month, and grab a
	'** reference to the previous and next months for
	'** later use
	Call dt.AdjustDay(1 - hday)
	
	Dim lastMonth As New NotesDateTime(dt.DateOnly)
	Call lastMonth.AdjustMonth(-1)
	Dim nextMonth As New NotesDateTime(dt.DateOnly)
	Call nextMonth.AdjustMonth(1)
	
	'** start writing out the HTML string we'll be sending back
	returnString = |
<html>
<head>
<title>QuickCal Monthly</title>
| & css & |
</head>
<body>
<table cols=7 class='calendarTable'>
<tr class='calendarTitleTR'>
  <td class='calendarButtonTD'>
<input type='button' value='&lt;' onClick='location.href="| & _
GetLink(lastMonth, CAL_MONTHLY, False) & |";' class='calendarButton'>
</td>
  <td colspan=5 class='calendarTitleTD'><div class='calendarTitleText'>
| & monthArrayLong(Month(dt.DateOnly) - 1) & | | & _
Year(dt.DateOnly) & | </div></td>
  <td class='calendarButtonTD'>
<input type='button' value='&gt;' onClick='location.href="| & _
GetLink(nextMonth, CAL_MONTHLY, False) & |";' class='calendarButton'>
</td>
</tr>
|
	
	'** names of days of the week
	returnString = returnString & |<tr class='calendarDayTR'>|
	Forall dayName In dayArrayShort
		returnString = returnString & |
  <td class='calendarDayTD'>| & dayName & |</td>|
	End Forall
	returnString = returnString & newline & |</tr>| & newline
	
	'** leading blanks prior to the first day
	returnString = returnString & |<tr class='calendarTR'>| & newline
	For i = 2 To Weekday(dt.DateOnly)
		returnString = returnString & |<td class='calendarTD'>&nbsp;</td>|
	Next
	
	'** all the days of the month (with links, if there are
	'** any events/meetings on a particular day)
	Do
		dayNum = Day(dt.DateOnly)
		tag = r5Replace(r5Replace(GetTag(dt), "<b>", ""), "</b>", "")
		tag = r5Replace(tag, "<br>", newline)
		link = GetLink(dt, CAL_DAILY, False)
		
		'** if there is anything scheduled for this day, turn the
		'** day into a link (for convenience, we're using a title
		'** in the link so the user can just hover over it to see
		'** what's going on that day)
		If (Len(tag) > 0) Then
			link = |<a href="| & link & |" title="| & tag & |" target="_self">| & dayNum & |</a>|
		Else
			link = Cstr(dayNum)
		End If
		
		'** if we're supposed to highlight the day, we will
		If (highlightDate And (hday = dayNum)) Then
			returnString = returnString & |  <td class='calendarDayHighlightTD'>
<div class='calendarDayHighlight'>| & link & |</div>
</td>| & newline
		Else
			returnString = returnString & |  <td class='calendarTD'>| & link & _
			|</td>| & newline
		End If
		
		'** if this is the end of a row, start a new one
		If (Weekday(dt.DateOnly) = 7) Then
			returnString = returnString & |</tr><tr>| & newline
		End If
		
		'** advance to the next day and continue
		Call dt.AdjustDay(1)
	Loop Until (Day(dt.DateOnly) = 1)
	
	'** fill in any trailing blanks
	For i = Weekday(dt.DateOnly) To 2 Step -1
		returnString = returnString & |<td class='calendarTD'>&nbsp;</td>|
	Next
	returnString = returnString & |</tr>| & newline
	
	'** add a button that allows us to easily return to today
	Dim dtToday As New NotesDateTime(Today)
	returnString = returnString & |<tr class='calendarTodayButtonTR'>
<td colspan=7 class='calendarTodayButtonTD'>
<input type='button' value='Today is | & _
dayArrayMed(Weekday(Today) - 1) & |, | & _
monthArrayMed(Month(Today) - 1) & | | & _
Day(Today) & |' onClick='location.href="| & _
GetLink(dtToday, CAL_MONTHLY, True) & |";' class='calendarTodayButton'>
</td>
</tr>| & newline
	
	'** also add some links that let the user open the real
	'** calendar on the web or in Notes
	returnString = returnString & |<tr>
<td colspan=7>| & GetRealCalendarLinks() & |</td>
</tr>|
	
	'** close the table and return
	returnString = returnString & |
</table>
</body>
</html>
	|
	
	GetMonthlyData = returnString
End Function
Function GetWeeklyData (dt As NotesDateTime, highlightDate As Integer) As String
	'** the weekly calendar is left as an exercise for the reader  ;-)
	GetWeeklyData = GetMonthlyData(dt, highlightDate)
End Function
Function GetDailyData (dt As NotesDateTime, highlightDate As Integer) As String
	'** this is the function that will display a daily calendar page.
	'** To adjust the look and feel, you can play with the HTML tags
	'** directly in this code, or modify the CSS styles, as defined in
	'** the Declarations section as a string constant.
	Dim returnString As String
	Dim tag As String
	
	'** we'll need a reference to the previous and next days
	Dim prevDay As New NotesDateTime(dt.DateOnly)
	Call prevDay.AdjustDay(-1)
	Dim nextDay As New NotesDateTime(dt.DateOnly)
	Call nextDay.AdjustDay(1)
	
	'** start writing out the HTML string we'll be sending back
	returnString = |
<html>
<head>
<title>QuickCal Daily</title>
| & css & |
</head>
<body>
<table cols=3 class='calendarTable' width=200>
<tr class='calendarTitleTR'>
  <td class='calendarButtonTD'>
<input type='button' value='&lt;' onClick='location.href="| & _
GetLink(prevDay, CAL_DAILY, False) & |";' class='calendarButton'>
</td>
  <td class='calendarTitleTD'><div class='calendarTitleText'>
| & dayArrayMed(Weekday(dt.DateOnly) - 1) & |, | & _
Day(dt.DateOnly) & | | & _
monthArrayMed(Month(dt.DateOnly) - 1) & | | & _
Year(dt.DateOnly) & |</div></td>
  <td class='calendarButtonTD'>
<input type='button' value='&gt;' onClick='location.href="| & _
GetLink(nextDay, CAL_DAILY, False) & |";' class='calendarButton'>
  </td>
</tr>
|
	
	'** this is a list of the things that are planned for this day,
	'** if anything
	tag = r5Replace(GetTag(dt), "<br><br>", "<br><hr><br>")
	If (Len(tag) = 0) Then
		tag = "<br>** nothing is planned **<br>"
	End If
	tag = tag & "<br>"
	returnString = returnString & |<tr class='calendarTR'>
<td colspan=3 class='calendarDailyInfoTD'>| & tag & |</td>
</tr>|
	
	'** give the user a way to return to the monthly calendar
	returnString = returnString & |<tr>
<td colspan=3>switch to <a href='| & _
GetLink(dt, CAL_MONTHLY, False) & _
|' target='_self'>| & |monthly view</a></td>
</tr>|
	
	'** add a button that allows us to easily return to today
	Dim dtToday As New NotesDateTime(Today)
	returnString = returnString & |<tr class='calendarTodayButtonTR'>
<td colspan=3 class='calendarTodayButtonTD'>
<input type='button' value='Today is | & _
dayArrayMed(Weekday(Today) - 1) & |, | & _
monthArrayMed(Month(Today) - 1) & | | & _
Day(Today) & |' onClick='location.href="| & _
GetLink(dtToday, CAL_DAILY, True) & |";' class='calendarTodayButton'>
</td>
</tr>| & newline
	
	'** also add some links that let the user open the real
	'** calendar on the web or in Notes
	returnString = returnString & |<tr>
	<td colspan=3>| & GetRealCalendarLinks() & |</td>
</tr>|
	
	'** close the table and return
	returnString = returnString & |
</table>
</body>
</html>
	|
	
	GetDailyData = returnString
End Function
Function GetQueryElement (queryString As String, elementName As String) As String
	'** get the value of a particular element in the query string
	Dim qe As String
	Dim pos As Integer
	
	pos = Instr(1, queryString, elementName, 5)
	If (pos > 0) Then
		qe = Mid$(queryString, pos + Len(elementName) + 1)
	Else
		Exit Function
	End If
	
	pos = Instr(1, qe, "&", 5)
	If (pos > 0) Then
		qe = Left$(qe, pos - 1)
	End If
	
	GetQueryElement = Trim(Ucase(qe))
End Function
Function GetTag (dt As NotesDateTime) As String
	'** get all of the calendar items for this particular day
	Dim session As New NotesSession
	Dim db As NotesDatabase
	Static view As NotesView
	Dim doc As NotesDocument
	Dim ve As NotesViewEntry
	Dim vc As NotesViewEntryCollection
	Dim tag As String
	
	'** use a static reference to the view, so we don't have to
	'** grab a handle to it every time we use this function
	'** (which could be up to 31 times for a monthly lookup)
	If (view Is Nothing) Then
		Set db = session.CurrentDatabase
		'** the Meetings view shows multiple-day events only on
		'** the first day... create your own view if you don't like that
		Set view = db.GetView("Meetings")
	End If
	
	'** the first sorted column in the Meetings view has Date/Time
	'** values, so we'll want to do the lookup with a NotesDateRange
	Dim dateRange As NotesDateRange
	Set dateRange = session.CreateDateRange()
	dateRange.Text = dt.DateOnly & " 12:00:00 AM - " & dt.DateOnly & " 11:59:59 PM"
	
	'** grab all the entries for this date and list some basic information
	Set vc = view.GetAllEntriesByKey(dateRange)
	Set ve = vc.GetFirstEntry
	Do Until (ve Is Nothing)
		Set doc = ve.Document
		tag = tag & |<br><b>| & _
		Format(doc.StartDateTime(0), "h:mm AM/PM") & | - | & _
		Format(doc.EndDateTime(0), "h:mm AM/PM") & |</b><br>| & _
		doc.Subject(0) & | <br>|
		Set ve = vc.GetNextEntry(ve)
	Loop
	
	'** change any double-quotes to single-quotes (in case this ends up
	'** getting referenced in a quoted string), and return
	GetTag = r5Replace(tag, |"|, |'|)
End Function
Function GetLink (dt As NotesDateTime, calType As Integer, _
doHighlight As Integer) As String
	'** create a URL that would run this agent using a particular
	'** date, format, and highlight preference
	Select Case calType
	Case CAL_MONTHLY :
		GetLink = agentURL & "?OpenAgent&date=" & dt.DateOnly & _
		"&display=monthly&highlight=" & doHighlight
	Case CAL_WEEKLY :
		GetLink = agentURL & "?OpenAgent&date=" & dt.DateOnly & _
		"&display=weekly&highlight=" & doHighlight
	Case CAL_DAILY :
		GetLink = agentURL & "?OpenAgent&date=" & dt.DateOnly & _
		"&display=daily&highlight=" & doHighlight
	End Select
End Function
Function GetRealCalendarLinks () As String
	'** return some URLs that will open this calendar
	'** either on the web or from the Notes client
	Dim session As New NotesSession
	Dim db As NotesDatabase
	Dim serverName As String
	Dim webLink As String
	Dim notesLink As String
	
	Set db = session.CurrentDatabase
	
	'** fully qualified server names don't always work in notes://
	'** references, so make sure to get just the common server name
	serverName = db.Server
	If (Left$(serverName, 3) = "CN=") Then
		serverName = Mid$(serverName, 4, Instr(serverName, "/") - 4)
	End If
	
	webLink = Strleftback(agentURL, "/") & "/Calendar?OpenView"
	notesLink = r5Replace(r5Replace("notes://" & serverName & "/" & _
	db.FilePath & "/Calendar?OpenView", "\", "/"), " ", "+")
	
	GetRealCalendarLinks = |Open Calendar: <a href='| & webLink & _
	|' target='_blank'>web</a> or <a href='#' onClick='noteswin=window.open("| &_
	notesLink & |"); noteswin.close();' target='_self'>notes</a>|
	
End Function
Function r5Replace (Byval fullString As String, oldString As String, newString As String) As String
	'** in case you're not using release 6 or higher yet, here's a version of the Replace
	'** function that you can use
	On Error Goto processError
	
	Dim tempString As String
	Dim tempString2 As String
	Dim lenOldString As Integer
	Dim pos As Integer
	
	'** If the user passes us bogus values, just exit
	If (fullString = "") Or (oldString = "") Then
		r5Replace = fullString
		Exit Function
	End If
	
	'** initialize the variables
	tempString = fullString
	lenOldString = Len(oldString)
	pos = Instr(tempString, oldString)
	
	'** get all the matches in the string, building a new string as we go
	Do While (pos > 0)
		tempString2 = tempString2 & Left$(tempString, pos - 1) & newString
		tempString = Mid$(tempString, pos + lenOldString)
		pos = Instr(tempString, oldString)
	Loop
	
	'** add anything that's left in the original string to the end of
	'** the return string
	tempString2 = tempString2 & tempString
	r5Replace = tempString2
	
	Exit Function
	
processError:
	'** error 228 is String Too Large
	Dim errMess As String
	errMess = "Error " & Err & ": " & Error$
	r5Replace = fullString
	Exit Function
	
End Function
Function r5Split (thisText As String, delim As String) As Variant
	'** convert a string to an array, separating at the specified delimiter
	'** (if you're using release 6 or higher, you can just use the built-in
	'** Split function)
	Dim temparray() As String
	Dim tempstring As String
	Dim delimlength As Integer
	Dim pos As Integer
	Dim i As Integer
	
	tempstring = thisText
	delimlength = Len(delim)
	pos = Instr(1, tempstring, delim, 5)
	i = 0
	
	Do While (pos > 0)
		'** add a placeholder in the array for the new element
		Redim Preserve temparray(i) As String
		
		'** get the substring
		temparray(i) = Left$(tempstring, pos - 1)
		
		'** reset the variables
		tempstring = Right$(tempstring, Len(tempstring) - pos - delimlength + 1)
		pos = Instr(1, tempstring, delim, 5)
		i = i + 1
	Loop
	
	'** make sure you get the stuff at the end of the string
	Redim Preserve temparray(i) As String
	temparray(i) = tempstring$
	
	'** return the array as a result
	r5Split = temparray
	
End Function