Function IsOntarioParalegalAssociation( x, jsonData )
IsOntarioParalegalAssociation = InStr( CacheURL, "ontarioparalegalassociation" ) > 0
End Function
'GLOBAL UNLOCK OF ALL CHILKAT OBJECTS
If NOT IsObject( oChilkatUnlockGlobal ) Then
Set oChilkatUnlockGlobal = Server.CreateObject("Chilkat_9_5_0.Global")
bSuccess = oChilkatUnlockGlobal.UnlockBundle("WBMRKC.CB1042021_qGkqkA756rn9")
End If
Randomize
Function Authen()
Authen = Authenticated()
End Function
Function Authenticated()
Authenticated = CBool( Session("bAuthen") )
End Function
Private Function Login( ByVal sEmail, ByVal sPassword )
If ( AdminSuper AND sPassword = True ) Then
'Address SuperAdmin Swap to any Specific User
If Session("bAdminSuperUser") <> True Then
Session("iAdminSuperUser") = iOwner
End If
Session("bAdminSuperUser") = True
sPhone = "NOT Phone" 'Required to avoid validating an empty field
Else
Session("bAdminSuperUser") = False
Session("iAdminSuperUser") = 0
iPhone = Numeric( sEmail )
If iPhone > 2002000000 Then
sPhone = Phone( iPhone )
Else
sPhone = "NOT Phone" 'Required to avoid validating an empty field
End If
End If
Login = False
sEmail = Clean( sEmail )
sKeyAccount = UCase( Left( AlphaNumeric( sEmail & Now ), 15 ) )
sSQL = "SELECT TOP 1 tblAccounts.* FROM tblAccounts WHERE bLive > 0 AND bDeleted = 0 AND ( '@' + sUserID = '" & sEmail & "' OR sEmail = '" & LCase( sEmail ) & "' OR sPhone = '" & sPhone & "' OR sKey = '" & sEmail & "')"
Set rsLogin = CreateObject("ADODB.Recordset")
rsLogin.CursorLocation = adUseClient
rsLogin.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If rsLogin.EOF Then
Login = "Passport | Account does not exist."
Else
If Session("bAdminSuperUser") <> True Then
rsLogin.Filter = "sPassword = '" & Clean( sPassword ) & "'"
End If
If rsLogin.EOF Then
Login = "Password is incorrect."
Else
Session("bAuthen") = True
Session("iTypeAccount") = rsLogin("iTypeAccount")
Session("iSubscriptionType") = rsLogin("iSubscriptionType")
Session("sKey") = rsLogin("sKey")
Session("sKeyAccount") = rsLogin("sKey")
Session("sUserID") = rsLogin("sUserID")
Session("sKeyPersonasAdministrative") = rsLogin("sKeyPersonasAdministrative")
Session("bAdmin") = CBool( rsLogin("bAdmin") )
Session("bSuper") = CBool( rsLogin("bSuper") ) OR Session("bAdminSuperUser")
Session("iSavvy") = rsLogin("iSavvy")
Session("bAdminSavvy") = CBool( ( Session("bAdmin") AND Session("iSavvy") > 3 ) OR Session("bSuper") )
Session("iOwner") = rsLogin("ID")
Session("sFacebookID") = rsLogin("sFacebookID")
Session("sName") = rsLogin("sName")
aNameFull = Split( Session("sName") & "", " ")
Session("sNameFirst") = aNameFull( 0 )
Session("sEmail") = rsLogin("sEmail")
Session("sPhone") = rsLogin("sPhone")
Session("sPostal") = rsLogin("sPostal")
Session("sAddress1") = rsLogin("sAddress1")
Session("sAddress2") = rsLogin("sAddress2")
Session("sCity") = rsLogin("sCity")
Session("bMemberOPA") = rsLogin("bMemberOPA")
Login = True
If Session("bAdminSuperUser") <> True Then
Call LoginLog()
End If
If Session("sURLRedirectAfterDetourComplete") = Empty Then
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
bSuccess = oJSON.Load( rsLogin("jsonPreferences") )
If bSuccess Then
Session("sURLAfterSignIn") = oJSON.StringOf("sURLAfterSignIn")
End If
Destroy oJSON
Else
Session("sURLAfterSignIn") = Session("sURLRedirectAfterDetourComplete")
End If
End If
End If
Destroy( rsLogin )
If AppVar("bSuspended") AND NOT AdminSuper Then
Call Logout()
Redirect("/")
Quit
End If
End Function
Private Function LoginLog()
sSQL = "SELECT TOP 1 tblAccountsLog.* FROM tblAccountsLog WHERE tblAccountsLog.iOwner = " & iOwner & " AND tblAccountsLog.iSessionID = " & Numeric( Request.Cookies("Session.SessionID") )
Set rsLog = CreateObject("ADODB.Recordset")
rsLog.CursorLocation = adUseClient
rsLog.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If rsLog.EOF Then
rsLog.AddNew
rsLog("iSessionID") = Numeric( Session.SessionID )
End If
rsLog("sIPAddress") = ServerVariable("REMOTE_ADDR")
rsLog("iOwner") = iOwner
rsLog("bAuthen") = 1
rsLog("sKeyPersona") = Session("sKeyPersona")
rsLog("idPersona") = Session("idPersona")
rsLog("dSessionEnd") = Now
rsLog.Update
Destroy( rsLog )
End Function
Private Function Logout()
Session("bAuthen") = 0
Session("bAdmin") = 0
Session("bSuper") = 0
Session("iSavvy") = 1
Session("iOwner") = 0
Session("iTypeAccount") = 0
Session("iLevel") = 0
Session("sKeyAccount") = Empty
Session("sEmail") = Empty
Session("sName") = Empty
Session("sNameFirst") = Empty
Session("bAdminSuperUser") = False
Session("iAdminSuperUser") = 0
Call LogoutLog()
End Function
Private Function LogoutLog() 'This needs to be added to the Session.End event in the Global.asa
sSQL = "SELECT TOP 1 tblAccountsLog.* FROM tblAccountsLog WHERE tblAccountsLog.iOwner = " & iOwner & " AND tblAccountsLog.iSessionID = " & Numeric( Request.Cookies("Session.SessionID") )
Set rsLog = CreateObject("ADODB.Recordset")
rsLog.CursorLocation = adUseClient
rsLog.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If NOT rsLog.EOF Then
rsLog("dSessionEnd") = Now
rsLog.Update
End If
Destroy( rsLog )
End Function
Function LogContact( iTypeContact, sKeyAccountRecipient, sKeyAccountContact, sMessage, sIPData, sURLSentFrom )
LogContact = False
sSQL = "SELECT TOP 1 tblContactRelations.* FROM tblContactRelations WHERE tblContactRelations.ID = -1"
Set rsCMS = CreateObject("ADODB.Recordset")
rsCMS.CursorLocation = adUseClient
rsCMS.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If rsCMS.EOF Then
rsCMS.AddNew
rsCMS("sKey") = Key( 15 )
rsCMS("iTypeContact") = iTypeContact 'Sale Successful = 1, Lead/Message = 5
rsCMS("sKeyPersona") = sKeyAccountRecipient 'Website Persona or Recipient Person
rsCMS("sKeyAccountContact") = AlphaNumeric( sKeyAccountContact ) 'Meaning the Sender
rsCMS("sMessage") = Clean( sMessage )
rsCMS("sIPData") = sIPData 'JSONLocationGet( ServerVariable("REMOTE_ADDR") )
rsCMS("sURLSentFrom") = sURLSentFrom
rsCMS.Update
LogContact = True
End If
Destroy( rsCMS )
End Function
Private Function AsideAd( sLayout )
If AppVar("bAdPublisher") Then
If Session("sAreasOfLaw") = Empty Then
Session("sAreasOfLaw") = " TERMINATOR,, "
End If
sTemp = " " & Replace( Replace( Replace( Session("sAreasOfLaw") & "", "TERMINATOR", ""), " ", ""), ",,,", ",")
sTemp = Trim( Left( sTemp, Len( sTemp ) - 1 ) )
aTemp = Split( sTemp, ",")
sTemp = Empty
For iLoop = 0 To UBound( aTemp )
sTemp = sTemp & " CHARINDEX(' " & aTemp( iLoop ) & ",', tbl@Ads.sAreasOfLaw) > 0"
If iLoop < UBound( aTemp ) Then
sTemp = sTemp & " OR "
End If
Next
'THERE IS SOME FUCKING PROBLEM AMONG THE NEXT 5 LINES IN SOME NEW PERSONAS'
sTemp = " ( " & sTemp & " ) "
sSQL = "SELECT tbl@Ads.* FROM tbl@Ads WHERE tbl@Ads.sKeyBusiness = '" & Session("sKeyBusiness") & "' AND ( " & sTemp & " OR tbl@Ads.bGeneric <> 0 ) AND sCodeLanguage = '" & Session("sCodeLanguage") & "' AND tbl@Ads.bLive <> 0 AND tbl@Ads.bDeleted = 0 AND CONVERT( datetime, '" & Now & "' ) < tbl@Ads.dDateEnd ORDER BY NEWID()"
Set rsAds = CreateObject("ADODB.Recordset")
rsAds.CursorLocation = adUseClient
rsAds.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If rsAds.EOF Then
sHeading = "Advertise Here"
sDescription = "Your advertisement could be here and viewed thousands of times per month."
sURLPageLanding = "https://marketing.legal/contact"
sThemeColor = "primary"
Else
rsAds.Filter = "bGeneric = 0"
If rsAds.EOF Then
rsAds.Filter = ""
End If
sKeyAd = rsAds("sKey")
sHeading = rsAds("sHeading")
sDescription = rsAds("sDescription")
sURLPageLanding = rsAds("sURLPageLanding")
sFileImage1 = rsAds("sFileImage1") & ""
sThemeColor = rsAds("sThemeColor") & ""
bUseScreenShot = rsAds("bUseLandingPageScreenShot")
If IsBot() = False Then
On Error Resume Next
rsAds("iImpressions") = rsAds("iImpressions") + 1
rsAds.Update
On Error Goto 0
End If
End If
Destroy( rsAds )
If InStr( sURLPageLanding, Session("sDomain") ) = 0 Then
sTarget = "_blank"
End If
If Len( AlphaNumeric( sFileImage1 ) ) < 20 AND bUseScreenShot > 0 Then
sStrUrlImage = "url=" & sURLPageLanding & "&width=1200&height=630&quality=100"
sFileImage1 = "//api.urlbox.io/v1/F4UVscE5zgqc3BVd/" & UrlBoxEncode( sStrUrlImage ) & "/jpg?" & sStrUrlImage
End If
sURL = "/admin/advertisement-log.asp?sKeyAd=" & sKeyAd
If sLayout = "vertical" Then
sAd = ""
sAd = sAd & ""
sAd = sAd & ""
End If
If sLayout = "horizontal" Then
sAd = ""
sAd = sAd & ""
sAd = sAd & ""
End If
End If
AsideAd = sAd
End Function
Private Function BlogInfo( sHTML, sKeyPage )
sTemp = Empty
If InStr( sHTML, "#TOKEN-sBlogInfo#") > 0 Then
sSQL = "SELECT tblPageHTML.* FROM tblPageHTML WHERE sKey = '" & AlphaNumeric( sKeyPage ) & "'"
Set rsBlog = CreateObject("ADODB.Recordset")
rsBlog.CursorLocation = adUseClient
rsBlog.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If rsBlog.EOF = False Then
sTemp = "
"
Destroy( rsNav )
Destroy( rsPage )
End Function
Private Function AsideCourtHousesAndVenues( sPageAreasOfLaw )
If Numeric( AppVar("sCourtHouses") ) > 0 Then
sSQL = "SELECT tbl@CourtHouses.* FROM tbl@CourtHouses WHERE bLive = 1 AND bDeleted = 0 ORDER BY sName"
If Numeric( sPageAreasOfLaw ) > 0 Then
aTemp = Split( sPageAreasOfLaw, "," )
sTemp = Empty
For iLoop = 0 To UBound( aTemp )
If Numeric( aTemp( iLoop ) ) > 0 Then
sTemp = sTemp & " tbl@CourtHouses.sAreasOfLaw LIKE '% " & aTemp( iLoop ) & ",%'"
sTemp = sTemp & " OR "
End If
Next
sTemp = Left( sTemp, Len( sTemp ) - 4 )
Else
sTemp = "1=2"
End If
sSQL = Replace( sSQL, " WHERE ", " WHERE ( " & sTemp & " ) AND " )
sSQL = Replace( sSQL, " ", " ") 'Important
Set rsCourtHouse = CreateObject("ADODB.Recordset")
rsCourtHouse.CursorLocation = adUseClient
rsCourtHouse.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If rsCourtHouse.EOF = False Then
'' sVenues = ""
End If
aCourtHouses = Split( AppVar("sCourtHouses") & "", "," )
Call ArrayRandomize( aCourtHouses )
For iLoop = 0 To UBound( aCourtHouses )
If Numeric( aCourtHouses( iLoop ) ) > 0 Then
rsCourtHouse.Filter = "ID=" & aCourtHouses( iLoop )
If rsCourtHouse.EOF = False Then
sTmpURL = IIf( Len( rsCourtHouse("sCity") ) > 3 ,Replace( rsCourtHouse("sCity") & ", Ontario", " ", "_"), "/cities")
sVenues = sVenues & "
#TOKEN-sNameShort# attends: "
sVenues = sVenues & "" & rsCourtHouse("sName") & " "
sVenues = sVenues & "(" & rsCourtHouse("sNameShort") & ") "
sVenues = sVenues & "" & rsCourtHouse("sAddress1") & " "
sVenues = sVenues & "" & rsCourtHouse("sCity") & ", Ontario, " & rsCourtHouse("sPostal") & " "
If Numeric( rsCourtHouse("sPhone1") ) > 0 Then
'' sVenues = sVenues & "P: " & rsCourtHouse("sPhone1") & " "
End If
If Numeric( rsCourtHouse("sPhone2") ) > 0 Then
'' sVenues = sVenues & "P: " & rsCourtHouse("sPhone2") & " "
End If
If Numeric( rsCourtHouse("sPhoneFax") ) > 0 Then
'' sVenues = sVenues & "F: " & rsCourtHouse("sPhoneFax") & " "
End If
sVenues = sVenues & "
"
End If
End If
If iLoop > 3 Then
Exit For
End If
Next
AsideCourtHousesAndVenues = sVenues
If AppVar("bShowTestimonials") Then
AsideCourtHousesAndVenues = AsideCourtHousesAndVenues & " #TOKEN-htmlTestimonials-1#"
End If
Destroy( rsCourtHouse )
End If
End Function
Private Function AsideForm()
'AT SOME TIME, CONSOLIDATE THE 2 (FORM-CONTACT) FORMS AND HANDLE THEM IN A THANK YOU PAGE WITH ERROR CHECKING
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
Set oTextFile = oFS.OpenTextFile( MapPath("/form-contact-aside.asp"), 1, False )
AsideForm = oTextFile.ReadAll
Destroy( oTextFile )
Destroy( oFS )
End Function
Private Function AsideCallToAction()
If AppVar("iTypeFirm") > 0 AND AppVar("iTypeFirm") < 4 Then
aTemp1 = Split("Have Legal Questions and Need Answers?~|~Have Legal Issues and Need Help?~|~Do You Need to Address a Legal Matter?", "~|~")
sTemp1 = aTemp1( RandomInteger( 0, UBound( aTemp1 ) ) )
aTemp2 = Split("Avoid Delays.~|~Protect Your Legal Rights.~|~Address Your Legal Rights Today!~|~Discuss Your Legal Matter!~|~Get Legal Help Now.", "~|~")
sTemp2 = aTemp2( RandomInteger( 0, UBound( aTemp2 ) ) )
aTemp3 = Split("Contact #TOKEN-sNameShort#~|~Call #TOKEN-sPhone1#~|~Contact #TOKEN-sNameShort# #TOKEN-sPhone1#", "~|~")
sTemp3 = aTemp3( RandomInteger( 0, UBound( aTemp3 ) ) )
aTemp4 = Split("Discuss Your Legal Rights Today!~|~Get Started Today!~|~Don't Delay, Start Today!","~|~")
sTemp4 = aTemp4( RandomInteger( 0, UBound( aTemp4 ) ) )
sTemp = ""
Else
sTemp = ""
End If
AsideCallToAction = sTemp
End Function
Private Function AsidePromoConsultation()
If AppVar("iOfferFreeConsultation") > 0 Then
sTemp = "
"
AsidePromoConsultation = sTemp
End If
End Function
Private Function ConstrainDataToByte( iValue ) 'See color functions
ConstrainDataToByte = iValue
If iValue < 0 Then
ConstrainDataToByte = 0
End If
If iValue > 255 Then
ConstrainDataToByte = 255
End If
End Function
Private Function ColorDarken( sColor, iPercent ) 'Make iPercent < 1.0 to darken.
If Len( AlphaNumeric( sColor ) ) = 6 Then
sHex = Replace( Trim( sColor ), "#", "" )
iR = ConstrainDataToByte( Int( ( CInt("&H" & Left( sHex, 2 ) ) * iPercent ) + .5 ) )
iG = ConstrainDataToByte( Int( ( CInt("&H" & Mid ( sHex, 3, 2 ) ) * iPercent ) + .5 ) )
iB = ConstrainDataToByte( Int( ( CInt("&H" & Mid ( sHex, 5, 2 ) ) * iPercent ) + .5 ) )
ColorDarken = UCase( "#" & Right( "0" & Hex( iR ), 2 ) & Right( "0" & Hex( iG ), 2 ) & Right( "0" & Hex( iB ), 2 ) )
End If
End Function
Private Function ColorLighten( sColor, iPercent ) 'Make iPercent > 1.0 to lighten.
ColorLighten = ColorDarken( sColor, iPercent )
End Function
Private Function ColorRGBA( sColor, iAlpha )
sHex = Replace( Trim( sColor ), "#", "" )
iR = CInt("&H" & Left( sHex, 2 ) )
iG = CInt("&H" & Mid ( sHex, 3, 2 ) )
iB = CInt("&H" & Mid ( sHex, 5, 2 ) )
ColorRGBA = "rgba(" & iR & "," & iG & "," & iB & "," & iAlpha & ")"
End Function
Private Function ColorInvert( sColor )
If Len( AlphaNumeric( sColor ) ) = 6 Then
sHex = AlphaNumeric( sColor )
iR = 255 - CInt("&H" & Left( sHex, 2 ) )
iG = 255 - CInt("&H" & Mid ( sHex, 3, 2 ) )
iB = 255 - CInt("&H" & Mid ( sHex, 5, 2 ) )
ColorInvert = UCase( "#" & Right( "0" & Hex( iR ), 2 ) & Right( "0" & Hex( iG ), 2 ) & Right( "0" & Hex( iB ), 2 ) )
End If
End Function
Private Function CBit( bBoolean )
If bBoolean OR Numeric( bBoolean ) <> 0 OR UCase( Trim( bBoolean ) ) = "TRUE" Then
CBit = 1
Else
CBit = 0
End If
End Function
Private Function AccountExists( aArray ) 'aArray SHOULD BE: sName,sEmail,sPhone,sPostal,sUserID,sLicenceNumber,sKey; FUNCTION RETURNS VALUE OF 1 IF PROBABLE TO 80% OR MORE, AND RETURNS ID OF ACCOUNT IF CERTAIN.
AccountExists = 0
If IsArray( aArray ) Then
aSPAM = Split("ferrous,batteries,for sale, sell ,recycle, battery , aluminum, scrap ", ",")
For iLoop = 0 To UBound( aArray )
For iSPAM = 0 To UBound( aSPAM )
If InStr( LCase( aArray( iLoop ) ), aSPAM( iSPAM ) ) > 0 Then
Response.Status = "301 Moved Permanently"
Response.AddHeader "Location", "https://en.wikipedia.org/wiki/Spamming"
Session.Abandon
Quit
End if
Next
Next
For iLoop = 0 To UBound( aArray ) 'Parse out the array into its respective variables, then deal with the issue at hand
Select Case iLoop
Case 0
sName = Clean( aArray( iLoop ) )
Case 1
sEmail = Clean( aArray( iLoop ) )
Case 2
sPhone = Phone( Numeric( aArray( iLoop ) ) )
Case 3
sPostal = Clean( aArray( iLoop ) )
Case 4
sUserID = Replace( Clean( aArray( iLoop ) ), "@", "")
Case 5
sLicenceNumber = Clean( aArray( iLoop ) )
Case 6
sKey = AlphaNumeric( aArray( iLoop ) )
End Select
Next
aName = Split( Replace( sName, "-", " " ) ) 'ASSISTS TO ENSURE THAT A HYPHENATED NAME IS BREAKABLE INTO SUB-PIECES
sTemp = " tblAccounts.sEmail = '" & sEmail & "'" 'DO THIS FIRST AND ALWAYS, SO THE SQL STRING CAN BEGIN WITHOUT ANY BOOLEAN LOGIC
For iLoop = 0 To UBound( aName )
sTemp = sTemp & " OR tblAccounts.sName LIKE '%" & aName( iLoop ) & "%'"
Next
If Numeric( sPhone ) > 2012010000 Then
sTemp = sTemp & " OR sPhone = '" & sPhone & "'"
End If
If sUserID <> Empty Then
sTemp = sTemp & " OR sUserID = '" & sUserID & "'"
End If
If sLicenceNumber <> Empty Then
sTemp = sTemp & " OR sLicenceNumber = '" & sLicenceNumber & "'"
End If
If Len( sKey ) = 15 Then
sTemp = sTemp & " OR sKey = '" & sKey & "'"
End If
sSQL = "SELECT tblAccounts.ID, tblAccounts.sKey, tblAccounts.sName, tblAccounts.sEmail, tblAccounts.sPhone, tblAccounts.sPostal, tblAccounts.sUserID, tblAccounts.sLicenceNumber FROM tblAccounts WHERE " & sTemp
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient
rs.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
iExistsProbable = 0 'PERCENTAGE OF PROBABILITY
idAccountLikely = 0
If NOT rs.EOF Then
rs.Filter = "sEmail = '" & sEmail & "'"
If NOT rs.EOF AND sEmail <> Empty Then
idAccountLikely = rs("ID")
iExistsProbable = 100
End If
rs.Filter = "sUserID = '" & sUserID & "'"
If NOT rs.EOF AND sUserID <> Empty AND sEmail = Empty Then
idAccountLikely = rs("ID")
iExistsProbable = 100
End If
rs.Filter = "sKey = '" & sKey & "'"
If NOT rs.EOF AND sKey <> Empty AND sEmail = Empty AND sUserID = Empty Then
idAccountLikely = rs("ID")
iExistsProbable = 100
End If
rs.Filter = ""
Do Until rs.EOF OR iExistsProbable > 79
iTempProbable = 0
idAccountLikely = 0
If IsArray( aName ) Then
For iLoop = 0 To UBound( aName )
If InStr( 1, rs("sName"), Trim( aName( iLoop ) ), 1 ) > 0 AND Len( Trim( aName( iLoop ) ) ) > 1 Then
iTempProbable = iTempProbable + 27
End If
Next
End If
If Numeric( sPhone ) > 2012010000 AND InStr( rs("sPhone"), sPhone ) > 0 Then
iTempProbable = iTempProbable + 50
End If
If Len( sPostal ) > 3 AND AlphaNumeric( rs("sPostal") ) = AlphaNumeric( sPostal ) Then
iTempProbable = iTempProbable + 27
End If
If Len( sLicenceNumber ) > 3 AND InStr( 1, rs("sLicenceNumber"), sLicenceNumber, 1 ) > 0 Then
iTempProbable = iTempProbable + 50
End If
If iExistsProbable & iTempProbable > 79 Then
idAccountLikely = rs("ID")
iExistsProbable = iExistsProbable & iTempProbable
Exit Do
End If
rs.MoveNext
Loop
End If
If idAccountLikely > 0 Then
AccountExists = idAccountLikely
Else
If iExistsProbable > 79 Then
AccountExists = 1
End If
End If
End If
Destroy( rs )
End Function
'ADDED 2022-01-02 - REPLACES OLD AND ALSO NOW ACCOMMODATES sPhone AS AN ACCOUNT CREATION COMPONENT IN OUR CHANGING WORLD :)
Private Function AccountUserNewCreate( sName, sEmail, sPhone, sPassword, sKeyPersonaCreated, bLive, iCreator ) 'If bLive is received as an Array, then the [1] element sets bAddUserViaStealth; [2] element if present sets account type;
bAccountCreatorIsDeleted = CBool( Numeric( Fetch("tblAccounts","bDeleted","ID=" & iCreator ) ) )
sName = Clean( sName )
sUserID = RegularExpression( "" & Replace( sName, " ", "."), "[^0-9a-zA-Z.-]", "" )
bUserIDExists = Numeric( AccountUserIDExists( sUserID ) ) > 0
If bUserIDExists Then
sUserID = Left( Right( Key( 15 ), 5 ) & "-" & sUserID, 60 )
End If
If IsAllLCase( sName ) OR IsAllUCase( sName ) Then
sName = PCase( sName )
End If
bAccountNameIsAcceptable = Len( Alpha( sName ) ) > 4 AND InStr( AlphaSpace( sName ), " " ) > 1
sEmail = LCase( Clean( sEmail ) )
bIsEmail = IsEmail( sEmail )
sPhone = Phone( Numeric( sPhone ) )
bIsPhone = Numeric( sPhone ) > 2002000000 AND Numeric( sPhone ) < 10000000000
sPassword = Left( sPassword, 30 )
If Trim( sPassword ) = Empty Then 'WE ARE PRESUMABLY WITHIN AN AUTOMATED PROCESS, SO AUTO-GENERATE A PASSWORD
sPassword = "a" & Key( 11 )
End If
bAccountPasswordIsAcceptable = ( sPassword = Clean( sPassword ) ) AND Len( Clean( sPassword ) ) > 7
bAccountPasswordIsAcceptable = bAccountPasswordIsAcceptable AND ( Len( Alpha( sPassword ) ) > 0 AND ( Numeric( sPassword ) > 0 OR InStr( sPassword, "0") > 0 ) )
If NOT bAccountCreatorIsDeleted AND bAccountNameIsAcceptable AND ( bIsEmail OR bIsPhone ) AND bAccountPasswordIsAcceptable Then
sSQL = "SELECT TOP 1 tblAccounts.* FROM tblAccounts WHERE tblAccounts.sEmail = '" & sEmail & "'"
Set rsNew = CreateObject("ADODB.Recordset")
rsNew.CursorLocation = adUseClient
rsNew.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If rsNew.EOF Then
rsNew.AddNew
sKeyAccountUserNew = Key( 15 )
rsNew("sKey") = sKeyAccountUserNew
rsNew("iTypeAccount") = 1 'USER / PERSON
rsNew("sName") = sName
rsNew("sUserID") = sUserID
rsNew("sUserIDLCase") = LCase( sUserID )
If bIsEmail Then
rsNew("sEmail") = sEmail
End If
If bIsPhone Then
rsNew("sPhone") = sPhone
End If
rsNew("sPassword") = sPassword
If Len( AlphaNumeric( sKeyPersonaCreated ) ) <> 15 Then
sKeyPersonaCreated = Session("sKeyPersona")
End If
rsNew("sKeyPersonaCreated") = sKeyPersonaCreated
If NOT IsArray( bLive ) Then
rsNew("bLive") = CBit( bLive )
rsNew("bAddedViaStealth") = 0
bAddUserViaStealth = False
Else
rsNew("bLive") = CBit( bLive( 0 ) )
rsNew("bAddedViaStealth") = CBit( bLive( 1 ) )
bAddUserViaStealth = CBit( bLive( 1 ) )
If UBound( bLive ) > 1 Then
rsNew("iTypeAccount") = Numeric( bLive( 2 ) )
End If
End If
If Len( AlphaNumeric( Request("sLicenceNumber") ) ) > 5 AND InStr( UCase( Alpha( Request("sLicenceNumber") ) ), "P") = 0 Then
rsNew("iTypeAccount") = 2 'LAWYER / ATTORNEY
End If
If UCase( Alpha( Request("sLicenceNumber") ) ) = "P" Then
rsNew("iTypeAccount") = 3 'PARALEGAL
End If
rsNew("iCreator") = Numeric( iCreator )
rsNew("iOwner") = iOwner
rsNew.Update
bAccountUserNewSuccess = True
Call AccountUserProfileNewCreate( sKeyAccountUserNew ) 'CREATE THE FUNDAMENTAL PROFILE RECORD TO SATISFY ANY JOINS THAT MIGHT RELY ON ITS EXISTENCE - NEED TO CREATE ALL RETROACTIVES!!!
If bAddUserViaStealth <> True Then
Call AccountUserNewWelcome( sName, sEmail, sKeyAccountUserNew ) 'Add phone notification ASAP
End If
Else
fsErrors = fsErrors & "An account/passport for the person appears to already exist. "
End If
Destroy( rsNew )
Else
fsErrors = fsErrors & "Something happened. An account could not be created. "
End If
If bAccountUserNewSuccess Then
AccountUserNewCreate = sKeyAccountUserNew
Else
AccountUserNewCreate = fsErrors
End If
End Function
'ADDED 2022-01-02
Private Function AccountUserProfileNewCreate( sKeyAccount )
idAccount = Fetch("tblAccounts","ID","sKey='" & AlphaNumeric( sKeyAccount ) & "'" )
bAccountExists = CBool( CBit( idAccount ) )
If bAccountExists Then
sSQL = "SELECT TOP 1 tblAccountsProfiles.* FROM tblAccountsProfiles WHERE sKeyAccount = '" & AlphaNumeric( sKeyAccount ) & "'"
Set rsProfile = CreateObject("ADODB.Recordset")
rsProfile.CursorLocation = adUseClient
rsProfile.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If rsProfile.EOF Then
sKeyProfile = Key( 15 )
rsProfile.AddNew
rsProfile("sKey") = sKeyProfile
rsProfile("idAccount") = idAccount
rsProfile("sKeyAccount") = sKeyAccount
rsProfile("iCreator") = iOwner
rsProfile("iOwner") = iOwner
If AlphaNumeric( Request("sLicenceNumber") ) <> Empty Then
jsonLicence = "{'sLicenceType':'Type','sLicenceNumber':'" & AlphaNumeric( Request("sLicenceNumber") ) & "':'','iYearLicenced':0}"
If Len( AlphaNumeric( Request("sLicenceNumber") ) ) > 5 AND InStr( UCase( Alpha( Request("sLicenceNumber") ) ), "P") = 0 Then
jsonLicence = Replace( jsonLicence, "'Type'", "'L1'" )
End If
If UCase( Alpha( Request("sLicenceNumber") ) ) = "P" Then
jsonLicence = Replace( jsonLicence, "'Type'", "'P1'" )
End If
rsProfile("jsonLicence") = Replace( jsonLicence, "'", Chr( 34 ) )
End If
rsProfile.Update
bAccountUserNewProfileSuccess = True
Else
sErrors = sErrors & "Something happened. An account could not be created. "
End If
Destroy( rsProfile )
End If
End Function
'ADDED 2023-09-17
Private Function AccountUserIDExists( sUserID )
AccountUserIDExists = Fetch("tblAccounts","ID","LOWER( sUserID ) = LOWER('" & sUserID & "')") ' "sUserID='" & sUserID & "' OR sUserIDLCase ='" & LCase( sUserID ) & "'")
End Function
Private Function AccountUpdateAddress( sKeyAccount, sAddress1, sAddress2, sAddressSuite, sCity, iCity, iProv, sPostal, iCountry, bOverWrite ) 'OVERWRITE PROTECTION NOT YET IMPLEMENTED
sSQL = "SELECT TOP 1 tblAccounts.* FROM tblAccounts WHERE sKey = '" & AlphaNumeric( sKeyAccount ) & "'"
Set rsAddress = CreateObject("ADODB.Recordset")
rsAddress.CursorLocation = adUseClient
rsAddress.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
bAccountExists = NOT rsAddress.EOF
If bAccountExists Then
rsAddress("sAddress1") = Clean( sAddress1 )
rsAddress("sAddress2") = Clean( sAddress2 )
rsAddress("sAddressSuite") = UCase( AlphaNumeric( sAddressSuite ) )
rsAddress("sCity") = Clean( sCity )
'' rsAddress("iCity") = Numeric( iCity )
rsAddress("iProv") = Numeric( iProv )
rsAddress("sPostal") = AlphaNumericSpace( sPostal )
rsAddress("iCountry") = 1
rsAddress("iOwner") = iOwner
rsAddress.Update
bAccountUpdateAddressSuccess = True
Else
sErrors = sErrors & "The requisite account does not exist. "
End If
Destroy( rsAddress )
End Function
'ADDED 2021-12-14
Private Function AccountUserNewWelcome( sName, sEmail, sKeyAccount )
sKeyVerification = Key( 20 )
If iOwner > 0 AND Session("sKeyAccount") <> sKeyAccount Then 'It is someone inviting someone to join.
sMessageWelcome = Scrape("/emails/user-welcome-invite.txt")
sMessageSubject = Session("sName") & " Invites You to Join the Success.Legal Network"
sNameUserInvited = sName
sName = Fetch("tblAccounts","sName","sKey = '" & Session("sKeyAccount") & "'")
Else
sMessageWelcome = Scrape("/emails/user-welcome.txt")
sMessageSubject = "From the " & AppVar("sNameShort") & " Website "
End If
sMessageWelcome = Replace( sMessageWelcome, "#TOKEN-sDomain#", Session("sDomain") )
sMessageWelcome = Replace( sMessageWelcome, "#TOKEN-sNameUser#", sName )
sMessageWelcome = Replace( sMessageWelcome, "#TOKEN-sEmailUser#", sEmail )
sMessageWelcome = Replace( sMessageWelcome, "#TOKEN-sEmailUserInvited#", sEmail )
sMessageWelcome = Replace( sMessageWelcome, "#TOKEN-sNameUserInvited#", sNameUserInvited ) 'ADDED 2022-01-22
sMessageWelcome = Replace( sMessageWelcome, "#TOKEN-sKeyAccount#", sKeyAccount )
sMessageWelcome = Replace( sMessageWelcome, "#TOKEN-sKeyVerification#", sKeyVerification )
sSQL = "SELECT TOP 1 tblAccounts.sKeyVerification, tblAccounts.dEmailVerifySought, tblAccounts.dModified FROM tblAccounts WHERE tblAccounts.sKey = '" & sKeyAccount & "'"
Set rsAccount = CreateObject("ADODB.Recordset")
rsAccount.CursorLocation = adUseClient
rsAccount.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If rsAccount.EOF Then
Write "Something went wrong."
Else
If IsNull( rsAccount("dEmailVerifySought") ) Then
rsAccount("sKeyVerification") = sKeyVerification
rsAccount("dEmailVerifySought") = Now
rsAccount("dModified") = Now
rsAccount.Update
Call Email( sEmail, "sent.from.marketing.legal@gmail.com", sMessageSubject, sMessageWelcome )
End If
End If
Destroy( rsAccount )
End Function
Function Admin()
Admin = CBool( Session("bAdmin") )
End Function
Function AdminSavvy()
AdminSavvy = CBool( Session("bAdminSavvy") )
End Function
Function AdminSuper()
AdminSuper = CBool( Session("bSuper") )
End Function
Function SuperAdmin()
SuperAdmin = AdminSuper()
End Function
Private Function AjaxPager( oObject, sURL, iPageSize, iPages, iPage )
iPage = Numeric( iPage )
If iPage < 1 Then
iPage = 1
End If
iTemp = iPage - 4
If iTemp + 8 > iPages Then
iTemp = iPages - 8
End If
If iTemp < 1 Then
iTemp = 1
End If
For iLoop = 0 To 8
sLink = Replace( Replace( Replace( sURL, "&iPage=" & iPage, Empty ), "iPage=" & iPage, Empty ), "?", "?iPage=" )
If InStr( sLink, "?" ) = 0 Then
sLink = sLink & "?iPage="
End If
If iPage <> iLoop + iTemp Then
sClass = "btn"
Else
sClass = "btn-primary active"
End If
sLink = Replace( Replace( sLink, "?iPage=", "?iPage=" & iLoop + iTemp & "&" ), "&&", "&" )
If Right( sLink, 1 ) = "&" Then
sLink = Left( sLink, Len( sLink ) -1 )
End If
sTemp = sTemp & "" & Right("0" & iLoop + iTemp, 2 ) & " "
If iLoop + iTemp >= iPages Then
Exit For
End If
Next
sTemp = " " & sTemp
sTemp = sTemp & " "
AjaxPager = "
" & Replace( Replace( sTemp, ""
End Function
Private Function Alpha( sTemp )
Alpha = RegularExpression( sTemp, "[^A-Z]", "" )
End Function
Private Function AlphaNumeric( sTemp )
AlphaNumeric = RegularExpression( sTemp, "[^A-Z0-9]", "" )
End Function
Private Function AlphaNumeric15( sTemp )
AlphaNumeric15 = Left("XXXXXXXXXXXXXXX" & AlphaNumeric( sTemp ), 15 )
End Function
Private Function AlphaNumericSpace( sTemp )
AlphaNumericSpace = RegularExpression( sTemp, "[^A-Z0-9 ]", "" )
End Function
Function AlphaSpace( sTemp )
AlphaSpace = RegularExpression( sTemp, "[^A-Z ]", "" )
End Function
Private Function ArraySort( aSort ) 'Sorts alphabetical and makes array items distinct
If IsArray( aSort ) Then
If UBound( aSort ) > 0 Then
Set rsSort = CreateObject("ADODB.RECORDSET")
rsSort.Fields.append "sField", adVarChar, 25
rsSort.CursorType = adOpenStatic
rsSort.Open
For iLoop = 0 to UBound( aSort )
rsSort.AddNew "sField", aSort( iLoop )
rsSort.Update
Next
rsSort.Sort = "sField"
rsSort.MoveFirst
sTemp = Empty
Do Until rsSort.EOF
sTemp = sTemp & rsSort.Fields("sField") & "~|~"
rsSort.MoveNext
Loop
Destroy( rsSort )
ArraySort = Split( sTemp, "~|~")
Else
ArraySort = aSort( 0 )
End If
End If
End Function
Function CalcProjectionMonth( vValue, dtDate )' IF dtDate IS NOT A VALID DATE, THEN NOW IS USED
Dim iDayOfMonthCurrent, iDaysInMonth, iProjectionTotal, dtParsedDate
dtParsedDate = IIf( IsDate( dtDate ), CDate( dtDate ), Now )
iDayOfMonthCurrent = Day( dtParsedDate )
iDaysInMonth = Day( DateSerial( Year( dtParsedDate ), Month( dtParsedDate ) + 1, 0 ) )
iProjectionTotal = ( vValue / iDayOfMonthCurrent ) * iDaysInMonth
CalcProjectionMonth = iProjectionTotal
End Function
Private Function CacheURL()
CacheURL = Replace( ServerVariable("CACHE_URL"), ":443", "" ) 'Remarks
End Function
Private Function CacheURLPart( sPart )
CacheURLPart = URLPart( ServerVariable("CACHE_URL"), sPart ) 'DO NOT shortcut with CACHEURL
End Function
Private Function URLPart( sURL, sPart )
Set oURL = Server.CreateObject("Chilkat_9_5_0.Url")
sParse = oURL.ParseUrl( sURL )
Select Case sPart
Case "Host"
URLPart = oURL.Host
Case "Port"
URLPart = oURL.Port
Case "Path"
URLPart = oURL.Path
Case "Query"
URLPart = oURL.Query
Case "Frag"
URLPart = oURL.Frag
Case "Hash" 'Vernacular second option
URLPart = oURL.Frag
End Select
Destroy( oURL )
End Function
Private Function IsJSONArray( ByVal sDataJSON )
Set oTempJSONArray = Server.CreateObject("Chilkat_9_5_0.JsonArray")
IsJSONArray = CBool( oTempJSONArray.Load( sDataJSON & "" ) )
Destroy( oTempJSONArray )
End Function
Private Function IsJSONObject( ByVal sDataJSON )
Set oTempJSONObject = Server.CreateObject("Chilkat_9_5_0.JsonObject")
IsJSONObject = CBool( oTempJSONObject.Load( sDataJSON & "" ) )
Destroy( oTempJSONObject )
End Function
Private Function IsJSON( ByVal sDataJSON )
IsJSON = IsJSONArray( sDataJSON ) OR IsJSONObject( sDataJSON )
End Function
Function JSONObjectUpdate( oTempJSONbyRef, sNamePath, vValue, jsonOther ) 'NOTE: oTempJSONbyRef (Objects) operate ByRef by default, and is named as such, DO NOT DESTROY
Set oTemp = Server.CreateObject("Chilkat_9_5_0.JsonObject")
bSuccess = oTemp.Load( oTempJSONbyRef )
If bSuccess Then
Select Case VarType( vValue )
Case vbBoolean
bSuccess = oTemp.UpdateBool( sNamePath, vValue )
Case vbInteger
bSuccess = oTemp.UpdateInt( sNamePath, vValue )
Case vbString
bSuccess = oTemp.UpdateString( sNamePath, vValue )
Case vbSingle
bSuccess = oTemp.UpdateNumber( sNamePath, vValue )
Case vbDouble
bSuccess = oTemp.UpdateNumber( sNamePath, vValue )
Case vbDate
bSuccess = oTemp.UpdateString( sNamePath, CStr( vValue ) )
Case vbVariant
' "Variant"
Case vbArray
' "Array"
Case Else
' "Unknown Type"
End Select
End If
End Function
Function JSONArrayFromVBArray( aTempArray, xMore ) 'THIS FUNCTION CURRENTLY ONLY SUPPORTS STRING DATA TYPE, CREATED DECEMBER 17 2023
Dim oJSONArray 'DIM FOR DISTINCT FUNCTION SCOPE FOR RECURSIVE SCENARIOS
Set oJSONArray = Server.CreateObject("Chilkat_9_5_0.JsonArray")
oJSONArray.EmitCompact = False 'Set to True for compact JSON, False for pretty-printed JSON
Dim iLoop
For iLoop = 0 To UBound( aTempArray )
bSuccess = oJSONArray.AddStringAt( -1, aTempArray( iLoop ) ) 'Add element of the VBScript array to end of JSON array
Next
JSONArrayFromVBArray = oJSONArray.Emit ' Return the JSON array as a string
End Function
Private Function xxxKeyInURLSlug( ByVal sURL ) '-CHANGED TO THE FUNCTION BELOW, ON DECEMBER 16 2023
Set oURL = Server.CreateObject("Chilkat_9_5_0.Url")
sParse = oURL.ParseUrl( sURL )
aTemp = Split( oURL.Path, "/")
For iLoop = 0 To UBound( aTemp )
sTemp = AlphaNumeric( aTemp( iLoop ) ) & ""
If Len( sTemp ) = 15 AND StrComp( sTemp, UCase( sTemp ) ) = 0 Then
KeyInURLSlug = sTemp
Exit For
End If
Next
Destroy( oURL )
End Function
Function KeyInURLSlug( ByVal sTempURL )
Dim RegEx, Match, Matches
Set RegEx = New RegExp
RegEx.Pattern = "/([0-9A-Z]{15})(/|$)" 'Regular expression for matching the 15-character alphanumeric string
RegEx.IgnoreCase = False
RegEx.Global = False
Set Matches = RegEx.Execute( sTempURL )
If Matches.Count > 0 Then
Set Match = Matches( 0 )
KeyInURLSlug = Match.SubMatches( 0 )
Else
KeyInURLSlug = ""
End If
Destroy( RegEx )
End Function
Private Function StringChop( sString, sStringChopAt, sAfterOrBefore ) 'Chops/Clips a string: chops a string after/before the 1st occurance of a substring.
Set oCKS = Server.CreateObject("Chilkat_9_5_0.CkString")
oCKS.Str = sString
If "after" = LCase( sAfterOrBefore ) Then
oCKS.ChopAfter sStringChopAt
Else
oCKS.ChopBefore sStringChopAt
End If
StringChop = oCKS.Str
Destroy( oCKS )
End Function
Private Function StringPluralizeWord( sWord, bTrueOrFalse ) ' The string must contain a single word and leading/trailing spaces should be trimmed.
Set oCKS = Server.CreateObject("Chilkat_9_5_0.CkString")
oCKS.Str = Trim( sWord )
If bTrueOrFalse Then
oCKS.Pluralize
Else
oCKS.Unpluralize
End If
StringPluralizeWord = oCKS.Str
Destroy( oCKS )
End Function
Private Function Clean( sTemp )
sTemp = sTemp & "" 'Addresses any NULL circumstances
sTemp = Replace( sTemp, "'", "'")
sTemp = Replace( sTemp, Chr( 34 ), """)
sTemp = Replace( sTemp, "\n", "&vbCrLf;")
sTemp = Replace( sTemp, vbCrLf, "&vbCrLf;")
sTemp = Replace( sTemp, "xp_", "")
sTemp = Replace( sTemp, "’","’")
'' sTemp = Replace( sTemp, "--", "-")
''' /^[a-zàâçéèêëîïôûùüÿñæœ .-]*$/i
Clean = Trim( RegularExpression( "" & sTemp, "[^0-9a-zA-Z\u00C0-\u017F\~#!@&$%()™’,.-|+/\*^:;_ ’-]", "" ) ) ' It was... "[^0-9a-zA-Z\u00C0-\u017F\~#!@&$%()™’,.-|+/\*^:;_ -]" ...prior to June 20 2024. Added the ’ character on November 7 2021 to address apostrophe names that are cleaned
Clean = Replace( sTemp, "’", "’")
End Function
Private Function CleanUnDo( sTemp )
CleanUnDo = Replace( sTemp & "", "&vbCrLf;" & "", vbCrLf)
End Function
Private Function ToHTML( sTemp )
ToHTML = Replace( sTemp, "&vbCrLf;", " ")
End Function
Private Function CleanAndFormatHTML( sHTML )
CleanAndFormatHTML = TextDoubleSpace( Trim( sHTML ) )
If ( Request("sName") <> Empty OR Request("sTitle") <> Empty ) AND InStr( CleanAndFormatHTML, "alt=" & Chr( 34 ) & Chr( 34 ) ) > 0 Then
CleanAndFormatHTML = Replace( CleanAndFormatHTML, "alt=" & Chr( 34 ) & Chr( 34 ), "alt='" & Replace( NoHTML( Request("sTitle") ), " ", " " ) & "'" )
End If
If CleanAndFormatHTML = "undefined" OR CleanAndFormatHTML = "null" Then
CleanAndFormatHTML = Replace( "
", "")
aTemp = Split("289- 416- 647- 705- 800- 905-")
For iLoop = 0 To UBound( aTemp )
aTemp( iLoop ) = Numeric( aTemp( iLoop ) )
CleanAndFormatHTML = Replace( CleanAndFormatHTML, aTemp( iLoop ) & "-", "(" & aTemp( iLoop ) & ") ")
Next
CleanAndFormatHTML = Replace( CleanAndFormatHTML, "0pm", "0PM")
CleanAndFormatHTML = Replace( CleanAndFormatHTML, "0am", "0AM")
Do Until InStr( CleanAndFormatHTML, "Youtube movie:" ) = 0
iTemp1 = InStr( CleanAndFormatHTML, "Youtube movie:") - 1
iTemp2 = InStr( iTemp1, CleanAndFormatHTML, "" )
CleanAndFormatHTML = Left( CleanAndFormatHTML, iTemp1 ) & Mid( CleanAndFormatHTML, iTemp2, 1048576 )
Loop
CleanAndFormatHTML = Replace( CleanAndFormatHTML, "Default preview for : Iframe", "" )
CleanAndFormatHTML = Replace( CleanAndFormatHTML, "Default preview for : Video", " " )
aTemp = Split("-xs -sm -lg -1x -2x -3x -4x -5x -6x -7x -10x")
For iLoop = 0 To UBound( aTemp)
CleanAndFormatHTML = Replace( CleanAndFormatHTML, "fa" & aTemp( iLoop ) & Chr( 34 ) & " />", "fa" & aTemp( iLoop ) & Chr( 34 ) & ">" )
Next
CleanAndFormatHTML = Replace( CleanAndFormatHTML, "", "")
End If
End Function
Function TextDoubleSpace( ByVal sText )
Dim oRegEx
Set oRegEx = New RegExp
oRegEx.Pattern = "([.!?]) ([A-Z])"
oRegEx.IgnoreCase = False
oRegEx.Global = True
TextDoubleSpace = oRegEx.Replace( sText, "$1 $2" )
Destroy( oRegEx )
End Function
'Added 2022-02-01
Private Function ClioGrowInbox( sName, sEmail, sMessage, sPhone, sURLReferring, sSource, sClioGrowInboxKey )
On Error Resume Next 'Just in case the Clio account has any issue that we cannot control
aName = Split( sName )
sNameFirst = aName( 0 )
sNameLast = aName( 1 )
Set jsonClioLead = Server.CreateObject("Chilkat_9_5_0.JsonObject")
iIndex = -1 'An index value of -1 is used to append at the end.
bSuccess = jsonClioLead.AddStringAt( iIndex, "from_first", sNameFirst )
bSuccess = jsonClioLead.AddStringAt( iIndex, "from_last", sNameLast )
bSuccess = jsonClioLead.AddStringAt( iIndex, "from_message", sMessage )
bSuccess = jsonClioLead.AddStringAt( iIndex, "from_email", sEmail )
bSuccess = jsonClioLead.AddStringAt( iIndex, "from_phone", sPhone )
bSuccess = jsonClioLead.AddStringAt( iIndex, "referring_url", sURLReferring )
bSuccess = jsonClioLead.AddStringAt( iIndex, "from_source", sSource )
Set jsonClioGrow = Server.CreateObject("Chilkat_9_5_0.JsonObject")
bSuccess = jsonClioGrow.AddObjectAt( iIndex, "inbox_lead" )
Set jsonInfo = jsonClioGrow.ObjectOf("inbox_lead")
bSuccess = jsonInfo.Load( jsonClioLead.Emit() )
bSuccess = jsonClioGrow.AddStringAt( iIndex, "inbox_lead_token", sClioGrowInboxKey )
jsonClioGrow.EmitCompact = 1
Set oHTTP = Server.CreateObject("Chilkat_9_5_0.Http")
oHTTP.Accept = "application/json"
sURLPost = "https://grow.clio.com/inbox_leads"
Set oRESP = oHTTP.PostJson2( sURLPost, "application/json", jsonClioGrow.Emit() )
If ( oHTTP.LastMethodSuccess = 0 ) Then 'An Error Occured
sError = Server.HTMLEncode( oHTTP.LastErrorText )
End If
ClioGrowInbox = oRESP.StatusCode & " " & sError
Destroy( oRESP )
Destroy( oHTTP )
Destroy( jsonInfo )
Destroy( jsonClioGrow )
Destroy( jsonClioLead )
On Error Goto 0
End Function
Function Connection()
Set Connection = Server.CreateObject("ADODB.Connection")
'Connection.Open "Driver={SQL Server};Server=tcp:wmc-sql-1.database.windows.net,1433;Database=_Marketing.legal;Uid=Steve;Pwd=PNuw38UtXKmZGCCv;Encrypt=yes;TrustServerCertificate=no;Connection Timeout=15;"
Connection.Open "Driver={SQL Server};Server=tcp:wmc-sql-1-ca.database.windows.net,1433;Database=_Marketing.legal;Uid=Steve;Pwd=PNuw38UtXKmZGCCv;Encrypt=yes;TrustServerCertificate=no;Connection Timeout=15;"
End Function
Function ConnectionLong( iSeconds )
iSeconds = 300
Set ConnectionLong = Server.CreateObject("ADODB.Connection")
'ConnectionLong.Open "Driver={SQL Server};Server=tcp:wmc-sql-1.database.windows.net,1433;Database=_Marketing.legal;Uid=Steve;Pwd=PNuw38UtXKmZGCCv;Encrypt=yes;TrustServerCertificate=no;Connection Timeout=" & iSeconds & ";"
ConnectionLong.Open "Driver={SQL Server};Server=tcp:wmc-sql-1-ca.database.windows.net,1433;Database=_Marketing.legal;Uid=Steve;Pwd=PNuw38UtXKmZGCCv;Encrypt=yes;TrustServerCertificate=no;Connection Timeout=" & iSeconds & ";"
End Function
Private Function CookieDel( sName )
CookieDelete( sName )
End Function
Private Function CookieDelete( sName )
Response.Cookies( sName ).Expires = DateAdd("YYYY", -10, Now )
End Function
Private Function CookieRemove( sName )
CookieDelete( sName )
End Function
Private Function CookieGet( sName )
CookieGet = Request.Cookies( sName )
End Function
Private Function CookieSet( sName, sValue, sExpires )
Response.Cookies( sName ) = sValue
If IsDate( sExpires ) = True Then
sExpires = CDate( sExpires )
Else
sExpires = DateAdd("H", 1, Now )
End If
Response.Cookies( sName ).Expires = sExpires
End Function
Private Function CopyFile( sPathFrom, sPathTo )
On Error Resume Next
Set oASPUpload = Server.CreateObject("Persits.Upload.1")
oASPUpload.MoveFile MapPath( sPathFrom ), MapPath( sPathTo )
Destroy( oASPUpload )
CopyFile = Err.Number & "|" & Err.Description
End Function
Private Function CreateAccount( sKey, bAdmin, iType, sEmail, sPassword, sName, sPhone )
'LEGACY AS OF JANUARY 2 2022, NEW TO RECODE THIS TO WORK WITH THE NEW AccountUserCreate()
If Len( sKey & "" ) < 15 Then
sKey = Key( 15 )
End If
If IsEmail( sEmail ) = True AND Len( Alpha( sName ) ) > 5 Then
sSQL = "SELECT TOP 1 tblAccounts.* FROM tblAccounts WHERE sEmail LIKE '" & sEmail & "'"
Set rsAccount = CreateObject("ADODB.RecordSet")
rsAccount.CursorLocation = adUseClient
rsAccount.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If rsAccount.EOF = True Then
rsAccount.AddNew
rsAccount("sKey") = sKey
rsAccount("bAdmin") = Numeric( bAdmin )
rsAccount("iType") = Numeric( iType )
rsAccount("sEmail") = sEmail
rsAccount("sName") = Trim( AlphaNumericSpace( sName ) )
rsAccount("sPhone") = Phone( sPhone )
If Len( sPassword ) < 8 Then
rsAccount("sPassword") = Key( 10 )
End If
rsAccount.Update
'EmailWelcome( CreateAccount )
End If
End If
CreateAccount = sKey
Destroy( rsAccount )
End Function
Private Function CreateDirectory( sPath ) 'IF ERRORS OCCUR, ENSURE THAT THE RESPECTIVE APP POOL HAS 32BIT APPLICATIONS ENABLED - Persits is 32Bit
On Error Resume Next
Set oASPUpload = Server.CreateObject("Persits.Upload.1")
oASPUpload.CreateDirectory MapPath( sPath ), True
Destroy( oASPUpload )
End Function
Private Function DateString( sDate, bMonthShort )
If IsDate( sDate ) = True Then
DateString = MonthName( Month( sDate ), CBool( bMonthShort ) ) & " " & Right( "0" & Day( sDate ), 2 ) & " " & Year( sDate )
Else
DateString = Empty
End If
End Function
Private Function DateTime( dDateTime )
If IsDate( dDateTime ) = True Then
DateTime = Year( dDateTime ) & "/" & Right( "0" & Month( dDateTime ), 2 ) & "/" & Right( "0" & Day( dDateTime ), 2 ) & " " & TwelveHourClock( dDateTime )
Else
DateTime = Empty
End If
End Function
Private Function DeleteDirectory( sPath )
On Error Resume Next
Set oFSO = CreateObject("Scripting.FileSystemObject")
oFSO.DeleteFolder( MapPath( sPath ) )
On Error Goto 0
Destroy( oFSO )
End Function
Function Destroy( oRS )
On Error Resume Next
oRS.Close
Set oRS = Nothing
End Function
Private Function DistinctTerms( sString, sDelimiter )
sString = Trim( sString )
Set oDict = Server.CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare
For Each sTerm In Split( sString, sDelimiter )
oDict( sTerm ) = Null
Next
DistinctTerms = Join( oDict.Keys, sDelimiter )
Destroy( oDict )
End Function
Private Function DomainAvailability( sDomain )
sTemp = Scrape("https://domain-availability.whoisxmlapi.com/api/v1?apiKey=at_Bb5uTVqL9LOs04NBEb6gUlxUwRfS1&domainName=" & sDomain & "&credits=DA")
DomainAvailability = NOT CBool( InStr( sTemp, "UNAVAILABLE") )
End Function
Private Function Email( sTo, sFrom, sSubject, sMessage )
sMessage = Replace( sMessage & "", "&vbCrLf;", " ")
Call EmailViaMailGun( sTo, sFrom, sSubject, sMessage, aFileAttachments )
End Function
Private Function EmailViaGmail( sTo, sFrom, sSubject, sMessage )
Set oEmail = CreateObject("CDO.Message")
Set oConf = CreateObject("CDO.Configuration")
Set oFlds = oConf.Fields
sSchema = "http://schemas.microsoft.com/cdo/configuration/" 'DO NOT CHANGE THIS TO HTTPS!!!!!!!!!!!!!!!
oFlds.Item( sSchema & "sendusing") = 2
oFlds.Item( sSchema & "smtpauthenticate") = 1
If AppVar("bServerSMTPCustom") Then
oFlds.Item( sSchema & "smtpserver") = AppVar("sServerSMTP")
oFlds.Item( sSchema & "smtpserverport") = AppVar("sServerSMTPPort")
oFlds.Item( sSchema & "sendusername") = AppVar("sServerSMTPUsername")
oFlds.Item( sSchema & "sendpassword") = AppVar("sServerSMTPPassword")
Else 'Use our Google SMTP
oFlds.Item( sSchema & "smtpserver") = "smtp.gmail.com"
oFlds.Item( sSchema & "smtpserverport") = 465
oFlds.Item( sSchema & "sendusername") = "sent.from.marketing.legal@gmail.com"
oFlds.Item( sSchema & "sendpassword") = "rbuatemthrxrpxjq" '<---- New Google App Code' '"1638474@bcD"
End If
oFlds.Item( sSchema & "smtpusessl") = 1
oFlds.Update
sMessage = Replace( sMessage, "&vbCrLf;", " ")
With oEmail
.To = sTo
If sTo = AppVar("sEmail") AND IsEmail( AppVar("sEmailSecondary") ) Then
.Cc = AppVar("sEmailSecondary")
End If
.Bcc = "info@webmarketconsultants.ca;success@marketing.legal"
.From = sFrom
.Subject = Replace( NoHTML( sSubject ), "’", "'")
sHTML = "" '
" & sSubject & "
"
If InStr( sMessage, "
" & sMessage & "
"
Else
sHTML = sHTML & sMessage
End If
sHTML = sHTML & "
This email was securely sent via Gmail, initiated on " & DateTime( Now ) & " from the IP Address: " & ServerVariable("REMOTE_ADDR") & " by a user on the website located at the domain " & Session("sDomain") & "; "
sHTML = sHTML & "as is hosted on the Success.Legal | Referrals.Legal professional network and software platform serving all Canadians interacting among the legal community.
This email was securely sent via MailGun, initiated on " & DateTime( Now ) & " from the IP Address: " & ServerVariable("REMOTE_ADDR") & " by a user on the " & AppVar("sNameShort") & " website; "
sHTML = sHTML & "which is hosted on the Success.Legal | Referrals.Legal professional network and software platform serving all Canadians interacting among the legal community.
"
sMessageShell = Scrape("/emails/shell-master.txt")
sEmailHTML = Replace( sMessageShell, "#TOKEN-CONTENT#", sHTML )
sEmailHTML = Replace( sEmailHTML, "#TOKEN-sDomain#", Session("sDomain") )
sEmailHTML = Replace( sEmailHTML, "#TOKEN-sName#", AppVar("sName") )
sEmailHTML = Replace( sEmailHTML, "#TOKEN-sNameShort#", AppVar("sNameShort") )
sEmailHTML = Replace( sEmailHTML, "#TOKEN-sButtonLogin#", "Login to " & AppVar("sNameShort") & "" )
sEmailHTML = Replace( Replace( sEmailHTML, "'", "'"), "’", "'")
sEmailHTML = Replace( sEmailHTML, "#TOKEN-bg-primary#", AppVar("sColorPrimary") )
Set oEmail = Server.CreateObject("Chilkat_9_5_0.Email")
oEmail.Subject = sSubject
'oEmail.From = UCase( Session("sDomain") ) & " | " & AppVar("sNameShort") & " <" & sFrom & ">"
oEmail.From = UCase( Session("sDomain") ) & " | " & AppVar("sNameShort") & " "
'oEmail.ReplyTo = sFrom
bSuccess = oEmail.AddTo("Recipient", sTo )
bSuccess = oEmail.AddHtmlAlternativeBody( sEmailHTML )
Set oHTTP = Server.CreateObject("Chilkat_9_5_0.Http")
oHTTP.Login = "api"
oHTTP.Password = "16691d9e9fba229287a965e990f05048-c76388c3-45b49225"
Set oPost = Server.CreateObject("Chilkat_9_5_0.HttpRequest")
oPost.HttpVerb = "POST"
oPost.Path = "/v3/cpd.legal/messages.mime"
oPost.ContentType = "multipart/form-data"
'oPost.AddParam "from", UCase( Session("sDomain") ) & " | " & AppVar("sNameShort") & " <" & sFrom & ">"
oPost.AddParam "from", UCase( Session("sDomain") ) & " | " & AppVar("sNameShort") & " "
oPost.AddParam "to","<" & sTo & ">"
'oPost.AddParam "h:Reply-To", sFrom ' Add the consumer's email as the "Reply-To" address
'oPost.AddParam "h:BCC", "steve@marketing.legal" ' Add the consumer's email as the "Reply-To" address
oPost.AddParam "o:tag","IsOpened"
If sTo = AppVar("sEmail") AND IsEmail( AppVar("sEmailSecondary") ) Then
oPost.AddParam "to","<" & AppVar("sEmailSecondary") & ">"
bSuccess = oEmail.AddTo("", AppVar("sEmailSecondary") )
End If
bSuccess = oPost.AddStringForUpload2("message","message.eml",oEmail.GetMime(),"utf-8","application/octet-stream")
Set oResp = oHTTP.SynchronousRequest("api.mailgun.net", 443, 1, oPost )
Destroy( oResp )
Destroy( oPost )
Destroy( oHTTP )
Destroy( oEmail )
'BCC HACK FOR NOW, UNTIL MAILGUN BCC IS FIGURED OUT
Set oEmail = Server.CreateObject("Chilkat_9_5_0.Email")
oEmail.Subject = sSubject
oEmail.From = UCase( Session("sDomain") ) & " | " & AppVar("sNameShort") & " <" & sFrom & ">"
'oEmail.From = UCase( Session("sDomain") ) & " | " & AppVar("sNameShort") & " "
bSuccess = oEmail.AddTo("", "steve@marketing.legal" )
bSuccess = oEmail.AddTo("", "success@marketing.legal" )
bSuccess = oEmail.AddHtmlAlternativeBody( sEmailHTML )
Set oHTTP = Server.CreateObject("Chilkat_9_5_0.Http")
oHTTP.Login = "api"
oHTTP.Password = "16691d9e9fba229287a965e990f05048-c76388c3-45b49225"
Set oPost = Server.CreateObject("Chilkat_9_5_0.HttpRequest")
oPost.HttpVerb = "POST"
oPost.Path = "/v3/cpd.legal/messages.mime"
oPost.ContentType = "multipart/form-data"
'oPost.AddParam "from", UCase( Session("sDomain") ) & " | " & AppVar("sNameShort") & " <" & sFrom & ">"
oPost.AddParam "from", UCase( Session("sDomain") ) & " | " & AppVar("sNameShort") & " "
oPost.AddParam "to",""
oPost.AddParam "to",""
oPost.AddParam "h:Reply-To", sFrom ' Add the consumer's email as the "Reply-To" address
oPost.AddParam "o:tag","IsOpened"
bSuccess = oPost.AddStringForUpload2("message","message.eml",oEmail.GetMime(),"utf-8","application/octet-stream")
Set oResp = oHTTP.SynchronousRequest("api.mailgun.net", 443, 1, oPost )
Destroy( oResp )
Destroy( oPost )
Destroy( oHTTP )
Destroy( oEmail )
End Function
Private Function Fetch( ByVal sTable, ByVal sField, ByVal sFilter )
On Error Resume Next
Dim rs
sSQL = "SELECT TOP 1 " & sTable & "." & sField & " FROM " & sTable & " WHERE " & sFilter
Set rs = CreateObject("ADODB.RecordSet")
rs.CursorLocation = adUseClient
rs.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If rs.EOF = False Then
Fetch = rs( sField )
End If
Destroy( rs )
End Function
Private Function FetchAvg( ByVal sTable, ByVal sField, ByVal sFilter )
On Error Resume Next
sSQL = "SELECT AVG(" & sField & ") -0.0 AS iAverage FROM " & sTable & " WHERE " & sFilter 'WITHOUT THE -0.0, IT ALWAYS RETURNS A WHOLE NUMBER '
Set rs = CreateObject("ADODB.RecordSet")
rs.CursorLocation = adUseClient
rs.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If rs.EOF = False Then
FetchAvg = rs("iAverage")
End If
Destroy( rs )
End Function
Private Function FetchRows( sSQL, iRows, iRowStart, aFields ) 'THIS FUNCTION IS NOT USEFUL WHEN SUBSEQUENT ITERATION THROUGH A RECORDSET REQUIRES REFERENCING FIELD ITEMS BY THEIR RESPECTIVE NAMES
If Numeric( iRows ) < 1 Then
iRows = adGetRowsRest
End If
If Numeric( iRowStart ) < 1 Then
iRowStart = 1
End If
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient
rs.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If NOT rs.EOF Then
FetchRows = rs.GetRows( iRows, iRowStart, aFields )
End If
Destroy( rs )
End Function
Private Function FileExists( ByVal sPathFile )
If InStr( sPathFile, ":") = 0 Then
sPathFile = Server.MapPath( sPathFile )
End If
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists( sPathFile )
Destroy( oFSO )
End Function
Private Function FileRead( ByVal sPathFile )
If FileExists( sPathFile ) Then
If InStr( sPathFile, ":") = 0 Then
sPathFile = Server.MapPath( sPathFile )
End If
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFile = oFSO.OpenTextFile( sPathFile, 1 ) '1 = Reading
FileRead = oFile.ReadAll
Destroy( oFile )
Destroy( oFSO )
End If
End Function
Private Function XXXXXXXXFileWrite( sPathFile, sTextToWrite, bAllowOverwrite, jsonX ) 'XXXX - REMOVED JUNE 9 2024, AS IT SEEMS TO ONLY ADDRESS A CSS FILE AND HAS AN sPath Variable isn't doing anything. Delete??
If InStr( sPathFile, ":") = 0 Then
sPathFile = Server.MapPath( sPathFile )
End If
If InStr( sPathFile, "/files/" & Session("sKeyPersona") & "/") > 0 Then
sPathFile = ServerVariable("APPL_PHYSICAL_PATH") & sPath & "custom.css"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set fText = oFSO.CreateTextFile( sPathFile )
aTemp = Split( Trim( sTextToWrite ), vbCrLf )
For iLoop = 0 To UBound( aTemp )
fText.WriteLine( aTemp( iLoop ) )
Next
Destroy( fText )
Destroy ( oFSO )
End If
End Function
Private Function FileWrite( sPathFile, sTextToWrite, bAllowOverwrite, jsonX ) 'NEW AS OF JUNE 9 2024, BUT MIGHT BREAK THE WRITE OF CUSTOM.CSS???
If InStr(sPathFile, ":") = 0 Then
sPathFile = Server.MapPath( sPathFile )
End If
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FileExists( sPathFile ) Then
If bAllowOverwrite Then
Set fText = oFSO.CreateTextFile( sPathFile, True )
Else
Destroy( fText )
End If
Else
Set fText = oFSO.CreateTextFile( sPathFile, True )
End If
If NOT fText Is Nothing Then
aTemp = Split( Trim( sTextToWrite ), vbCrLf)
For iLoop = 0 To UBound( aTemp )
fText.WriteLine( aTemp( iLoop ) )
Next
fText.Close
End If
Destroy( fText )
Destroy( oFSO )
End Function
Function Flush()
Response.Flush
End Function
Private Function Form( sTemp )
Form = Request.Form( sTemp )
End Function
Function FormatTimeOfDay( ByVal sTempFormat )
FormatTimeOfDay = RegularExpression( sTempFormat, "(\b\d{1,2}:\d{2})\s(AM|PM)\b", "$1$2" )
End Function
Private Function GetURLSlug( ByVal sURL )
Set oURL = Server.CreateObject("Chilkat_9_5_0.Url")
bParseIt = oURL.ParseUrl( sURL )
GetURLSlug = oURL.Path
Destroy( oURL )
End Function
Private Function GetText( sPath )
On Error Resume Next
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oTStream = oFSO.OpenTextFile( Server.MapPath( sPath ), 1 )
Do Until oTStream.AtEndOfStream
sTemp = sTemp & oTStream.ReadLine & vbCRLF
Loop
Destroy( oTStream )
GetText = sTemp
End Function
'This is NOT yet working... ??
Private Function TextSet( sPath, sText )
On Error Resume Next
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFile = oFSO.CreateTextFile( Server.MapPath( sPath ), True )
oFile.Write( sText )
Destroy( oFile )
Destroy( oFSO )
On Error Goto 0
End Function
Private Function Greeting
Select Case Hour( Now )
Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11
Greeting = "Good Morning "
Case 18, 19, 20, 21, 22, 23
Greeting = "Good Evening "
Case Else
Greeting = "Good Afternoon "
End Select
End Function
Private Function GreetString
GreetString = Greeting() & " " & Session("sName")
End Function
Private Function HoursOfBusiness( jsonHoursBusiness )
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
bSuccess = oJSON.Load( jsonHoursBusiness & "" )
aDays = Split("Sunday Monday Tuesday Wednesday Thursday Friday Saturday")
sTemp = ""
For iLoop = 0 To UBound( aDays )
If oJSON.StringOf( aDays( iLoop ) & ".sOpen" ) <> Empty Then
sTime = TwelveHourClock( oJSON.StringOf( aDays( iLoop ) & ".sOpen" ) )
sTemp = sTemp & Left( sTime, 5 ) & Right( sTime, 2 )
sTemp = sTemp & " - "
sTime = TwelveHourClock( oJSON.StringOf( aDays( iLoop ) & ".sClose" ) )
sTemp = sTemp & Left( sTime, 5 ) & Right( sTime, 2 ) & " "
End If
Next
sTemp = sTemp & ""
For iLoop = 0 To UBound( aDays )
If oJSON.StringOf( aDays( iLoop ) & ".sOpen" ) <> Empty Then
sTemp = sTemp & Left( aDays( iLoop ), 3 )
sTemp = sTemp & "" & Mid( aDays( iLoop ), 4 ) & ": "
End If
Next
Destroy( oJSON )
HoursOfBusiness = sTemp
End Function
Function HTMLArea( ByVal sHTML )
HTMLArea = HTMLAreaSized( sHTML, "100%", "80vh")
End Function
Function HTMLAreaSized( sHTML, iWidthWYSIWYG, iHeightWYSIWYG )
Set rte = new RichTextEditor
rte.AjaxPostbackUrl = "/master.asp"
rte.DesignDocType = "HTML5"
rte.DisabledItems = "new,print,spellcheck,pasteword,pageproperties,virtualkeyboard,googlemap,insertdate,syntaxhighlighter,inserttemplate,insertimagemap,insertlayer,insertform,toggleborder,fontname,fontsize,formatpainter"
' rte.SetSecurity("Gallery,Image", "*", "MaxFileSize", "102400")
rte.AllowScriptCode = True
rte.EnableDragDrop = True
rte.ShowPreviewToolbar = False
rte.Text = sHTML
rte.SaveButtonScript = "return doSwalSaving();"
rte.Name = "sHTML"
rte.ShiftEnterKeyTag = "br"
rte.Skin = "office2003silver2"
rte.TagBlackList = "object"
rte.TagWhiteList = "style"
'rte.URLType = "siterelative"
rte.UseHTMLEntities = True
rte.Width = iWidthWYSIWYG
rte.Height = iHeightWYSIWYG
'rte.ContentCss = "//stackpath.bootstrapcdn.com/bootstrap/4.1.3/css/bootstrap.min.css,/css/bootstrap.css,/css/style.css,/css/project.custom.css,files/" & Session("sKeyPersona") & "/css/custom.css,//maxcdn.bootstrapcdn.com/font-awesome/4.7.0/css/font-awesome.min.css,//fonts.googleapis.com/css?family=Open+Sans"
rte.ContentCss = "//stackpath.bootstrapcdn.com/bootstrap/4.1.3/css/bootstrap.min.css,/css/project.custom.css,//fonts.googleapis.com/css2?family=Open+Sans:wght@300;400;600;700;800"
rte.EditorBodyStyle = "overflow-x:hidden;"
' All rte.Security config is in master.asp and needs to be
If sCommunalLocked = "readonly" Then
rte.EditorMode = "View"
rte.ShowBottomBar = False
rte.ReadOnly
End If
rte.MvcInit()
Write( rte.GetString() )
HTMLAreaSized = rte.ID
Destroy( rte )
End Function
Function HTMLGateway( idPageGateway, jsonDataOptions )
Dim iParent, iCols, sIcon, htmlOutput, sTemp, aIcon
'iParent = Numeric( Fetch("tblNavigation", "ID", "iPageID=" & idPageGateway) ) 'IN CASE RETURNS 0, THE SQL BELOW EXCLUDES 0, WHICH OTHERWISE WOULD RETURN THOUSANDS OF IMPROPER RESULTS
sTemp = IIf( Session("bHomePage") = True, 0, "( SELECT ID FROM tblNavigation WHERE iPageID = " & idPageGateway & ") ")
sSQL = "SELECT tblNavigation.*, tblPageHTML.sTitle, tblPageHTML.sSynopsis, tblPageHTML.sIconFontAwesome FROM tblNavigation INNER JOIN tblPageHTML ON tblPageHTML.ID = tblNavigation.iPageID " & _
"WHERE tblNavigation.idPersona = " & Session("idPersona") & " AND tblNavigation.iParent = " & _
sTemp & " AND tblNavigation.bLive > 0 AND tblNavigation.bDeleted = 0 AND tblNavigation.sLabel <> 'About' AND tblNavigation.sLabel <> 'Home' AND tblNavigation.sLabel <> 'Contact' " & _
"ORDER BY tblNavigation.iWeight, tblNavigation.sLabel, tblNavigation.ID"
Set rsGate = Server.CreateObject("ADODB.Recordset")
rsGate.CursorLocation = adUseClient
rsGate.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If NOT rsGate.EOF Then
Select Case rsGate.RecordCount
Case 1
iCols = 12
Case 2
iCols = 6
Case Else
iCols = 4
End Select
htmlTemplate = FileRead("/templates/gateway-default-html.asp")
Do Until rsGate.EOF
tempTemplate = htmlTemplate ' Start with a fresh template each iteration.
If InStr( rsGate("sIconFontAwesome") & "", "fa-") = 0 Then
sIcon = AppVar("sIconDefault")
sIconStyle = IIf( InStr( AppVar("sIconDefault"), "fa-kit" ) > 0, "fa-kit", "fa-duotone")
Else
sIconStyle = IIf( InStr( rsGate("sIconFontAwesome"), "fa-kit" ) > 0, "fa-kit", "fa-duotone")
aIcon = Split( rsGate("sIconFontAwesome") & "", ",")
sIcon = aIcon( 0 )
End If
tempTemplate = Replace( tempTemplate, "#TOKEN-iCols#", iCols )
tempTemplate = Replace( tempTemplate, "#TOKEN-sIcon#", sIcon )
tempTemplate = Replace( tempTemplate, "#TOKEN-sIconStyle#", sIconStyle )
tempTemplate = Replace( tempTemplate, "#TOKEN-sLabel#", rsGate("sLabel") )
tempTemplate = Replace( tempTemplate, "#TOKEN-sSynopsis#", Truncate( rsGate("sSynopsis"), 63 ) )
tempTemplate = Replace( tempTemplate, "#TOKEN-sPath#", rsGate("sPath") )
htmlOutput = htmlOutput & tempTemplate
rsGate.MoveNext
Loop
HTMLGateway = "
" & htmlOutput & "
"
End If
Destroy( rsGate )
End Function
Function IIf(blnExpression, vTrueResult, vFalseResult)
If blnExpression Then
IIf = vTrueResult
Else
IIf = vFalseResult
End If
End Function
Private Function ImageMaxWidth( sFile, iWidth ) 'OUTPUT IS ALWAYS IN .JPG
If InStr(".bmp.gif.jpeg.jpg.png", Right( sFile, 4 ) ) > 0 Then
Set oJpeg = Server.CreateObject("Persits.Jpeg")
oJpeg.Open Server.MapPath( sFile )
If oJpeg.Width > iWidth Then
sPathSave = Server.MapPath( sFile )
oJpeg.PreserveAspectRatio = True
oJpeg.Width = iWidth
oJpeg.Quality = 90
oJpeg.Save sPathSave
End If
Destroy( oJpeg )
End If
End Function
Private Function InstallPage( idMasterPage, idPersonaDestination, jsonData )
sSQL = "SELECT tblPageHTML.* FROM tblPageHTML WHERE ID = " & idMasterPage
Set rsExport = CreateObject("ADODB.Recordset")
rsExport.CursorLocation = adUseClient
rsExport.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If NOT rsExport.EOF Then
sSQL = "SELECT tblPageHTML.* FROM tblPageHTML WHERE ID = 0"
Set rsImport = CreateObject("ADODB.Recordset")
rsImport.CursorLocation = adUseClient
rsImport.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
rsImport.AddNew
rsImport("sKey") = Key( 15 )
rsImport("idPersona") = idPersonaDestination
rsImport("sKeyPersona") = Fetch("tbl@Personas","sKey","ID=" & idPersonaDestination )
rsImport("sKeyPageHTMLSyndicate") = rsExport("sKey")
sFieldsSkip = ",ID,sKey,idPersona,sKeyPersona,sKeyPageHTMLSyndicate,iOwner,iCreator,bCommunal,bCommunalSyncAllow,dCreated,dModified," 'LEADING AND TRAILING COMMAS ARE REQUIRED
For Each oField In rsExport.Fields
If InStr( sFieldsSkip, "," & oField.Name & "," ) = 0 AND NOT IsNull( oField.Value ) Then
rsImport( oField.Name ) = oField.Value
End If
Next
rsImport("bCommunalSyncAllow") = 1
rsImport("iOwner") = iOwner
rsImport("iCreator") = iOwner
rsImport("dCreated") = Now
rsImport("dModified") = Now
rsImport.Update
InstallPage = rsImport("ID") 'RETURN ID OF PAGE
Destroy( rsImport )
End If
Destroy( rsExport )
End Function
Private Function InstallPageNav( idMasterNav, idPersonaDestination, idPage, idParentNew, sPath, jsonData )
sSQL = "SELECT tblNavigation.* FROM tblNavigation WHERE ID = " & idMasterNav
Set rsExport = CreateObject("ADODB.Recordset")
rsExport.CursorLocation = adUseClient
rsExport.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If NOT rsExport.EOF Then
sSQL = "SELECT tblNavigation.* FROM tblNavigation WHERE ID = 0"
Set rsImport = CreateObject("ADODB.Recordset")
rsImport.CursorLocation = adUseClient
rsImport.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
rsImport.AddNew
rsImport("sKey") = Key( 15 )
rsImport("idPersona") = idPersonaDestination
rsImport("sKeyPersona") = Fetch("tbl@Personas","sKey","ID=" & idPersonaDestination )
sFieldsSkip = ",ID,sKey,idPersona,sKeyPersona,idPage,iOwner,iCreator,dCreated,dModified," 'LEADING AND TRAILING COMMAS ARE REQUIRED
For Each oField In rsExport.Fields
If InStr( sFieldsSkip, "," & oField.Name & "," ) = 0 AND NOT IsNull( oField.Value ) Then
rsImport( oField.Name ) = oField.Value
End If
Next
rsImport("iPageID") = idPage
rsImport("iParent") = idParentNew
If sPath <> Empty Then
rsImport("sPath") = sPath
End If
rsImport("iOwner") = iOwner
rsImport("iCreator") = iOwner
rsImport("dCreated") = Now
rsImport("dModified") = Now
rsImport.Update
InstallPageNav = rsImport("ID") 'RETURN ID OF NAV-ITEM
Destroy( rsImport )
End If
Destroy( rsExport )
End Function
Function IsBot()
sUserAgent = ServerVariable("HTTP_USER_AGENT")
iLocationOfBot = InStr( 1, sUserAgent, "Bot", 1 )
IsBot = ( iLocationOfBot > 0 )
End Function
Function IsFirefox()
sUserAgent = ServerVariable("HTTP_USER_AGENT")
iLocationOfFirefox = InStr( 1, sUserAgent, "Firefox", 1 )
IsFirefox = ( iLocationOfFirefox > 0 )
End Function
Function IsChrome()
sUserAgent = ServerVariable("HTTP_USER_AGENT")
iLocationOfChrome = InStr( 1, sUserAgent, "Chrome", 1 )
IsChrome = ( iLocationOfChrome > 0 )
End Function
Function IsEdge()
sUserAgent = ServerVariable("HTTP_USER_AGENT")
iLocationOfEdge = InStr( 1, sUserAgent, "Edge", 1 )
IsEdge = ( iLocationOfEdge > 0 )
End Function
Function IsInternetExplorer()
sUserAgent = ServerVariable("HTTP_USER_AGENT")
iLocationOfInternetExplorer = InStr( 1, sUserAgent, "MSIE", 1 )
IsInternetExplorer = ( iLocationOfInternetExplorer > 0 )
End Function
Private Function Issue301Redirect( sURLSlugOld, sURLSlugNew, sKeyRecordIssuing )
sURLSlugOld = Replace( sURLSlugOld, "//", "/" )
sURLSlugNew = Replace( sURLSlugNew, "//", "/" )
sKeyRecordIssuing = AlphaNumeric( sKeyRecordIssuing )
sSQL = "SELECT * FROM tbl@301Redirects WHERE tbl@301Redirects.sURLSlugOld = '" & sURLSlugOld & "' AND tbl@301Redirects.sURLSlugNew = '" & sURLSlugNew & "'"
Set rs301 = CreateObject("ADODB.RecordSet")
rs301.CursorLocation = adUseClient
rs301.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If rs301.EOF = True Then
rs301.AddNew
rs301("sKey") = Key( 15 )
rs301("sURLSlugOld") = sURLSlugOld
rs301("sURLSlugNew") = sURLSlugNew
rs301("sKeyRecordIssuing") = AlphaNumeric( sKeyRecordIssuing )
rs301("iOwner") = iOwner
rs301.Update
End If
Destroy( rs301 )
End Function
'****** THE BELOW FUNCTIONS CREATED ON FEBRUARY 4 2024, SHOULD ACCOMMODATE ALL BASIC JSON REQUIREMENTS'
Function jsonAddObjectMemberValue( ByVal jsonData, ByVal sObjectName, ByVal sMemberName, ByVal vValue, jsonMore )
jsonAddObjectMemberValue = jsonSetObjectMemberValue( jsonData, sObjectName, sMemberName, vValue, jsonMore ) 'SYNONYMOUS FUNCTION, USE SET
End Function
Function jsonGetAsString( ByVal jsonData, ByVal sPath, jsonMore )
Dim oJSON
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
If oJSON.Load( jsonData ) Then
If sPath = "" Then
jsonGetAsString = oJSON.NameAt( 0 )
Else
If oJSON.HasMember( sPath ) Then
jsonGetAsString = oJSON.StringOf( sPath )
End If
End If
Else
jsonGetAsString = ""
End If
Set oJSON = Nothing
End Function
Function jsonGetObjectMemberValueAsString( ByVal jsonData, ByVal sObjectName, ByVal sMemberName, jsonMore )
Dim oJSON
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
jsonGetObjectMemberValueAsString = ""
If oJSON.Load( jsonData ) Then
If oJSON.HasMember( sObjectName & "." & sMemberName ) Then
jsonGetObjectMemberValueAsString = oJSON.StringOf( sObjectName & "." & sMemberName )
End If
End If
Destroy( oJSON )
End Function
Function jsonRemoveObjectMember( ByVal jsonData, ByVal sObjectName, ByVal sMemberName )
Dim oJSON
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
If oJSON.Load( jsonData ) Then
bSuccess = oJSON.Delete( sObjectName & "." & sMemberName )
jsonRemoveObjectMember = oJSON.Emit()
Else
jsonRemoveObjectMember = jsonData
End If
Destroy(oJSON)
End Function
Function jsonRenameObjectMember( ByVal jsonData, ByVal sObjectName, ByVal sMemberName, ByVal sMemberNameNew )
Dim oJSON
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
If oJSON.Load( jsonData ) Then
bSuccess = oJSON.Rename( sObjectName & "." & sMemberName, sObjectName & "." & sMemberNameNew )
jsonRenameObjectMember = oJSON.Emit()
Else
jsonRenameObjectMember = jsonData
End If
Destroy(oJSON)
End Function
Function jsonSet( ByVal jsonData, ByVal sPath, ByVal vValue, jsonMore )
Dim oJSON, oTemp, aTemp
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
If oJSON.Load( jsonData ) Then
sDataType = TypeName( vValue )
Select Case sDataType
Case "Integer", "Long"
oJSON.UpdateInt sPath, vValue
Case "String"
oJSON.UpdateString sPath, vValue
Case "Boolean"
oJSON.UpdateBool sPath, vValue
Case "Double", "Single"
oJSON.UpdateNumber sPath, vValue
Case Else
If IsJSONObject( vValue ) Then
Set oTemp = Server.CreateObject("Chilkat_9_5_0.JsonObject")
If oTemp.Load( vValue ) Then
oJSON.UpdateObject sPath, oTemp
End If
ElseIf IsJSONArray( vValue ) Then
Set aTemp = Server.CreateObject("Chilkat_9_5_0.JsonArray")
If aTemp.Load( vValue ) Then
oJSON.UpdateArray sPath, aTemp
End If
Else
oJSON.UpdateNull sPath 'Handle null or unrecognized data types
End If
End Select
jsonSet = oJSON.Emit()
Else
jsonSet = jsonData
End If
Destroy( oTemp )
Destroy( aTemp )
Destroy( oJSON )
End Function
Function jsonSetObjectMemberValue( ByVal jsonData, ByVal sObjectName, ByVal sMemberName, ByVal vValue, jsonMore )
Dim oJSON, sPath, sDataType, oTemp, aTemp
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
If oJSON.Load( jsonData ) Then
If sObjectName <> Empty AND sMemberName <> Empty AND InStr( sObjectName & sMemberName, ".") = 0 Then
sPath = sObjectName & "." & sMemberName
Else
sPath = sObjectName & sMemberName
End If
sDataType = TypeName( vValue )
Select Case sDataType
Case "Integer", "Long"
oJSON.UpdateInt sPath, vValue
Case "String"
oJSON.UpdateString sPath, vValue
Case "Boolean"
oJSON.UpdateBool sPath, vValue
Case "Double", "Single"
oJSON.UpdateNumber sPath, vValue
Case Else
If IsJSONObject( vValue ) Then
Set oTemp = Server.CreateObject("Chilkat_9_5_0.JsonObject")
If oTemp.Load( vValue ) Then
oJSON.UpdateObject sPath, oTemp
End If
ElseIf IsJSONArray( vValue ) Then
Set aTemp = Server.CreateObject("Chilkat_9_5_0.JsonArray")
If aTemp.Load( vValue ) Then
oJSON.UpdateArray sPath, aTemp
End If
Else
oJSON.UpdateNull sPath 'Handle null or unrecognized data types
End If
End Select
jsonSetObjectMemberValue = oJSON.Emit()
Else
jsonSetObjectMemberValue = jsonData 'On a failure, return the original JSON
End If
Destroy( oTemp )
Destroy( aTemp )
Destroy( oJSON )
End Function
'****** THE ABOVE FUNCTIONS CREATED ON FEBRUARY 4 2024, SHOULD ACCOMMODATE ALL BASIC JSON REQUIREMENTS'
Private Function JSONLocationGet( sIPAddress ) 'KEEP THIS CENTRALIZED, AS IT ALSO LOGS RESOURCES
JSONLocationGet = Scrape("https://api.ipdata.co/" & sIPAddress & "?api-key=75f7172b027c17cf0278dada8a0c2613aead13f80164c7f70cd0f4eb")
Call LogUseResources("IPData", "{""iCost"": .002 }" )
End Function
Private Function JSONStringsOf( sJSON, sItems ) 'sItems is a csv list, if more than one item is being sought, an Array of Strings is returned in same pecking order as sItems
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
oJSON.EmitCompact = 0
bSuccess = oJSON.Load( sJSON )
aItems = Split( sItems, ",")
For iLoop = 0 To UBound( aItems )
aItems( iLoop ) = oJSON.StringOf( aItems( iLoop ) ) 'Essentially replaces Items( iLoop ) from being the name of the JSON item requested, to being the value of the JSON item requested
Next
If UBound( aItems ) = 0 Then
JSONStringsOf = aItems( 0 ) 'Returns value as String
Else
JSONStringsOf = aItems 'Returns values as Strings in Array
End If
Destroy( oJSON )
End Function
Private Function jsonStringsGet( sJSON, sItems ) 'sItems is a ~|~ delimited list, if more than one item is being sought, an Array of Strings is returned in same pecking order as sItems
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
oJSON.EmitCompact = 0
bSuccess = oJSON.Load( sJSON )
If bSuccess Then
aItems = Split( sItems, "~|~")
For iLoop = 0 To UBound( aItems )
aItems( iLoop ) = oJSON.StringOf( aItems( iLoop ) ) 'Essentially replaces Items( iLoop ) from being the name of the JSON item requested, to being the value of the JSON item requested
Next
If UBound( aItems ) = 0 Then
JSONStringsOf = aItems( 0 ) 'Returns value as String
Else
JSONStringsOf = aItems 'Returns values as Strings in Array
End If
Else
'sJSON does not contain parseable JSON data, return Empty
jsonStringsGet = Empty
End If
Destroy( oJSON )
End Function
Private Function jsonStringsSet( aItems ) 'A two dimensional array of key-value pairs is expected.'
If IsArray( aItems ) Then
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
iIndex = -1 'An index value of -1 is used to append at the end.
For iLoop = 0 To UBound( aItems )
bSuccess = oJSON.AddStringAt( iIndex, aItems( iLoop )(0), aItems( iLoop )(1) )
Next
oJSON.EmitCompact = 1 'Compacts JSON data to a single line, not nested/human readable.
jsonStringsSet = oJSON.Emit()
Destroy( oJSON )
Else
jsonStringsSet = "ERROR: The function expects an array as an argument."
End If
End Function
Private Function Key( iLength ) 'Advanced Key Generator - New as of Nov 28 2018
aTemp = Split("A B C D E F G H J K L M N P Q R S T U V W X Y Z 2 3 4 5 6 7 8 9")
sTemp = aTemp( Year( Now ) - 2018 ) 'Keep this as 2018
sTemp = sTemp & aTemp( Month( Now ) - 1 )
sTemp = sTemp & aTemp( Day( Now ) - 1 )
sTemp = sTemp & aTemp( Hour( Now ) ) 'Already zero based (24 hour clock)
sTemp = sTemp & aTemp( Int( Minute( Now ) / 2 ) )
sTemp = sTemp & aTemp( Int( Second( Now ) / 2 ) )
sTemp = sTemp & Right( CStr( Numeric( Now ) ), 4 )
Randomize
For iLoopPrivate = 1 To 3
Key = Key & aTemp ( Int( UBound( aTemp ) * Rnd( 1 ) ) + 1 )
Next
Key = Right( sTemp & Key, iLength )
Do Until Len( Key ) = iLength
Key = Key & aTemp ( Int( UBound( aTemp ) * Rnd( 1 ) ) + 1 )
Loop
End Function
Private Function Keywords( sTemp )
sTemp = Replace( sTemp, " ", " " )
'Keywords = AlphaNumericSpace( RegularExpression( Replace( Replace( Replace( Clean( sTemp ), ",", " "), ".", " "), "/", " "), "\b\w{1,2}\b", " " ) ) 'Removes commas and words < 3 chars.
Keywords = RegularExpression( Replace( Replace( Clean( sTemp ), ".", " "), "/", " "), "\b\w{1,2}\b", " " ) 'Removes commas and words < 3 chars.
'Keywords = Replace( LCase( RegularExpression( Keywords, "\s{2,}", " ") ), " ", "," ) 'Removes double spaces and makes lower case. - PRE MAY 25 2024, FORCED KEYWORDS, NOT KEY PHRASES
Keywords = LCase( RegularExpression( Keywords, "\s{2,}", " ") ) 'Removes double spaces and makes lower case.
'' aKeywordsToMute = Split("and for the that they who can are get with also what has such more", " ")
'' For iLoop = 0 To UBound( aKeywordsToMute )
'' Keywords = Replace( Keywords, "," & aKeywordsToMute( iLoop ) & ",", ",")
'' Next
Keywords = DistinctTerms( Keywords, "," )
End Function
Function KillSession()
sSQL = "SELECT TOP 1 tblAccountsLog.* FROM tblAccountsLog WHERE iSessionID = " & Numeric( Session.SessionID ) & " ORDER BY ID DESC"
Set rsLog = CreateObject("ADODB.Recordset")
rsLog.CursorLocation = adUseClient
rsLog.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If rsLog.EOF = False Then
rsLog("iSessionID") = 0
rsLog("dSessionEnd") = Now
rsLog.Update
End If
Destroy( rsLog )
Session.Contents.RemoveAll()
End Function
Function iOwner
iOwner = Numeric( Session("iOwner") )
End Function
Private Function IsAllLCase( sTemp )
IsAllLCase = NOT CBool( StrComp( sTemp, LCase( sTemp ) ) )
End Function
Private Function IsAllUCase( sTemp )
IsAllUCase = NOT CBool( StrComp( sTemp, UCase( sTemp ) ) )
End Function
Private Function IsAllCaps( sTemp )
IsAllCaps = IsAllUCase( sTemp )
End Function
Private Function IsEmail( sTemp )
Set oRegExp = New RegExp
oRegExp.Pattern = "^[a-z0-9][\w\.-]*[a-z0-9]@[a-z0-9][\w\.-]*[a-z0-9]\.[a-z][a-z\.]*[a-z]$"
IsEmail = oRegExp.Test( LCase( Trim( sTemp & "" ) ) )
Destroy( oRegExp )
End Function
Function IsDeviceMobile()
Dim oRegExp, userAgent
Set oRegExp = New RegExp
With oRegExp
.Pattern = "(up.browser|up.link|mmp|smartphone|midp|wap|phone|windows ce|pda|mobile|mini|ipad|android|blackberry|iphone|ipod|palm|symbian|webos|opera mini|opera mobi|nokia|fennec|htc|kindle|silk|silk-accelerated)"
.IgnoreCase = True
.Global = True
End With
userAgent = Request.ServerVariables("HTTP_USER_AGENT")
IsDeviceMobile = oRegExp.Test(userAgent)
Set oRegExp = Nothing
End Function
Private Function LoadPersonaTheme()
aTemp = Split("sFontsGoogle,sHTMLLogo,sHTMLLogoVertical,sFileLogo,sFileLogoVertical,jsonIconsAndImages,sColorPrimary,sFileCustomCSS,bHeroBar,sFilePathImagesHero,sHeroOverlayColor,iHeroOverlayColorPercent,bHeaderTopShowDesktop,iHeaderTopConfig,bHeaderCentered,bHeaderLogoLock,bHeaderLight,bShowHeaderSignIn,bNavbarSearch,bNavbarLight,bNavbarFancy,bGrayscaleImages,iImagesMonotoneOffsetSaturation,iImagesMonotoneOffsetHue,bImagesScreenshotHome,bBreadcrumbsStriped,bSidebar,sSidebarColor,bLiveFX,sNameFXDefault,tDelayFX,bIncludeAnimateCSS", ",")
sSQL = "SELECT tbl@PersonasThemes.* FROM tbl@PersonasThemes WHERE tbl@PersonasThemes.idPersona = " & Session("idPersona") & " OR tbl@PersonasThemes.ID = 1 ORDER BY tbl@PersonasThemes.ID DESC"
Set rsTheme = CreateObject("ADODB.Recordset")
rsTheme.CursorLocation = adUseClient
rsTheme.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
If rsTheme.EOF = False Then
For iLoop = 0 To UBound( aTemp )
Call AppVarSet( aTemp( iLoop ), rsTheme( aTemp( iLoop ) ) )
Next
End If
Call AppVarSet("sIconDefault", jsonGetObjectMemberValueAsString( rsTheme("jsonIconsAndImages"), sObjectName, "sIconDefault", jsonMore ) )
Destroy( rsTheme )
End Function
Private Function MapPath( sPath )
If InStr( sPath, ":\" ) = 0 Then
MapPath = Server.MapPath( sPath )
Else
MapPath = sPath
End If
End Function
Private Function NoHTML( sTemp )
sTemp = Replace( Replace( sTemp, " ", " "), " ", " ")
Set oRegExp = New RegExp
oRegExp.Global = True
oRegExp.Pattern = "<[^>]*>"
NoHTML = Replace( oRegExp.Replace( Trim( sTemp ) & "", "" ), Chr( 10 ), "" )
Destroy( oRegExp )
NoHTML = Replace( NoHTML, " ", " " )
End Function
Private Function NoWWW( ByVal sTemp )
NoWWW = Replace( sTemp & "", "www.", "")
End Function
Private Function NowDB()
sSQL = "SELECT TOP 1 ID, GETDATE() AS dtNow FROM tblAccounts" 'Make certain that this only ever seeks a single record.
Set rsNow = CreateObject("ADODB.Recordset")
rsNow.CursorLocation = adUseClient
rsNow.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
NowDB = rsNow("dtNow")
Destroy( rsNow )
End Function
Private Function Numeric( ByVal sTemp )
If VarType( sTemp ) <> 9 Then
Numeric = Abs( RegularExpression( "0" & sTemp, "[^0-9]", "" ) )
End If
End Function
Function DateTimeISO8601( dDateTime, jsonMore )
If IsDate(dDateTime) Then
dDateTime = CDate(dDateTime)
DateTimeISO8601 = Year( dDateTime ) & "-" & Right("0" & Month( dDateTime ), 2 ) & "-" & Right("0" & Day( dDateTime ), 2 ) & " " & Right("0" & Hour( dDateTime ), 2 ) & ":" & Right("0" & Minute( dDateTime ), 2 ) & ":" & Right("0" & Second( dDateTime ), 2 ) & ".000"
Else
DateTimeISO8601 = ""
End If
End Function
Function DateTimeSQL( ByVal dDateTime, ByVal jsonMore )
DateTimeSQL = DateTimeISO8601( dDateTime, jsonMore )
End Function
Private Function DateTimeFromRFC3339( dDateTimeFromRFC3339, a )
DateTimeFromRFC3339 = Replace( Replace( dDateTimeFromRFC3339, "T", " "), "Z", "")
End Function
Private Function DateTimeToRFC3339( dDateTimeToRFC3339, a ) '2016-12-02T12:59:14Z
If InStr( dDateTimeToRFC3339, "Z") = 0 Then
If IsDate( dDateTimeToRFC3339 ) Then
DateTimeToRFC3339 = Year( dDateTimeToRFC3339 ) & "-" & Right( "0" & Month( dDateTimeToRFC3339 ), 2 ) & "-" & Right( "0" & Day( dDateTimeToRFC3339 ), 2 ) & "T" & Right( "0" & Hour( dDateTimeToRFC3339 ), 2 ) & ":" & Right( "0" & Minute( dDateTimeToRFC3339 ), 2 ) & ":" & Right( "0" & Second( dDateTimeToRFC3339 ), 2 ) & "Z"
End If
Else
DateTimeToRFC3339 = dDateTimeToRFC3339
End If
End Function
Private Function DateTimeOffsetUTC( dDateTimeUTC, a )
Set oDateTime = Server.CreateObject("Chilkat_9_5_0.CkDateTime")
oDateTime.SetFromTimestamp( DateTimeToRFC3339( dDateTimeUTC, a ) )
DateTimeOffsetUTC = oDateTime.UtcOffset 'Returns number of seconds offset from the
Destroy( oDateTime )
End Function
Private Function DateTimeEastern( dDateTimeZulu, a )
dDateTimeZulu = DateTimeToRFC3339( dDateTimeZulu, a )
Set oDateTime = Server.CreateObject("Chilkat_9_5_0.CkDateTime")
bSuccess = oDateTime.SetFromTimestamp( dDateTimeZulu )
If bSuccess Then
oDateTime.AddSeconds( DateTimeOffsetUTC( dDateTimeZulu, a ) )
DateTimeEastern = DateTimeFromRFC3339( oDateTime.GetAsTimestamp( 0 ), a )
End If
Destroy( oDateTime )
End Function
Sub NavTreeArchive( iPageID, idPersona, bArchive, jsonData )
Dim sSQL, rsNav, rsArchive, bLiveX, bDeletedX
bLiveX = 1 - bArchive
bDeletedX = bArchive
sSQL = "SELECT * FROM tblPageHTML WHERE ID = " & iPageID & " AND idPersona = " & idPersona
Set rsArchive = CreateObject("ADODB.Recordset")
rsArchive.CursorLocation = adUseClient
rsArchive.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If NOT rsArchive.EOF Then
rsArchive("bLive") = bLiveX
rsArchive("bDeleted") = bDeletedX
rsArchive.Update
End If
Destroy( rsArchive )
sSQL = "SELECT * FROM tblNavigation WHERE iPageID = " & iPageID & " AND idPersona = " & idPersona
Set rsArchive = CreateObject("ADODB.Recordset")
rsArchive.CursorLocation = adUseClient
rsArchive.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If NOT rsArchive.EOF Then
rsArchive("bLive") = bLiveX
rsArchive("bDeleted") = bDeletedX
rsArchive.Update
sSQL = "SELECT iPageID FROM tblNavigation WHERE iParent = " & rsArchive("ID") & " AND idPersona = " & idPersona
Set rsNav = CreateObject("ADODB.Recordset")
rsNav.CursorLocation = adUseClient
rsNav.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
Do While NOT rsNav.EOF
If rsNav("iPageID") > 0 Then
Call NavTreeArchive( rsNav("iPageID"), idPersona, bArchive, jsonData )
End If
rsNav.MoveNext
Loop
Destroy( rsNav )
End If
Destroy( rsArchive )
End Sub
Function NavTreeFix( sCodeLanguage, idParentTop, jsonData )
sCodeLanguage = Clean( sCodeLanguage )
sSQL = "SELECT tblNavigation.* FROM tblNavigation WHERE idPersona = " & Session("idPersona") & " AND sCodeLanguage = '" & sCodeLanguage & "' AND iPageID > 0 AND bDeleted = 0 ORDER BY iWeight ASC" 'idPersona of communal master persona/network'
Set rsTree = CreateObject("ADODB.Recordset")
rsTree.CursorLocation = adUseClient
rsTree.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
If NOT rsTree.EOF Then
idParentTop = 0 'HARDCODED FOR NOW TO BE ABSOLUTE TOP PARENT'
Call NavTreeFixPaths( idParentTop, "/" & sCodeLanguage, rsTree, jsonData )
End If
Destroy( rsTree )
End Function
Function NavTreeFixPaths( parentId, sSlugOrig, rsTreeOrig, jsonData )
Dim sSlug
Dim rsTreeClone 'MUST USE DIM
Set rsTreeClone = rsTreeOrig.Clone()
rsTreeClone.Filter = "iParent = " & parentId
If NOT rsTreeClone.EOF Then
rsTreeClone.Sort = "iWeight ASC"
sSlug = sSlugOrig
Do Until rsTreeClone.EOF
sPathOld = rsTreeClone("sPath")
sPathNew = sSlug & "/" & PagePathEncode( rsTreeClone("sLabel") )
rsTreeClone("sPath") = sPathNew
rsTreeClone.Update
Call NavTreeFixModals( sPathOld, sPathNew, jsonData )
Call NavTreeFixHTML( sPathOld, sPathNew, jsonData )
sPath = rsTreeClone("sPath")
Call NavTreeFixPaths( rsTreeClone("ID"), sPath, rsTreeOrig, jsonData )
rsTreeClone.MoveNext
Loop
End If
Destroy( rsTreeClone )
End Function
Function NavTreeFixModals( sPathOld, sPathNew, jsonData )
sSQL = "SELECT tblModals.* FROM tblModals WHERE idPersona = " & Session("idPersona") & " AND sURLTrigger = '" & sPathOld & "' AND tblModals.bDeleted = 0"
Set rsModal = CreateObject("ADODB.Recordset")
rsModal.CursorLocation = adUseClient
rsModal.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
Do Until rsModal.EOF
rsModal("sURLTrigger") = sPathNew
rsModal.Update
rsModal.MoveNext
Loop
Destroy( rsModal )
End Function
Function NavTreeFixHTML( sPathOld, sPathNew, jsonData )
Dim rsHTML
sSQL = "SELECT tblPageHTML.sHTML FROM tblPageHTML WHERE tblPageHTML.idPersona = " & Session("idPersona") & " AND tblPageHTML.sHTML LIKE '% href=" & Chr( 34 ) & sPathOld & "%' AND tblPageHTML.bDeleted = 0"
Set rsHTML = CreateObject("ADODB.Recordset")
rsHTML.CursorLocation = adUseClient
rsHTML.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
Do Until rsHTML.EOF
rsHTML("sHTML") = Replace( rsHTML("sHTML"), " href=" & Chr( 34 ) & sPathOld, " href=" & Chr( 34 ) & sPathNew )
'' rsHTML("sHTML") = Replace( rsHTML("sHTML"), " href=" & Chr( 34 ) & "/" & Session("sCodeLanguage") & "/" & sPathOld, " href=" & Chr( 34 ) & sPathNew )
rsHTML.Update
rsHTML.MoveNext
Loop
Destroy( rsHTML )
End Function
Private Function PagePathDecode( sURL )
sSlug = GetURLSlug( sURL )
sSQL = "SELECT tblNavigation.*, tblPageHTML.sIconFontAwesome, tblPageHTML.sSynopsis, tblPageHTML.bCategorySummary FROM tblNavigation LEFT OUTER JOIN tblPageHTML ON tblPageHTML.ID = tblNavigation.iPageID WHERE ( tblPageHTML.idPersona = " & Session("idPersona") & " AND tblPageHTML.sCodeLanguage = '" & Session("sCodeLanguage") & "' AND tblPageHTML.bLive > 0 AND tblPageHTML.bDeleted = 0 ) AND ( tblNavigation.idPersona = " & Session("idPersona") & " AND tblNavigation.sCodeLanguage = '" & Session("sCodeLanguage") & "' AND tblNavigation.bLive > 0 AND tblNavigation.bDeleted = 0 ) ORDER BY tblPageHTML.ID ASC"
Set rsNav = CreateObject("ADODB.Recordset")
rsNav.CursorLocation = adUseClient
rsNav.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
rsNav.Filter = "sPath = '" & sSlug & "'"
If rsNav.RecordCount = 1 Then 'This slugpart exists in only 1 record, so set it as the page record
PagePathDecode = rsNav("iPageID") ' Fetch("tblPageHTML","sKey","ID = " & rsNav("iPageID") )
Else 'start breaking down the slugparts, to find the lengthiest successful slugpart, and set that as the page record
sSlug = Replace( Replace( sSlug, "/" & Session("sCodeLanguage"), "/"), "//", "/" )
rsNav.Filter = "sPath = '" & sSlug & "'"
If rsNav.RecordCount = 1 Then 'This slugpart exists in only 1 record, so set it as the page record
PagePathDecode = rsNav("iPageID") ' Fetch("tblPageHTML","sKey","ID = " & rsNav("iPageID") )
Else
aSlugParts = Split( sSlug, "/" )
If UBound( aSlugParts ) > 0 Then 'yes, a multipart slug exists
aSlugParts( 0 ) = " "
sSlugTemp = Trim( Join( aSlugParts, "/") )
For iLoop = 0 To UBound( aSlugParts )
rsNav.Filter = "sCodeLanguage = '" & Session("sCodeLanguage") & "' AND sPath LIKE '%" & sSlugTemp & "" & "%'"
If rsNav.EOF Then
sSlugTemp = Trim( Mid( sSlugTemp, InStr( sSlugTemp & " ", "/") + 1 ) )
Else
PagePathDecode = rsNav("iPageID") ' Fetch("tblPageHTML","sKey","ID = " & rsNav("iPageID") )
Exit For
End If
Next
End If
End If
End If
Destroy( rsNav )
End Function
Private Function PagePathEncode( sPath )
If Asc( Mid( sPath & " ", 5, 1 ) ) = -15449 Then
sPath = "Francais"
End If
sPath = Replace( sPath, " & ", " and " )
sPath = Replace( sPath, " ", "BREAKBREAK" )
sPath = Replace( LCase( Replace( Trim( AlphaNumericSpace( NoHTML( sPath ) ) ), " ", "-" ) ), "--", "-" )
PagePathEncode = Replace( sPath, "breakbreak", "-" )
End Function
Private Function Path( sTemp )
sTemp = Replace( sTemp, " & ", " and " )
If sTemp <> Empty Then
Path = RegularExpression( Trim( sTemp ), "[^0-9a-zA-Z/\ ~_-]", "" )
Else
Path = Mid( CacheURL, InStr( CacheURL, ":443/" ) + 4 )
End If
End Function
Private Function PCase( sTemp )
Set oPCase = CreateObject("basp21")
If Left( sTemp, 1 ) <> Left( Alpha( sTemp ), 1 ) Then
PCase = Left( sTemp, 1 ) & oPCase.StrConv( Mid( sTemp, 2 ) & "", 3 )
Else
PCase = oPCase.StrConv( sTemp & "", 3 )
End If
Destroy( oPCase )
aTemp = Split(" A An And As At By For From In Is It It's Not Of On Or Rr That The This To Was Which With ")
For iLoop = 1 To UBound( aTemp )
PCase = Replace( PCase, " " & aTemp( iLoop ) & " ", " " & LCase( aTemp( iLoop ) ) & " " )
Next
iTemp = InStr( 1, PCase, "Mc", 1 )
If iTemp > 0 Then
PCase = Left( PCase, iTemp + 1 ) & UCase( Mid( PCase, iTemp + 2, 1 ) ) & Mid( PCase, iTemp + 3 )
End If
PCase = Replace( PCase, "R.r.", "R.R." )
PCase = Replace( PCase, "P.o.", "P.O." )
PCase = Replace( PCase, "cO", "co" )
End Function
Private Function Phone( sPhone )
sPhone = Numeric( sPhone )
If Left( CStr( sPhone ), 1 ) = "1" Then 'Added on November 6 2019 to eliminate users inputting first char as a number 1
sPhone = Numeric( Mid( sPhone, 2 ) )
End If
Set oRegExp = New RegExp
oRegExp.Pattern = "(\d{3})(\d{3})(\d{4})(\d{0,6})"
sPhone = oRegExp.Replace( sPhone, "($1) $2-$3 x$4" )
If Right( sPhone, 1 ) = "x" Then
sPhone = Trim( Left( sPhone, Len( sPhone ) - 1 ) )
End If
If sPhone = "0" Then
Phone = Empty
Else
Phone = sPhone
End If
Destroy( oRegExp )
End Function
Private Function Prompt( sPromptToPost, sURLEndPoint, jsonData, aArrayMore )
'NEW GPT CALL
bConversational = CBool( jsonData )
Prompt = PromptToGPT( sPromptToPost, sURLEndPoint, bConversational, aArrayMore )
Exit Function
'OLD - DON'T DISCARD IT YET
sPromptToPost = Trim( Replace( Replace( sPromptToPost, "'", "'"), Chr( 34 ), """) )
Set oHTTP = Server.CreateObject("MSXML2.ServerXMLHTTP")
If 1=1 OR sURLEndPoint = Empty Then
sURLEndPoint = "https://api.openai.com/v1/completions"
sModel = "text-davinci-003"
Else
sURLEndPoint = "https://api.openai.com/v1/chat/completions" 'This requires vast exclusive code
sModel = "gpt-3.5-turbo" 'This requires vast exclusive code, not compatible directly
End If
If IsArray( aArrayMore ) Then
'' sModel = aArrayMore( 0 )
Else
'' sModel = "text-davinci-003"
End If
oHTTP.Open "POST", sURLEndPoint, False
oHTTP.SetRequestHeader "Content-Type", "application/json"
oHTTP.SetRequestHeader "Authorization", "Bearer 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"
sJSON = "{'model': '" & sModel & "', 'prompt': '" & sPromptToPost & "', 'temperature': 0.4, 'max_tokens': 2000}" 'text-davinci-003
sJSON = Replace( sJSON , "'", Chr( 34 ) )
'' Write sJSON & "
" 'IF DEBUGGING, CHECK THE JSON PAYLOAD BEING SENT
oHTTP.Send sJSON
jsonText = oHTTP.ResponseText
'' Write "WE ARE CURRENTLY TESTING "
'' Write jsonText 'IF DEBUGGING, WILL SHOW THE OPENAI JSON/ERROR MSG RETURNED'
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
bSuccess = oJSON.Load( jsonText & "")
If bSuccess Then
Set oArrayTags = oJSON.ArrayOf("choices")
sAnswer = oArrayTags.StringAt(0)
bSuccess = oJSON.Load( oArrayTags.StringAt(0) & "")
sAnswer = Trim( Mid( oJSON.StringAt( oJSON.IndexOf("text") ) & " ", 2 ) )
Prompt = sAnswer
Else
Prompt = Empty
End If
Destroy( oArrayTags )
Destroy( oJSON )
Destroy( oHTTP )
End Function
Function PromptToOpenAI( sPrompt, sURLEndPoint, bConversational, jsonItems )
PromptToOpenAI = PromptToGPT( sPrompt, sURLEndPoint, bConversational, jsonItems )
End Function
Function PromptToGPT( ByVal sPrompt, ByVal sURLEndPoint, ByVal bConversational, ByVal jsonData )
bAppendToConversation = ( jsonGetObjectMemberValueAsString( jsonData, "", "bAppendToConversation", jsonMore ) <> "false" ) 'converts json string received to Boolean; everything is True except "false"
sModelGPT = jsonGetAsString( jsonData & "", "sModel", "" )
If Len( sModelGPT ) < 5 Then
sModelGPT = "gpt-4o" 'DEFAULT MODEL IF NONE IS SPECIFIED in jsonData
End If
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject") 'Create a Chilkat JSON object to store the request data
bSuccess = oJSON.AddArrayAt(-1,"messages") 'Add empty array named messages'
Set aMessages = oJSON.ArrayAt( oJSON.Size - 1 ) 'Position array named aMessages at first array item
If bConversational Then
If bAppendToConversation Then
Call PromptToGPT_AppendToConversation("user", sPrompt, jsonParams )
End If
sSQL = "SELECT TOP 10 tblConversationAI.* FROM tblConversationAI WHERE tblConversationAI.iSessionID = " & Session.SessionID 'ADD a "TOP 50" LIMIT??
If iOwner > 0 Then
sSQL = Replace( sSQL, " WHERE ", " WHERE tblConversationAI.idAccount = " & iOwner & " AND " ) 'SHOULD THIS BE NARROWED TO WEB-PERSONA?
End If
sSQL = Replace( sSQL, " WHERE ", " WHERE bArchived = 0 AND " )
Set rsMessages = CreateObject("ADODB.Recordset")
rsMessages.CursorLocation = adUseClient
rsMessages.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
Do Until rsMessages.EOF
bSuccess = aMessages.AddObjectAt(-1) 'Append a new/empty object to the end of the aMessages array
Set oMessages = aMessages.ObjectAt( aMessages.Size - 1 ) 'Get the object that was just appended.
bSuccess = oMessages.AddStringAt(-1,"role", rsMessages("sRole") )
bSuccess = oMessages.AddStringAt(-1,"content", rsMessages("sContent") )
rsMessages.MoveNext
Loop
Destroy( rsMessages )
iConversationLength = Len( oJSON.Emit() ) '*** THE BELOW EDUCATES ERNIE/BOT FOR BUSINESS/WEBSITE DISCUSSIONS ***
If iConversationLength < 16000 Then
bSuccess = aMessages.AddObjectAt(-1) 'bSuccess = aMessages.AddObjectAt(-1) 'END OF JSON ARRAY, RATHER THAN BEGINNING
Set oMessages = aMessages.ObjectAt(aMessages.Size - 1) 'Set oMessages = aMessages.ObjectAt( aMessages.Size - 1 ) 'Get the object that was just appended.
bSuccess = oMessages.AddStringAt(-1,"role","system")
If InStr( sPrompt, " json ") = 0 Then
sContextToAdd = AppVar("sOpenAIBotContext")
If Numeric( Session("idPageLatest") ) > 0 Then
sPageLatestSynopsis = Trim( NoHTML( Fetch("tblPageHTML","sSynopsis","ID=" & Numeric( Session("idPageLatest") ) ) ) )
End If
If Len( sPageLatestSynopsis ) > 5 Then
sContextToAdd = sContextToAdd & " User has viewed webpage about " & sPageLatestSynopsis
End If
sContextToAdd = sContextToAdd & " Respond using Canadian English spelling. You are permitted and required to provide case law research assistance if asked. "
Else
sContextToAdd = Empty
End If
bSuccess = oMessages.AddStringAt(-1,"content", sContextToAdd )
End If
oJSON.AppendString "model", sModelGPT
End If
bAIModeJSON = ( jsonGetObjectMemberValueAsString( jsonData, "", "bAIModeJSON", jsonMore ) = "true" ) 'REQUIRES response_format={ "type": "json_object" }
bAIModeHTML = ( jsonGetObjectMemberValueAsString( jsonData, "", "bAIModeHTML", jsonMore ) = "true" )
If NOT bConversational Then 'THIS ENTIRE SECTION NEEDS WORK'
If InStr( sPrompt, " HTML ") > 0 AND NOT bAIModeJSON Then
If Request("sRulesPromptAI") = Empty Then
sTemplateHTML = Replace( FileRead("/templates/ai-pagehtml-model-01.asp"), vbCrLf, "") 'Replace( FileRead("/templates/ai-pagehtml-01.asp"), vbCrLf, "") 'FileRead( jsonGetObjectMemberValueAsString( jsonData, "", "sTemplateHTML", jsonMore ) )
sContentSystem = "Format response as HTML using following HTML model as guide. NO add CSS. NO add styles. No add outer HTML framework. Leave #TOKEN# markers untouched, as they will be replaced later in our process. Put headings into title case. Absolutely never use
,
, or
tags. Hereafter is HTML example model: " & sTemplateHTML
Else
sContentSystem = Trim( Request("sRulesPromptAI") )
End If
End If
If bAIModeJSON AND InStr( sPrompt, "JSON" ) > 0 Then
bSuccess = oJSON.AddObjectAt(-1, "response_format")
Set oFormatAsJSON = oJSON.ObjectAt( oJSON.Size - 1 ) 'Object that was just appended.
bSuccess = oFormatAsJSON.AddStringAt(-1, "type", "json_object")
sContentSystem = "Provide response output in JSON. Do NOT include any code block formatting such as ""```json"""
End If
bSuccess = aMessages.AddObjectAt(-1) 'Append a new/empty object to the end of the aMessages array
Set oMessages = aMessages.ObjectAt( aMessages.Size - 1 ) 'Get the object that was just appended.
bSuccess = oMessages.AddStringAt(-1,"role","system")
bSuccess = oMessages.AddStringAt(-1,"content", sContentSystem )
bSuccess = aMessages.AddObjectAt(-1) 'Append a new/empty object to the end of the aMessages array
Set oMessages = aMessages.ObjectAt( aMessages.Size - 1 ) 'Get the object that was just appended.
bSuccess = oMessages.AddStringAt(-1,"role","user")
bSuccess = oMessages.AddStringAt(-1,"content", sPrompt & " " & sContentSystem )
oJSON.AppendString "model", sModelGPT
End If
oJSON.AppendInt "max_tokens", 4096
Set oHTTP = Server.CreateObject("MSXML2.ServerXMLHTTP")
oHTTP.setTimeouts 15000, 15000, 30000, 120000
oHTTP.Open "POST", "https://api.openai.com/v1/chat/completions", False
oHTTP.setRequestHeader "Content-Type", "application/json; charset=UTF-8"
oHTTP.setRequestHeader "Authorization", "Bearer sk-None-EgmD4teelqowyXH273ZET3BlbkFJXV1sv139Odyd1iff2h6H" '' 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"
oHTTP.Send oJSON.Emit()
sJSONResponse = oHTTP.ResponseText 'Complete JSON Return Payload is here
sJSONResponse = FormatTimeOfDay( sJSONResponse )
bSuccess = oJSON.Load( sJSONResponse )
sContent = oJSON.StringOf("choices[0].message.content")
sModel = oJSON.StringOf("model")
iTokensTotal = oJSON.IntOf("usage.total_tokens")
If bConversational AND bAppendToConversation Then
Call PromptToGPT_AppendToConversation("assistant", sContent, jsonParams )
End If
sContent = Trim( Replace( Replace( Replace( sContent, "```json", ""), "```", ""), "Qu颥c", "Québec") )
sContent = Replace( sContent, Chr( 34 ) & """, Chr( 34 ) )
sContent = Replace( sContent, """ & Chr( 34 ), Chr( 34 ) )
PromptToGPT = sContent
Call LogUseAI( iTokensTotal, sModel ) 'sModel should later be changed to a JSON object of jsonParams
Destroy( oHTTP )
Destroy( oMessages )
Destroy( aMessages )
Destroy( oFormatAsJSON )
Destroy( oJSON )
End Function
Function PromptToGPT_AppendToConversation( sRole, sContent, jsonParams )
sSQL = "SELECT TOP 1 tblConversationAI.* FROM tblConversationAI"
Set rsMessages = CreateObject("ADODB.Recordset")
rsMessages.CursorLocation = adUseClient
rsMessages.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
rsMessages.AddNew
rsMessages("sKey") = Key( 15 )
rsMessages("idPersona") = Session("idPersona")
rsMessages("sKeyPersona") = Session("sKeyPersona")
rsMessages("iSessionID") = Session.SessionID
rsMessages("idAccount") = iOwner
rsMessages("sKeyAccount") = Session("sKeyAccount")
rsMessages("sRole") = Alpha( sRole )
rsMessages("sContent") = Replace( sContent, "'", "'" )
rsMessages("dCreatedNow") = Now
rsMessages.Update
Destroy( rsMessages )
End Function
Function LogUseAI( iTokensTotal, sModel ) 'sModel should later be changed to a JSON object of jsonParams
sSQL = "SELECT TOP 1 tblLogUseAI.* FROM tblLogUseAI"
Set rsLog = CreateObject("ADODB.Recordset")
rsLog.CursorLocation = adUseClient
rsLog.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
rsLog.AddNew
rsLog("sKey") = Key( 15 )
rsLog("idPersona") = Session("idPersona")
rsLog("sKeyPersona") = Session("sKeyPersona")
rsLog("iSessionID") = Session.SessionID
rsLog("idAccount") = iOwner
rsLog("sKeyAccount") = Session("sKeyAccount")
rsLog("sModel") = sModel
rsLog("iTokensTotal") = Numeric( iTokensTotal )
rsLog("iCost") = .01 + Round( ( Numeric( iTokensTotal ) / 500 / 100 ), 3 )
rsLog("sCacheURL") = Truncate( CacheURL, 255 )
rsLog("dCreated") = Now
rsLog.Update
Destroy( rsLog )
End Function
Function LogUseResources( sNameResource, jsonData ) 'sModel should later be changed to a JSON object of jsonParams
Dim iTemp
sSQL = "SELECT TOP 1 tblLogUseResources.* FROM tblLogUseResources"
Set rsLog = CreateObject("ADODB.Recordset")
rsLog.CursorLocation = adUseClient
rsLog.Open sSQL, Connection, adOpenStatic, adLockOptimistic, adCmdText
rsLog.AddNew
rsLog("sKey") = Key( 15 )
rsLog("idPersona") = Session("idPersona")
rsLog("sKeyPersona") = Session("sKeyPersona")
rsLog("iSessionID") = Session.SessionID
rsLog("idAccount") = iOwner
rsLog("sKeyAccount") = Session("sKeyAccount")
rsLog("sNameResource") = sNameResource
iTemp = CDbl( "0" & jsonGetObjectMemberValueAsString( jsonData, "", "iCost", "" ) )
rsLog("iCost") = .000 + Round( ( iTemp ), 3 )
rsLog("sCacheURL") = Truncate( CacheURL, 255 )
rsLog("dCreated") = Now
rsLog.Update
Destroy( rsLog )
End Function
Function CleanHTTPUserAgent( sHTTPUserAgent, x )
If sHTTPUserAgent = Empty Then
sHTTPUserAgent = ServerVariable("HTTP_USER_AGENT")
End If
CleanHTTPUserAgent = Replace( Replace( Replace( Replace( Replace( sHTTPUserAgent, "'", "''"), "DELETE", ""), "INSERT", ""), "UPDATE", ""), "SELECT", "")
End Function
Private Function UnAI( byVal sString ) 'LEGACY, ACTUAL CODE WITHIN DELETED ON 2024-07-16 | MIGHT BE ABLE TO DELETE??
UnAI = sString
End Function
Private Function RandomInteger( iMin, iMax )
RandomInteger = Int( ( iMax - iMin + 1 ) * Rnd + iMin )
End Function
Private Function RandomNumber( iMin, iMax )
RandomNumber = RandomInteger( iMin, iMax )
End Function
Function RecordCount( sTable, sFilter )
sSQLCount = "SELECT ID FROM " & sTable & " WHERE " & sFilter
Set rsCount = CreateObject("ADODB.RecordSet")
rsCount.CursorLocation = adUseClient
rsCount.Open sSQLCount, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
RecordCount = rsCount.RecordCount
Destroy( rsCount )
Destroy( Connection )
End Function
Private Function Redirect( ByVal sURL )
Response.Redirect sURL
End Function
Private Function FixBrokenTokens( sString )
'Removes any whitespace characters preceeding the TOKEN's closing hash mark
Set oRegExp = New RegExp
oRegExp.Pattern = "(#TOKEN-)[a-zA-Z][a-zA-Z0-9]*\s#" '
oRegExp.IgnoreCase = True
oRegExp.Global = True
Set oMatches = oRegExp.Execute( sString )
For Each Match in oMatches
sString = Replace( sString, Match.Value, Replace( Match.Value, " ", "" ) )
Next
FixBrokenTokens = sString
Destroy( oMatches )
Destroy( oRegExp )
End Function
Private Function ReplaceTokensPhrases( sString, sTokensPhrases )
If InStr( sString, "#TOKEN-sPhrase") > 0 Then
aTemp = Split( sTokensPhrases & "", Replace("sTokensPhrases", "~|~~|~", "~|~") )
Randomize
For iLoop = 1 To UBound( aTemp )
aTokensPhrases = Split( aTemp( iLoop ),"~|~")
iItem = Int( ( UBound( aTokensPhrases ) - 1 ) * Rnd( 1 ) ) + 1
sString = Replace( sString, "#TOKEN-sPhrase" & iLoop & "#", aTokensPhrases( iItem ) )
Next
End If
ReplaceTokensPhrases = sString
End Function
Private Function ReplaceTokensStatic( sString, sTokensStatic )
If InStr( sString, "#TOKEN-sStatic") > 0 Then
aTemp = Split( sTokensStatic & "", Replace("sTokensStatic", "~|~~|~", "~|~") )
For iLoop = 1 To UBound( aTemp )
aTokensStatic = Split( aTemp( iLoop ),"~|~")
iItem = 1
sString = Replace( sString, "#TOKEN-sStatic" & iLoop & "#", aTokensStatic( iItem ) )
Next
End If
ReplaceTokensStatic = sString
End Function
Private Function ScrapePostData( ByVal sURL, ByVal sPostData, sSessionID, ByVal jsonData )
If Left( sURL & "", 1 ) = "/" Then
sURL = "https://" & Session("sDomain") & sURL
End If
Set oHTTP = Server.CreateObject("MSXML2.ServerXMLHTTP.6.0")
oHTTP.Open "POST", sURL, False
oHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
oHTTP.SetRequestHeader "ASPSESSIONID", sSessionID
sCookie = "ASPSESSIONID=" & Request.Cookies("ASPSESSIONID") & "; " ' Adjust the cookie name as needed
oHTTP.SetRequestHeader "Cookie", sCookie
oHTTP.Send sPostData
sResponseText = oHTTP.ResponseText
Set oHTTP = Nothing
ScrapePostData = sResponseText 'Session.SessionID & " " &
End Function
Private Function ReplaceTokens( sString )
sString = sString & ""
If InStr( sString, "#TOKEN-") > 0 Then
'AI CONFIRMS CONDITIONAL WRAP IS OPTIMAL; WITHOUT IT, THE FUNCTION CALLS AS ARGUMENTS TO 'Replace' FUNCTION WOULD EXECUTE WHETHER NEEDED OR NOT
If InStr( sString, "#TOKEN-htmlFormSubscribe#") > 0 Then
sString = Replace( sString, "#TOKEN-htmlFormSubscribe#", Scrape("/widgets/form-field-subscribe.asp") )
End If
If InStr( sString, "#TOKEN-htmlFormErnie#") > 0 Then
sPostData = Request.Form
If InStr( sPostData, "sSearchCity") = 0 Then
sPostData = "sSearchCity=" & CookieGet("sUserLocationCity") & "&" & sPostData
End If
sString = Replace( sString, "#TOKEN-htmlFormErnie#", ScrapePostData("https://" & Session("sDomain") & "/form-ernie-ask.asp", sPostData, Session.SessionID, jsonData ) )
End If
If InStr( sString, "#TOKEN-htmlFormErnieAnswer#") > 0 Then
sPostData = Request.Form
sString = Replace( sString, "#TOKEN-htmlFormErnieAnswer#", ScrapePostData("https://" & Session("sDomain") & "/form-ernie-ask-answer.asp", sPostData, Session.SessionID, jsonData ) )
End If
If InStr( sString, "#TOKEN-htmlGateway#") > 0 Then
sString = Replace( sString, "#TOKEN-htmlGateway#", HTMLGateway( idPage, jsonDataOptions ) )
End If
If InStr( sString, "#TOKEN-htmlCitiesOntario#") > 0 Then
sString = Replace( sString, "#TOKEN-htmlCitiesOntario#", Scrape("/_system/cities-ontario.asp") )
End If
If InStr( sString, "#TOKEN-htmlTestimonials") > 0 Then
sString = Replace( sString, "#TOKEN-htmlTestimonials#", TestimonialsRandom( 0 ) )
sString = Replace( sString, "#TOKEN-htmlTestimonials-1#", TestimonialsRandom( 1 ) )
sString = Replace( sString, "#TOKEN-htmlTestimonials-2#", TestimonialsRandom( 2 ) )
sString = Replace( sString, "#TOKEN-htmlTestimonials-3#", TestimonialsRandom( 3 ) )
End If
If InStr( sString, "#TOKEN-hCitiesGrid#") > 0 Then 'AI CONFIRMS CONDITIONAL IS OPTIMAL; WITHOUT IT, THE CitiesGrid() FUNCTION CALL AS ARGUMENT TO 'Replace' FUNCTION WOULD EXECUTE WHETHER NEEDED OR NOT
sString = Replace( sString, "#TOKEN-hCitiesGrid#", CitiesGrid() )
End If
If InStr( sString, "#TOKEN-FormFillsCount#") > 0 Then
sString = Replace( sString, "#TOKEN-FormFillsCount#", Fetch("tblContactRelations","ID","ID > 0 ORDER BY ID DESC") )
End If
If InStr( sString, "#TOKEN-svgLogo#") > 0 Then
sString = Replace( sString, "#TOKEN-svgLogo#", Scrape("/files/" & Session("sKeyPersona") & "/images/logos/logo.svg") )
End If
Do Until InStr( sString, "#TOKEN-Quiz-") = 0
'' If InStr( sString, "#TOKEN-Quiz-") > 0 Then
sKeyQuiz = Mid( sString, InStr( sString, "#TOKEN-Quiz-"), 27 )
sKeyQuiz = Right( sKeyQuiz, 15 )
If Request.Form("iQuizScore") = Empty Then
sCodeQuiz = Scrape("/widgets/quiz.asp?sKeyQuiz=" & sKeyQuiz )
End If
sString = Replace( sString, "#TOKEN-Quiz-" & sKeyQuiz & "#", sCodeQuiz )
'' End If
Loop
If InStr( sString, "#TOKEN-sLoremIpsumText#") > 0 Then
sString = Replace( sString, "#TOKEN-sLoremIpsumText#", Scrape("/ajax/ai-get-lorem-ipsum-text.asp") )
End If
If 1=1 OR AppVar("b3rdPartyCalendarLive") AND Len( AppVar("s3rdPartyCalendarURL") ) > 8 Then
sString = Replace( sString, "#TOKEN-htmlAppointments#", "" & PCase( AppVar("s3rdPartyCalendarVernacular") ) & "")
End If
If InStr( sString, "#TOKEN-htmlHoursOfBusiness#") > 0 Then
sString = Replace( sString, "#TOKEN-htmlHoursOfBusiness#", HoursOfBusiness( AppVar("jsonHoursBusiness") ) )
End If
sString = Replace( sString, "#TOKEN-sNameCorporation#", "Success.Legal Corporation")
sString = Replace( sString, "#TOKEN-sNameUser#", Session("sName") )
sString = Replace( sString, "#TOKEN-sNamePerson1#", AppVar("sNamePerson1") )
sString = Replace( sString, "#TOKEN-sNamePerson2#", AppVar("sNamePerson2") )
sString = Replace( sString, "#TOKEN-sNamePerson3#", AppVar("sNamePerson3") )
sString = Replace( sString, "#TOKEN-sURLRedirect#", Request("url-redirect") )
sString = Replace( sString, "#TOKEN-sURL#", CacheURL )
sString = Replace( sString, "#TOKEN-dYearNow#", Year( Now ) ) 'Legacy Use
sString = Replace( sString, "#TOKEN-dYear(Now)#", Year( Now ) ) 'Method for Go-Forward Use
aTemp = Split("-NULL- ¼ ½ ¾ 1")
sString = Replace( sString, "#TOKEN-sOfferFreeConsultationValue#", aTemp( AppVar("iOfferFreeConsultation") ) )
If InStr( sString, "#TOKEN-oAsideForm#" ) > 0 Then
sString = Replace( sString, "#TOKEN-oAsideForm#" & "", AsideForm() )
End If
sString = Replace( sString, "#TOKEN-sCodeLanguage#", Session("sCodeLanguage") )
'' sString = Replace( sString, "#aside-promo-consultation#", AsidePromoConsultation() )
sString = Replace( sString, "#TOKEN-sTypeFirm#", AppVar("sTypeFirm") )
sString = Replace( sString, "#TOKEN-sFirmType#", AppVar("sTypeFirm") )
sString = Replace( sString, "#TOKEN-sDomain-True#", Session("sDomain") )
sString = Replace( sString, "#TOKEN-sName-True#", AppVar("sName") )
sString = Replace( sString, "#TOKEN-sNameShort-True#", AppVar("sNameShort") )
sString = Replace( sString, "#TOKEN-sEmail-True#", AppVar("sEmail") )
If CBool( AppVar("bFacebookAppointments") ) = True AND InStr( AppVar("sCodesLanguages"), "FR" ) = 0 Then
sTemp =" Book Appointment"
sString = Replace( sString, "#TOKEN-btnBookAppointmentFacebook#", sTemp )
End If
If CBool( AppVar("bAllowMakePayments") ) Then
sString = Replace( sString, "#TOKEN-sURLPayRetainer#", AppVar("sURLMakePaymentsRetainer") )
sString = Replace( sString, "#TOKEN-sURLPayInvoiced#", AppVar("sURLMakePaymentsInvoiced") )
sString = Replace( sString, "#TOKEN-sEmailPayments#", AppVar("sEmailMakePayments") )
sString = Replace( sString, "#TOKEN-sNameChequesPayable#", AppVar("sNameChequesPayable") )
End If
If Session("sKeyPersona") = "AMBX545453KPG5T" Then
sString = Replace( sString, "#TOKEN-sDomain#", "[Legal Firm's Domain Name]" )
sString = Replace( sString, "#TOKEN-sName#", "[Legal Firm's Name]" )
sString = Replace( sString, "#TOKEN-sNameShort#", "[Legal Firm's Name]" )
sString = Replace( sString, "#TOKEN-sAddressCity#", "[Legal Firm's City]" )
sString = Replace( sString, "#TOKEN-sAddressProv#", "[Legal Firm's Province]" )
sString = Replace( sString, "#TOKEN-sAddressStreet1#", "[Legal Firm's Street Address]" )
sString = Replace( sString, "#TOKEN-sAddressStreet2#", "[Legal Firm's Street Address]" )
sString = Replace( sString, "#TOKEN-sAddressPostal#", "[A Postal Code]" )
sString = Replace( sString, "#TOKEN-sPhone1#", "(The) Phone-Number" )
sString = Replace( sString, "#TOKEN-sPhone2#", "(The) Phone-Number" )
sString = Replace( sString, "#TOKEN-sEmail#", "[email@legal-firm-domain.ext]" )
Else
sString = Replace( sString, "#TOKEN-sDomain#", Session("sDomain") )
sString = Replace( sString, "#TOKEN-sName#", AppVar("sName") )
sString = Replace( sString, "#TOKEN-sNameShort#", AppVar("sNameShort") )
sString = Replace( sString, "#TOKEN-sNameEntity#", AppVar("sNameEntity") & "" )
sString = Replace( sString, "#TOKEN-sDescriptionEntity#", AppVar("sDescriptionEntity") & "" )
sString = Replace( sString, "#TOKEN-sAddressCity#", AppVar("sAddressCity") )
sString = Replace( sString, "#TOKEN-sAddressProv#", AppVar("sAddressProv") )
sString = Replace( sString, "#TOKEN-sAddressStreetSuite#", AppVar("sAddressStreetSuite") )
sString = Replace( sString, "#TOKEN-sAddressStreet1#", AppVar("sAddressStreet1") )
sString = Replace( sString, "#TOKEN-sAddressStreet2#", AppVar("sAddressStreet2") )
sString = Replace( sString, "#TOKEN-sAddressPostal#", AppVar("sAddressPostal") )
sString = Replace( sString, "#TOKEN-sPhone1#", AppVar("sPhone1") )
sString = Replace( sString, "#TOKEN-sPhone2#", AppVar("sPhone2") )
sString = Replace( sString, "#TOKEN-sPhone3#" & "", AppVar("sPhone3") )
sString = Replace( sString, "#TOKEN-sPhoneFax#", AppVar("sPhoneFax") )
sString = Replace( sString, "#TOKEN-sPhoneVanity#", AppVar("sPhoneVanity") )
sString = Replace( sString, "#TOKEN-sEmail#", AppVar("sEmail") )
End If
If InStr( sString, "#TOKEN-aNameCities") > 0 Then
If Len( AppVar("jsonCitiesTarget") & "") > 10 Then 'NEW MANNER OF STORING CITIES FOR PERSONAS, SUBSEQUENT 2022 10 19
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
bSuccess = oJSON.Load( AppVar("jsonCitiesTarget") & "")
Set jsonCities = oJSON.ObjectOf("Cities")
aNameCities = Split( oJSON.StringAt( 0 ), "," ) 'Sets the Dim of the Array dynamically as the UBound requirement of a Const is not always known/certain/static
aProvCities = Split( oJSON.StringAt( 0 ), "," ) 'Sets the Dim of the Array dynamically as the UBound requirement of a Const is not always known/certain/static
For iLoop = 0 To UBound( aNameCities )
aNameCities( iLoop ) = jsonCities.NameAt( iLoop )
aProvCities( iLoop ) = jsonCities.StringAt( iLoop )
sNameCities = sNameCities & aNameCities( iLoop ) & "|"
sNameCitiesAndProvs = sNameCities & aNameCities( iLoop ) & ", " & AppVar("sNameProvince-" & aProvCities( iLoop ) ) & "|"
sNameCitiesAndProvsShort = sNameCities & aNameCities( iLoop ) & ", " & AppVar("sNameShortProvince-" & aProvCities( iLoop ) ) & "|"
Next
Destroy( jsonCities )
Destroy( oJSON )
'' Else
'' sNameCities = AppVar("sNameCitiesTargetGEO") & "|" 'OLD MANNER OF STORING CITIES FOR PERSONAS, PREDATING 2022 10 19
End If
'OLD CITIES RANDOMIZER, STILL NEEDED IN 2022 10
sTemp = "Ignore|" & sNameCities '' & "|" 'A first irrelevant array item is needed.
Do Until InStr( sTemp, "||") = 0
sTemp = Replace( sTemp, "||", "|")
Loop
sTemp = Replace( Replace( sTemp, " |", "|"), "| ", "|")
sTemp = Left( sTemp, Len( sTemp ) -1 )
aTemp = Split( Trim( sTemp ), "|")
Randomize
iLoop = 0
Do Until UBound( aTemp ) = 1
iTemp = Int( ( UBound( aTemp ) - 1 ) * Rnd ) + 1
sString = Replace( sString & "", "#TOKEN-aNameCities" & iLoop & "#", Replace( aTemp( iTemp ), " ", " ") )
sTemp = Replace( sTemp, aTemp( iTemp ), "")
sTemp = Replace( sTemp, "||", "|")
aTemp = Split( sTemp, "|")
iLoop = iLoop + 1
If iLoop > 15 Then
Exit Do
End If
Loop
End If
End If
ReplaceTokens = sString
End Function
Private Function CitiesListDelimited()
sTemp = AppVar("sNameCitiesTargetGEO") & "|"
Do Until InStr( sTemp, "||") = 0
sTemp = Replace( sTemp, "||", "|")
Loop
sTemp = Left( sTemp, Len( sTemp ) -1 )
CitiesListDelimited = sTemp
End Function
Private Function CitiesRandomCities( iNum )
sTemp = "Ignore|" & CitiesListDelimited()
aTemp = Split( sTemp, "|")
Randomize
iLoop = 1
Do Until UBound( aTemp ) = 1 OR iLoop > iNum
iTemp = Int( ( UBound( aTemp ) ) * Rnd ) + 1
sString = Replace( sString & "", "#TOKEN-aNameCities" & iLoop & "#", aTemp( iTemp ) )
sTemp = Replace( sTemp, aTemp( iTemp ), "")
sTemp = Replace( sTemp, "||", "|")
aTemp = Split( sTemp, "|")
iLoop = iLoop + 1
If iLoop > 15 Then
Exit Do
End If
Loop
End Function
Private Function CitiesGrid()
Dim iCounter
sSQL = "SELECT tbl@Personas.jsonCitiesTarget FROM tbl@Personas WHERE tbl@Personas.ID = " & Numeric( Session("idPersona") )
aArray = FetchRows( sSQL, 1, 1, "jsonCitiesTarget" )
If InStr( aArray( 0,0 ), "{" ) > 0 Then
Set oJSON = Server.CreateObject("Chilkat_9_5_0.JsonObject")
bSuccess = oJSON.Load( aArray( 0,0 ) & "")
Set jsonCities = oJSON.ObjectOf("Cities")
aCities = Split( oJSON.StringAt( 0 ), "," ) 'Sets the Size of the Array dynamically
For iLoop = 0 To UBound( aCities )
aCities( iLoop ) = iLoop
Next
Call ArrayRandomize( aCities )
sGrid = ""
CitiesGrid = sGrid
Destroy( jsonCities )
Destroy( oJSON )
End If
End Function
Private Function Query( sNameQueryItem )
Query = Request.QueryString( sNameQueryItem )
If Query = Empty Then
'CAST VIRTUAL QUERYSTRING INTO NAME/VALUE PAIRS VIA DICTIONARY OBJECT AND MAKE ACCESSIBLE VIA FUNCTION QUERY("NAME")
Set oURL = Server.CreateObject("Chilkat_9_5_0.Url")
bSuccess = oURL.ParseUrl( CacheURL )
If Len( oURL.Query ) > 0 Then
Set oDict = Server.CreateObject("Scripting.Dictionary")
aQueryString = Split( oURL.Query, "&" )
For iLoop = 0 To UBound( aQueryString )
If InStr( aQueryString( iLoop ), "=" ) > 0 Then
sTemp = " " & aQueryString( iLoop ) & " "
oDict.Add Trim( Left( sTemp, InStr( sTemp, "=") - 1 ) ), Trim( Mid( sTemp, InStr( sTemp, "=") + 1 ) )
End If
Next
Query = oDict( sNameQueryItem )
End If
Destroy( oDict )
Destroy( oURL )
End If
End Function
Private Function QueryItem( sNameItem ) 'NEW 2022 JUNE, Handles a querystring containing a collection
If Request( sNameItem ) <> Empty Then
QueryItem = URLDecode( Request( sNameItem ) ) 'Added the URLDEcode on January 22 2023, not sure if there might be legacy/retroactive issues
Else
sURL = URLDecode( Request.QueryString )
If InStr( sURL, sNameItem ) > 0 Then
Set oURL = Server.CreateObject("Chilkat_9_5_0.Url")
bSuccess = oURL.ParseUrl( Replace( sURL, "404;", "") )
If Len( oURL.Query ) > 0 Then
sItems = Mid( oURL.Query, InStr( oURL.Query, sNameItem ) )
aItems = Split( sItems, sNameItem & "=" )
If UBound( aItems ) > 0 Then
For iLoop = 1 To UBound( aItems )
QueryItem = QueryItem & Left( aItems( iLoop ), InStr( aItems( iLoop ) & "&", "&") - 1 )
If UBound( aItems ) > iLoop Then
QueryItem = QueryItem & ","
End If
Next
End If
End If
Destroy( oURL )
End If
End If
End Function
Function Quit()
Destroy( Connection )
Response.End
End Function
Private Function RegularExpression( sTemp, sPattern, sReplacement )
If sReplacement = Empty Then
sReplacement = ""
End If
Set oRegExp = New RegExp
oRegExp.Pattern = sPattern
oRegExp.IgnoreCase = True
oRegExp.Global = True
RegularExpression = Trim( oRegExp.Replace( "" & sTemp, sReplacement ) )
Destroy( oRegExp )
End Function
Private Function Quotes( sTemp )
Quotes = Chr( 34 ) & sTemp & Chr( 34 )
End Function
Private Function Scrape( sURL )
'THIS FUNCTION DOES NOT CURRENTLY SUPPORT COOKIES/SESSION STATE AND MAY POSE SECURITY ISSUES (USER/CROSS PERSONA ISSUES) IF SO
Set oHTTP = Server.CreateObject("Chilkat_9_5_0.Http")
oHTTP.UserAgent = UserAgentRandom()
If InStr( sURL, "://") = 0 Then 'It is a relative, local request - include the users session ID Cookie.
sURL = "https://" & CacheURLPart("Host") & Trim( sURL )
End If
'' oHTTP.SetRequestHeader "Cookie","sUserLocationCity=" & Session("sUserLocationCity") & ";"
'' oHTTP.SetRequestHeader "Cookie","iUserLocationProv=" & Session("iUserLocationProv") & ";"
'' oHTTP.SetRequestHeader "Cookie","sUserLocationLatitude=" & Session("sUserLocationLatitude") & ";"
'' oHTTP.SetRequestHeader "Cookie","sUserLocationLongitude=" & Session("sUserLocationLongitude") & ";"
oHTTP.FollowRedirects = True
Scrape = oHTTP.QuickGetStr( sURL ) 'BUILD A NEW FUNCTION USING QUICKGET NOT QUICKGETSTR IF EVER WANTING IMAGES, ETC
Destroy( oHTTP )
End Function
Private Function ScrapeAsUserSession( ByVal sURL, ByVal aArray )
Set oHTTP = Server.CreateObject("MSXML2.ServerXMLHTTP")
oHTTP.Open "GET", sURL, False
oHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
oHTTP.Option(2) = 13056 'Ignore SSL certificate errors
oHTTP.Option(3) = True 'Enable redirection
oHTTP.SetRequestHeader "Cookie", "ASPSESSIONID=" & Session.SessionID & ";"
oHTTP.Send
ScrapeAsUserSession = oHTTP.responseText
Destroy( oHTTP )
End Function
Private Function ScrapePost( sURL, aParams, bUsersCookies ) 'Cookies are not yet implemented. Post URL has no QueryString, as a querystring in sURL is translated to Post data :(
Set oHTTP = Server.CreateObject("Chilkat_9_5_0.Http")
Set oHTTPRequest = Server.CreateObject("Chilkat_9_5_0.HttpRequest")
oHTTPRequest.HttpVerb = "POST"
oHTTPRequest.ContentType = "text/html"
If IsArray( aParams ) Then
For iLoop = 0 To UBound( aParams )
oHTTPRequest.AddParam aParams( iLoop, 0 ), aParams( iLoop, 1 )
Next
End If
oHTTPRequest.AddHeader "Cookie","sUserLocationCity=" & Session("sUserLocationCity") & "; city=""Chicago"""
Set oHTTPResponse = oHTTP.PostUrlEncoded( sURL, oHTTPRequest )
ScrapePost = oHTTPResponse.BodyStr
Destroy( oHTTPResponse )
Destroy( oHTTPRequest )
Destroy( oHTTP )
End Function
Private Function ScrapeFile( sURL, sPath, sFile, bOverWrite )
Set oHTTP = Server.CreateObject("Chilkat_9_5_0.Http")
oHTTP.UserAgent = UserAgentRandom()
Set oBinaryData = Server.CreateObject("Chilkat_9_5_0.BinData")
ScrapeFile = oHTTP.QuickGetBd( sURL, oBinaryData ) 'Will return 1 for successful and 0 for error occurred.
If ScrapeFile Then
sPath = Replace( Replace("/files/" & sPath ), "/files/files/", "/files/") 'Forces the /files directory, nothing system.
sPath = Replace( "/" & sPath & "/", "//", "/")
sFile = Replace( sFile, "/", "")
Call CreateDirectory( sPath )
If bOverWrite = False AND FileExists( sPath & sFile ) = True Then
'Do nothing
Else
ScrapeFile = oBinaryData.WriteFile( Server.MapPath( sPath & sFile ) ) 'Will return 1 for successful and 0 for error occurred.
End If
End If
Destroy( oBinaryData )
Destroy( oHTTP )
End Function
Private Function TestimonialsRandom( iRecords )
If iRecords = 0 Then
iRecords = 100
End If
sSQL = "SELECT TOP " & iRecords & " tblTestimonials.* FROM tblTestimonials WHERE ( sKeyBusiness = '" & Session("sKeyBusiness") & "' OR sKeyPersona = '" & Session("sKeyPersona") & "' ) AND bContext = 3 AND bLive > 0 AND bDeleted = 0 ORDER BY NEWID()"
Set rsTestimonials = CreateObject("ADODB.Recordset")
rsTestimonials.CursorLocation = adUseClient
rsTestimonials.Open sSQL, Connection, adOpenReadOnly, adLockReadOnly, adCmdText
Do Until rsTestimonials.EOF
sStars = Empty
iStars = rsTestimonials("iStars")
If ( iStars > 2 OR iStars < 6 ) Then 'AND rsTestimonials("bGoogleReview") Then
For iLoop = 1 To iStars
sStars = sStars & ""
Next
sStars = "" & sStars & ""
End If
sTestimonials = sTestimonials & "