<%@ LANGUAGE="VBSCRIPT" %>
<%
Option Explicit
Const DAO = "DAO.Dbengine.36"

Main

Sub Main() 'As String
Dim fs, sDigits, sCount, sReferrer, strData
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Check to see if the count database exists
	If Not fs.FileExists(Server.MapPath(".") & "\access_db\counter.mdb") Then CreateDatabase
	'Look up the count
	sReferrer = Request.ServerVariables("")
	If sReferrer = "" Then sReferrer = "Direct"
	sCount = DbLookup(sReferrer)
	'See if number of digits was specified
	If Request.Item("digits") = "" Then
		sDigits = Len(Cstr(sCount))
	Else
		sDigits = Request.Item("digits")
	End If
	'Get the string version of the bitmap
	strData = MakeBitmap(Clng(sCount), Cint(sDigits))
	'Send the response
	Response.Buffer = True
	Response.ContentType = "image/bmp"
	Response.BinaryWrite strData
	'Clean up and quit
	Set fs = Nothing
End Sub

Function MakeBitmap(lngNumber, intDigits)
Const FONT_WIDTH = 10 'width in pixels of a single character
Const FONT_HEIGHT = 12 'height in pixels of a single character
Dim strImageData 'strImageData is collection of font images.
Dim intNumber, intOffset, intRow, intCol, intDigit
Dim strNumber
Dim vArray()
	'Image data was made by converting to PBM P1(ASCII) files and unwrapping the data.
	strImageData = ""
	strImageData = strImageData & "000111100000111111000011001100011000011001100001100110000110011000011001100001100110000110001100110000111111000001111000"
	strImageData = strImageData & "000011000001111100000111110000000011000000001100000000110000000011000000001100000000110000000011000001111111100111111110"
	strImageData = strImageData & "000111100000111111000111001110011000011000000001100000001100000001100000001100000001100000001100000001111111100111111110"
	strImageData = strImageData & "000111100001111111000110000110000000011000000011100001111100000111110000000011100000000110110000011011111111000111111000"
	strImageData = strImageData & "000001110000000111000000111100000110110000011011000011001100011000110001111111100111111110000000110000001111100000111110"
	strImageData = strImageData & "001111110000111111000011000000001100000000111110000011111100001100111000000001100000000110011000111001111111000011111000"
	strImageData = strImageData & "000001111000011111100011100000001100000001101110000111111100011100111001100001100110000110001100111000111111000001111000"
	strImageData = strImageData & "011111111001111111100110000110000000111000000011000000001100000001110000000110000000011000000011100000001100000000110000"
	strImageData = strImageData & "000111100000111111000110000110011000011001100001100011111100001111110001100001100110000110011000011000111111000001111000"
	strImageData = strImageData & "000111100000111111000111001100011000011001100001100111001110001111111000011101100000001100000001110001111110000111100000"
	'Format the number with leading zeros (if appropriate)
	If intDigits = 0 Then
		strNumber = CStr(lngNumber)
		intDigits = Len(strNumber)
	Else
		strNumber = Right(String(intDigits, "0") & CStr(lngNumber), intDigits)
	End If
	'Set up the image array
	ReDim vArray(FONT_HEIGHT, FONT_WIDTH * intDigits)
	'Get each row of the image
	For intRow = 0 To FONT_HEIGHT - 1
		'Each row will slice across all the digits in the counter. Check eack digit.
		For intDigit = 1 To intDigits
			'What is the particular number we are processing?
			intNumber = Cint(Mid(strNumber, intDigit, 1))
			'How deep into the strImageData do we look to find the start of that number's data?
			intOffset = (intNumber * FONT_WIDTH * FONT_HEIGHT) + 1
			'Get all the columns (all the fields) in this row of this number
			For IntCol = 0 To FONT_WIDTH - 1
				vArray(intRow, intCol + ((intDigit - 1) * FONT_WIDTH)) = _
					Mid(strImageData, intOffset + intCol + (intRow * FONT_WIDTH) , 1)
			Next
		Next
	Next
	'Return a value
	MakeBitmap = ArrayToBmp(vArray)
