<%@ Language="VBSCRIPT" %> <% ' Generic Database - CalendarView Records ' Notice: (c) 2000 Douglas LaMar, All Rights Reserved. ' E-Mail: dlamar@lamarsoft.com ' URL: http://www.lamarsoft.com/asp/ ' ' Notice: Additional (c) 1998, 1999 Eli Robillard, All Rights Reserved. ' E-Mail: erobillard@ofifc.org ' URL: http://www.ofifc.org/Eli/ASP/ ' ' Look out for: ' - Look out for: If two config files use the same dbRS, when jumping from one to the other the session vars won't be blanked. ' - Why: Session vars are reset on opening a new config file. Does so using dbRS to see if a different recordset is being opended. ' Revision History: ' ' '=============================================================== ' This section slightly modified from Robillard's Generic files '=============================================================== On Error Resume Next ' Set up 'Option Explicit ' Prevent caching Response.Buffer = True Response.ExpiresAbsolute = Now() - 1 Response.AddHeader "cache-control", "must-revalidate" Response.AddHeader "cache-control", "private" Response.AddHeader "pragma", "no-cache" Dim QUOTE, LT, GT Dim strEditor, strType, strConn, strDisplay, strSearchFields Dim strFields, strTable, strWhere, strGroupBy, strHaving, strOrderBy, strFieldNames, strFont Dim intAllowSort, intOrderBy, intPrimary, intFontSize, intHidePageNumbers Dim intDisplayRecs, intStartRec, intStopRec, intTotalRecs, intFieldCount Dim strBorderColor, strMenuColor, strMenuTextColor, bgcolor Dim strInMonthCellColor, strNotInMonthCellColor, strCalendarBorderColor Dim strCalendarBorderTextColor, strCalendarDateTextColor, strCalendarEventTextColor, strCalendarDOWTextColor Dim dEventDate, iThisMonth, iThisYear, iPrevMonth, iNextMonth, iPrevYear, iNextYear Dim iFirstWeekDay, iNoDays, iDay, iRows, iLoop, iMonthIndex, iYearIndex Dim sScript, xConn, xrs, strSQL Dim strMonthYearFormPos, strPassThru QUOTE = chr(34) LT = chr(60) GT = chr(62) intAllowSort = 1 bgcolor="#FFFFCC" sScript = Request.ServerVariables("SCRIPT_NAME") ' Get the executing script's page intDisplayRecs = 10000 ' Dont limit the number of records shown on the calendar intStartRec = 1 ' Start at the first record ' Check for parameters, if we jump in another direction we need to pass them on strPassThru = "?" if Request.QueryString("EventDate").Count > 0 Then strPassThru = strPassThru & "EventDate=" & Request.Querystring("EventDate") if strPassThru = "?" then strPassThru = "" end if '=============================================================== ' This is Calendar-Specific code ' Check the RequestForm for a Date If (Request.Form("Date") & "x") = "x" Then ' No Date Passed by form POST If strPassThru = "" Then ' No date passed in the QueryString, so use today dEventDate = FormatDateTime(Date(), vbShortDate) 'Get EventDates date into a variable called dEventDate Else ' Something WAS passed in the QueryString dEventDate = CDate(URLDecode(Request.QueryString("EventDate"))) End If Else ' Use the passed date dEventDate = URLDecode(Request.Form("Date")) End if '=============================================================== ' Quick security check, make sure we have an active session If Session("dbRs") = "" Then Response.Clear Response.Redirect "GenericError.asp" End If ' Check which editor to use for Add and Edit links If Session("dbEditTemplate") & "x" = "x" Then strEditor = "GenericEdit.asp" Else strEditor = "GenericCustomEdit.asp" End if ' If this is the first time through, blank the vars. If Trim(Session("dbLastRs")) <> Trim(Session("dbRs")) Then Session("dbLastRs") = Session("dbRs") Response.Clear Response.Redirect Session("dbGenericPath") & "GenericExit.asp?CMD='Reset'" End If ' Get the settings from the Config File strType = UCase(Session("dbType")) strConn = Session("dbConn") strDisplay = Session("dbDispList") strSearchFields = Session("dbSearchFields") strMonthYearFormPos = UCase(Trim(Session("dbMonthYearFormPos"))) strFields = Session("dbFields") strTable = Session("dbRs") strGroupBy = Session("dbGroupBy") strHaving = Session("dbHaving") strOrderBy = Session("dbOrderBy") strFieldNames = Session("dbFieldNames") intOrderBy = Session("dbOrder") intPrimary = Session("dbKey") strFont = Session("dbFont") intFontSize = Session("dbFontSize") intHidePageNumbers = Session("dbHidePageNumbers") strBorderColor = Session("dbBorderColor") strMenuColor = Session("dbMenuColor") strMenuTextColor = Session("dbMenuTextColor") Session("ErrorNumber") = 0 strInMonthCellColor = Session("dbInMonthCellColor") strNotInMonthCellColor = Session("dbNotInMonthCellColor") strCalendarBorderColor = Session("dbCalendarBorderColor") strCalendarBorderTextColor = Session("dbCalendarBorderTextColor") strCalendarDateTextColor = Session("dbCalendarDateTextColor") strCalendarEventTextColor = Session("dbCalendarEventTextColor") strCalendarDOWTextColor = Session("dbCalendarDOWTextColor") strWhere = "Month(StartDate) = " & Month(dEventDate) & " OR Month(EndDate) = " & Month(dEventDate) strWhere = strWhere & " OR (Month(StartDate) < " & Month(dEventDate) & " AND Month(EndDate) > " & Month(dEventDate) & ")" ' Check and set fonts and colours If Trim(strFont) = "" Then strFont = "Verdana, Arial, Helvetica" If Not (intFontSize > 0) Then intFontSize = 2 If Trim(strBorderColor) = "" Then strBorderColor = "#99CCCC" If Trim(strMenuColor) = "" Then strMenuColor = "#99CCCC" If Trim(strMenuTextColor) = "" Then strMenuTextColor = "Black" If NOT (Trim(Session("dbExitPageText")) = "") Then txtExit = Session("dbExitPageText") If strMonthYearFormPos <> "TOP" Then strMonthYearFormPos = "BOTTOM" If Trim(strInMonthCellColor) = "" Then strInMonthCellColor = "#cccccc" ' Light Gray If Trim(strNotInMonthCellColor) = "" Then strNotInMonthCellColor = "#999999" ' Medium Gray If Trim(strCalendarBorderColor) = "" Then strCalendarBorderColor = "#666666" ' Dark Gray If Trim(strCalendarBorderTextColor) = "" Then strCalendarBorderTextColor = "blue" If Trim(strCalendarDateTextColor) = "" Then strCalendarDateTextColor = "black" If Trim(strCalendarEventTextColor) = "" Then strCalendarEventTextColor = "white" If Trim(strCalendarDOWTextColor) = "" Then strCalendarDOWTextColor = "black" ' Is a field list provided If Trim(strFields) = "" Then strFields = "*" Session("dbFields") = "*" End If ' Check for an Order parameter If Request.QueryString("ORDER").Count > 0 Then ' Check if an ASC/DESC toggle is required (- for desc, + for asc) if abs(intOrderBy) = abs(Request.QueryString("ORDER")) then intOrderBy = 0 - intOrderBy else intOrderBy = Request.QueryString("ORDER") end if Session("dbOrder") = intOrderBy End If 'Set the last record to display intStopRec = intStartRec + intDisplayRecs - 1 ' Open Connection to the database set xConn = Server.CreateObject("ADODB.Connection") xConn.Open strConn ' Build Query strSQL = "SELECT " & strFields & " FROM [" & strTable & "]" Select Case strType Case "UDF" strSQL = "SELECT " & strFields & " FROM " & strTable Case "SQL" strSQL = Replace(strsql,"[","") strSQL = Replace(strsql,"]","") End Select If Not Trim(strGroupBy) = "" Then strSQL = strSQL & " GROUP BY " & strGroupBy intAllowSort = 0 End If ' Open recordset set xrs = Server.CreateObject("ADODB.Recordset") xrs.Open strSQL, xConn ' Call Error Handler if query bombs If Err.Number <> 0 Then Session("ErrNumber") = Err.Number Session("ErrDesc") = Err.Description Session("ErrSource") = Err.Source Session("ErrLine") = Err.Line Session("ErrMsg") = "Query: " & strSQL Response.Clear Response.Redirect "GenericError.asp" End If intFieldCount = xrs.Fields.Count Dim aFields() ReDim aFields(intFieldCount,4) ' Get field info If Trim(Session("dbFieldNames")) & "x" = "x" Then ReDim arrFieldNames(intFieldCount) For x = 1 to intFieldCount aFields(x, 1) = xrs.Fields(x-1).Name aFields(x, 2) = xrs.Fields(x-1).Type aFields(x, 3) = xrs.Fields(x-1).DefinedSize aFields(x, 4) = 0 ' For running totals (per dbTotalFields) arrFieldNames(x-1) = xrs.Fields(x-1).Name Next Else For x = 1 to intFieldCount aFields(x, 1) = xrs.Fields(x-1).Name aFields(x, 2) = xrs.Fields(x-1).Type aFields(x, 3) = xrs.Fields(x-1).DefinedSize aFields(x, 4) = 0 Next arrFieldNames = Split(Session("dbFieldNames"), ",") End If ' Are totals required (NEVER!) If Trim(strTotalFields) = "" Then strTotalFields = String(intFieldCount,"0") xrs.Close Set xrs = Nothing ' Reopen the Recordset, this time use the parameters passed strSQL = "SELECT " & strFields & " FROM [" & strTable & "]" Select Case strType Case "UDF" strSQL = "SELECT " & strFields & " FROM " & strTable Case "SQL" strSQL = Replace(strSQL,"[","") strSQL = Replace(strSQL,"]","") End Select If (strWhere & "x") <> "x" Then strSQL = strSQL & " WHERE " & strWhere If NOT Trim(strGroupBy) = "" Then strSQL = strSQL & " GROUP BY " & strGroupBy If NOT Trim(strHaving) = "" Then strSQL = strSQL & " HAVING " & strHaving If intOrderBy <> 0 Then if intOrderBy > 0 then strSQL = strSQL & " ORDER BY [" & aFields(intOrderBy, 1) & "]" else strSQL = strSQL & " ORDER BY [" & aFields(abs(intOrderBy), 1) & "] DESC" end if Else ' See if a dbOrderBy string was passed. If Trim(strOrderBy) & "x" <> "x" Then strSQL = strSQL & " ORDER BY " & strOrderBy End If If strType = "SQL" Then ' SQL databases do not allow spaces or brackets in table or field names strSQL = Replace(strSQL,"[","") strSQL = Replace(strSQL,"]","") End If set xrs = Server.CreateObject("ADODB.Recordset") xrs.Open strSQL, xConn, 1, 2 ' Call Error Handler if query bombs If Err.Number <> 0 Then Session("ErrNumber") = Err.Number Session("ErrDesc") = Err.Description Session("ErrSource") = Err.Source Session("ErrLine") = Err.Line Session("ErrMsg") = "Query: " & strsql Response.Clear Response.Redirect "GenericError.asp" End If intTotalRecs = xrs.RecordCount '=============================================================== ' This section begins Calendar-Specific code '=============================================================== ' Get the current month and year iThisMonth = Month(dEventDate) iThisYear = Year(dEventDate) ' Get the previous month and year. This is used to create the back image iPrevMonth = Month(DateSerial(iThisYear, iThisMonth - 1, 1)) iPrevYear = Year(DateSerial(iThisYear, iThisMonth - 1, 1)) ' Get the next month and year. This information is used to drive the forward image iNextMonth = Month(DateSerial(iThisYear, iThisMonth + 1, 1)) iNextYear = Year(DateSerial(iThisYear, iThisMonth + 1, 1)) ' Determine what day the first of the month falls iFirstWeekDay = WeekDay(DateSerial(iThisYear, iThisMonth, 1)) ' Determine the number of days in the month iNoDays = Day(DateSerial(iThisYear, iThisMonth + 1, 0)) ' Initialize the day to the first cell of the month. If the day does not fall in the month, ' it will have a negative value until the month begins iDay = 2 - iFirstWeekDay %> <%= Session("dbTitle") %> <% If Session("dbBodyTag") & "x" <> "x" Then Response.Write "" Else %> <%End If%>

