<% '------------------------------------------------------------- '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. 'See License.txt for additional information '------------------------------------------------------------- 'Change Log: '------------------------------------------------------------- '# 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 20, 2001 by FlipDaMusic 'Future Support for SQL6, SQL7, Access 2000, Access97 (not fully implemented) 'Add Loading of Config Variables '# Feb 5, 2001 by Kevin Yochum 'Added IP filter to ignore hits from specified visitor IP's 'Added configuration switch to display url's as active links '------------------------------------------------------------- '------------------------------------------------- 'You don't need to modify anything below this line. '------------------------------------------------- 'Construct the connection string '## Make sure to uncomment one of the sConnStats lines! '## MS Access 97 'sConnStats = "DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=c:\inetpub\wwwroot\scx\stats.mdb" '## MS Access 2000 using virtual path sConnStats = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("/data/stats.mdb") '## MS Access 2000 'sConnStats = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\inetpub\wwwroot\scx\stats.mdb;" '## MS SQL Server 7 'sConnStats = "driver={SQL Server};server=SERVERNAME;uid=USERNAME;pwd=PASSWORD;database=DATABASENAME" 'Pre Create the connection and recordset objects set conn = Server.CreateObject("ADODB.Connection") set rs = Server.CreateObject("ADODB.Recordset") 'ADO Constants '---- CursorTypeEnum Values ---- Const adOpenForwardOnly = 0 Const adOpenKeyset = 1 Const adOpenDynamic = 2 Const adOpenStatic = 3 '---- CursorLocationEnum Values ---- Const adUseServer = 2 Const adUseClient = 3 '---- CommandTypeEnum Values ---- Const adCmdUnknown = &H0008 Const adCmdText = &H0001 Const adCmdTable = &H0002 Const adCmdStoredProc = &H0004 Const adCmdFile = &H0100 Const adCmdTableDirect = &H0200 sub OpenDB(sConn) 'Opens the given connection and initializes the recordset conn.open sConn set rs.ActiveConnection = conn rs.CursorType = adOpenStatic end sub sub CloseDB() 'Closes and destroys the connection and recordset objects rs.close conn.close set rs = nothing set conn = nothing end sub sub w(sText) 'A Quickie ;) response.write sText & vbCrLf end sub 'Load Config from DB 'Open Connection conn.open sConnStats 'Build SqlString strSql = "SELECT C_ImageLoc " strSql = strSql & ", C_FilterIP " strSql = strSql & ", C_ShowLinks " strSql = strSql & ", C_RefThisServer " strSql = strSql & ", C_StripPathParameters " strSql = strSql & ", C_StripPathProtocol " strSql = strSql & ", C_StripRefParameters " strSql = strSql & ", C_StripRefProtocol " strSql = strSql & ", C_StripRefFile " strSql = strSql & "FROM Config WHERE ID = 1" 'Open RecordSet set rs = conn.Execute(strSql) 'Get Variables sImageLocation = rs.Fields("C_ImageLoc") sFilterIps = rs.Fields("C_FilterIP") bShowLinks = rs.Fields("C_ShowLinks") bRefThisServer = rs.Fields("C_RefThisServer") bStripPathParameters = rs.Fields("C_StripPathParameters") bStripPathProtocol = rs.Fields("C_StripPathProtocol") bStripRefParameters = rs.Fields("C_StripRefParameters") bStripRefProtocol = rs.Fields("C_StripRefProtocol") bStripRefFile = rs.Fields("C_StripRefFile") 'Terminate database connection rs.Close conn.close %> <% '------------------------------------------------------------- '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: '------------------------------------------------------------- '# 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 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") sIP = Request.ServerVariables("REMOTE_ADDR") sU = Request.ServerVariables("HTTP_USER_AGENT") 'Ignore certain IPs aIps = Split( sFilterIPs, "," ) bExit = False For Each sFilterIp In aIps If sFilterIP = sIP Then bExit = True End If Next 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 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 '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) 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("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 %>