End Function

Function ArrayToBmp(vArray)
'vArray must be a two dimensional array of numbers. vArray is arranged 
'in row, col (height, width). For example, in a 255x255 graphic, 
'top left of picture will be vArray(0,0) and top right is vArray(0, 254) 
Dim intWidth, intHeight
Dim strBuffer, strLineBuffer, strPictureBuffer
Dim intBuffer, intNybble, intRowCount, intColCount
Dim lngFileSize, lngImageSize
	'Get the image height and width from the array dimensions
	intHeight = UBound(vArray, 1)
	intWidth = UBound(vArray, 2)
	'Calculate the image size taking any padding bits into account
	lngImageSize = ((intWidth + ((intWidth Mod 8)\2)) / 2) * intHeight	'Calculate the file size
	lngFileSize = lngImageSize + 118 'First 117 bytes are all header stuff
	'Build a header for a 16-color bitmap
	strBuffer = ChrB(Asc("B")) & ChrB(Asc("M")) 'The bitmap identifier BM
	'Four file size bytes, LSB first
	strBuffer = strBuffer & ChrB(lngFileSize And &HFF)
	strBuffer = strBuffer & ChrB((lngFileSize And &HFF00) \ &H100)
	strBuffer = strBuffer & ChrB((lngFileSize And &HFF0000) \ &H10000)
	strBuffer = strBuffer & ChrB((lngFileSize And &HFF000000) \ &H1000000)
	'Four zeros (reserved part of the header)
	strBuffer = strBuffer & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0)
	'Four picture start location bytes (always &H76 for a 16-color bitmap)
	strBuffer = strBuffer & ChrB(&H76) & ChrB(0) & ChrB(0) & ChrB(0)
	'Four header size bytes (always &H28 for a 16-color bitmap)
	strBuffer = strBuffer & ChrB(&H28) & ChrB(0) & ChrB(0) & ChrB(0)
	'Four image width bytes, LSB first
	strBuffer = strBuffer & ChrB(intWidth And &HFF)
	strBuffer = strBuffer & ChrB((intWidth And &HFF00) \ &H100)
	strBuffer = strBuffer & ChrB((intWidth And &HFF0000) \ &H10000)
	strBuffer = strBuffer & ChrB((intWidth And &HFF000000) \ &H1000000)
	'Four image height bytes, LSB first
	strBuffer = strBuffer & ChrB(intHeight And &HFF)
	strBuffer = strBuffer & ChrB((intHeight And &HFF00) \ &H100)
	strBuffer = strBuffer & ChrB((intHeight And &HFF0000) \ &H10000)
	strBuffer = strBuffer & ChrB((intHeight And &HFF000000) \ &H1000000)
	'Two image planes count bytes (always 1 because there is only one plane in a bitmap)
	strBuffer = strBuffer & ChrB(1) & ChrB(0)
	'Two bits per pixel bytes (always 4 bits per pixel in a 16-color bitmap)
	strBuffer = strBuffer & ChrB(4) & ChrB(0)
	'Four compression type bytes (zero because no compression)
	strBuffer = strBuffer & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0)
	'Four image size (length in bytes) bytes, LSB first
	strBuffer = strBuffer & ChrB(lngImageSize And &HFF)
	strBuffer = strBuffer & ChrB((lngImageSize And &HFF00) \ &H100)
	strBuffer = strBuffer & ChrB((lngImageSize And &HFF0000) \ &H10000)
	strBuffer = strBuffer & ChrB((lngImageSize And &HFF000000) \ &H1000000)
	'Four horizontal resolution bytes (zero because I ignore it)
	strBuffer = strBuffer & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0)
	'Four vertical resolution bytes (zero because I ignore it)
	strBuffer = strBuffer & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0)
	'Four bytes to count number of colors (always 16 in a 16-color bitmap)
	strBuffer = strBuffer & ChrB(16) & ChrB(0) & ChrB(0) & ChrB(0)
	'Four bytes to count number of IMPORTANT colors (0 for all colors or specify 16)
	strBuffer = strBuffer & ChrB(16) & ChrB(0) & ChrB(0) & ChrB(0)
	'Four bytes to specify each of 16 palette entries. 
	'These are in BGR (not RGB!) order with last byte always zero.
	'Feel free to change the order or the actual values. These are Windows colors.
	'It's in this order because it is easy for me to remember.
	strBuffer = strBuffer & ChrB(255) & ChrB(255) & ChrB(255) & ChrB(0) 'White - 0
	strBuffer = strBuffer & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) 'Black - 1
	strBuffer = strBuffer & ChrB(0) & ChrB(0) & ChrB(255) & ChrB(0) 'Red - 2
	strBuffer = strBuffer & ChrB(0) & ChrB(255) & ChrB(0) & ChrB(0) 'Green - 3
	strBuffer = strBuffer & ChrB(255) & ChrB(0) & ChrB(0) & ChrB(0) 'Blue - 4
	strBuffer = strBuffer & ChrB(255) & ChrB(255) & ChrB(0) & ChrB(0) 'Cyan - 5
	strBuffer = strBuffer & ChrB(255) & ChrB(0) & ChrB(255) & ChrB(0) 'Magenta - 6
	strBuffer = strBuffer & ChrB(0) & ChrB(255) & ChrB(255) & ChrB(0) 'Yellow - 7
	strBuffer = strBuffer & ChrB(192) & ChrB(192) & ChrB(192) & ChrB(0) 'Light Gray - 8
	strBuffer = strBuffer & ChrB(128) & ChrB(128) & ChrB(128) & ChrB(0) 'Dark Gray - 9
	strBuffer = strBuffer & ChrB(0) & ChrB(0) & ChrB(128) & ChrB(0) 'Dark Red - 10
	strBuffer = strBuffer & ChrB(0) & ChrB(128) & ChrB(0) & ChrB(0) 'Dark Green - 11
	strBuffer = strBuffer & ChrB(128) & ChrB(0) & ChrB(0) & ChrB(0) 'Dark Blue - 12
	strBuffer = strBuffer & ChrB(128) & ChrB(128) & ChrB(0) & ChrB(0) 'Dark Cyan - 13
	strBuffer = strBuffer & ChrB(128) & ChrB(0) & ChrB(128) & ChrB(0) 'Dark Magenta - 14
	strBuffer = strBuffer & ChrB(0) & ChrB(128) & ChrB(128) & ChrB(0) 'Dark Yellow - 15
	'Now get the picture data! Each byte will contain two pixels at one nybble per pixel.
	strPictureBuffer = ""
	For intRowCount = (intHeight - 1) To 0 Step -1 'Gotta read bitmaps starting from the last row
		strLineBuffer = ""
		For intColCount = 0 To intWidth - 1 Step 2
			If intColCount <= intWidth - 2 Then
				strLineBuffer = strLineBuffer & ChrB((16 * vArray(intRowCount, intColCount)) + vArray(intRowCount, intColCount + 1))
			Else
				strLineBuffer = strLineBuffer & ChrB(16 * vArray(intRowCount, intColCount))
			End If
		Next
		'Line must end on a four-byte boundary. Pad with zeros as needed.
		Do Until LenB(strLineBuffer) Mod 4 = 0
			strLineBuffer = strLineBuffer & ChrB(0)
		Loop
		strPictureBuffer = strPictureBuffer & strLineBuffer
	Next
	strBuffer = strBuffer & strPictureBuffer
	ArrayToBmp = strBuffer