<% If Session("dbHeader") = 1 Then %> <% End If %>

Home | Add/Edit Events WIDTH="98%"> <%If strMonthYearFormPos = "TOP" Then Response.Write "" & vbCrLf & "" & vbCrLf & "" & vbCrLf End If %> <% ' Create a calendar of 6 rows; 6 is the maximum weeks in any given month For iRows = 1 To 6 Response.Write "" & vbCrLf ' Inner loop prints the days in a week. In ' other words, prints the date columns For iLoop = 1 To 7 ' Check if the day falls within the month. If iDay < 1 Or iDay > iNoDays Then ' No, write a blank cell Response.Write "" & vbCrLf Else ' Yes, the day falls within the month write it. Response.Write "" & vbCrLf ' Close the cell End If ' Increment the day count iDay = iDay + 1 xrs.MoveFirst Next ' Table Cell Response.Write "" & vbCrLf ' Close the table row Next ' Table Row %> <%If strMonthYearFormPos = "BOTTOM" Then Response.Write "" & vbCrLf & "" & vbCrLf & "" & vbCrLf End If %>
<%= Session("dbTitle") %>  
<% If Session("dbPrevImage") & "x" <> "x" Then Response.Write "" Else Response.Write "Prev" End If %>   <%= MonthName(iThisMonth)%> <%= iThisYear%> <% If Session("dbNextImage") & "x" <> "x" Then Response.Write "" Else Response.Write "Next" End If %>  
" & vbCrLf %> <% Response.Write "
>S >M >T >W >T >F >S
 " & vbCrLf & _ "" & iDay & "

