Analog Reports

<% Dim strAnalogPath Dim objFSO Dim objRootDir Dim colFolders Dim objFolder Dim colDays Dim objSubDays Dim objRegExp CONST ANALOG_VDIR = "/Analog/" 'Look for Query String Dim sYear Dim sMonthPattern Dim sYearPattern sYear = Request.QueryString("Year") if sYear = "" Then '200601 sMonthPattern = "^" & Year(Now()) & "\d\d$" sYearPattern = "^" & Year(Now()) & "$" Else if IsNumeric(sYear) Then if sYear > 2000 and sYear < 2025 Then sMonthPattern = "^" & sYear & "\d\d$" sYearPattern = "^" & sYear & "$" Else Response.Write "Year must be between 2000 and 2025." Repsonse.end end if Else Response.Write "Year must be a number." Repsonse.end end if End if Set objFSO = Server.CreateObject("Scripting.FileSystemObject") 'Open File System Object strAnalogPath = Server.MapPath(ANALOG_VDIR) Set objRootDir = objFSO.GetFolder(strAnalogPath) Set objRegExp = New RegExp Set colFolders = objRootDir.SubFolders For Each objFolder In colFolders objRegExp.Pattern = sYearPattern If objRegexp.Test(objFolder.Name) Then Call WriteYear(objRootDir, objFolder.Name) End If Next Set objRegExp = New RegExp Set colFolders = objRootDir.SubFolders For Each objFolder In colFolders objRegExp.Pattern = sMonthPattern If objRegexp.Test(objFolder.Name) Then Call WriteMonth(objRootDir, objFolder.Name) End If Next Set objFSO = Nothing Set objRootDir = Nothing Set objRegExp = Nothing Function WriteYear(objRootDir, strYYYY) Dim strYear strYear = Left(strYYYYMM, 4) Response.Write "" & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write "

" & vbCRLF Response.Write " " & strYYYY & "" & vbCRLF Response.Write " Ž " & vbCRLF Response.Write "

" & vbCRLF Response.Write "
" & vbCRLF End Function Function WriteMonth(objRootDir, strYYYYMM) Dim strYear Dim strMonth Dim dtFirstOfMonth Dim dtLastOfMonth Dim iFirstOfMonthDOW Dim iWeeks Dim iDays Dim iCount Dim iCal Dim aCal() Dim dtCurrentDay Dim strWeek CONST TD_START = " " CONST TD_END = "" CONST TD_BLANK = " " strYear = Left(strYYYYMM, 4) strMonth = Right(strYYYYMM, 2) dtFirstOfMonth = DateSerial(strYear, strMonth, 1) iFirstOfMonthDOW = WeekDay (dtFirstOfMonth) dtLastOfMonth = DateSerial(strYear, strMonth + 1, 0) iCal = 1 ReDim aCal(44) For iCount = iFirstOfMonthDOW to iFirstOfMonthDOW + DateDiff("D", dtFirstOfMonth, dtLastOfMonth) aCal(iCount) = iCal iCal = iCal + 1 Next Response.Write "" & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF Response.Write " " & vbCRLF For iWeeks = 0 to 5 'Max weeks is 6 Response.Write " " & vbCRLF For iDays = 1 to 7 'Days If aCal(iWeeks * 7 + iDays) > 0 Then dtCurrentDay = DateSerial (strYear, strMonth, aCal(iWeeks * 7 + iDays) ) If objFSO.FolderExists(objFSO.BuildPath(objRootDir, strYYYYMM & LZeroPad(aCal(iWeeks * 7 + iDays),2))) Then Response.Write TD_START & vbCRLF Response.Write "" & LZeroPad(aCal(iWeeks * 7 + iDays),2) & "" & vbCRLF Response.Write " Ž" & vbCRLF Response.Write TD_END & vbCRLF Else Response.Write " " & vbCRLF End if Else Response.Write TD_BLANK & vbCRLF End if Next 'Write out EOW Report strWeek = LZeroPad(DatePart("ww", dtCurrentDay),2) If objFSO.FolderExists(objFSO.BuildPath(objRootDir, strYear & "_W" & strWeek)) Then Response.Write TD_START & vbCRLF Response.Write "W" & strWeek & "" & vbCRLF Response.Write " Ž" & vbCRLF Response.Write TD_END & vbCRLF Else Response.Write " " & vbCRLF End if Response.Write " " & vbCRLF 'Make sure we don't put out a blank week If iWeeks > 0 Then If aCal(iWeeks * 7 + iDays) = 0 Then Exit For End if End if Next Response.Write "

" & vbCRLF Response.Write " " & MonthName(Month(dtFirstOfMonth), true) & " " & LEFT(strYYYYMM,4) & "" & vbCRLF Response.Write " Ž " & vbCRLF Response.Write "
Sun	Mon	Tue	Wed	Thr	Fri	Sat	EOW
" & LZeroPad(aCal(iWeeks * 7 + iDays),2) & "	W" & strWeek & "

" & vbCRLF Response.Write "
" & vbCRLF End Function Function LZeroPad(iNumber, iDigits) Dim iLen Dim iCount Dim strTemp iLen = LEN(iNumber) strTemp = iNumber If iLen < iDigits Then For iCount = 1 to iDigits - iLen strTemp = "0" & strTemp Next End if LZeroPad = strTemp End function %>