<% Response.Buffer = True %> <% ' HEADER ********************************************************************** %> <% ' END HEADER ****************************************************************** ' DESCRIPTION ***************************************************************** ' Name: db.inc ' Author: Bob Doyle and Derek Doyle ' Copyright 1999-2001 skyBuilders.com. All rights reserved. GPL ' ' make the database connection and define common-tool methods ' included in almost every server page ' ' 20010816 dtd ' vars and methods modernized to 's', 'a', and 'm' standard names ' END DESCRIPTION ************************************************************* ' SERVER DECLARATIONS ********************************************************* Dim oDBConnection, sOrgPath Dim sSQLQuery Dim sLocaleID Dim sCopyrightString Dim sUnixEpoch, sServerUEStart, sServerZoneOffset Dim sDBServerType Dim sQuoteString Dim sUserAgent Dim sScheduleColor, sLogoColor, sLoginColor, sHiLiteColor, sColor, sDarkColor ' for PageCurrent.inc and PageFooter.inc Dim sVariantFileName, sPageText, sCurrentPageID ' Dim sLocaleID, SELECTStrings Dim sStatusMessage, sMessageDuration ' END SERVER DECLARATIONS ***************************************************** ' SERVER SUBROUTINES ********************************************************** ' contents of old QuoteSQL.inc: ' unQuote when sending to the Database (for SQL entry to DB) ' reQuote when returning from Database (RSTablelist out of DB) ' use escape() or Server.URLEncode() for QueryStrings ' Single quote (apostrophe i.e. ') must be escaped for SQL by a second apostrophe 2000/01/24 ' Double quote (quote i.e. ") character breaks HTML attribute VALUE="" in Form Input ' many accented characters will break the interface - in reQuote we replace with HTML entities ' we must restore reQuoting for memo fields - though they do not get edited through INPUT tags, but through TEXTAREA tags, which are not broken by a double quote, they may still have accented chars ' so for display only reQuote with entities - then HTML restores double quote on display ' added getStringsText, getStringsMemo 2000/07/23 FUNCTION mUnQuote(sSourceString) ' use to mUnQuote(for SQL entry to DB) Dim sQuoteString ' Response.Write("
SQLQuery = " & sSQLQuery) sQuoteString = sSourceString If (IsNull(sQuoteString) OR (sQuoteString = "")) Then sQuoteString = "**NULL**" Else ' is this line needed any longer? ' sQuoteString = Replace(sSourceString,CHR(039) & CHR(039),CHR(034)) ' escape single quote for sSQLQuery sQuoteString = Replace(sQuoteString, CHR(039), CHR(039) & CHR(039)) End If mUnQuote = sQuoteString END FUNCTION FUNCTION mReQuote(sSourceString) ' use to mReQuote(RSTablelist out of DB) Dim sQuoteString, sEntity ' Response.Write("
sSourceString = " & sSourceString) ' Response.Write("
sSQLQuery = " & sSQLQuery) sQuoteString = sSourceString If (sQuoteString = "**NULL**") Then sQuoteString = "" End If If Not (IsNull(sQuoteString) OR (sQuoteString = "")) Then sQuoteString = Replace(sQuoteString, "**NULL**", "") ' sQuoteString = Replace(sSourceString,CHR(187),CHR(039)) ' sQuoteString = Replace(sQuoteString, "**NULL**", "") ' sQuoteString = sSourceString ' escape double quote for form INPUT tags ' was sQuoteString = Replace(sQuoteString,CHR(034),CHR(039) & CHR(039)) ' Response.Write("
sQuoteString = " & sQuoteString) ' & (ampersand) must come first, since it would break any other entities - be careful not to do any subsequent replacements on # (hash mark/pound) or ; (semi-colon), as they will break everything too sQuoteString = Replace(sQuoteString, CHR(038), "&") ' ampersand sQuoteString = Replace(sQuoteString, CHR(034), """) ' double quote sQuoteString = Replace(sQuoteString, CHR(039), "'") ' apostrophe sQuoteString = Replace(sQuoteString, CHR(169), "©") ' copyright sQuoteString = Replace(sQuoteString, CHR(153), "™") ' trademark sQuoteString = Replace(sQuoteString, CHR(010), " ") ' CR/NL sQuoteString = Replace(sQuoteString, CHR(013), " ") ' CR/NL If (InStr(sUserAgent, "Mac") > 0) Then ' Response.Write("
sQuoteString before mac replacement = " & sQuoteString) ' sQuoteString = Replace(sQuoteString, CHR(010) & CHR(013), "\r") ' CR/NL sQuoteString = Replace(sQuoteString, " " & " ", " ") ' CR/NL ' sQuoteString = Replace(sQuoteString, CHR(013), "\r") ' CR ' the next line corrects for the earlier insidious whitespace problem - in June, check whether there are any whitespace problems, and take this next line out if there aren't any sQuoteString = Replace(sQuoteString, " ", " ") End If ' accented characters For sEntity = 192 to 255 sQuoteString = Replace(sQuoteString, CHR(sEntity), "&#" & sEntity & ";") Next ' Response.Write ("
sQuoteString = " & sQuoteString) Else End If mReQuote = sQuoteString END FUNCTION FUNCTION mEscapeToJS(sSourceString) Dim sQuoteString sQuoteString = sSourceString If Not (IsNull(sQuoteString) OR (sQuoteString = "")) Then ' sQuoteString = Replace(sSourceString,CHR(187),CHR(039)) ' Response.Write("
sQuoteString = " & sQuoteString) ' the main things for JS are both types of quotes, the CR/NL, and the backslash sQuoteString = Replace(sQuoteString, CHR(092), "\\") ' backslash sQuoteString = Replace(sQuoteString, CHR(060), "\<") ' less than sQuoteString = Replace(sQuoteString, CHR(062), "\>") ' greater than sQuoteString = Replace(sQuoteString, CHR(034), "\" & CHR(034)) ' double quote sQuoteString = Replace(sQuoteString, CHR(039), "\'") ' apostrophe sQuoteString = Replace(sQuoteString, CHR(038), "\&") ' semicolon - this one is not strictly necessary - just to keep html entities from being resolved too soon and breaking statements by creating apostrophes ' line feed (javascript escape /n) ' carriage return (javascript escape /r) ' these two characters are a major issue on the Macintosh - it interprets either character as a line delimiter in a textarea, causing skyWriter to double the number of lines in a piece of code upon loading it, which then gets written to the file upon save ' the sequence that windows generates is CR/LF or 13, 10. if we replace this sequence with just one character, 13, under those circumstances, it may solve the problem ' will the parameters of this replacement have to change if we are serving from a *nix or macintosh file? Will they be different for each client/server combination? If (InStr(sUserAgent, "Mac") > 0) Then ' Response.Write("
sQuoteString before mac replacement = " & sQuoteString) ' sQuoteString = Replace(sQuoteString, CHR(010) & CHR(013), "\r") ' CR/NL sQuoteString = Replace(sQuoteString, CHR(013) & CHR(010), "\r") ' CR/NL sQuoteString = Replace(sQuoteString, CHR(013), "\r") ' CR ' the next line corrects for the earlier insidious whitespace problem - in June, check whether there are any whitespace problems, and take this next line out if there aren't any sQuoteString = Replace(sQuoteString, "\r\r\r\r", "\r") If (0 = 1) Then ' debugging the mac CRLF bug If (sToolsPriv > 4) Then sHoldString = sQuoteString sQuoteString = "begin ASCII debug: " ' sQuoteString = "begin ASCII debug: Length = " & Len(holdString) & " Asc test = " & Asc("a") & " MID test (should be '\') = " & Asc(Mid(holdString, 1, 1)) & " And the ASCII itself = " For sNumLetter = 1 to Len(sHoldString) - 1 sQuoteString = sQuoteString & " " & Asc(Mid(sHoldString, sNumLetter, 1)) Next End If End If Else sQuoteString = Replace(sQuoteString, CHR(010), "\n") ' CR/NL sQuoteString = Replace(sQuoteString, CHR(013), "\r") ' CR/NL End If ' Response.Write("
sQuoteString = " & sQuoteString) End If mEscapeToJS = sQuoteString END FUNCTION FUNCTION mXMLEscape(sSourceString) Dim sQuoteString ' Response.Write ("
sSourceString = " & sSourceString) ' Response.Write ("
sSQLQuery = " & sSQLQuery) sQuoteString = sSourceString If (sQuoteString = "**NULL**") Then sQuoteString = "" End If If Not (IsNull(sQuoteString) OR (sQuoteString = "")) Then ' Response.Write ("
sQuoteString = " & sQuoteString) ' & (ampersand) must come first, since it would break any other entities - be careful not to do any subsequent replacements on # (hash mark/pound) or ; (semi-colon), as they will break everything too sQuoteString = Replace(sQuoteString, CHR(038), "&") ' ampersand sQuoteString = Replace(sQuoteString, CHR(034), """) ' double quote sQuoteString = Replace(sQuoteString, CHR(039), "'") ' apostrophe sQuoteString = Replace(sQuoteString, CHR(060), "<") ' less than sQuoteString = Replace(sQuoteString, CHR(062), ">") ' greater than ' Response.Write ("
sQuoteString = " & sQuoteString) End If mXMLEscape = sQuoteString END FUNCTION FUNCTION mXMLUnescape(sSourceString) Dim sQuoteString ' Response.Write ("
sSourceString = " & sSourceString) ' Response.Write ("
sSQLQuery = " & sSQLQuery) sQuoteString = sSourceString If (sQuoteString = "**NULL**") Then sQuoteString = "" End If If Not (IsNull(sQuoteString) OR (sQuoteString = "")) Then ' Response.Write ("
sQuoteString = " & sQuoteString) ' & (ampersand) must come first, since it would break any other entities - be careful not to do any subsequent replacements on # (hash mark/pound) or ; (semi-colon), as they will break everything too sQuoteString = Replace(sQuoteString, "&", CHR(038)) ' ampersand sQuoteString = Replace(sQuoteString, """, CHR(034)) ' double quote sQuoteString = Replace(sQuoteString, "'", CHR(039)) ' apostrophe sQuoteString = Replace(sQuoteString, "<", CHR(060)) ' less than sQuoteString = Replace(sQuoteString, ">", CHR(062)) ' greater than ' Response.Write ("
sQuoteString = " & sQuoteString) End If mXMLUnescape = sQuoteString END FUNCTION FUNCTION mGetStringsText(sStringName) ' Response.Write ("
mGetStringsText(" & sStringName & ")") sSQLQuery = "SELECT ODBM_Strings.ID, ODBM_StringsText.StringsID, ODBM_Strings.Name, ODBM_StringsText.StringText FROM ODBM_Strings INNER JOIN ODBM_StringsText ON (ODBM_Strings.ID = ODBM_StringsText.StringsID) WHERE ODBM_Strings.Name = '" & sStringName & "' AND ODBM_StringsText.LocaleID = " & sLocaleID & ";" ' Response.Write("
SQLQuery = " & sSQLQuery) Set SELECTStrings = oDBConnection.Execute(sSQLQuery) If (SELECTStrings.EOF) Then Response.Write ("
mGetStringsText cannot find " & sStringName) Else mGetStringsText = mReQuote(SELECTStrings("StringText")) End If ' Response.Write("
mGetStringsText(" & sStringName & ")" & mReQuote(SELECTStrings("StringText"))) End FUNCTION FUNCTION mGetStringsMemo(sStringName) sSQLQuery = "SELECT ODBM_Strings.ID, ODBM_StringsMemo.StringsID, Name, StringMemo FROM ODBM_Strings INNER JOIN ODBM_StringsMemo ON (ODBM_Strings.ID = ODBM_StringsMemo.StringsID) WHERE Name = '" & sStringName & "' AND LocaleID = " & sLocaleID & ";" ' Response.Write("
SQLQuery = " & sSQLQuery) Set SELECTStrings = oDBConnection.Execute(sSQLQuery) If (SELECTStrings.EOF) Then Response.Write("
mGetStringsMemo cannot find " & sStringName) Else mGetStringsMemo = mReQuote(SELECTStrings("StringMemo")) End If End FUNCTION FUNCTION mGetModulePrivileges(sThisUserID, sModuleID, sPrivType) Dim sPrivLevel sSQLQuery = "SELECT PrivLevel FROM ODBM_User_Module WHERE UserID = " & sThisUserID & " AND ModuleID = " & sModuleID & " AND PrivType = '" & sPrivType & "';" ' Response.Write ("
SQLQuery = " & sSQLQuery) Set SELECTPrivileges = oDBConnection.Execute(sSQLQuery) ' Response.Write("
SELECTPrivileges('PrivLevel') = " & SELECTPrivileges("PrivLevel")) If (SELECTPrivileges.EOF) Then ' the chosen User has no privileges set for this module; substitute the default user's privileges sSQLQuery = "SELECT um.PrivLevel FROM (ODBM_User_Module AS um INNER JOIN ODBM_Users AS u ON (um.UserID = u.ID)) WHERE u.UserName = 'Default' AND um.ModuleID = " & sModuleID & " AND um.PrivType = '" & sPrivType & "';" ' Response.Write ("
SQLQuery = " & sSQLQuery) Set SELECTPrivileges = oDBConnection.Execute(sSQLQuery) If (SELECTPrivileges.EOF) Then ' default privilege is Normal sPrivLevel = 3 Else sPrivLevel = SELECTPrivileges("PrivLevel") End If sSQLQuery = "INSERT INTO ODBM_User_Module (UserID, ModuleID, PrivLevel, PrivType) VALUES (" & sThisUserID & ", " & sModuleID & ", " & sPrivLevel & ", 'Modular');" ' Response.Write("
SQLQuery = " & sSQLQuery) Set INSERTPrivileges = oDBConnection.Execute(sSQLQuery) Else sPrivLevel = SELECTPrivileges("PrivLevel") End If mGetModulePrivileges = sPrivLevel End FUNCTION FUNCTION mGetModularPrivileges(sThisUserID, sModuleName) Dim sThisModuleID, SELECTModules sSQLQuery = "SELECT * FROM ODBM_Modules WHERE ModuleName = '" & sModuleName & "';" ' Response.Write("
SQLQuery = " & sSQLQuery) Set SELECTModules = oDBConnection.Execute(sSQLQuery) sThisModuleID = SELECTModules("ID") ' Response.Write ("
sModuleID = " & sModuleID) mGetModularPrivileges = mGetModulePrivileges(sThisUserID, sThisModuleID, "Modular") End FUNCTION Sub mGetModuleColors(sModuleName) Dim sModuleDark sModuleDark = sModuleName & "Dark" sSQLQuery = "SELECT Name, Color FROM ODBM_Colors WHERE ((Name = 'Schedule') OR (Name = '" & sModuleName & "') OR (Name = '" & sModuleDark & "'));" Set SELECTColors = oDBConnection.Execute(sSQLQuery) While NOT (SELECTColors.EOF) Select Case SELECTColors("Name") Case "Schedule" sScheduleColor = "#" & SELECTColors("Color") Case sModuleName sColor = "#" & SELECTColors("Color") Case sModuleDark sDarkColor = "#" & SELECTColors("Color") End Select SELECTColors.MoveNext Wend End Sub Function mGetColor(sColorName) ' to support deprecated calls sColorName = Replace(sColorName, "Color", "") sSQLQuery = "SELECT Color FROM ODBM_Colors WHERE Name = '" & sColorName & "';" Set SELECTColors = oDBConnection.Execute(sSQLQuery) mGetColor = "#" & SELECTColors("Color") End Function Sub mMakeModularPrivileges(sThisUserID, sModuleName, sNewPrivLevel) Dim sThisModuleID sSQLQuery = "SELECT * FROM ODBM_Modules WHERE ModuleName = '" & sModuleName & "';" ' Response.Write("
SQLQuery = " & sSQLQuery) Set SELECTModules = oDBConnection.Execute(sSQLQuery) sThisModuleID = SELECTModules("ID") ' Response.Write("
sModuleID = " & sModuleID) sSQLQuery = "INSERT INTO ODBM_User_Module (UserID, ModuleID, PrivLevel, PrivType) VALUES (" & sThisUserID & ", " & sThisModuleID & ", " & sNewPrivLevel & ", 'Modular');" ' Response.Write("
SQLQuery = " & sSQLQuery) Set INSERTPrivileges = oDBConnection.Execute(sSQLQuery) End Sub Sub mSetModularPrivileges(sThisUserID, sModuleName, sNewPrivLevel) Dim sThisModuleID, SELECTModules sSQLQuery = "SELECT * FROM ODBM_Modules WHERE ModuleName = '" & sModuleName & "';" ' Response.Write("
SQLQuery = " & sSQLQuery) Set SELECTModules = oDBConnection.Execute(sSQLQuery) sThisModuleID = SELECTModules("ID") ' Response.Write("
sModuleID = " & sModuleID) sSQLQuery = "UPDATE ODBM_User_Module SET PrivLevel = " & sNewPrivLevel & " WHERE ((UserID = " & sThisUserID & ") AND (ModuleID = " & sThisModuleID & ") AND (PrivType = 'Modular'));" ' Response.Write("
SQLQuery = " & sSQLQuery) Set UPDATEPrivileges = oDBConnection.Execute(sSQLQuery) End Sub FUNCTION mGetNameListing(sThisUserID) Dim sNamePreparation ' expects pre-dimmed and defined vars: ' sNameOption, sAnonymousLabel ' sThisGivenName, sThisSurname, sThisEmail, sThisUserName ' Response.Write ("
NameOption = " & NameOption) ' Response.Write ("
ReservedString = " & ReservedString) ' Response.Write ("
sThisGivenName = " & sThisGivenName) ' Response.Write ("
sThisSurname = " & sThisSurname) ' Response.Write ("
sThisEmail = " & sThisEmail) ' Response.Write ("
sThisUserName = " & sThisUserName) ' if we used userID instead, this could query for itself ' and evaluate correctly the user's chosen handle, ' and whether this is a generic user viewing their own info, ' a generic user viewing another g. user's info (subject to admin- and user-set display restrictions, ' or an admin or developer with different rights ' ' - this would also simplify the matter of handle being either: ' the user's Username ' the user's Email ' or any of the user's Names ' NO. A new thought here is that if they want a handle that matches their UN or Email, they can make a name with either one as the content. That way, we can only check against ODBM_Names. Maybe UN and Email should be defaulted as Names to begin with, so they get the hint. SELECT CASE sNameOption CASE "Anonymous" mGetNameListing = sAnonymousLabel CASE "UserName" mGetNameListing = sThisUserName CASE "Email" mGetNameListing = sThisEmail CASE "Surname" mGetNameListing = sThisSurname CASE "Initial" If NOT (sThisGivenName = "") Then sNamePreparation = Left(sThisGivenName, 1) & ". " End If mGetNameListing = sNamePreparation & sThisSurname CASE "Full Name" If NOT (sThisGivenName = "") Then sNamePreparation = sThisGivenName & " " End If mGetNameListing = sNamePreparation & sThisSurname End SELECT End FUNCTION Function mRemoveSkyTags(sPageContent) ' Response.Write("
sPageContent = " & sPageContent) ' remove asp head sPageContent = Right(sPageContent, Len(sPageContent) - InStr(sPageContent, Chr(60) & "%= sHeadSpace %" & Chr(62)) + 1) ' remove sHeadSpace, sMetaString, and sFooterString sPageContent = Replace(sPageContent, Chr(60) & "%= sHeadSpace %" & Chr(62), "") sPageContent = Replace(sPageContent, Chr(60) & "%= sMetaString %" & Chr(62), "") sPageContent = Replace(sPageContent, Chr(60) & "%= sFooterString %" & Chr(62), "") ' remove DOCTYPE ! (the full DOCTYPE tag breaks javascript in skyWriter on Mac with an Unterminated string literal.) sPageContent = Replace(sPageContent, Chr(60) & "!DOCTYPE", Chr(60) & "DOCTYPE") mRemoveSkyTags = sPageContent End Function Function mRestoreSkyTags(sPageID, sPageASCII) ' restore header and footer sPageASCII = Chr(60) & "%@ LANGUAGE = VBScript %" & Chr(62) & Chr(13) & Chr(60) & "% sPageID = " & sPageID & " %" & Chr(62) & Chr(13) & Chr(60) & "!-- #include virtual = '" & sOrgDir & "/db.inc' --" & Chr(62) & Chr(13) & Chr(60) & "!-- #include virtual = '" & sOrgDir & "/PageFooter.inc' --" & Chr(62) & Chr(13) & Chr(60) & "%= sHeadSpace %" & Chr(62) & sPageASCII ' restore sMetaString and sFooterString sPageASCII = Replace(sPageASCII, "", "" & Chr(60) & "%= sMetaString %" & Chr(62)) sPageASCII = Replace(sPageASCII, "", Chr(60) & "%= sFooterString %" & Chr(62) & "") sPageASCII = Replace(sPageASCII, "", "" & Chr(60) & "%= sMetaString %" & Chr(62)) sPageASCII = Replace(sPageASCII, "", Chr(60) & "%= sFooterString %" & Chr(62) & "") ' restore DOCTYPE ! (the full DOCTYPE tag breaks javascript in skyWriter on Mac with an Unterminated string literal.) sPageContent = Replace(sPageContent, Chr(60) & "DOCTYPE", Chr(60) & "!DOCTYPE") mRestoreSkyTags = sPageASCII End Function FUNCTION mGetRandomString(sTheSeed) ' returns a six char string from a string eight characters long randomized by sTheSeed Dim sSeed, sRandomString, sNumDigit, sDigit, sLetter, sDigitPair, sLastDigit, sASCIIOffset sSeed = sTheSeed sLastDigit = Mid(sSeed, 4, 1) For sNumDigit = 1 to 4 If ((sNumDigit Mod 2) = 1) Then sASCIIOffset = 97 Else sASCIIOffset = 65 End If sDigit = Mid(sSeed, sNumDigit, 1) sRandomString = sRandomString + sDigit sDigitPair = sLastDigit & sDigit sLetter = CHR((sDigitPair Mod 26) + sASCIIOffset) sRandomString = sRandomString + sLetter sLastDigit = sDigit Next ' trim it to six from eight chars sRandomString = Left(sRandomString, 6) ' Response.Write("
sRandomString = " & sRandomString) mGetRandomString = sRandomString END FUNCTION ' END SERVER SUBROUTINES ****************************************************** ' REQUEST ********************************************************************* sUserAgent = Request.ServerVariables("HTTP_User_Agent") ' END REQUEST ********************************************************************* ' RESPONSE ********************************************************************* %> <% Response.Clear ' sServerZoneOffset is crucial to many pages' ability to correct from server timezone/daylight condition to UE time sServerZoneOffset = Session("sServerZoneOffset") ' Response.Write("
sServerZoneOffset = " & sServerZoneOffset) ' sServerZoneOffset = Request.QueryString("sServerZoneOffset") ' If (sServerZoneOffset = "") Then ' sServerZoneOffset = Request.Form("sServerZoneOffset") ' End If Response.CacheControl = "Private" Response.Expires = 0 ' sOrgPath = server.mappath("db.inc") ' this only returns the directory of the includer ' sOrgPath = Left(sOrgPath, InStrRev(sOrgPath, "\")) ' locate home directory ' Response.Write ("
APPL_PHYSICAL_PATH = " & Request.ServerVariables("APPL_PHYSICAL_PATH")) sOrgPath = Request.ServerVariables("APPL_PHYSICAL_PATH") If (Mid(sOrgPath, Len(sOrgPath)) = "\") Then sOrgPath = Left(sOrgPath, Len(sOrgPath) - 1) End If ' Response.Write("
sOrgPath = " & sOrgPath) sOrgPath = sOrgPath & "\TimeLines\" ' Response.Write("
sOrgPath = " & sOrgPath) ' !!! Unix Epoch is the absolute start time for all JS MS dates ' DT data coming out of server was in server timezone - it must corrected back to GMT and transformed to MS by a DateDiff to sServerUEStart ' For example EST needs: ' sServerUEStart = "12/31/1969 7P" ' For EDT: ' sServerUEStart = "12/31/1969 8P" ' General formula is: ' sServerUEStart = sUnixEpoch + sServerZoneOffset (including any Daylight time Offset) sUnixEpoch = "1/1/1970" sServerUEStart = DateAdd("n", sServerZoneOffset, sUnixEpoch) ' Response.Write("
sServerUEStart = " & sServerUEStart) sDBServerType = "MSSQLServer" 'FYI now use 'sDBFileName = "sBtL_skybuilders_com"' if pertinant Set oDBConnection = Server.CreateObject("ADODB.Connection") ' Find the current name of the db - through the file system ' or the db? ' sCurrentDBName = "" sDBFileName = "timeLines.mdb" sDBPath = sOrgPath & sDBFileName Sub mDBConnect() ' make the database connection Select Case sDBServerType Case "MSAccess" ' connect to the db ' Response.Write("
sDBPath = " & sDBPath) oDBConnection.Open("Driver={Microsoft Access Driver (*.mdb)};DBQ=" & sDBPath) If (0 = 1) Then ' get the DBNameUpdateInterval and the DBNameUpdateDate from the db sSQLQuery = "SELECT DBNameUpdateInterval, DBNameUpdateDate FROM ODBM_Globals;" ' Response.Write ("
SQLQuery = " & sSQLQuery) Set SELECTGlobals = oDBConnection.Execute(sSQLQuery) sDBNameUpdateInterval = SELECTGlobals("DBNameUpdateInterval") sDBNameUpdateDate = SELECTGlobals("DBNameUpdateDate") If ((sDBNameUpdateInterval = "") OR (IsNull(sDBNameUpdateInterval))) Then ' one month: sDBNameUpdateInterval = "2592000" ' one minute: sDBNameUpdateInterval = "60" sDBNameUpdateDate = "1/1/1970" sSQLQuery = "UPDATE ODBM_Globals SET (DBNameUpdateInterval = '" & sDBNameUpdateInterval & "');" ' Response.Write("
SQLQuery = " & sSQLQuery) Set UPDATEGlobals = oDBConnection.Execute(sSQLQuery) End If Set SELECTGlobals = nothing SELECTGlobals = empty ' check the logic ' should be now greater than UpdateDate If (DateDiff(s, sDBNameUpdateDate, Now()) > 0) Then ' generate new CryptString ' must be alphanumeric, ten characters long ' the parameter of getRandomString is the seed sCurrentTime = Now() sCurrentMS = DateDiff("S", sServerUEStart, sCurrentTime) & "000" ' generate random password - eight chars long ' was the MS of the moment of processing sCryptString = mGetRandomString(Mid(sCurrentMS, 6, 4)) ' formulate new db name sNewDBFileName = "timelines" & sCryptString & ".mdb" ' instantiate a File System Object Set oFS = CreateObject("Scripting.FileSystemObject") ' load the db file into a File Object Set oDBFile = oFS.GetFile(sOrgPath & sDBFileName) ' rename the db file oDBFile.Name = sNewDBFileName ' write new db name to db.inc ' load the file into a File Object Set oIncFile = oFS.GetFile(sOrgPath & "db.inc") ' load the source into a Stream Object Set oIncSource = oIncFile.OpenAsTextStream(ForReading, TriStateASCII) sIncSource = oIncSource.ReadAll() oIncSource.Close sIncSource = Replace(sIncSource, sDBFileName, sNewDBFileName) ' open the file for writing Set oIncFile = oFS.OpenTextFile(sOrgPath & "db.inc", ForWriting, True, TriStateASCII) ' write source into file oIncFile.Write(sIncSource) oIncFile.Close Set oDBFile = nothing oDBFile = empty Set oIncFile = nothing oIncFile = empty Set oFS = nothing oFS = empty ' increment UpdateDate by UpdateInterval, write to db sDBNameUpdateDate = DateAdd(s, sDBNameUpdateDate, sDBNameUpdateInterval) sSQLQuery = "UPDATE ODBM_Globals SET (DBNameUpdateDate = '" & sDBNameUpdateDate & "');" ' Response.Write("
SQLQuery = " & sSQLQuery) Set UPDATEGlobals = oDBConnection.Execute(sSQLQuery) Set UPDATEGlobals = nothing UPDATEGlobals = empty End If End If Case "MSSQLServer" Set oDBConnection = Server.CreateObject("ADODB.Connection") ' connection by named pipes? 'oDBConnection.Open("Driver={SQL Server}; Server=Skypoly1; Database=skein; UID=timelines; PWD=timelines") ' connection by TCP/IP ' Dim sMSSQLConnection sMSSQLConnection = "Trusted_Connection=yes;Provider=SQLOLEDB; Data Source=HOSTS5; Initial Catalog=sBtL_skybuilders_com; User ID=; Password=;" ' this works as Administrator oDBConnection.Open sMSSQLConnection End Select End Sub Call mDBConnect() ' initialize sLocaleID sSQLQuery = "SELECT LocaleID FROM ODBM_Globals;" Set SELECTGlobals = oDBConnection.Execute(sSQLQuery) sLocaleID = SELECTGlobals("LocaleID") SELECTGlobals.Close Set SELECTGlobals = Nothing sCopyrightString = mGetStringsText("CopyrightString") ' Response.Write("
QuoteSQL sCopyrightString = " & sCopyrightString) %> <% ' END RESPONSE ************************************************************** ' SERVER CLEANUP ************************************************************** ' END SERVER CLEANUP ********************************************************** ' END SERVER LOGIC ************************************************************** ' Copyright © 2000, 2001 skyBuilders.com All Rights Reserved. ' Registered skyBuilders developers have a non-exclusive license to use parts of this code in any of their work. They may not sell the entire work or part of it as "timeLines" itself, without written permission from skyBuilders.com. %>