<% '------------------------------------------------------------- 'StatCounteX 3.1 'http://www.2enetworx.com/dev/projects/statcountex.asp 'File: admin.asp 'Description: StatCounteX Reports Main Page 'Initiated by Hakan Eskici on Nov 18, 2000 'See credits.txt for the list of contributors 'You may use the code for any purpose 'But re-publishing is discouraged. '------------------------------------------------------------- 'Change Log: '------------------------------------------------------------- '# May 2, 2001 by Pasquale Cavallo (p.cavallo@pineapple.it) 'Changed the support por PC filter '# Feb 25, 2001 by Rami Kattan 'WindowsME can be counted now (database file need a new entry in OSes: OsName= WinMe, OsId = 8 'Netscape 6.x is reported as NS 6.x '# Feb 21, 2001 by FlipDaMusic 'Change - Sub Count - If Clauses True/False to 0/1 (DB - Values) '# Feb 5, 2001 by Kevin Yochum 'Moved counting code into Log() subroutine '------------------------------------------------------------- function GetIdOS(sName) 'Get OsID lIdOs = 1 select case sName case "Win95" : lIdOs = 2 case "Win98" : lIdOs = 3 case "WinNT" : lIdOs = 4 case "Win2K" : lIdOs = 5 case "Mac" : lIdOs = 6 case "Linux" : lIdOs = 7 case "WinME" : lIdOs = 8 case else : lIdOs = 1 end select sSQL = "SELECT Total FROM OSes WHERE OsID = " & lIdOs rs.Open sSQL,,,adCmdTable rs("Total") = CLng(rs("Total")) + 1 rs.update rs.close GetIdOS = lIdOs end function function GetIdColor(sName) 'Get ColorID lIdColor = 1 select case sName case "8" : lIdColor = 2 case "16" : lIdColor = 3 case "24" : lIdColor = 4 case "32" : lIdColor = 5 case else : lIdColor = 1 end select sSQL = "SELECT Total FROM Colors WHERE ColorID = " & lIdColor rs.Open sSQL,,,adCmdTable rs("Total") = CLng(rs("Total")) + 1 rs.update rs.close GetIdColor = lIdColor end function function GetIdBrowser(sName) 'Get BrowserID sSQL = "SELECT BrowserID, BrowserName, Total FROM Browsers WHERE BrowserName = '" & sName & "'" rs.Open sSQL,,,adCmdTable if rs.recordcount = 0 then rs.AddNew rs("BrowserName") = sName rs("Total") = 0 end if rs("Total") = CLng(rs("Total")) + 1 rs.update GetIdBrowser = rs("BrowserID") rs.close end function function GetIdLang(sName) 'Get LangID sSQL = "SELECT LangID, Lang, Total FROM Languages WHERE Lang = '" & sName & "'" rs.Open sSQL,,,adCmdTable if rs.recordcount = 0 then rs.AddNew rs("Lang") = sName rs("Total") = 0 end if rs("Total") = CLng(rs("Total")) + 1 rs.update GetIdLang = rs("LangID") rs.close end function function GetIdPath(sName) 'Get PathID sSQL = "SELECT PathID, PathName, Total FROM Paths WHERE PathName = '" & sName & "'" rs.Open sSQL,,,adCmdTable if rs.recordcount = 0 then rs.AddNew rs("PathName") = sName rs("Total") = 0 end if rs("Total") = CLng(rs("Total")) + 1 rs.update GetIdPath = rs("PathID") rs.close end function function GetIdRef(sName) 'Get RefID sSQL = "SELECT RefID, RefName, Total FROM Refs WHERE RefName = '" & sName & "'" rs.Open sSQL,,,adCmdTable if rs.recordcount = 0 then rs.AddNew rs("RefName") = sName rs("Total") = 0 end if rs("Total") = CLng(rs("Total")) + 1 rs.update GetIdRef = rs("RefID") rs.close end function function GetIdRes(sName) 'Get ResID sSQL = "SELECT ResID, ResName, Total FROM Resolutions WHERE ResName = '" & sName & "'" rs.Open sSQL,,,adCmdTable if rs.recordcount = 0 then rs.AddNew rs("ResName") = sName rs("Total") = 0 end if rs("Total") = CLng(rs("Total")) + 1 rs.update GetIdRes = rs("ResID") rs.close end function function StripParameter(sPath) iPlace = instr(sPath, "?") if iPlace then sBuffer = left(sPath, iPlace-1) else sBuffer = sPath StripParameter = sBuffer end function function StripProtocol(sPath) iPlace = instr(sPath, "://") if iPlace then sBuffer = right(sPath, len(sPath) - (3 + iPlace - 1)) else sBuffer = sPath if left(sBuffer, 4) = "www." then sBuffer = right(sBuffer, len(sBuffer) - 4) StripProtocol = sBuffer end function Sub Log() 'Nevermind if error 'On Error Resume Next 'Get parameters sResolution = request("w") & "x" & request("h") sColor = request("c") sPath = Request("u") sReferer = Request("r") sFontSmoothing = Request("fs") sFilterPC = Request.Cookies("FilterPC") sIP = Request.ServerVariables("REMOTE_ADDR") sU = Request.ServerVariables("HTTP_USER_AGENT") sLang = Request.ServerVariables("HTTP_ACCEPT_LANGUAGE") 'Ignore certain IPs aIps = Split( sFilterIPs, "," ) bExit = False For Each sFilterIp In aIps If sFilterIP = sIP Then bExit = True End If Next if sFilterPC = "1" then bExit = True If bExit Then Exit Sub End If 'Process the inputs if sResolution = "x" then sResolution = "(unknown)" end if if sFontSmoothing = "true" then sFontSmoothing = True else sFontSmoothing = False end if if sReferer = "" then sReferer = request.servervariables("http_referer") if sReferer = "" then sReferer = "..." 'This server as a referer? if bRefThisServer = "0" then if instr(StripParameter(sReferer), request.servervariables("http_host")) then sReferer = "..." end if end if 'Referer path and file if bStripRefFile = "1" then iPlace = InstrRev(sReferer, "/") if iPlace then sReferer = left(sReferer, iPlace - 1) end if end if 'Path Parameters if bStripPathParameters = "1" then sPath = StripParameter(sPath) end if 'Path Protocol if bStripPathProtocol = "1" then sPath = StripProtocol(sPath) end if 'Referer Parameters if bStripRefParameters = "1" then sReferer = StripParameter(sReferer) end if 'Referer Protocol if bStripRefProtocol = "1" then sReferer = StripProtocol(sReferer) end if if sPath = "" then sPath = "/" if instr(sU, "98") then sOS = "Win98" if instr(sU, "95") then sOS = "Win95" if instr(sU, "Win 9x") then sOS = "WinME" if instr(sU, "NT") then sOS = "WinNT" if instr(sU, "NT 5") then sOS = "Win2K" if instr(sU, "Linux") then sOS = "Linux" if instr(sU, "Mac") then sOS = "Mac" sBrowserType = request("b") select case sBrowserType case "MSIE" p1 = instr(sU, ";") p2 = instr(p1+1, sU, ";") sBrowser = mid(sU, p1+2, (p2-p1)-2) case "NS" sBrowser = "NS " & mid(sU, 9, 3) if instr(sU, "Netscape") then i = instr(20, sU, "/") sBrowser = "NS " & right(sU, len(sU)-i) end if if instr(sU, "Netscape6/") then p1 = instr(sU, "Netscape6/") + 10 sBrowser = "NS " & mid(sU, p1) p2 = instr(4, sBrowser, " ") if p2 <> 0 then sBrowser = left(sBrowser, p2) end if case else If instr( sU, "MSIE" ) > 0 Then p1 = instr( sU, "MSIE" ) p2 = instr( p1+1, sU, ";") sBrowser = mid(sU, p1, (p2-p1)-1) Else sBrowser = sU End If end select 'Client Acceptable Languages if sLang = "" then sLang = "(unknown)" end if 'Open the database OpenDB sConnStats 'Get ID's by Names lIdOS = GetIdOS(sOS) lIdColor = GetIdColor(sColor) lIdBrowser = GetIdBrowser(sBrowser) lIdPath = GetIdPath(sPath) lIdRef = GetIdRef(sReferer) lIdRes = GetIdRes(sResolution) lIdLanguage = GetIdLang(sLang) sSQL = "SELECT * FROM Stats" rs.Open sSQL,,,adCmdTable 'Save the data rs.AddNew rs("OsID") = lIdOS rs("ColorID") = lIdColor rs("BrowserID") = lIdBrowser rs("PathID") = lIdPath rs("RefID") = lIdRef rs("ResID") = lIdRes rs("LangID") = lIdLanguage rs("Date") = date rs("Time") = time rs("IP") = sIP rs.Update 'Terminate database connection CloseDB End Sub 'Log a hit Log() 'Show the image response.redirect sImageLocation %>