End Function

Sub AddToArray(varArray, strData)
'Modifies Input array
Dim intCount
	For intCount = 1 To Len(strData)
		ReDim Preserve varArray(UBound(varArray) + 1)
		varArray(UBound(varArray)) = CByte(Asc(Mid(strData, intCount, 1)))
	Next
End Sub

Sub CreateDatabase()
'Creates a database with the same root name as the script
'but with an mdb file extension. Initializes the new database
'with a table "Hits" and a single record entry.
Dim dbeng 'As Object
Dim db 'As Database
Dim td 'As TableDef
Dim fld 'As Field
Dim rs 'As Recordset
Const dbDate = 8 'DAO.DataTypeEnum
Const dbText = 10 'DAO.DataTypeEnum
Const dbMemo = 12 'DAO.DataTypeEnum
Const dbLangGeneral = ";LANGID=0x0409;CP=1252;COUNTRY=0" 'DAO.LanguageConstants
	Set dbeng = CreateObject(DAO)
	'Create the database mdb file
	Set db = dbeng.CreateDatabase(Server.MapPath(".") & "\access_db\counter.mdb", dbLangGeneral)
	'Create the table named Hits
	Set td = db.CreateTableDef("Hits")
	td.Fields.Append td.CreateField("Referrer", dbText, 250)
	td.Fields.Append td.CreateField("HitCount", dbText, 15)
	db.TableDefs.Append td
	'Fill the first record with some data
	Set rs = db.OpenRecordset("Hits")
	rs.AddNew
	rs.Fields("Referrer").Value = "127.0.0.1"
	rs.Fields("HitCount").Value = "0"
	rs.Update
	'Clean up
	db.Close
	Set rs = Nothing
	Set fld = Nothing
	Set td = Nothing
	Set db = Nothing
	Set dbeng = Nothing
