<%
'###########################################################
'## COPYRIGHT (C) 2002-2005, Brinkster Site Statistics Corp.
'##
'## For licensing details, lease read the license.txt file
'## included with MetaTraffic or located at:
'## http://www.metasun.com/products/metatraffic/license.asp
'##
'## All copyright notices regarding MetaTraffic
'## must remain intact in the scripts and in the
'## outputted HTML. All text and logos with
'## references to Metasun or MetaTraffic must
'## remain visible when the pages are viewed on
'## the internet or intranet.
'##
'## For support, please visit http://www.metasun.com
'## and use the support forum.
'###########################################################
Class MTConfig
' DEFINE CLASS ONLY VARIABLES
Private strSql, datStart, datEnd, aryDB, aryConfig
Private strDatabaseType, strTablePrefix
Private intSetting
Private strSiteName, strShortDate
Public Property Let Config(pConfig)
aryConfig = pConfig
strSiteName = aryConfig(intMTSiteName)
strShortDate = aryConfig(intMTShortDateFormat)
End Property
Public Property Let Database(pDatabase)
aryDB = pDatabase
' ASSIGN CONFIGS
strDatabaseType = aryDB(0)
strTablePrefix = aryDB(5)
End Property
Public Property Let Connection(pConnection)
objConn = pConnection
End Property
Public Property Let Setting(pSetting)
intSetting = pSetting
End Property
Public Function SiteName()
SiteName = strSiteName
End Function
Public Function Version()
Version = "Site Statistics Pro "
End Function
' *****************
' * SETTINGS *
' *****************
Public Sub GenerateSettings(intSetting)
Dim strResult, rsQuery, intRow, strClass, intLoop
Dim strMode, strAction, intID, strError, strMsg, strGroup
Dim rsCheck, rsUpdate, rsDelete, strReadonly
' DISPLAY SETTINGS
Select Case intSetting
Case 0 ' General
Call DisplaySettingsHeader("General")
With Response
strSql = "SELECT c_name, c_value, c_group FROM " & strTablePrefix & "Config " &_
"WHERE c_type IN (0,1) " &_
"ORDER BY c_type ASC, c_order ASC"
Set rsConfig = Server.CreateObject("ADODB.RecordSet")
rsConfig.Open strSql, objConn, 3, 1, &H0000
Do While Not rsConfig.Eof
If rsConfig(2) <> strGroup Then
.Write("
" & rsConfig(2) & "
")
End If
strGroup = rsConfig(2)
.Write("
")
.Write("
" & Replace(rsConfig(0), "_", " ") & ":
")
If rsConfig(1) <> "" Then
.Write("
" & rsConfig(1) & "
")
Else
.Write("
N/A
")
End If
.Write("
")
rsConfig.Movenext
intLoop = intLoop + 1
Loop
End With
rsConfig.Close : Set rsConfig = Nothing
' COUNT PAGELOG RECORDS
Dim intPageLog
strSql = "SELECT COUNT(*) FROM " & strTablePrefix & "PageLog"
Dim rsPageLog : Set rsPageLog = Server.CreateObject("ADODB.RecordSet")
rsPageLog.Open strSql, objConn, 3, 1, &H0000
If Not rsPageLog.Eof Then
intPageLog = rsPageLog(0)
Else
intPageLog = 0
End If
rsPageLog.Close : Set rsPageLog = Nothing
' COUNT ROBOTLOG RECORDS
Dim intRobotLog
strSql = "SELECT COUNT(*) FROM " & strTablePrefix & "RobotLog"
Dim rsRobotLog : Set rsRobotLog = Server.CreateObject("ADODB.RecordSet")
rsRobotLog.Open strSql, objConn, 3, 1, &H0000
If Not rsRobotLog.Eof Then
intRobotLog = rsRobotLog(0)
Else
intRobotLog = 0
End If
rsRobotLog.Close : Set rsRobotLog = Nothing
' COUNT USERS
Dim intUsers
strSql = "SELECT COUNT(*) FROM " & strTablePrefix & "Users"
Dim rsUsers : Set rsUsers = Server.CreateObject("ADODB.RecordSet")
rsUsers.Open strSql, objConn, 3, 1, &H0000
If Not rsUsers.Eof Then
intUsers = rsUsers(0)
Else
intUsers = 0
End If
rsUsers.Close : Set rsUsers = Nothing
With Response
.Write("
Logging
")
.Write("
")
.Write("
Log Records:
")
.Write("
" & intPageLog & "
")
.Write("
")
If intPageLog > 0 Then
.Write("
")
.Write("
Log Start:
")
.Write("
" & GetLogDate("MIN", "Page") & "
")
.Write("
")
.Write("
")
.Write("
Log End:
")
.Write("
" & GetLogDate("MAX", "Page") & "
")
.Write("
")
End If
.Write("
")
.Write("
Robot Log Records:
")
.Write("
" & intRobotLog & "
")
.Write("
")
If intRobotLog > 0 Then
.Write("
")
.Write("
Robot Log Start:
")
.Write("
" & GetLogDate("MIN", "Robot") & "
")
.Write("
")
.Write("
")
.Write("
Robot Log End:
")
.Write("
" & GetLogDate("MAX", "Robot") & "
")
.Write("
")
End If
.Write("
Other
")
.Write("
")
.Write("
Users:
")
.Write("
" & intUsers & "
")
.Write("
")
End With
Call DisplaySettingsFooter()
Case 1 ' CONFIG
Dim objItem, aryConfig, strValue, aryExtra, rsConfig, strName, strRegExp
If Request.Form("action") = "UPDATE" Then
ReDim aryConfig(3, Request.Form.Count - 4)
Dim aryForm : aryForm = Split(Request.Form, "&")
For intLoop = 0 To UBound(aryConfig, 2)
Dim aryFormItem : aryFormItem = Split(aryForm(intLoop), "=")
aryConfig(0, intLoop) = aryFormItem(0)
aryConfig(1, intLoop) = UrlDecode(aryFormItem(1))
Next
strSql = "SELECT c_extra, c_group FROM " & strTablePrefix & "Config " &_
"WHERE c_type = 2 ORDER BY c_order ASC"
Dim rsExtra : Set rsExtra = Server.CreateObject("ADODB.RecordSet")
rsExtra.Open strSql, objConn, 3, 1, &H0000
Dim intCounter
Do While Not rsExtra.Eof
aryConfig(2, intCounter) = rsExtra(0)
aryConfig(3, intCounter) = rsExtra(1)
rsExtra.Movenext : intCounter = intCounter + 1
Loop
rsExtra.Close : Set rsExtra = Nothing
For intLoop = 0 To UBound(aryConfig, 2)
aryExtra = Split(aryConfig(2, intLoop), "||")
Select Case aryExtra(0)
Case "textarea"
aryConfig(1, intLoop) = Replace(aryConfig(1, intLoop), vbcrlf, ",")
Case "checkbox"
If CInt(aryConfig(1, intLoop)) = 1 Then
aryConfig(1, intLoop) = True
Else
aryConfig(1, intLoop) = False
End If
End Select
strRegExp = aryExtra(4)
If strRegExp <> "" Then
Dim objCheck : Set objCheck = New RegExp
With objCheck
.Pattern = strRegExp
.IgnoreCase = True
If Not .Test(aryConfig(1, intLoop)) Then
strError = strError & "
" & Replace(aryConfig(0, intLoop), "_", " ") & "
" & vbcrlf
End If
End With
Set objCheck = Nothing
End If
Next
If strError = "" Then
Dim strConfigPath : strConfigPath = Request.Servervariables("Script_Name")
strConfigPath = Left(strConfigPath, InStrRev(strConfigPath, "/") - 1)
Dim objFSO : Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Dim objTS : Set objTS = objFSO.OpenTextFile(Server.MapPath(strConfigPath & "/config.asp"), 2)
If Err.Number = 0 Then
objTS.WriteLine("<" & Chr(37))
For intLoop = 0 To UBound(aryConfig, 2)
strName = Replace(aryConfig(0, intLoop), "_", "")
objTS.WriteLine("Dim intMT" & strName & " : " & "intMT" & strName & " = " & intLoop)
Next
objTS.WriteLine()
objTS.WriteLine("Dim aryMTConfig(" & UBound(aryConfig, 2) & ")")
For intLoop = 0 To UBound(aryConfig, 2)
strName = Replace(aryConfig(0, intLoop), "_", "")
aryExtra = Split(aryConfig(2, intLoop), "||")
If aryExtra(1) = "str" Then
strValue = """" & aryConfig(1, intLoop) & """"
Else
strValue = aryConfig(1, intLoop)
End If
objTS.WriteLine("aryMTConfig(" & "intMT" & strName & ") = " & strValue)
Next
objTS.WriteLine(Chr(37) & ">")
strResult = "
Successfully updated configuration
"
Else
strResult = "
Configuration update failed. Details:
" &_
"Description: " & Err.Description & "
"
End If
On Error Goto 0
Set objTS = Nothing : Set objFSO = Nothing
' UPDATE DATABASE CONFIG
strSql = "SELECT c_name, c_value " &_
"FROM " & strTablePrefix & "Config " &_
"WHERE c_type = 2 ORDER BY c_order ASC"
Set rsConfig = Server.CreateObject("ADODB.RecordSet")
rsConfig.Open strSql, objConn, 1, 2, &H0000
intLoop = 0
Do While Not rsConfig.Eof
rsConfig.Update Array(0,1), Array(aryConfig(0, intLoop), aryConfig(1, intLoop))
rsConfig.Movenext : intLoop = intLoop + 1
Loop
rsConfig.Close : Set rsConfig = Nothing
Else
strResult = "
There were errors with the following fields:
" &_
"
" & strError & "
"
End If
Else
' GET CONFIG FROM DATABASE
strSql = "SELECT c_name, c_value, c_extra, c_group FROM " & strTablePrefix & "Config " &_
"WHERE c_type = 2 " &_
"ORDER BY c_order ASC"
Set rsConfig = Server.CreateObject("ADODB.Recordset")
rsConfig.Open strSql, objConn, 1, 2, &H0000
aryConfig = rsConfig.GetRows()
rsConfig.Close : Set rsConfig = Nothing
End If
Call DisplaySettingsHeader("Configuration")
If strResult <> "" Then
Response.Write("
" & strResult & "
")
End If
With Response
.Write("")
End With
Call DisplaySettingsFooter()
Case 2 ' USERS
Dim strUsername, strPassword, blnAdmin
strUsername = Request.Form("username")
strPassword = Request.Form("password")
blnAdmin = CInt(Request.Form("admin"))
intID = Request("id")
strMode = Request.Querystring("m")
strAction = Request.Form("action")
If strMode = "" Then
strMode = "VIEW"
ElseIf strMode = "DELETE" Then
strMode = "VIEW"
strAction = "DELETE"
End If
If blnAdmin = 1 Then
blnAdmin = True
Else
blnAdmin = False
End If
Select Case strAction
Case "UPDATE", "ADD NEW"
' DO SOME CHECKS
If strAction = "ADD NEW" Then
If strUsername = "" Then
strError = "
Username cannot be blank.
"
Else
strSql = "SELECT u_id FROM " & strTablePrefix & "Users WHERE u_username = " & FormatDatabaseString(strUsername, 20)
Set rsCheck = Server.CreateObject("ADODB.Recordset")
rsCheck.Open strSql, objConn, 3, 1, &H0000
If Not rsCheck.Eof Then
strError = "
Username already exists.
"
End If
rsCheck.Close : Set rsCheck = Nothing
End If
End If
If strError = "" Then
strSql = "SELECT u_id, u_username, u_password, u_admin FROM " & strTablePrefix & "Users " &_
"WHERE u_id = " & intID
Set rsUpdate = Server.CreateObject("ADODB.Recordset")
rsUpdate.Open strSql, objConn, 1, 2, &H0000
If rsUpdate.Eof Then
rsUpdate.AddNew
End If
rsUpdate(1) = strUsername
rsUpdate(2) = strPassword
rsUpdate(3) = blnAdmin
rsUpdate.Update
rsUpdate.Close : Set rsUpdate = Nothing
strMode = "VIEW"
End If
Case "DELETE"
strSql = "DELETE FROM " & strTablePrefix & "Users WHERE u_id = " & intID
Set rsDelete = Server.CreateObject("ADODB.Recordset")
rsDelete.Open strSql, objConn, 3, 1, &H0000
Set rsDelete = Nothing
End Select
Call DisplaySettingsHeader("Users")
Select Case strMode
Case "EDIT"
If intID = 0 Then
strAction = "ADD NEW"
Else
strAction = "UPDATE"
strReadonly = " readonly"
strSql = "SELECT u_id, u_username, u_password, u_admin " &_
"FROM " & strTablePrefix & "Users WHERE u_id = " & intID
Set rsQuery = Server.CreateObject("ADODB.Recordset")
rsQuery.Open strSql, objConn, 3, 1, &H0000
If Not rsQuery.Eof Then
strUsername = rsQuery(1)
strPassword = rsQuery(2)
blnAdmin = rsQuery(3)
End If
rsQuery.Close : Set rsQuery = Nothing
End If
If strError <> "" Then
Response.Write("
" & strError & "
")
End If
With Response
.Write("")
End With
Case "VIEW"
strSql = "SELECT u_id, u_username, u_password, u_admin " &_
"FROM " & strTablePrefix & "Users " &_
"ORDER BY u_username ASC"
Set rsQuery = Server.CreateObject("ADODB.Recordset")
If strDatabaseType = "MYSQL" Then
rsQuery.CursorLocation = 3
End If
rsQuery.Open strSql, objConn, 3, 1, &H0000
intRow = 0
With Response
If rsQuery.Recordcount > 0 Then
.Write("
Username
Admin
Action
")
Do While Not rsQuery.Eof
intRow = intRow + 1
If (intRow Mod 2) = 1 Then
strClass = "data"
Else
strClass = "dataalt"
End If
.Write("
")
.Write("
" & rsQuery(1) & "
")
.Write("
" & DisplayAdmin(rsQuery(3)) & "
")
.Write("
")
.Write("
")
.Write("
")
rsQuery.Movenext
Loop
Else
.Write("
There are no users.
")
End If
rsQuery.Close : Set rsQuery = Nothing
.Write("
")
.Write("")
.Write("
")
End With
End Select
Call DisplaySettingsFooter()
Case 3 ' MAINTENANCE
Call DisplaySettingsHeader("Maintenance")
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then
Dim strInstallPath : strInstallPath = Request.Servervariables("Script_Name")
strInstallPath = Left(strInstallPath, InStrRev(strInstallPath, "/") - 1) & "/data"
Dim objUpload : Set objUpload = New Upload
On Error Resume Next
objUpload.Save(Server.MapPath(strInstallPath))
strAction = UCase(objUpload.Form("action"))
If strAction = "DEFINITIONS" Or strAction = "COUNTRIES" Then
If Err.Number <> 0 Then
strMsg = "
Upload failed:
Could not write file. " &_
"Check permissions and ensure the IUSR_machine account has MODIFY " &_
"permissions to the data folder.
"
End If
Dim strFileName
Dim objFiles : objFiles = objUpload.UploadedFiles.Keys
If (UBound(objFiles) <> -1) Then
Dim objFile : For Each objFile in objUpload.UploadedFiles.Keys
strFileName = objUpload.UploadedFiles(objFile).FileName
Next
End If
End If
On Error Goto 0
Dim datStart : datStart = objUpload.Form("startdate")
Dim datEnd : datEnd = objUpload.Form("enddate")
If strMsg = "" Then
' PROCESS ACTIONS
Select Case strAction
Case "DEFINITIONS"
strMsg = UpdateDefinitions(strFileName)
Case "COUNTRIES"
strMsg = UpdateCountries(strFileName)
Case "COMPACT"
strMsg = CompactDatabase()
Case "DELETE"
strMsg = DeleteStatistics(datStart, datEnd)
Case "ROBOTLOG"
strMsg = DeleteRobotLog(datStart, datEnd)
End Select
End If
Else
' SET DEFAULTS
If Not IsDate(datStart) Then
datStart = GetLogDate("MIN", "Page")
If Not IsDate(datStart) Then
datStart = Date()
Else
datStart = FormatDateTime(datStart, 2)
End If
End If
If Not IsDate(datEnd) Then
datEnd = GetLogDate("MAX", "Page")
If Not IsDate(datEnd) Then
datEnd = Date()
Else
datEnd = FormatDateTime(datEnd, 2)
End If
End If
End If
With Response
.Write("")
End With
Call DisplaySettingsFooter()
Case 4 ' ACTIONS
Dim strActionName, strActionCode, blnDisplay
strActionName = Request.Form("name")
strActionCode = Request("code")
blnDisplay = CInt(Request.Form("display"))
strMode = Request.Querystring("m")
strAction = Request.Form("action")
If strMode = "" Then
strMode = "VIEW"
End If
If blnDisplay = 1 Then
blnDisplay = True
Else
blnDisplay = False
End If
Select Case strAction
Case "UPDATE", "ADD NEW"
' DO SOME CHECKS
If strAction = "ADD NEW" Then
If strActionCode = "" Then
strError = "
Code cannot be blank.
"
ElseIf strActionName = "" Then
strError = "
Name cannot be blank.
"
ElseIf CInt(CheckCode(strActionCode)) = 0 Then
strError = "
Code can only contain " &_
"letters, numbers, hyphen (-) and underscore (_). Spaces are not permitted.
"
strActionCode = ""
Else
strSql = "SELECT a_code FROM " & strTablePrefix & "Actions WHERE a_code LIKE " & FormatDatabaseString(strActionCode, 12)
Set rsCheck = Server.CreateObject("ADODB.Recordset")
rsCheck.Open strSql, objConn, 3, 1, &H0000
If Not rsCheck.Eof Then
strError = "
Code already exists.
"
End If
rsCheck.Close : Set rsCheck = Nothing
End If
End If
If strError = "" Then
strSql = "SELECT a_code, a_name, a_display FROM " & strTablePrefix & "Actions " &_
"WHERE a_code LIKE " & FormatDatabaseString(strActionCode, 12)
Set rsUpdate = Server.CreateObject("ADODB.Recordset")
rsUpdate.Open strSql, objConn, 1, 2, &H0000
If rsUpdate.Eof Then
rsUpdate.AddNew
End If
rsUpdate(0) = strActionCode
rsUpdate(1) = strActionName
rsUpdate(2) = blnDisplay
rsUpdate.Update
rsUpdate.Close : Set rsUpdate = Nothing
strMode = "VIEW"
End If
End Select
Call DisplaySettingsHeader("Actions")
Select Case strMode
Case "EDIT"
If strActionCode = "" Then
strAction = "ADD NEW"
blnDisplay = True
Else
strAction = "UPDATE"
strReadonly = " readonly"
strSql = "SELECT a_code, a_name, a_display " &_
"FROM " & strTablePrefix & "Actions WHERE a_code LIKE " & FormatDatabaseString(strActionCode, 12)
Set rsQuery = Server.CreateObject("ADODB.Recordset")
rsQuery.Open strSql, objConn, 3, 1, &H0000
If Not rsQuery.Eof Then
strActionCode = rsQuery(0)
strActionName = rsQuery(1)
blnDisplay = rsQuery(2)
End If
rsQuery.Close : Set rsQuery = Nothing
End If
If strError <> "" Then
Response.Write("
" & strError & "
")
End If
With Response
.Write("")
End With
Case "VIEW"
strSql = "SELECT a_code, a_name, a_display " &_
"FROM " & strTablePrefix & "Actions " &_
"ORDER BY a_display, a_name, a_code ASC"
Set rsQuery = Server.CreateObject("ADODB.Recordset")
If strDatabaseType = "MYSQL" Then
rsQuery.CursorLocation = 3
End If
rsQuery.Open strSql, objConn, 3, 1, &H0000
intRow = 0
With Response
If rsQuery.Recordcount > 0 Then
.Write("
Name
Code
Display
Action
")
Do While Not rsQuery.Eof
intRow = intRow + 1
If (intRow Mod 2) = 1 Then
strClass = "data"
Else
strClass = "dataalt"
End If
.Write("
")
.Write("
" & rsQuery(1) & "
")
.Write("
" & rsQuery(0) & "
")
.Write("
" & DisplayAdmin(rsQuery(2)) & "
")
.Write("
")
.Write("
")
rsQuery.Movenext
Loop
Else
.Write("
There are no actions configured.
")
End If
rsQuery.Close : Set rsQuery = Nothing
.Write("
")
.Write("")
.Write("
")
End With
End Select
Call DisplaySettingsFooter()
Case 5 ' CAMPAIGNS
Dim strCampaignName, strCampaignCode
strCampaignName = Request.Form("name")
strCampaignCode = Request("code")
strMode = Request.Querystring("m")
strAction = Request.Form("action")
If strMode = "" Then
strMode = "VIEW"
ElseIf strMode = "DELETE" Then
strMode = "VIEW"
strAction = "DELETE"
End If
Select Case strAction
Case "UPDATE", "ADD NEW"
' DO SOME CHECKS
If strAction = "ADD NEW" Then
If strCampaignCode = "" Then
strError = "
Code cannot be blank.
"
ElseIf strCampaignName = "" Then
strError = "
Name cannot be blank.
"
ElseIf CInt(CheckCode(strCampaignCode)) = 0 Then
strError = "
Code can only contain " &_
"letters, numbers, hyphen (-) and underscore (_). Spaces are not permitted.
"
strCampaignCode = ""
Else
strSql = "SELECT ca_code FROM " & strTablePrefix & "Campaigns WHERE ca_code LIKE " & FormatDatabaseString(strCampaignCode, 12)
Set rsCheck = Server.CreateObject("ADODB.Recordset")
rsCheck.Open strSql, objConn, 3, 1, &H0000
If Not rsCheck.Eof Then
strError = "
Code already exists.
"
End If
rsCheck.Close : Set rsCheck = Nothing
End If
End If
If strError = "" Then
strSql = "SELECT ca_code, ca_name FROM " & strTablePrefix & "Campaigns " &_
"WHERE ca_code LIKE " & FormatDatabaseString(strCampaignCode, 12)
Set rsUpdate = Server.CreateObject("ADODB.Recordset")
rsUpdate.Open strSql, objConn, 1, 2, &H0000
If rsUpdate.Eof Then
rsUpdate.AddNew
End If
rsUpdate(0) = strCampaignCode
rsUpdate(1) = strCampaignName
rsUpdate.Update
rsUpdate.Close : Set rsUpdate = Nothing
strMode = "VIEW"
End If
Case "DELETE"
strSql = "DELETE FROM " & strTablePrefix & "Campaigns WHERE ca_code LIKE " & FormatDatabaseString(strCampaignCode, 12)
Set rsDelete = Server.CreateObject("ADODB.Recordset")
rsDelete.Open strSql, objConn, 3, 1, &H0000
Set rsDelete = Nothing
End Select
Call DisplaySettingsHeader("Campaigns")
Select Case strMode
Case "EDIT"
If strCampaignCode = "" Then
strAction = "ADD NEW"
Else
strAction = "UPDATE"
strReadonly = " readonly"
strSql = "SELECT ca_code, ca_name " &_
"FROM " & strTablePrefix & "Campaigns WHERE ca_code LIKE " & FormatDatabaseString(strCampaignCode, 12)
Set rsQuery = Server.CreateObject("ADODB.Recordset")
rsQuery.Open strSql, objConn, 3, 1, &H0000
If Not rsQuery.Eof Then
strCampaignCode = rsQuery(0)
strCampaignName = rsQuery(1)
End If
rsQuery.Close : Set rsQuery = Nothing
End If
If strError <> "" Then
Response.Write("
" & strError & "
")
End If
With Response
.Write("")
End With
Case "VIEW"
strSql = "SELECT ca_code, ca_name " &_
"FROM " & strTablePrefix & "Campaigns " &_
"ORDER BY ca_name, ca_code ASC"
Set rsQuery = Server.CreateObject("ADODB.Recordset")
If strDatabaseType = "MYSQL" Then
rsQuery.CursorLocation = 3
End If
rsQuery.Open strSql, objConn, 3, 1, &H0000
intRow = 0
With Response
If rsQuery.Recordcount > 0 Then
.Write("
Name
Code
Action
")
Do While Not rsQuery.Eof
intRow = intRow + 1
If (intRow Mod 2) = 1 Then
strClass = "data"
Else
strClass = "dataalt"
End If
.Write("
")
.Write("
" & rsQuery(1) & "
")
.Write("
" & rsQuery(0) & "
")
.Write("
")
.Write("
")
.Write("
")
rsQuery.Movenext
Loop
Else
.Write("
There are no campaigns configured.
")
End If
rsQuery.Close : Set rsQuery = Nothing
.Write("
")
.Write("")
.Write("
")
End With
End Select
Call DisplaySettingsFooter()
End Select
End Sub
Private Function SetInputState(blnActual, blnRadio, strValue)
Dim strTemp
If blnActual = blnRadio Then
strTemp = strValue
End If
SetInputState = strTemp
End Function
Private Function DisplayAdmin(blnValue)
Dim strTemp
blnValue = CBool(blnValue)
If blnValue = True Then
strTemp = "Yes"
Else
strTemp = "No"
End If
DisplayAdmin = strTemp
End Function
Private Sub DisplaySettingsHeader(strName)
With Response
.Write("
")
.Write("
")
.Write("
")
.Write("
")
.Write(strName & "
")
.Write("")
.Write("
")
.Write("
")
.Write("
")
End With
End Sub
Private Sub DisplaySettingsFooter()
With Response
.Write ("
")
End With
End Sub
' *****************
' MISC DB FUNCTIONS
' *****************
Public Function GetLogDate(strType, strTable) ' MIN OR MAX
Dim datTemp
Dim strFirst : strFirst = LCase(Left(strTable, 1))
strSql = "SELECT " & strType & "(" & strFirst & "l_datetime) FROM " & strTablePrefix & strTable & "Log"
Dim rsDate : Set rsDate = Server.CreateObject("ADODB.Recordset")
rsDate.Open strSql, objConn, 3, 1, &H0000
If Not rsDate.Eof Then
datTemp = rsDate(0)
Else
datTemp = Date()
End If
rsDate.Close : Set rsDate = Nothing
GetLogDate = datTemp
End Function
' *********************
' MAINTENANCE FUNCTIONS
' *********************
Private Function UpdateDefinitions(strFileName)
Dim strError, strLine, aryLine, intLine, strResult
Dim strInstallPath : strInstallPath = Request.Servervariables("Script_Name")
strInstallPath = Left(strInstallPath, InStrRev(strInstallPath, "/") - 1) & "/data"
Dim objFSO : Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If strFileName = "" Then
strFileName = "definitions.txt"
End If
Dim objTS : Set objTS = objFSO.OpenTextFile(Server.MapPath(strInstallPath) & "\" & strFileName, 1)
strError = strError & CheckErrors(Err.Number, Err.Description)
If strError <> "" Then
UpdateDefinitions = "
Update definitions failed:
" & strError & "
"
Exit Function
End If
If strDatabaseType = "MSACCESS" Then
strSql = "DELETE FROM " & strTablePrefix & "Definitions"
Else
strSql = "TRUNCATE TABLE " & strTablePrefix & "Definitions"
End If
Dim rsTruncate : Set rsTruncate = Server.CreateObject("ADODB.Recordset")
rsTruncate.Open strSql, objConn, 1, 2, &H0000
Set rsTruncate = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
If strError <> "" Then
UpdateDefinitions = "
Update definitions failed:
" & strError & "
"
Exit Function
End If
On Error Goto 0
If Not objTS.AtEndOfStream Then
' GET FILE HEADER
Dim strFirstLine : strFirstLine = objTS.ReadLine
' CHECK HEADER
If Not CheckFileHeader("Definitions", strFirstLine) Then
UpdateDefinitions = "
The definitions file has does not have the correct header. Check the file and try again.
"
Exit Function
End If
Dim datSerial : datSerial = Right(strFirstLine, 10)
Dim rsInsert : Set rsInsert = Server.CreateObject("ADODB.Recordset")
Do While Not objTS.AtEndOfStream
intLine = objTS.Line
strLine = objTS.Readline
aryLine = Split(strLine,"||")
If UBound(aryLine) = 4 Then
If strDatabaseType = "MYSQL" Then
aryLine(0) = Replace(aryLine(0), "\", "\\")
aryLine(1) = Replace(aryLine(1), "\", "\\")
aryLine(2) = Replace(aryLine(2), "\", "\\")
aryLine(3) = Replace(aryLine(3), "\", "\\")
aryLine(4) = Replace(aryLine(4), "\", "\\")
End If
strSql = "INSERT INTO " & strTablePrefix & "Definitions " &_
"(d_name, d_regexp, d_extra, d_url, d_type) VALUES(" &_
FormatDatabaseString(Trim(aryLine(0)), 255) & ", " &_
FormatDatabaseString(Trim(aryLine(1)), 255) & ", " &_
FormatDatabaseString(Trim(aryLine(2)), 255) & ", " &_
FormatDatabaseString(Trim(aryLine(3)), 255) & ", " &_
Trim(aryLine(4)) & ")"
rsInsert.Open strSql, objConn, 1, 2, &H0000
Else
strError = strError & "
Error on line " & intLine & ".
"
End If
Loop
Set rsInsert = Nothing : Set objFSO = Nothing
End If
If strError <> "" Then
strResult = "
Update definitions partially completed, some lines had errors:
" & strError & "
"
Else
strResult = "
Definitions successfully updated.
"
Call UpdateConfigValue("Definitions", datSerial)
End If
objTS.Close : Set objTS = Nothing
UpdateDefinitions = strResult
End Function
Public Function UpdateCountries(strFileName)
Dim strError, strLine, aryLine, intLine, strResult
Dim strInstallPath : strInstallPath = Request.Servervariables("Script_Name")
strInstallPath = Left(strInstallPath, InStrRev(strInstallPath, "/") - 1) & "/data"
Dim objFSO : Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If strFileName = "" Then
strFileName = "countries.txt"
End If
On Error Resume Next
Dim objTS : Set objTS = objFSO.OpenTextFile(Server.MapPath(strInstallPath) & "\" & strFileName, 1)
strError = strError & CheckErrors(Err.Number, Err.Description)
If strError <> "" Then
UpdateCountries = "
Update Countries failed:
" & strError & "
"
Exit Function
End If
If strDatabaseType = "MSACCESS" Then
strSql = "DELETE FROM " & strTablePrefix & "IPCountry"
Else
strSql = "TRUNCATE TABLE " & strTablePrefix & "IPCountry"
End If
Dim rsTruncate : Set rsTruncate = Server.CreateObject("ADODB.Recordset")
rsTruncate.Open strSql, objConn, 1, 2, &H0000
Set rsTruncate = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
If strError <> "" Then
UpdateCountries = "
Update countries failed:
" & strError & "
"
Exit Function
End If
On Error Goto 0
If Not objTS.AtEndOfStream Then
' GET FILE HEADER
Dim strFirstLine : strFirstLine = objTS.ReadLine
' CHECK HEADER
If Not CheckFileHeader("Countries", strFirstLine) Then
UpdateCountries = "
The countries file has does not have the correct header. Check the file and try again.
"
Exit Function
End If
Dim datSerial : datSerial = Right(strFirstLine, 10)
Dim rsInsert : Set rsInsert = Server.CreateObject("ADODB.Recordset")
Do While Not objTS.AtEndOfStream
intLine = objTS.Line
strLine = objTS.Readline
aryLine = Split(strLine,"||")
If UBound(aryLine) = 2 Then
strSql = "INSERT INTO " & strTablePrefix & "IPCountry " &_
"(ic_ipstart, ic_ipend, ic_code) VALUES(" &_
Trim(aryLine(0)) & ", " &_
Trim(aryLine(1)) & ", " &_
FormatDatabaseString(Trim(aryLine(2)), 2) & ")"
rsInsert.Open strSql, objConn, 1, 2, &H0000
Else
strError = strError & "
Error on line " & intLine & ".
"
End If
Loop
Set rsInsert = Nothing : Set objFSO = Nothing
End If
If strError <> "" Then
strResult = "
Update countries partially completed, some lines had errors:
" & strError & "
"
Else
strResult = "
Countries successfully updated.
"
Call UpdateConfigValue("Countries", datSerial)
End If
objTS.Close : Set objTS = Nothing
UpdateCountries = strResult
End Function
Private Function DeleteStatistics(datStart, datEnd)
Dim strError, strResult
On Error Resume Next
strSql = "DELETE FROM " & strTablePrefix & "PageLog " &_
"WHERE pl_datetime BETWEEN " & FormatDatabaseDate(datStart) &_
" AND " & FormatDatabaseDate(datEnd & " 23:59:59")
Dim rsDelete1 : Set rsDelete1 = Server.CreateObject("ADODB.Recordset")
rsDelete1.Open strSql, objConn, 1, 2, &H0000
Set rsDelete1 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "PageNames " &_
"WHERE pn_id NOT IN (SELECT DISTINCT pl_pn_id FROM " & strTablePrefix & "PageLog)"
Dim rsDelete2 : Set rsDelete2 = Server.CreateObject("ADODB.Recordset")
rsDelete2.Open strSql, objConn, 1, 2, &H0000
Set rsDelete2 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "Referrers " &_
"WHERE r_id NOT IN (SELECT DISTINCT pl_r_id FROM " & strTablePrefix & "PageLog)"
Dim rsDelete3 : Set rsDelete3 = Server.CreateObject("ADODB.Recordset")
rsDelete3.Open strSql, objConn, 1, 2, &H0000
Set rsDelete3 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "ReferrerNames " &_
"WHERE rn_id NOT IN (SELECT DISTINCT r_rn_id FROM " & strTablePrefix & "Referrers)"
Dim rsDelete4 : Set rsDelete4 = Server.CreateObject("ADODB.Recordset")
rsDelete4.Open strSql, objConn, 1, 2, &H0000
Set rsDelete4 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "Keywords " &_
"WHERE k_id NOT IN (SELECT DISTINCT r_k_id FROM " & strTablePrefix & "Referrers)"
Dim rsDelete5 : Set rsDelete5 = Server.CreateObject("ADODB.Recordset")
rsDelete5.Open strSql, objConn, 1, 2, &H0000
Set rsDelete5 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "Sessions " &_
"WHERE s_id NOT IN (SELECT DISTINCT pl_s_id FROM " & strTablePrefix & "PageLog)"
Dim rsDelete6 : Set rsDelete6 = Server.CreateObject("ADODB.Recordset")
rsDelete6.Open strSql, objConn, 1, 2, &H0000
Set rsDelete6 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "Names " &_
"WHERE n_id NOT IN (SELECT DISTINCT s_hostname FROM " & strTablePrefix & "Sessions) " &_
"AND n_id NOT IN (SELECT DISTINCT s_useragent FROM " & strTablePrefix & "Sessions) " &_
"AND n_id NOT IN (SELECT DISTINCT s_browser FROM " & strTablePrefix & "Sessions) " &_
"AND n_id NOT IN (SELECT DISTINCT s_os FROM " & strTablePrefix & "Sessions) " &_
"AND n_id NOT IN (SELECT DISTINCT s_screenarea FROM " & strTablePrefix & "Sessions) " &_
"AND n_id NOT IN (SELECT DISTINCT k_site FROM " & strTablePrefix & "Keywords)"
Dim rsDelete7 : Set rsDelete7 = Server.CreateObject("ADODB.Recordset")
rsDelete7.Open strSql, objConn, 1, 2, &H0000
Set rsDelete7 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "CampaignLog " &_
"WHERE cl_datetime BETWEEN " & FormatDatabaseDate(datStart) &_
" AND " & FormatDatabaseDate(datEnd & " 23:59:59")
Dim rsDelete8 : Set rsDelete8 = Server.CreateObject("ADODB.Recordset")
rsDelete8.Open strSql, objConn, 1, 2, &H0000
Set rsDelete8 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "ActionLog " &_
"WHERE al_datetime BETWEEN " & FormatDatabaseDate(datStart) &_
" AND " & FormatDatabaseDate(datEnd & " 23:59:59")
Dim rsDelete9 : Set rsDelete9 = Server.CreateObject("ADODB.Recordset")
rsDelete9.Open strSql, objConn, 1, 2, &H0000
Set rsDelete9 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
On Error Goto 0
If strError <> "" Then
strResult = "
The following database errors occured:
" & strError & "
"
Else
strResult = "
Statistics deleted successfully.
"
End If
Call UpdateConfigValue("Delete_Log", Year(Date()) & "-" & FormatDatePart(Month(Date())) & "-" & FormatDatePart(Day(Date())))
DeleteStatistics = strResult
End Function
Private Function DeleteRobotLog(datStart, datEnd)
Dim strError, strResult
On Error Resume Next
strSql = "DELETE FROM " & strTablePrefix & "RobotLog " &_
"WHERE rl_datetime BETWEEN " & FormatDatabaseDate(datStart) & " " &_
"AND " & FormatDatabaseDate(datEnd & " 23:59:59")
Dim rsDelete1 : Set rsDelete1 = Server.CreateObject("ADODB.Recordset")
rsDelete1.Open strSql, objConn, 1, 2, &H0000
Set rsDelete1 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "PageNames " &_
"WHERE pn_id NOT IN (SELECT DISTINCT rl_pn_id FROM " & strTablePrefix & "RobotLog)"
Dim rsDelete2 : Set rsDelete2 = Server.CreateObject("ADODB.Recordset")
rsDelete2.Open strSql, objConn, 1, 2, &H0000
Set rsDelete2 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
strSql = "DELETE FROM " & strTablePrefix & "Names " &_
"WHERE n_id NOT IN (SELECT DISTINCT rl_useragent FROM " & strTablePrefix & "RobotLog) " &_
"AND n_id NOT IN (SELECT DISTINCT rl_robot FROM " & strTablePrefix & "RobotLog)"
Dim rsDelete3 : Set rsDelete3 = Server.CreateObject("ADODB.Recordset")
rsDelete3.Open strSql, objConn, 1, 2, &H0000
Set rsDelete3 = Nothing
strError = strError & CheckErrors(Err.Number, Err.Description)
On Error Goto 0
If strError <> "" Then
strResult = "
The following database errors occured:
" & strError & "
"
Else
strResult = "
Robot log deleted successfully.
"
End If
Call UpdateConfigValue("Delete_Robot_Log", Year(Date()) & "-" & FormatDatePart(Month(Date())) & "-" & FormatDatePart(Day(Date())))
DeleteRobotLog = strResult
End Function
Private Function CheckErrors(intNumber, strDescription)
Dim strError
If intNumber <> 0 Then
strError = strError & "
" & strDescription & "
"
Err.Clear
End If
CheckErrors = strError
End Function
' ******************
' * MISC MAINTENANCE
' ******************
Private Function CheckFileHeader(strFileType, strHeader)
Dim blnResult
If Left(strHeader, Len(strFileType) + 3) <> "##" & strFileType & ":" Or Not IsDate(Right(strHeader, 10)) Then
blnResult = False
Else
blnResult = True
End If
CheckFileHeader = blnResult
End Function
Private Sub UpdateConfigValue(strName, strValue)
strSql = "UPDATE " & strTablePrefix & "Config " &_
"SET c_value = " & FormatDatabaseString(strValue, 255) & " " &_
"WHERE c_name = " & FormatDatabaseString(strName, 255)
Dim rsUpdate : Set rsUpdate = Server.CreateObject("ADODB.RecordSet")
rsUpdate.Open strSql, objConn, 1, 2, &H0000
Set rsUpdate = Nothing
End Sub
Private Function UrlDecode(strDecode)
Dim strIn : strIn = strDecode
Dim strOut : Dim intLoop
Dim intPos : intPos = InStr(strIn, "+")
Do While intPos
Dim strLeft : Dim strRight
If intPos > 1 Then
strLeft = Left(strIn, intPos - 1)
End If
If intPos < Len(strIn) Then
strRight = Mid(strIn, intPos + 1)
End If
strIn = strLeft & " " & strRight
intPos = InStr(strIn, "+")
intLoop = intLoop + 1
Loop
intPos = InStr(strIn, "%")
Do While intPos
If intPos > 1 Then
strOut = strOut & Left(strIn, intPos - 1)
End If
strOut = strOut & Chr(CInt("&H" & Mid(strIn, intPos + 1, 2)))
If intPos > (Len(strIn) - 3) Then
strIn = ""
Else
strIn = Mid(strIn, intPos + 3)
End If
intPos = Instr(strIn, "%")
Loop
URLDecode = strOut & strIn
End Function
' ************
' * DATABASE *
' ************
Private Function CompactDatabase()
Dim strLocation, strName, strError
Dim strConn, strConnBak, strLocationType, strDB, strTempDB, strResult
strLocation = aryMTDB(1)
strName = aryMTDB(2)
' CREATE RANDOM NUMBER
Dim intSeconds : intSeconds = Second(Now())
Dim intMinutes :intMinutes = Minute(Now())
Dim intRandom : intRandom = intMinutes * intSeconds
Dim objFSO : Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
' CHECK TO SEE IF THERE IS A COLON IN strLOCATION
If Len(strLocation) > 2 Then
If Mid(strLocation, 2, 1) = ":" Or Mid(strLocation, 1, 2) = "\\" Then
' PATH USES A DRIVE LETTER, MUST BE ABSOLUTE
strLocationType = "ABSOLUTE"
Else
strLocationType = "VIRTUAL"
End If
Else
strLocationType = "VIRTUAL"
End If
If strLocationType = "ABSOLUTE" Then
strDB = strLocation & "\" & strName
strTempDB = strLocation & "\" & "db" & intRandom & ".mdb"
Else ' VIRTUAL
strDB = Server.MapPath(strLocation & "/" & strName)
strTempDB = Server.MapPath(strLocation & "/" & "db" & intRandom & ".mdb")
End If
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDB
strConnBak = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strTempDB
If IsObject(objConn) Then
objConn.Close : Set objConn = Nothing
End If
Dim objJRO : Set objJRO = Server.CreateObject("JRO.JetEngine")
objJRO.CompactDatabase strConn, strConnBak
Set objJRO = Nothing
On Error Resume Next
If objFSO.FileExists(strDB) And objFSO.FileExists(strTempDB) Then
objFSO.DeleteFile(strDB)
strError = strError & CheckErrors(Err.Number, Err.Description)
objFSO.MoveFile strTempDB, strDB
strError = strError & CheckErrors(Err.Number, Err.Description)
If strError <> "" Then
strResult = "
Compact / Repair failed:
" & strError & "
"
Else
strResult = "
Compact / Repair completed successfully.
"
End If
Else
strResult = "
Compact and Repair failed.
"
End If
On Error Goto 0
Set objFSO = Nothing
Call CreateDatabaseConnection(1)
Call UpdateConfigValue("Compact", Year(Date()) & "-" & FormatDatePart(Month(Date())) & "-" & FormatDatePart(Day(Date())))
CompactDatabase = strResult
End Function
Private Function CheckCode(strCode)
Dim intTemp, strChar, intLoop
For intLoop = 1 to Len(strCode)
strChar = Mid(strCode, intLoop, 1)
If strChar = "_" _
Or strChar = "-" _
Or IsNumeric(strChar) _
Or (Asc(UCase(strChar)) >= Asc("A") And Asc(UCase(strChar)) <= Asc("Z")) Then
intTemp = 1
Else
intTemp = 0
Exit For
End if
Next
CheckCode = intTemp
End Function
Private Function CheckDefaultDatabaseLocation()
Dim blnCheck : blnCheck = False
Dim strDBType : strDBType = aryMTDB(0)
Dim strDBLocation : strDBLocation = aryMTDB(1)
Dim strDBName : strDBName = aryMTDB(2)
If UCase(strDBType) = "MSACCESS" Then
Dim strInstallPath : strInstallPath = Request.Servervariables("Script_Name")
strInstallPath = Left(strInstallPath, InStrRev(strInstallPath, "/") - 1)
If LCase(strInstallPath) = LCase(strDBLocation) And LCase(strDBName) = "db.mdb" Then
blnCheck = True
End If
End If
CheckDefaultDatabaseLocation = blnCheck
End Function
End Class
%>