" & vbCrLf ' Loop through records and show events for the date here intCount = 0 intActual = 0 Do While (NOT xrs.EOF) AND (intCount < intStopRec) 'For recLoop = 1 to intTotalRecs intCount = intCount + 1 If Cint(intCount) >= Cint(intStartRec) Then intActual = intActual + 1 ' Make a date out of the current day counter dThisDay = FormatDateTime(iThisMonth & "/" & iDay & "/" & iThisYear, vbShortDate) 'Get Field Values for this record x = 0 For Each xField in xrs.Fields x = x + 1 curVal = xField.Value ' Get begin & end dates for this record If xField.Name = "EventID" Then iEventID = Cint(curVal) If xField.Name = "StartDate" Then dStartDate = FormatDateTime(curVal, vbShortDate) If xField.Name = "EndDate" Then dEndDate = FormatDateTime(curVal, vbShortDate) If xField.Value = "" Then dEndDate = "" End If If xField.Name = "EventStartTime" Then tStartTime = curVal If xField.Name = "EventEndTime" Then tEndTime = curVal If xField.Name = "EventTitle" Then sEventTitle = Trim(curVal) If xField.Name = "EventDetails" Then mEventDetails = curVal If xField.Name = "EventURL" Then sEventURL = curVal If xField.Name = "EventContact" Then sEventContact = curVal Next ' Determine display type sShowItAs = "" If CDate(dThisDay) = CDate(dStartDate) Then If CDate(dThisDay) = CDate(dEndDate) Then sShowItAs = "1DayEvent" Else sShowItAs = "EventBegin" End If Else If ((CDate(dStartDate) < CDate(dThisDay)) AND (CDate(dThisDay) < CDate(dEndDate))) Then If iDay = 1 Then sShowItAs = "EventBegin" Else sShowItAs = "EventMiddle" End If Else If CDate(dThisDay) = CDate(dEndDate) Then sShowItAs = "EventEnd" End If End If ' Do I need to output this record? If sShowItAs <> "" Then ' Yes, record output follows ' Write out the record info according to the display type decided above Response.Write "
" Select Case sShowItAs Case "1DayEvent" Response.Write "" &_ " Today " & "
" & tStartTime & " - " & tEndTime & "
" &_ sEventTitle & "
" & sEventContact & "

" Case "EventBegin" Response.Write "" &_ dStartDate & " - " & dEndDate & "
" & tStartTime & " - " & tEndTime & "
" &_ sEventTitle & "
" & sEventContact & "

" Case "EventMiddle" Response.Write "" &_ sEventTitle & " continues...

" Case "EventEnd" Response.Write "" &_ sEventTitle & " ends.

" Case Else End Select Response.Write "
" End If ' No, forget the record this time around End If xrs.MoveNext Loop ' Records Loop 'Next Response.Write "
" & vbCrLf %> <% Response.Write "
 
  <% If Session("dbFooter") = 1 Then %> <% End If %>