End Sub

Function DbLookup(sWebPage) 'As String
'Returns a number showing how many times the sWebPage has hit
Dim dbeng 'As Object
Dim db 'As Database
Dim rs 'As Recordset
Dim sOutput 'As String
Dim lPointer 'As Long
Dim sQuery 'As String
Dim sQueryString 'As String
Dim ws 'As Object
Dim args 'As Object
Const dbOpenDynaset = 2 'DAO.RecordsetTypeEnum
	Set ws = CreateObject("WScript.Shell")
	Set args = CreateObject("Scripting.Dictionary")
	'Open the database and recordset
	Set dbeng = CreateObject(DAO)
	Set db = dbeng.OpenDatabase(Server.MapPath(".") & "\access_db\counter.mdb")
	sQuery = "SELECT * FROM Hits WHERE Referrer=""" & sWebPage & """"
	Set rs = db.OpenRecordset(sQuery, dbOpenDynaset)
	'Return the results
	If rs.EOF And rs.BOF Then
		'New page! Add it.
		DbAdd(sWebPage)
		'Return an initial value for the new page
		DbLookup = "1"
	Else
		'Increment the HitCount
		rs.Edit
		rs.Fields("HitCount").Value = Cstr(Clng(rs.Fields("HitCount").Value) + 1)
		'Now see if we have to reset the value
		If Request.Item("count")<>"" Then
			rs.Fields("HitCount").Value = Request.Item("count")
		End If
		rs.Update
		'Actually return the value
		DbLookup = rs.Fields("HitCount").Value
	End If	  
	'Clean up
	Set ws = Nothing
	Set args = Nothing
	Set rs = Nothing
	db.Close
	Set db = Nothing
	Set dbeng = Nothing
End Function

Sub DbAdd(sWebPage)
'Adds a new web page to the count database
Dim dbeng 'As Object
Dim db 'As Database
Dim rs 'As Recordset
Dim lPointer 'As Long
Const dbOpenDynaset = 2 'DAO.RecordsetTypeEnum
	'Open the database and recordset
	Set dbeng = CreateObject(DAO)
	Set db = dbeng.OpenDatabase(Server.MapPath(".") & "\access_db\counter.mdb")
	Set rs = db.OpenRecordset("Hits", dbOpenDynaset)
	'Add the new data
	rs.MoveLast
	rs.AddNew
	rs.Fields("Referrer").Value = sWebPage
	rs.Fields("HitCount").Value = "1"
	rs.Update
	'Clean up
	Set rs = Nothing
	db.Close
	Set db = Nothing
	Set dbeng = Nothing
End Sub

%>