<% OPTION EXPLICIT
'###########################################################
'## 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.
'###########################################################
%>
<%
Server.ScriptTimeout = 36000
Response.Buffer = True
Dim blnForm, strError, objConn, objConn2, strSql, strClass
Dim strAction : strAction = Request.Form("action")
Dim intInstall : intInstall = CInt(Request.Form("install"))
Dim strUsername : strUsername = Request.Form("username")
Dim strPassword : strPassword = Request.Form("password")
Dim strPassword2 : strPassword2 = Request.Form("password2")
Dim strDBType : strDBType = Request.Form("dbtype")
Dim strDBLocation : strDBLocation = Request.Form("dblocation")
Dim strDBName : strDBName = Request.Form("dbname")
Dim strDBUsername : strDBUsername = Request.Form("dbusername")
Dim strDBPassword : strDBPassword = Request.Form("dbpassword")
Dim strTablePrefix : strTablePrefix = Request.Form("dbprefix")
Dim intDBCreate : intDBCreate = CInt(Request.Form("dbcreate"))
Dim intDBDefinitions : intDBDefinitions = CInt(Request.Form("dbdefinitions"))
Dim intDBCountries : intDBCountries = CInt(Request.Form("dbcountries"))
Dim intDBConfig : intDBConfig = CInt(Request.Form("dbconfig"))
Dim intUpgradeType : intUpgradeType = CInt(Request.Form("upgradetype"))
Dim strDB2Type : strDB2Type = Request.Form("db2type")
Dim strDB2Location : strDB2Location = Request.Form("db2location")
Dim strDB2Name : strDB2Name = Request.Form("db2name")
Dim strDB2Username : strDB2Username = Request.Form("db2username")
Dim strDB2Password : strDB2Password = Request.Form("db2password")
Dim strTable2Prefix : strTable2Prefix = Request.Form("db2prefix")
If strAction = "" Then
intInstall = 1
strDBType = "MSACCESS"
strDBLocation = "c:\sites\SERVERNAME\USERNAME\database"
strDBName = "stats.mdb"
strTablePrefix = "mt_"
intDBCreate = 0
intDBDefinitions = 1
intDBCountries = 1
intDBConfig = 1
intUpgradeType = 1
strDB2Type = "MSACCESS"
strDB2Location = "c:\sites\SERVERNAME\USERNAME\database"
strDB2Name = "stats.mdb"
End If
If intInstall = 1 Then
strClass = "display:none;"
End If
%>
Site Statistics Setup
<%
If strAction <> "" Then
If intDBConfig = 1 And intInstall <> 3 Then
If Len(strUsername) = 0 Then
strError = strError & "
Username is a required field.
"
End If
If Len(strPassword) = 0 Then
strError = strError & "
Password is a required field.
"
End If
If strPassword <> strPassword2 Then
strError = strError & "
Passwords do not match.
"
End If
End If
If strError = "" Then
Dim intStep : intStep = 1
With Response
.Write("" & vbcrlf)
.Write("Site Statistics Setup")
.Write("
STEP " & intStep & ": Connecting to new database...")
Response.Flush : intStep = intStep + 1
Call CreateDatabaseConnection(strDBType, strDBLocation, strDBName, strDBUsername, strDBPassword, 1)
If intInstall = 2 Then
.Write("
STEP " & intStep & ": Connecting to old database...")
Response.Flush : intStep = intStep + 1
Call CreateDatabaseConnection(strDB2Type, strDB2Location, strDB2Name, strDB2Username, strDB2Password, 2) : Response.Flush
End If
.Write("
STEP " & intStep & ": Creating database connection file...")
Response.Flush : intStep = intStep + 1
Call CreateConnectionFile(strDBType, strDBLocation, strDBName, strDBUsername, strDBPassword, strTablePrefix) : Response.Flush
If intInstall < 3 Then
If strDBType <> "MSACCESS" Then
If intDBCreate = 1 Then
.Write("
STEP " & intStep & ": Creating new database tables...")
Response.Flush : intStep = intStep + 1
Call SetupDatabase(strDBType, strTablePrefix) : Response.Flush
End If
End If
ElseIf intInstall = 3 Then
Dim strVersion
.Write("
STEP " & intStep & ": Checking Site Statistics 2.x Lite database...")
Response.Flush : intStep = intStep + 1
Call TestDatabaseLite(strDBType, strTablePrefix) : Response.Flush
If (strDBType = "MSACCESS") Or (intDBCreate = 1 And strDBType <> "MSACCESS") Then
.Write("
STEP " & intStep & ": Upgrading database tables...")
Response.Flush : intStep = intStep + 1
Call UpgradeDatabase(strDBType, strTablePrefix) : Response.Flush
End If
End If
.Write("
STEP " & intStep & ": Testing database permissions...")
Response.Flush : intStep = intStep + 1
Call TestDatabase(strDBType, strTablePrefix) : Response.Flush
If intDBConfig = 1 Then
If intInstall < 3 Then
.Write("
STEP " & intStep & ": Writing new configuration data...")
Response.Flush : intStep = intStep + 1
Call WriteConfig(strTablePrefix) : Response.Flush
End If
End If
If intDBDefinitions = 1 Then
.Write("
STEP " & intStep & ": Loading definition data...")
Response.Flush : intStep = intStep + 1
Call UpdateDefinitions() : Response.Flush
End If
If intDBCountries = 1 Then
.Write("
STEP " & intStep & ": Loading country data (this will take a few minutes)...")
Response.Flush : intStep = intStep + 1
Call UpdateCountries() : Response.Flush
End If
If intInstall = 2 Then
.Write("
STEP " & intStep & ": Upgrading data (this could take a while)...
")
Call UpgradeData(intUpgradeType)
Response.Flush
End If
Call CloseDatabaseConnection(1)
Call CloseDatabaseConnection(2)
.Write("
")
.Write("
Congratulations!
")
.Write("
Setup is complete. You can now login to Site Statistics. ")
.Write("Once you have logged in, you should check your Settings.
")
.Write("
WARNING! Delete this file (setup.asp) ")
.Write("to prevent unauthorized access.
")
End With
Else
blnForm = True
End If
Else
blnForm = True
End If
%>
<% If blnForm Then %>
")
If Err.Number = -2147467259 And strType = "MSACCESS" Then
.Write("
The problem might be that there are no write permissions on the database ")
.Write("file or that the database could not be found because of an incorrect Database Location or Name.
")
.End
End With
End Sub
Function CheckErrors(intNumber, strDescription)
Dim strError
If intNumber <> 0 Then
strError = strError & "
" & strDescription & "
"
Err.Clear
End If
CheckErrors = strError
End Function
Sub UpdateDefinitions()
Dim strError, strLine, aryLine, intLine, strResult, strFileName
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
strFileName = "definitions.txt"
Dim objTS : Set objTS = objFSO.OpenTextFile(Server.MapPath(strInstallPath) & "\" & strFileName, 1)
strError = strError & CheckErrors(Err.Number, Err.Description)
If strError <> "" Then
Response.Write("FAILED
" & strError & "
")
Exit Sub
End If
If strDBType = "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
Response.Write("FAILED
" & strError & "
")
Exit Sub
End If
On Error Goto 0
If Not objTS.AtEndOfStream Then
Dim strFirstLine : strFirstLine = objTS.ReadLine
If Not CheckFileHeader("Definitions", strFirstLine) Then
Response.Write("FAILED
The definitions file has does not have the correct header. Check the file and try again.
")
ExitSub
End If
Dim datSerial : datSerial = Right(strFirstLine, 10)
Do While Not objTS.AtEndOfStream
intLine = objTS.Line
strLine = objTS.Readline
aryLine = Split(strLine,"||")
If UBound(aryLine) = 4 Then
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)) & ")"
objConn.Execute(strSql)
Else
strError = strError & "
Error on line " & intLine & ".
"
End If
Loop
End If
If strError <> "" Then
Response.Write("OK. Update definitions partially completed, some lines had errors:
" & strError & "
")
Else
Response.Write("SUCCESS")
Call UpdateConfigValue("Definitions", datSerial)
End If
objTS.Close : Set objTS = Nothing
End Sub
Sub UpdateCountries()
Dim strError, strLine, aryLine, intLine, strResult, strFileName
Dim strInstallPath : strInstallPath = Request.Servervariables("Script_Name")
strInstallPath = Left(strInstallPath, InStrRev(strInstallPath, "/") - 1) & "/data"
Dim objFSO : Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
strFileName = "countries.txt"
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
Response.Write("FAILED
" & strError & "
")
Exit Sub
End If
If strDBType = "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
Response.Write("FAILED
" & strError & "
")
Exit Sub
End If
On Error Goto 0
If Not objTS.AtEndOfStream Then
Dim strFirstLine : strFirstLine = objTS.ReadLine
If Not CheckFileHeader("Countries", strFirstLine) Then
Response.Write("FAILED
The countries file has does not have the correct header. Check the file and try again.
")
Exit Sub
End If
Dim datSerial : datSerial = Right(strFirstLine, 10)
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) & ")"
objConn.Execute(strSql)
Else
strError = strError & "
Error on line " & intLine & ".
"
End If
Loop
End If
If strError <> "" Then
Response.Write("OK. Update countries partially completed, some lines had errors:
" & strError & "
")
Else
Response.Write("SUCCESS")
Call UpdateConfigValue("Countries", datSerial)
End If
objTS.Close : Set objTS = Nothing
End Sub
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
Sub InsertConfig(strName, strValue, strGroup, intType, intOrder, strExtra)
strSql = "INSERT INTO " & strTablePrefix & "Config (c_name, c_value, c_group, c_type, c_order, c_extra) VALUES" &_
"(" & FormatString(strName, 255) & ", " &_
FormatString(strValue, 255) & ", " &_
FormatString(strGroup, 255) & ", " &_
intType & ", " &_
intOrder & ", " &_
FormatString(strExtra, 255) & ")"
objConn.Execute(strSql)
End Sub
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
Sub UpdateConfigOrder(strName, intOrder)
strSql = "UPDATE " & strTablePrefix & "Config " &_
"SET c_order = " & intOrder & " " &_
"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
Sub UpgradeData(intUpgradeType)
Dim datBegin
If intUpgradeType = 2 Then
datBegin = FormatDatabaseDate(DateAdd("d", -7, Date()), strDB2Type)
ElseIf intUpgradeType = 3 Then
datBegin = FormatDatabaseDate(DateAdd("m", -1, Date()), strDB2Type)
ElseIf intUpgradeType = 4 Then
datBegin = FormatDatabaseDate(DateAdd("m", -3, Date()), strDB2Type)
ElseIf intUpgradeType = 5 Then
datBegin = FormatDatabaseDate(DateAdd("m", -6, Date()), strDB2Type)
ElseIf intUpgradeType = 6 Then
datBegin = FormatDatabaseDate(DateAdd("m", -12, Date()), strDB2Type)
End If
strSql = "SELECT COUNT(*) FROM " & strTable2Prefix & "PageLog "
If datBegin <> "" Then
strSql = strSql & "WHERE pl_datetime > " & datBegin
End If
Dim rsCount : Set rsCount = objConn2.Execute(strSql)
Dim intRecords : intRecords = rsCount(0)
rsCount.Close : Set rsCount = Nothing
With Response
.Write("
")
.Write("
")
.Flush
End With
Dim intCounter : intCounter = 0
Dim rsDefinitions : Set rsDefinitions = CreateObject("ADODB.Recordset")
strSql = "SELECT d_id, d_name, d_regexp, d_extra, d_type " &_
"FROM " & strTablePrefix & "Definitions " &_
"ORDER BY d_id ASC"
rsDefinitions.Open strSql, objConn, 0, 1, &H0001
strSql = "SELECT pl_datetime, pl_scriptname, pl_scripturl, pl_referrer, pl_referrerurl, pl_referrerhost, " &_
"pl_referrerdomain, pl_referrerextension, pl_keywords, pl_sessionid, pl_useragent, " &_
"pl_ipaddress, pl_remotehost, pl_browser, pl_browsertype, pl_screenarea, pl_os, pl_language " &_
"FROM " & strTable2Prefix & "PageLog "
If datBegin <> "" Then
strSql = strSql & "WHERE pl_datetime > " & datBegin & " "
End If
strSql = strSql & "ORDER BY pl_datetime ASC"
Dim rsPageLog : Set rsPageLog = objConn2.Execute(strSql)
Do While Not rsPageLog.Eof
intCounter = intCounter + 1
Dim datHit : datHit = rsPageLog(0)
Dim strScriptName : strScriptName = rsPageLog(1)
Dim strScriptUrl : strScriptUrl = rsPageLog(2)
Dim strReferrer : strReferrer = rsPageLog(3)
Dim strReferrerPage : strReferrerPage = rsPageLog(4)
Dim strReferrerHost : strReferrerHost = rsPageLog(5)
Dim strReferrerDomain : strReferrerDomain = rsPageLog(6)
Dim strReferrerExtension : strReferrerExtension = rsPageLog(7)
Dim strKeywords : strKeywords = rsPageLog(8)
Dim strSession : strSession = rsPageLog(9)
Dim strUserAgent : strUseragent = rsPageLog(10)
Dim strIPAddress : strIPAddress = rsPageLog(11)
Dim strHost : strHost = rsPageLog(12)
Dim strBrowser : strBrowser = rsPageLog(13)
Dim strBrowserType : strBrowserType = rsPageLog(14)
Dim strResolution : strResolution = rsPageLog(15)
Dim strOS : strOS = rsPageLog(16)
Dim strLanguage : strLanguage = rsPageLog(17)
If strHost = strIPAddress Then
strHost = ""
End If
Dim intSessionID : If Len(strIPAddress) > 0 Then
intSessionID = Left(strSession, Len(strSession) - Len(Replace(strIPAddress, ".", "")))
Else
intSessionID = strSession
End if
Dim intIPNumber : intIPNumber = ConvertIPAddressToLong(strIPAddress)
Dim strPath : strPath = ExtractPath(strScriptName)
Dim strExtension : strExtension = ExtractFileType(strScriptName)
strSql = "SELECT pn_id, pn_url, pn_page, pn_path, pn_extension " &_
"FROM " & strTablePrefix & "PageNames " &_
"WHERE pn_url = " & FormatDatabaseString(strScriptUrl, 255)
Dim rsUrl : Set rsUrl = Server.CreateObject("ADODB.Recordset")
If strDBType = "MYSQL" Then
rsUrl.CursorLocation = 3
End If
rsUrl.Open strSql, objConn, 1, 2, &H0001
If rsUrl.Eof Then
rsUrl.AddNew
rsUrl(1) = ProtectInsert(strScriptUrl, 255)
rsUrl(2) = ProtectInsert(strScriptName, 255)
rsUrl(3) = ProtectInsert(strPath, 255)
rsUrl(4) = ProtectInsert(strExtension, 10)
rsUrl.Update
End If
Dim intPage : intPage = rsUrl("pn_id")
rsUrl.Close : Set rsUrl = Nothing
Dim intUserAgent
If strBrowserType <> "Robot" Then
strSql = "SELECT s_id, s_ip, s_hostname, s_useragent, s_browser, " &_
"s_os, s_language, s_country, s_screenarea " &_
"FROM " & strTablePrefix & "Sessions " &_
"WHERE s_id = " & intSessionID
Dim rsSession : Set rsSession = Server.CreateObject("ADODB.Recordset")
rsSession.Open strSql, objConn, 1, 2, &H0001
If rsSession.Eof Then
Dim strCountry
If CheckPrivateIP(strIPAddress) = True Then
strCountry = "00"
Else
strCountry = GetCountry(intIPNumber)
End If
strLanguage = CleanLanguage(strLanguage)
intUserAgent = CheckName(2, strUserAgent)
Dim intHost : intHost = CheckName(1, strHost)
Dim intResolution : intResolution = CheckName(3, strResolution)
Dim intBrowser : intBrowser = CheckName(4, strBrowser)
Dim intOs : intOs = CheckName(5, strOs)
rsSession.Addnew
rsSession(0) = intSessionID
rsSession(1) = intIPNumber
rsSession(2) = intHost
rsSession(3) = intUserAgent
rsSession(4) = intBrowser
rsSession(5) = intOs
rsSession(6) = ProtectInsert(strLanguage, 5)
rsSession(7) = ProtectInsert(strCountry, 2)
rsSession(8) = intResolution
rsSession.Update
End If
rsSession.Close : Set rsSession = Nothing
Dim intReferrer : intReferrer = 0
If strReferrer <> "" And strReferrerPage = "" And strReferrerDomain = "" Then
strReferrer = ""
End If
If strReferrer <> "" Then
strSql = "SELECT r_id, r_url, r_rn_id, r_k_id " &_
"FROM " & strTablePrefix & "Referrers " &_
"WHERE r_url = " & FormatDatabaseString(strReferrer, 255)
Dim rsReferrer : Set rsReferrer = Server.CreateObject("ADODB.Recordset")
If strDBType = "MYSQL" Then
rsReferrer.CursorLocation = 3
End If
rsReferrer.Open strSql, objConn, 1, 2, &H0001
If rsReferrer.Eof Then
strSql = "SELECT rn_id, rn_page, rn_host, rn_domain, rn_extension " &_
"FROM " & strTablePrefix & "ReferrerNames " &_
"WHERE rn_page = " & FormatDatabaseString(strReferrerPage, 255)
Dim rsReferrerName : Set rsReferrerName = Server.CreateObject("ADODB.Recordset")
If strDBType = "MYSQL" Then
rsReferrerName.CursorLocation = 3
End If
rsReferrerName.Open strSql, objConn, 1, 2, &H0001
If rsReferrerName.Eof Then
rsReferrerName.AddNew
rsReferrerName(1) = ProtectInsert(strReferrerPage, 255)
rsReferrerName(2) = ProtectInsert(strReferrerHost, 255)
rsReferrerName(3) = ProtectInsert(strReferrerDomain, 100)
rsReferrerName(4) = ProtectInsert(strReferrerExtension, 10)
rsReferrerName.Update
End If
Dim intReferrerName : intReferrerName = rsReferrerName(0)
rsReferrerName.Close : Set rsReferrerName = Nothing
Dim intKeywords : intKeywords = 0
If strKeywords <> "" Then
Dim strSite : strSite = MatchDefinition(rsDefinitions, strReferrer, 4)
Dim intSite : intSite = CheckName(7, strSite)
strSql = "SELECT k_id, k_value, k_site " &_
"FROM " & strTablePrefix & "Keywords " &_
"WHERE k_value = " & FormatDatabaseString(strKeywords, 255) & " " &_
"AND k_site = " & intSite
Dim rsKeywords : Set rsKeywords = Server.CreateObject("ADODB.Recordset")
If strDBType = "MYSQL" Then
rsKeywords.CursorLocation = 3
End If
rsKeywords.Open strSql, objConn, 1, 2, &H0001
If rsKeywords.Eof Then
rsKeywords.AddNew
rsKeywords(1) = ProtectInsert(strKeywords, 255)
rsKeywords(2) = intSite
rsKeywords.Update
End If
intKeywords = rsKeywords("k_id")
rsKeywords.Close : Set rsKeywords = Nothing
End If
rsReferrer.Addnew
rsReferrer(1) = ProtectInsert(strReferrer, 255)
rsReferrer(2) = intReferrerName
rsReferrer(3) = intKeywords
rsReferrer.Update
End If
intReferrer = rsReferrer(0)
rsReferrer.Close : Set rsReferrer = Nothing
End If
strSql = "INSERT INTO " & strTablePrefix & "PageLog (pl_datetime, pl_pn_id, pl_r_id, pl_s_id) VALUES(" &_
FormatDatabaseDate(datHit, strDBType) & ", " &_
intPage & ", " &_
intReferrer & ", " &_
intSessionID & ")"
objConn.Execute(strSql)
Else
intUserAgent = CheckName(2, strUserAgent)
Dim intRobot : intRobot = CheckName(6, strBrowser)
strSql = "INSERT INTO " & strTablePrefix & "RobotLog (rl_datetime, rl_pn_id, rl_useragent, rl_robot, rl_ip) VALUES(" &_
FormatDatabaseDate(datHit, strDBType) & ", " &_
intPage & ", " &_
intUserAgent & ", " &_
intRobot & ", " &_
intIPNumber & ")"
objConn.Execute(strSql)
End If
If (intCounter Mod 100 = 0 Or intCounter = intRecords) Then
Response.Write("" & vbcrlf)
Response.Flush
End If
rsPageLog.Movenext
Loop
rsDefinitions.Close : Set rsDefinitions = Nothing
rsPageLog.Close : Set rsPagelog = Nothing
End Sub
Function FormatDatabaseDate(datDate, strType)
Dim datDateTemp, datTimeTemp, strDateFormat, strTimeFormat
Dim datTemp, strSeparator, datDatabaseDate, datDatabaseTime, datFull
If strType = "MSSQL" Then
strDateFormat = "YYYYMMDD"
Else
strDateFormat = "YYYY-MM-DD"
End If
strTimeFormat = "HH:MM:SS"
datDateTemp = UCase(strDateFormat)
datTimeTemp = UCase(strTimeFormat)
datDateTemp = Replace(datDateTemp, "DD", FormatDatePart(Day(datDate)))
datDateTemp = Replace(datDateTemp, "MMMM", MonthName(Month(datDate), False))
datDateTemp = Replace(datDateTemp, "MMM", MonthName(Month(datDate), True))
datDateTemp = Replace(datDateTemp, "MM", FormatDatePart(Month(datDate)))
datDateTemp = Replace(datDateTemp, "YYYY", Year(datDate))
datDateTemp = Replace(datDateTemp, "YY", Right(Year(datDate), 2))
datTimeTemp = Replace(datTimeTemp, "HH", FormatDatePart(DatePart("h", datDate)))
datTimeTemp = Replace(datTimeTemp, "MM", FormatDatePart(DatePart("n", datDate)))
datTimeTemp = Replace(datTimeTemp, "SS", FormatDatePart(DatePart("s", datDate)))
If strType = "MSACCESS" Then
strSeparator = "#"
Else
strSeparator = "'"
End If
datTemp = strSeparator & datDateTemp & " " & datTimeTemp & strSeparator
FormatDatabaseDate = datTemp
End Function
Function FormatDatePart(datPart)
Dim datTemp
If Len(datPart) = 1 Then
datTemp = "0" & datPart
Else
datTemp = datPart
End If
FormatDatePart = datTemp
End Function
Function FormatDatabaseString(strString, intLength)
Dim strTemp
If strDBType = "MYSQL" Then
strTemp = "'" & Replace(Replace(Left(strString, intLength), "\", "\\"), "'", "''") & "'"
Else
strTemp = "'" & Replace(Left(strString, intLength), "'", "''") & "'"
End If
FormatDatabaseString = strTemp
End Function
Function ConvertIPAddressToLong(strIPAddress)
Dim strTemp : strTemp = strIPAddress
Dim aryIP : aryIP = Split(strTemp, ".")
Dim intNumber : intNumber = (CInt(aryIP(0)) * 16777216) + (CInt(aryIP(1)) * 65536) + (CInt(aryIP(2)) * 256) + CInt(aryIP(3))
intNumber = intNumber - 2147483647
ConvertIPAddressToLong = intNumber
End Function
Function ExtractPath(strScriptName)
Dim strTemp : strTemp = Left(strScriptName, InStrRev(strScriptName, "/"))
ExtractPath = strTemp
End Function
Function ExtractFileType(strScriptName)
Dim strTemp
If InstrRev(strScriptName, ".") > 0 Then
strTemp = Mid(strScriptName, InStrRev(strScriptName, ".") + 1)
Else
strTemp = ""
End If
ExtractFileType = strTemp
End Function
Function GetCountry(intIPNumber)
Dim strValue
If Not IsNumeric(intIPNumber) Then
strValue = ""
Else
strSql = "SELECT ic_code FROM " & strTablePrefix & "IPCountry " &_
"WHERE " & intIPNumber & " BETWEEN ic_ipstart and ic_ipend"
Dim rsCountry : Set rsCountry = Server.CreateObject("ADODB.Recordset")
rsCountry.Open strSql, objConn, 1, 2, 1
If Not rsCountry.Eof Then
strValue = rsCountry(0)
Else
strValue = ""
End If
rsCountry.Close
Set rsCountry = Nothing
End If
GetCountry = strValue
End Function
Function CheckName(intType, strName)
Dim intValue
If strName = "" Then
intValue = 0
Else
strSql = "SELECT n_id, n_value, n_type FROM " & strTablePrefix & "Names WHERE n_value = " & FormatDatabaseString(strName, 255)
Dim rsName : Set rsName = Server.CreateObject("ADODB.Recordset")
If strDBType = "MYSQL" Then
rsName.CursorLocation = 3
End If
rsName.Open strSql, objConn, 1, 2, &H0001
If rsName.Eof Then
rsName.AddNew
rsName("n_value") = ProtectInsert(strName, 255)
rsName("n_type") = intType
rsName.Update
End If
intValue = rsName("n_id")
rsName.Close
Set rsName = Nothing
End If
CheckName = intValue
End Function
Public Function ExtractHost(strReferrer)
Dim strTemp : strTemp = strReferrer
strTemp = Replace(strTemp, "http://", "")
strTemp = Replace(strTemp, "https://", "")
If InStr(strTemp, "/") > 0 Then
strTemp = Mid(strTemp, 1, InStr(strTemp, "/") - 1)
End If
ExtractHost = strTemp
End Function
Public Function ExtractDomain(strHost)
Dim strDomain, strExtension
Dim strTemp : strTemp = strHost
If InStr(strTemp, ".") > 0 Then
Dim strEnd : strEnd = Mid(strTemp, InStrRev(strTemp, "."))
If InStr(".com.net.org.edu.gov.mil.int.aero.biz.coop.info.museum.name.pro", strEnd) > 0 Then
strExtension = strEnd
Else
If Len(strEnd) = 3 And Not IsNumeric(Right(strEnd, 2)) Then
Dim strRemainder : strRemainder = Left(strTemp, Len(strTemp) - Len(strEnd))
Dim strPart : strPart = Right(strRemainder, Len(strRemainder) - InStrRev(strRemainder, ".") + 1)
Dim strGeneric : strGeneric = ".ac.com.co.edu.go.gv.gov.govt.int.ltd.mi.mil.net.or.org.plc"
Select Case strEnd
Case ".ca"
strExtension = CheckExtension(".ab.bc.mb.nb.nf.ns.nt.nu.on.pe.qc.sk.yk", strPart, strEnd)
Case Else
strExtension = CheckExtension(strGeneric, strPart, strEnd)
End Select
If strExtension = "" Then
strExtension = strEnd
End If
End If
End If
End If
If strExtension <> "" Then
Dim objSearch : Set objSearch = New RegExp
Dim strPattern : strPattern = "[\w|\-]+" & Replace(strExtension, ".", "\.") & "$"
With objSearch
.Pattern = strPattern
.IgnoreCase = True
.Global = False
End With
Dim objResults : Set objResults = objSearch.Execute(strTemp)
If objResults.Count > 0 Then
Dim colItem
For Each colItem In objResults
strDomain = colItem.Value
Exit For
Next
End If
Set objSearch = Nothing : Set objResults = Nothing
Else
strDomain = ""
End If
ExtractDomain = strDomain
End Function
Function CheckExtension(strCompare, strPart, strEnd)
Dim strTemp
If InStr(strCompare, strPart) > 0 Then
strTemp = strPart & strEnd
End If
CheckExtension = strTemp
End Function
Public Function ExtractExtension(strDomain)
Dim strTemp : strTemp = strDomain
If strDomain <> "" Then
strTemp = Mid(strTemp, InStr(strTemp, "."))
Else
strTemp = ""
End If
ExtractExtension = strTemp
End Function
Function CleanLanguage(strLanguage)
Dim strTemp : strTemp = strLanguage
If strTemp <> "" Then
If InStr(strTemp, ",") > 0 Then
strTemp = Trim(Left(strTemp, InStr(strTemp, ",") - 1))
Else
strTemp = Trim(strTemp)
End If
If InStr(strTemp, ";") > 0 Then
strTemp = Trim(Left(strTemp, InStr(strTemp, ";") - 1))
End If
End If
CleanLanguage = strTemp
End Function
Function MatchDefinition(rsDefinition, strCompare, intType)
Dim strMatch
rsDefinition.Filter = "d_type = " & intType
Do While Not rsDefinition.Eof
Dim objSearch : Set objSearch = New RegExp
With objSearch
.Pattern = rsDefinition(2)
.IgnoreCase = True
.Global = False
End With
If objSearch.Test(strCompare) = True Then
strMatch = rsDefinition(1)
Exit Do
End If
Set objSearch = Nothing
rsDefinition.Movenext
Loop
MatchDefinition = strMatch
End Function
Function CheckPrivateIP(strIPAddress)
Dim blnCheck : blnCheck = False
If Left(strIPAddress, 3) = "10." Then
blnCheck = True
ElseIf Left(strIPAddress, 7) = "192.168" Then
blnCheck = True
ElseIf Left(strIPAddress, 4) = "172." Then
Dim aryIP : aryIP = Split(strIPAddress, ".")
If UBound(aryIP) = 3 Then
If CInt(aryIP(1)) => 16 And CInt(aryIP(1)) =< 31 Then
blnCheck = True
End If
End If
End If
CheckPrivateIP = blnCheck
End Function
Function ProtectInsert(strValue, intLength)
ProtectInsert = Left(strValue, intLength)
End Function
Function FormatString(strValue, intLength)
FormatString = "'" & Replace(Left(strValue, intLength), "'", "''") & "'"
End Function
%>
