<%Option Explicit%> <% Response.Write "" & vbNewLine & _ "" & vbNewLine & _ "Choose Your Birthdate" & vbNewLine & _ "" & vbNewLine Rem -Get info from Application Variables dim strCookieURL, strTimeAdjust, strForumTimeAdjust strCookieURL = Left(Request.ServerVariables("Path_Info"), InstrRev(Request.ServerVariables("Path_Info"), "/")) strTimeAdjust = Application(strCookieURL & "STRTIMEADJUST") strForumTimeAdjust = DateAdd("h", strTimeAdjust , Date()) Rem -Color and Font vars dim strDefaultFontFace,strDefaultFontSize,strHeaderFontSize,strFooterFontSize dim strPageBGColor,strDefaultFontColor,strHeadCellColor,strHeadFontColor dim strCategoryCellColor,strCategoryFontColor,strForumCellColor,strAltForumCellColor dim strForumFontColor,strForumLinkColor,strForumLinkTextDecoration,strForumVisitedLinkColor dim strForumVisitedTextDecoration,strForumActiveLinkColor,strForumActiveTextDecoration dim strForumHoverFontColor,strForumHoverTextDecoration,strTableBorderColor,strHiLiteFontColor dim strPageBGImageURL strDefaultFontFace = Application(strCookieURL & "STRDEFAULTFONTFACE") strDefaultFontSize = Application(strCookieURL & "STRDEFAULTFONTSIZE") strHeaderFontSize = Application(strCookieURL & "STRHEADERFONTSIZE") strFooterFontSize = Application(strCookieURL & "STRFOOTERFONTSIZE") strPageBGColor = Application(strCookieURL & "STRPAGEBGCOLOR") strDefaultFontColor = Application(strCookieURL & "STRDEFAULTFONTCOLOR") strHeadCellColor = Application(strCookieURL & "STRHEADCELLCOLOR") strHeadFontColor = Application(strCookieURL & "STRHEADFONTCOLOR") strCategoryCellColor = Application(strCookieURL & "STRCATEGORYCELLCOLOR") strCategoryFontColor = Application(strCookieURL & "STRCATEGORYFONTCOLOR") strForumCellColor = Application(strCookieURL & "STRFORUMCELLCOLOR") strAltForumCellColor = Application(strCookieURL & "STRALTFORUMCELLCOLOR") strForumFontColor = Application(strCookieURL & "STRFORUMFONTCOLOR") strForumLinkColor = Application(strCookieURL & "STRFORUMLINKCOLOR") strForumLinkTextDecoration = Application(strCookieURL & "STRFORUMLINKTEXTDECORATION") strForumVisitedLinkColor = Application(strCookieURL & "STRFORUMVISITEDLINKCOLOR") strForumVisitedTextDecoration = Application(strCookieURL & "STRFORUMVISITEDTEXTDECORATION") strForumActiveLinkColor = Application(strCookieURL & "STRFORUMACTIVELINKCOLOR") strForumActiveTextDecoration = Application(strCookieURL & "STRFORUMACTIVETEXTDECORATION") strForumHoverFontColor = Application(strCookieURL & "STRFORUMHOVERFONTCOLOR") strForumHoverTextDecoration = Application(strCookieURL & "STRFORUMHOVERTEXTDECORATION") strTableBorderColor = Application(strCookieURL & "STRTABLEBORDERCOLOR") strHiLiteFontColor = Application(strCookieURL & "STRHILITEFONTCOLOR") Response.Write "" & vbNewLine & _ "" & vbNewLine & _ "" & vbNewLine Rem -You can pass in a date... path/filename.asp?date=5/6/2003 It defaults to Todays date Rem -To turn on a no select date after today pass in "History=on" in the url Rem -Changed by Rakesh Jain(GauravBhabu) function GetDaysInMonth(ByVal iMonth, ByVal iYear) dim arrDaysInMonth arrDaysInMonth = Array(31,28,31,30,31,30,31,31,30,31,30,31) if isLeapYear(iYear) then arrDaysInMonth(1) = 29 GetDaysInMonth = arrDaysInMonth(iMonth -1) end Function Rem -This Procedure checks for leap year Rem -Added by Rakesh Jain(GauravBhabu) function IsLeapYear(ByVal intYear) 'As Integer) As Boolean IsLeapYear = False if (intYear Mod 100 = 0) then if (intYear Mod 400 = 0) then IsLeapYear = True elseif (intYear Mod 4 = 0) then IsLeapYear = True end if end function function GetWeekdayMonthStartsOn(ByVal dAnyDayInTheMonth) dim dTemp Rem -Deduct (Day Of Month - 1) from date to Get the date on first day of Month dTemp = DateAdd("d", -(Day(dAnyDayInTheMonth) - 1), dAnyDayInTheMonth) GetWeekdayMonthStartsOn = WeekDay(dTemp) end function Rem -Changed by Rakesh Jain(GauravBhabu) function PreviousMonth(ByVal dDate) dim dtePrevMonth dtePrevMonth = DateAdd("m", -1, dDate) PreviousMonth = dtePrevMonth end function Rem -Changed by Rakesh Jain(GauravBhabu) function NextMonth(ByVal dDate) dim dteNextMonth dteNextMonth = DateAdd("m", 1, dDate) if Month(dteNextMonth) > Month(strForumTimeAdjust) and Year(dteNextMonth) = Year(strForumTimeAdjust) then dteNextMonth = strForumTimeAdjust end if NextMonth = dteNextMonth end function Rem -This procedure writes the days of month for the calendar Rem -Added by Rakesh Jain(GauravBhabu) sub WriteDayOfMonth(ByVal strDate, ByVal strClass, ByVal intDay, ByVal blnOnClick) Dim strDayLink, strOnClick, strCellColor, strBoxTitle strBoxTitle = "" if blnOnClick then strBoxTitle = FormatdateTime(dCell,vbLongdate) strOnClick = " onclick=""" & strReturnFunc & """" if strClass = "" then strCellColor = strForumFontColor strDayLink = "" & intDay & "" else strCellColor = strForumCellColor strDayLink = "" & intDay & "" end if else strCellColor = strAltForumCellColor strDayLink = intDay end if Response.Write " " & strDayLink & "

" & vbNewLine end sub function SetMonthSelection(i_intMonth) if i_intMonth = Month(dDate) then SetMonthSelection = (" selected") end if end function sub SetYearSelection(i_intYear) if i_intYear = Year(dDate) then SetYearSelection = (" selected") end if end sub Rem -Append zeros to the left of single digit Months and days function doublenum(fNum) if fNum > 9 then doublenum = fNum else doublenum = "0" & fNum end if end function function IsValidDate(strDOBDate) dim intYear, intMonth, intDay IsValidDate = false if IsNumeric(strDOBDate) then if len(strDOBDate) = 8 then intYear = cLng(Left(strDOBDate,4)) intMonth = clng(Mid(strDOBDate,5,2)) intDay = cLng(Mid(strDOBDate,7,2)) if IsValidYear(intYear) then if IsValidMonth(intMonth) then if IsValidDay(intYear,intMonth,intDay) then IsValidDate = true end if end if end if end if end function function IsValidYear(ByVal intYear) IsValidYear = false if (intYear > 1900) and (intYear <= Year(Date)) then IsValidYear = true end function function IsValidMonth(ByVal intMonth) IsValidMonth = false if intMonth > 0 and intMonth < 13 then IsValidMonth = true end function function IsValidDay(ByVal intYear,ByVal intMonth,ByVal intDay) dim arrDaysInMonth arrDaysInMonth = Array(31,28,31,30,31,30,31,31,30,31,30,31) IsValidDay = false if IsLeapYear(intYear) then arrDaysInMonth(1) = 29 if (intDay) <= arrDaysInMonth(intMonth-1) then IsValidDay = true end function Rem -End Function Declaration dim dDate : Rem -Date we're displaying calendar for dim iDIM : Rem -Days In Month dim iDOW : Rem -Day Of Week that month starts on dim iCurrent : Rem -Variable we use to hold current day of month as we write table dim iPosition : Rem -Variable we use to hold current position in table dim strDOBDate : Rem -Holds the date of Birth if there is one - YYYYMMDD dim strReturnFuncEmpty Rem -Get selected date. There are two ways to do this. Rem -First check if we were passed a full date in RQS("date"). Rem -If so use it, if not look for seperate variables, putting them togeter into a date. Rem -Lastly check if the date is valid...if not use today if IsDate(Request.QueryString("date")) then Rem -This is date when navigating the calendar Rem -This should be a date as per locale Format dDate = cDate(Request.QueryString("date")) elseif IsValidDate(Request.QueryString("date")) then Rem -This is when user edits Date of Birth Rem -This should be in YYYYMMDD Format strDOBDate = Request.QueryString("date") dDate = cDate(Mid(strDOBDate,7,2) & "-" & MonthName(Mid(strDOBDate, 5,2)) & "-" & Mid(strDOBDate, 1,4)) else '****************** Put as one *********** Rem -Assign a Default date to dDate variable dDate = DateAdd("yyyy", -13, strForumTimeAdjust) dDate = DateValue(dDate) if Request("day") <> "" and Request("month") <> "" and Request("year") <> "" then Rem -This will be the date when User clicks on Go Button if IsDate(Request("day") & "-" & MonthName(Request("month")) & "-" & Request("year")) Then dDate = cDate(Request("day") & "-" & MonthName(Request("month")) & "-" & Request("year")) end if end if end if Response.Write "
" & vbNewLine & _ "" & vbNewLine & _ "" & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ "
" & vbNewLine Rem -Month Select Box dim intLastMonth Rem -Restrict the available Dates to Today if Year(dDate) = Year(strForumTimeAdjust) then intLastMonth = Month(strForumTimeAdjust) else intLastMonth = 12 end if if Month(dDate) >= intLastMonth and Year(dDate) >= Year(strForumTimeAdjust) then if Day(dDate) > Day(strForumTimeAdjust) then dDate = DateSerial(Year(dDate),intLastMonth, 1) else dDate = DateSerial(Year(dDate),intLastMonth, Day(dDate)) end if end if Rem -Days in Month iDIM = GetDaysInMonth(Month(dDate), Year(dDate)) Rem -Day of Week on First of Month iDOW = GetWeekdayMonthStartsOn(dDate) dim iMonth 'Counter to fill the Month Select Box Response.Write " " & vbNewLine Rem -Year Select Box dim int_YearCntr Response.Write " " & vbNewLine & _ " " & vbNewLine & _ "
" & vbNewLine Rem -Calendar Navigation Response.Write "" & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine Rem -Weekday Names Response.Write " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ "
" & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ "
<<" & MonthName(Month(dDate)) & " " & Year(dDate) & "" if NextMonth(dDate) <> strForumTimeAdjust then Response.Write(">>") else Response.Write(" ") Response.Write "
" & vbNewLine & _ "
" & vbNewline & _ " " & vbNewline & _ " " & vbNewLine dim iWeekDayName for iWeekDayName = 1 to 7 Response.Write " " & vbNewLine next Response.Write " " & vbNewLine strReturnFuncEmpty = "returnDate(' '); " Rem -Write spacer cells at beginning of first row if month doesn't start on a Sunday. if iDOW <> 1 then iPosition = iDOW Response.Write " " & vbNewLine & _ " " & vbNewLine end if Rem -Write days of month in proper day slots Dim strReturnFunc, dCell, strClass, blnOnClick iCurrent = 1 iPosition = iDOW 'dDate = DateValue(dDate) do while iCurrent <= iDIM Rem -If we're at the begginning of a row then write tr Rem -If we're at the endof a row then write /tr if iPosition > 7 then Response.Write " " & vbNewLine iPosition = 1 end if if iPosition = 1 then Response.Write " " & vbNewLine end if dCell = DateSerial(Year(dDate), Month(dDate), iCurrent) Rem -Get the current date in string Format (YYYYMMDD) strReturnFunc = "returnDate('" & Year(dDate) & doublenum(Month(dDate)) & doublenum(iCurrent) & "');" Rem -if Cell contains todays Date then highlight if dCell = dDate then 'and dDate < strForumTimeAdjust then strClass = "" blnOnClick = true Rem -if we are in the past then if history is 'off' the show cell disabled elseif dCell <= strForumTimeAdjust then if Request("History") = "on" then strClass = "" blnOnClick = false else strClass = "spnMessageText" blnOnClick = true end if Rem -else must be in the future else strClass = "" blnOnClick = false end if Call WriteDayOfMonth(strReturnFunc, strClass, iCurrent, blnOnClick) Rem -Increment variables iCurrent = iCurrent + 1 iPosition = iPosition + 1 loop Rem -Write spacer cells at end of last row if month doesn't end on a Saturday. iPosition = iPosition - 1 if iPosition < 7 then Response.Write " " & vbNewLine & _ " " & vbNewLine end if Response.Write "
" & WeekDayName(iWeekDayName, True) & "
 

 

" & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ " " & vbNewLine & _ "
Birthdate Selection/Removal:
  • Select Month and Year and press GO,
        then click on the date.
  • Click on ClearDOB to remove the Birthdate.
  • " & vbNewLine & _ "
    " & vbNewLine & _ "
    " & vbNewLine & _ "" & vbNewLine & _ "" & vbNewline %>