File: D:/web/secure/itpplates/admin/apputils - Copy (3).asp
<%
' ============
' apputils.asp
' ============
' Version 1.05 (05/04/22)
' ============
' HISTORY
' ============
' (SS,24/07/20) first version for ITP Plates
' (SS,20/08/20) changed to Sub ShowLicences to not show Cancelled licence, new Cancelled and Notes fields added to licences table.
' (SS,04/03/21) fixed duplicates being created this redirect (Post/Redirect/Get)
' see as mentioned here:https://en.wikipedia.org/wiki/Post/Redirect/Get
' And here: https://www.seobility.net/en/wiki/Post/Redirect/Get
' Another solution is by using window.history.replaceState (see https://stackoverflow.com/questions/6320113/how-to-prevent-form-resubmission-when-page-is-refreshed-f5-ctrlr)
' Used redirect because it's preferred
' (SS,28/05/21) modified to allow expiry date to be set and also new edit modal
' (SS,23/06/21) experience duplicate key issue, due to VB/ASP routine Randomize not being random enough
' fixed by replacing with new functions that use MySQL's RAND() function
' New functions GetRandomKeyMySQL Function RandomIntegerMySQL
' Change to Function CreateNewLicence to call GetRandomKeyMySQL instead of GetRandomKey
' (SS,05/04/22) Added new Function JSEscapeSingleQuote to fix Renew and Edit buttons not working when company name contains a single quote (')
' ============'
' global constants and variables '
' (SS,23/3/05) '
Dim NL
NL = Chr(13) + Chr(10)
' main variables '
Dim FSessionID
Dim strCommand
Dim gsITP_ErrorMessage ' error message passed back to browser using javascript '
' (SS,20/2/14) used to hold message shown on popup
Dim FPopUpMessage
Initialise
' (SS,30/8/04) runs code to be run before all templates
Sub Initialise
gsITP_ErrorMessage = ""
FPopUpMessage = "" ' (SS,20/2/14)
OpenDatabase ' close is done in Finalise sub
' following before if below, to allow sign to show immediately after sign out
If SignOutRequested Then SignOut
' if not already authenticated then process the authenticated if applicable
If Not IsAuthenticated Then Authenticate
FSessionID = Session.SessionID
End Sub
' to allow items to be added at the start of the head tag, call to HTMLHeadStart needs to in the correct place in main template
' DisableCache moved here and call to DisableCache in inc-template-main.asp replaced with HTMLHeadStart
Sub HTMLHeadStart
DisableCache
End Sub
' to allow items to be added just before the end of the head tag, call to HTMLHeadStart needs to in the correct place in main template
' good place for tracking code
Sub HTMLHeadEnd
End Sub
' called from end of inc-template-main.asp
Sub Finalise
CloseDatabase
ShowAlertMessage
ShowPopUpMessage
FinaliseDBFunctions
End Sub
' new simpler finalise especially for Ajax, which doesn't have analytics, redirection, alerts, and timer
Sub FinaliseAjax
CloseDatabase
FinaliseDBFunctions
End Sub
Function IsAuthenticated
IsAuthenticated = Session("Authenticated")
End Function
Sub Authenticate
' if not authenticated then email and password specified then try to authenticate
If Not Session("Authenticated") Then
Dim LEmail, LPassword, LResellerID
LEmail = Trim(Request("Email"))
LPassword = Trim(Request("Password"))
If LEmail <> "" And LPassword <> "" Then
'Response.Write "Email: " & Request("Email") & BR
'Response.Write "Password: " & Request("Password") & BR
' check if valid, and password is assigned i.e. not null or blank
LResellerID = GetSQLValueAsString("SELECT ResellerID FROM resellers WHERE EmailAddress = '" & CleanSQLStr(LEmail) & "' AND Password = '" & CleanSQLStr(LPassword) & "' AND COALESCE(Password, '') <> ''")
If LResellerID <> "" Then
SetResellerID LResellerID
Session("Authenticated") = True
LogSignIn
Else
SetAlertMessage "Email and/or password is invalid"
End If
End If
End If
End Sub
Function SignOutRequested
SignOutRequested = Request("cmd") = "signout"
End Function
Sub SignOut
Session("Authenticated") = False
Session("ResellerID") = ""
End Sub
' (SS,30/7/20)
Sub LogSignIn
Dim LSQL
LSQL = "INSERT INTO signin_log SET" &_
" ResellerID = '" & CleanSQLStr(GetResellerID) & "'" &_
", ResellerName = '" & CleanSQLStr(GetResellerField("ResellerName")) & "'" &_
", SignInDateTime = NOW()" &_
", IPAddress = '" & Request.ServerVariables("REMOTE_ADDR") & "'" &_
", SessionID = '" & Session.SessionID & "'"
ExecuteQuery(LSQL)
End Sub
Sub SetResellerID(AResellerID)
Session("ResellerID") = CLng(AResellerID)
End Sub
Function GetResellerID
GetResellerID = Session("ResellerID")
End Function
' (SS,27/7/20)
Function GetResellerField(AFieldName)
GetResellerField = GetSQLValueAsString("SELECT " & AFieldName & " FROM resellers WHERE ResellerID = '" & CleanSQLStr(GetResellerID) & "'")
End Function
' (SS,28/7/20)
Function GetLicenceField(ALicenceID, AFieldName)
GetLicenceField = GetSQLValueAsString("SELECT " & AFieldName & " FROM licences WHERE LicenceID = '" & CleanSQLStr(ALicenceID) & "'")
End Function
' (SS,10/6/07) *** followings settings to be held in a common database
Function GetMailServer(AServerNo)
If AServerNo = 1 Then
GetMailServer = "mail.itpartnership.com"
ElseIf AServerNo = 2 Then
GetMailServer = "mail.ontheworldweb.com"
Else
GetMailServer = ""
End If
End Function
' (SS,6/6/07) returns name of current script file, in most cases this will be products.asp
' but could also be worldpay-callback.asp etc
Function GetScriptName
Dim LScriptName
LScriptName = LCase(Request.ServerVariables("SCRIPT_NAME"))
If Left(LScriptName, 1) = "/" Then LScriptName = Mid(LScriptName, 2, Len(LScriptName) - 1)
GetScriptName = LScriptName
End Function
' (SS,28/11/13) returns true if on home page
Function IsHomePage
Dim LPageName
LPageName = LCase(CleanRequestQueryString("page"))
IsHomePage = LPageName = "home" Or (LPageName = "" And CleanRequestQueryString("cmd") = "" And GetProductCodeQS = "" And CleanRequestQueryString("cat") = "" And CleanRequestQueryString("grp") = "")
End Function
' (SS,23/8/17) new version which now calls SendEmailByCDO instead of SendEmailByDundas, previous SendMail renamed to SendEmailByDundas
Function SendEmail(AEmailAddress, ABCCEmailAddress, ABCCEmailAddress2, AFromEmailAddress, ASubject, ABody, AIsHTML)
SendEmail = SendEmailByCDO(AEmailAddress, ABCCEmailAddress, ABCCEmailAddress2, AFromEmailAddress, ASubject, ABody, "", AIsHTML, "", "")
End Function
' (SS,10/6/06) send email using CDO, returns False if there was a failure
' (SS,28/9/12) added AEmbeddedImage to allow image to be embedded inside the email
Function SendEmailByCDO(ATo, ABcc, ABcc2, AFrom, ASubject, ABody, AFiles, AIsHTML, AUrl, AEmbeddedImage)
' Create CDO message object
Dim objMessage
Set objMessage = CreateObject("CDO.Message")
' Set configuration fields.
With objMessage.Configuration.Fields
Const SCHEMA_PREFIX = "http://schemas.microsoft.com/cdo/configuration/"
' Original sender email address
.Item(SCHEMA_PREFIX & "sendemailaddress") = AFrom
' SMTP settings - without authentication, using standard port 25 on host smtp
.Item(SCHEMA_PREFIX & "sendusing") = 2 ' cdoSendUsingPort
.Item(SCHEMA_PREFIX & "smtpserverport") = 25
.Item(SCHEMA_PREFIX & "smtpserver") = GetMailServer(1)
' SMTP Authentication
.Item(SCHEMA_PREFIX & "smtpauthenticate") = 0 ' cdoAnonymous
' Timeout
.Item(SCHEMA_PREFIX & "smtpconnectiontimeout") = 10
.Update
End With
' Set other message fields.
With objMessage
' From, To, Subject And Body are required.
.From = AFrom
.To = ATo
.Subject = ASubject
' if AUrl is provided then build the email from given web page
If AUrl <> "" Then
.CreateMHTMLBody AUrl
ElseIf AIsHTML Then
' if HTML then set the HTML body
.HTMLBody = ABody
' (SS,28/9/12) embed image if supplied, image must be in the images folder
If AEmbeddedImage <> "" Then
' (SS,28/9/12) embed the image, the HTML must contain something like <img src="cid:myimage.gif">
' with help from http://support.jodohost.com/threads/tut-how-to-add-embedded-images-in-cdo-mail.7692/
Dim objBP
' Const CdoReferenceTypeName = 1
Set objBP = objMessage.AddRelatedBodyPart(Server.MapPath("/images/" & AEmbeddedImage), AEmbeddedImage, 1)
objBP.Fields.Item("urn:schemas:mailheader:Content-ID") = "<" & AEmbeddedImage & ">"
objBP.Fields.Update
End If
Else
' else normal plain text
.TextBody = ABody
End If
' Blind copy and attachments are optional.
If ABcc <> "" Then .BCC = ABcc
If ABcc2 <> "" Then .BCC = .BCC + ";" + ABcc2
If AFiles <> "" Then .AddAttachment AFiles
' Send the email and check for failure
On Error Resume Next
.Send
' if failed then try other mail servers
Dim LMailServer, LMailServerNo
LMailServerNo = 2
Do While Err.Number <> 0
LMailServer = GetMailServer(LMailServerNo)
If LMailServer = "" Then Exit Do
LMailServerNo = LMailServerNo + 1
With objMessage.Configuration.Fields
.Item(SCHEMA_PREFIX & "smtpserver") = LMailServer
.Update
End With
On Error Resume Next ' cancels the previous error message, i.e. Err.Number starts again at zero
.Send
Loop
End With
' Returns zero If succesfull. Error code otherwise
SendEmailByCDO = Err.Number = 0
' clean up
Set objMessage = Nothing
End Function
' (SS,17/11/04) sets javascript alert message call "onload" of body '
' can be called more than once, each new message is separated by newline
' (SS,4/6/09) added check for "", only adds if AMessage <> ""
' (SS,22/7/10) noticed that the alert wasn't appearing when message contained double quote
' escaped using \ to fix this for single and double quotes
Sub SetAlertMessage(AMessage)
If AMessage <> "" Then
If gsITP_ErrorMessage <> "" Then
gsITP_ErrorMessage = gsITP_ErrorMessage + "\n" ' i.e. newline in javascript '
End If
Dim LMessage
LMessage = Replace(AMessage, BR, "\n") ' (SS,1/6/07) replace <br> with "\n" ' (SS,7/6/11) replaced <br> with BR constant
LMessage = Replace(LMessage, "'", "\'") ' (SS,22/7/10) escape single quotes
LMessage = Replace(LMessage, """", "\""") ' (SS,22/7/10) escape double quotes
LMessage = Replace(LMessage, " ", " ") ' (SS,19/4/16) replaced non-breaking space (HTML) to normal space
gsITP_ErrorMessage = gsITP_ErrorMessage + Replace(LMessage, "<br>", "\n")
End If
End Sub
' (SS,15/4/16) returns True of alert message already contains given text
Function AlertMessageContains(AContains)
AlertMessageContains = InStr(1, gsITP_ErrorMessage, AContains, vbTextCompare) > 0
End Function
' (SS,19/4/16) add a line to separate message if already a message
Function AddAlertMessageSection
If gsITP_ErrorMessage <> "" Then
gsITP_ErrorMessage = gsITP_ErrorMessage + "\n" ' i.e. newline in javascript '
End If
End Function
' (SS,28/5/07) moved here from SetAlertMessage, so it can be run from finalise at the end of the page
Sub ShowAlertMessage
If gsITP_ErrorMessage <> "" Then
%>
<script language="JavaScript" type="text/JavaScript">
<!--
ITP_ErrorMessage = "<%=gsITP_ErrorMessage%>";
//-->
</script>
<%
End If
End Sub
' (SS,7/6/11)
Sub SetConfirmDialog(AMessage, AFunction)
%>
<script language="JavaScript" type="text/JavaScript">
ITP_ConfirmMessage = "<%=AMessage%>"
ITP_ConfirmFunction = "<%=AFunction%>"
</script>
<%
End Sub
' (SS,20/2/14)
' (SS,15/4/16) changed to append to existing message rather than overwrite
Sub SetPopUpMessage(AMessage)
FPopUpMessage = FPopUpMessage & IIf(FPopUpMessage = "", "", BR) & AMessage
End Sub
' (SS,20/2/14)
Sub ShowPopUpMessage
If FPopUpMessage <> "" Then
%>
<div id="popupmessage" style="display: none; position: absolute; top: 0px; right: 0px; background-color: #FFF; text-align: center; width: 394px; padding: 25px; border: 2px solid red;">
<p><%=FPopUpMessage%></p>
</div>
<script language="JavaScript" type="text/JavaScript">
$("#popupmessage").show();
/* (SS,11/6/14) added following to position below the shopping status */
l_top = $("#shopping-status").offset().top + $("#shopping-status").height() + 5;
l_left = $("#shopping-status").offset().left + $("#shopping-status").width() - $("#popupmessage").outerWidth() + 3;
$("#popupmessage").css({top: l_top, left: l_left});
$("#popupmessage").fadeOut(4000);
</script>
<%
End If
End Sub
' (SS,1/7/11) all redirects go through here, also Finalise runs before the redirect takes place
' (SS,4/3/21) added here
Sub DoRedirect(AURL, AIsPermanent)
' do the permanent redirection
Finalise ' make sure we close the database because Response.End will end the script
If AIsPermanent Then
Response.Status = "301 Moved Permanently"
Response.AddHeader "Location", AURL
Response.End
Else
Response.Redirect AURL
End If
End Sub
' (SS,27/7/20)
Sub DoOperation
' do nothing if not signed in
If Not IsAuthenticated Then Exit Sub
Dim LSuccess ' (SS,4/3/21)
LSuccess = False
Dim LCmd, LCompanyName, LLicenceID
LCmd = Request("cmd")
If LCmd = "createlicence" Then
LCompanyName = Trim(Request("CompanyName"))
If LCompanyName <> "" Then
' Response.Write ("###Licence requested for: " & LCompanyName & "###" & BR)
' Response.Write ("###Licence key is: " & GetRandomKey(6, 5) & "###" & BR)
' (SS,30/7/20) added maximum of 10 licences per reseller per day
' (SS,4/3/21) increased from 10 to 20 per day (due to Northern Plates unlimited licences)
If GetNewLicenceCountToday(GetResellerID) >= 20 Then
SetAlertMessage "Error code: MLR. Please contact IT Partnership for support."
Else
' (SS,28/5/21) now calls CreateOrRenewLicence instead of CreateNewLicence, this handles ExpiryDate
LSuccess = CreateRenewOrEditLicence("C", "", LCompanyName)
End If
End If
ElseIf LCmd = "renewlicence" Then
LLicenceID = Trim(Request("LicenceID"))
' (SS,28/5/21) now calls CreateOrRenewLicence instead of CreateNewLicence, this handles ExpiryDate
LSuccess = CreateRenewOrEditLicence("R", LLicenceID, "")
' (SS,28/5/21) new edit licence feature
ElseIf LCmd = "editlicence" Then
LLicenceID = Trim(Request("LicenceID"))
LSuccess = CreateRenewOrEditLicence("E", LLicenceID, "")
End If
' (SS,4/3/21) redirect to prevent form resubmission and creation of duplicates
If LSuccess Then
' redirect to this page i.e. index.asp
DoRedirect Request.ServerVariables("SCRIPT_NAME"), False
End If
End Sub
' (SS,28/5/21) both renewals and creation go through here to reduce repetitive code
' AType is "C" for "Create", "R" for "Renew" and "E" for "Edit"
Function CreateRenewOrEditLicence(AType, ALicenceID, ACompanyName)
Dim LSuccess, LExpiryDate
LSuccess = False
' (SS,28/5/21) if expiry date allowed then check that it has been entered and is valid
' if not allowed then as before, CreateNewLicence called with LExpiryDate set to ""
If ValidExpiryDate(LExpiryDate) Then
If AType = "C" Then
LSuccess = CreateNewLicence(ACompanyName, LExpiryDate)
ElseIf AType = "R" Then
LSuccess = RenewLicence(ALicenceID, LExpiryDate)
ElseIf AType = "E" Then
LSuccess = EditLicence(ALicenceID, LExpiryDate)
End If
Else
SetAlertMessage "Expiry Date is invalid"
End If
CreateRenewOrEditLicence = LSuccess
End Function
' (SS,28/5/21) returns true and the expiry date if expiry date is valid and applicable, true is also return if not applicable with "" as the date
Function ValidExpiryDate(ByRef AExpiryDate)
' (SS,28/5/21) if expiry date allowed then check that it has been entered and is valid
If AllowExpiryDateEntry Then
AExpiryDate = Trim(Request("ExpiryDate"))
ValidExpiryDate = IsDate(AExpiryDate)
Else
AExpiryDate = ""
ValidExpiryDate = True
End If
End Function
' (SS,27/7/20)
' (SS,28/6/21) added AExpiryDate
' (SS,23/6/21) changed to call GetRandomKey instead of GetRandomKeyMySQL
Function CreateNewLicence(ACompanyName, AExpiryDate)
Dim LSQL, LLicenceKey
' (SS<23/6/21) replaced GetRandomKey with GetRandomKeyMySQL for hopefully better random key
LLicenceKey = GetRandomKeyMySQL(6, 5)
LSQL = "INSERT INTO licences SET" &_
" ResellerID = '" & CleanSQLStr(GetResellerID) & "'" &_
", CompanyName = '" & CleanSQLStr(ACompanyName) & "'" &_
", LicenceKey = '" & CleanSQLStr(LLicenceKey) & "'" &_
", StartDate = CURRENT_DATE()" &_
", Enabled = TRUE"
' (SS,27/5/21) if expiry date specified then use it else as before, a year now
If AExpiryDate <> "" Then
LSQL = LSQL & ", ExpiryDate = '" & AExpiryDate & "'"
Else
LSQL = LSQL & ", ExpiryDate = DATE_ADD(CURRENT_DATE(), INTERVAL 1 YEAR)"
End If
ExecuteQuery(LSQL)
Dim LLicenceID, LExpiryDate
LLicenceID = GetSQLLastInsertID
LExpiryDate = GetSQLValueAsString("SELECT ExpiryDate FROM licences WHERE LicenceID = " & LLicenceID)
' also add licence transaction record
AddLicenceTransaction LLicenceID, LExpiryDate
' email the licence
EmailLicence "C", LLicenceID, ""
CreateNewLicence = True
End Function
' (SS,30/7/20)
Function GetNewLicenceCountToday(AResellerID)
GetNewLicenceCountToday = GetSQLValue("SELECT COUNT(*) FROM licences WHERE ResellerID = '" & CleanSQLStr(AResellerID) & "' AND StartDate = CURRENT_DATE")
End Function
' (SS,28/5/21) added AExpiryDate
Function RenewLicence(ALicenceID, AExpiryDate)
Dim LSQL
' validate that licence is for logged in reseller and expiry is less than equal to 30 days
' (SS,28/5/21) removed the less than 30 day check i.e. AND DATEDIFF(ExpiryDate, CURRENT_DATE) <= 30
LSQL = "SELECT LicenceID FROM licences WHERE ResellerID = '" & CleanSQLStr(GetResellerID) & "' AND LicenceID = '" & CleanSQLStr(ALicenceID) & "'"
' exit if not valid
If GetSQLValueAsString(LSQL) = "" Then
SetAlertMessage "Licence could not be renewed"
RenewLicence = False
Exit Function
End If
' increase expiry date by one year
LSQL = "UPDATE licences SET"
' (SS,28/5/21) if expiry date specified then use it else as before, a year now
If AExpiryDate <> "" Then
LSQL = LSQL & " ExpiryDate = '" & AExpiryDate & "'"
Else
LSQL = LSQL & " ExpiryDate = DATE_ADD(ExpiryDate, INTERVAL 1 YEAR)"
End If
LSQL = LSQL & " WHERE LicenceID = '" & CleanSQLStr(ALicenceID) & "'"
ExecuteQuery(LSQL)
Dim LExpiryDate
LExpiryDate = GetSQLValueAsString("SELECT ExpiryDate FROM licences WHERE LicenceID = " & ALicenceID)
' also add licence transaction record
AddLicenceTransaction ALicenceID, LExpiryDate
EmailLicence "R", ALicenceID, ""
RenewLicence = True
End Function
' (SS,28/5/21)
Function EditLicence(ALicenceID, AExpiryDate)
Dim LSQL, LLicenceEnabled, LClearComputerName
Dim LExistingExpiryDate, LExistingEnabled
LLicenceEnabled = Request("LicenceEnabled") = "yes"
LClearComputerName = Request("ClearComputerName") = "yes"
' validate that licence is for logged in reseller and get the existing expiry date and whether enabled or not
LSQL = "SELECT ExpiryDate, Enabled FROM licences WHERE ResellerID = '" & CleanSQLStr(GetResellerID) & "' AND LicenceID = '" & CleanSQLStr(ALicenceID) & "'"
' exit if not valid
If Not GetSQL2Values(LSQL, LExistingExpiryDate, LExistingEnabled) Then
SetAlertMessage "Licence could not be changed"
EditLicence = False
Exit Function
End If
LExistingEnabled = LExistingEnabled = 1
LExistingExpiryDate = ISODate(LExistingExpiryDate)
' check if change required, exit if no change
If LExistingEnabled = LLicenceEnabled And (AExpiryDate = "" Or LExistingExpiryDate = AExpiryDate) And LClearComputerName = False Then
SetAlertMessage "No change made"
EditLicence = False
Exit Function
End If
LSQL = ""
If LExistingEnabled <> LLicenceEnabled Then
LSQL = "Enabled = " & LLicenceEnabled
End If
If AExpiryDate <> "" And LExistingExpiryDate <> AExpiryDate Then
LSQL = LSQL + IIf(LSQL = "", "", ", ") + "ExpiryDate = '" & AExpiryDate & "'"
End If
If LClearComputerName Then
LSQL = LSQL + IIf(LSQL = "", "", ", ") + "ComputerName = ''"
End If
Dim LChanges
LChanges = LSQL
LSQL = "UPDATE licences SET " & LSQL & " WHERE LicenceID = '" & CleanSQLStr(ALicenceID) & "'"
'Response.Write("###LExpiryDate:" & AExpiryDate & "###" & BR)
'Response.Write("###LExistingExpiryDate:" & LExistingExpiryDate & "###" & BR)
'Response.Write("###LExistingEnabled:" & LExistingEnabled & "###" & BR)
'Response.Write("###LLicenceEnabled:" & LLicenceEnabled & "###" & BR)
'Response.Write("###LClearComputerName:" & LClearComputerName & "###" & BR)
'Response.Write("###LSQL:" & LSQL & "###" & BR)
ExecuteQuery(LSQL)
AddLicenceEditLog ALicenceID, LChanges
EmailLicence "E", ALicenceID, LChanges
EditLicence = True
End Function
' (SS,28/7/20) moved code here, called from two places
' (SS,28/5/21) replaced AIsNew with AType, "C" for create, "R" for renewal, "E" for edit
Sub EmailLicence(AType, ALicenceID, AEditDetails)
' email the licence
' *** to email to itpplates and reseller, perhaps get reseller name and email in query above instead of call to GetResellerName, perhaps routine called GetResellerField
Dim LSubject, LBody, LCompanyName
LSubject = "ITP Plates Licence "
If AType = "C" Then
LSubject = LSubject + "Key"
ElseIf AType = "R" Then
LSubject = LSubject + "Renewal"
ElseIf AType = "E" Then
LSubject = LSubject + "Edit"
End If
LCompanyName = GetLicenceField(ALicenceID, "CompanyName")
LSubject = LSubject + " - " & GetResellerField("ResellerName") & " / " & LCompanyName
LBody = "Company: " & LCompanyName & NL & "Licence Key: " & GetLicenceField(ALicenceID, "LicenceKey") & NL & "Expiry Date: " & GetLicenceField(ALicenceID, "ExpiryDate")
' (SS,28/5/21) added following for edit
If AType = "E" Then
LBody = LBody & NL & NL & "Edit Details:"
LBody = LBody & NL & AEditDetails
End If
' Function SendEmail(AEmailAddress, ABCCEmailAddress, ABCCEmailAddress2, AFromEmailAddress, ASubject, ABody, AIsHTML)
Dim LEmailAddress
LEmailAddress = GetResellerField("EmailAddress")
'SendEmail "surinder@itpartnership.com", "", "", "itpplates@itpartnership.com", LSubject, LBody, False
'SendEmail "itpplates@itpartnership.com", "", "", "itpplates@itpartnership.com", LSubject, LBody, False
SendEmail LEmailAddress, "itpplates@itpartnership.com", "", "itpplates@itpartnership.com", LSubject, LBody, False
' (SS,4/3/21) following for testing only
'SendEmail "surinder@itpartnership.com", "", "", "itpplates_test@itpartnership.com", LSubject, LBody, False
End Sub
' (SS,27/7/20)
Sub AddLicenceTransaction(ALicenceID, AExpiryDate)
Dim LSQL
LSQL = "INSERT INTO licence_trans SET" &_
" ResellerID = '" & CleanSQLStr(GetResellerID) & "'" &_
", LicenceID = '" & CleanSQLStr(ALicenceID) & "'" &_
", DateTimeIssued = NOW()" &_
", ExpiryDate = STR_TO_DATE('" & AExpiryDate & "', '%d/%m/%Y')"
ExecuteQuery(LSQL)
End Sub
' (SS,28/5/21)
Sub AddLicenceEditLog(ALicenceID, AEditDetails)
Dim LSQL
LSQL = "INSERT INTO licence_edit_log SET" &_
" LicenceID = '" & CleanSQLStr(ALicenceID) & "'" &_
", EditDateTime = NOW()" &_
", IPAddress = '" & Request.ServerVariables("REMOTE_ADDR") & "'" &_
", SessionID = '" & Session.SessionID & "'" &_
", EditDetails = '" & CleanSQLStr(AEditDetails) & "'"
ExecuteQuery(LSQL)
End Sub
' (SS,27/7/20)
' created from Delphi routine function TfrmMain.GetRandomKey
Function GetRandomKey(ASections, ASectionLength)
Dim LResult, i, n
LResult = ""
For i = 1 To ASections
For n = 1 To ASectionLength
LResult = LResult + Chr(Asc("A") + RandomInteger(0, 25))
Next
if i <> ASections Then LResult = LResult + "-" ' if not last section then add hyphen to separate the sections
Next
GetRandomKey = LResult
End Function
' (SS,23/6/21) GetRandomKey above was creating duplicates, even though RandomInteger calls Randomize and then Rnd
' replaced with this MySQL version
Function GetRandomKeyMySQL(ASections, ASectionLength)
Dim LResult, i, n
LResult = ""
For i = 1 To ASections
For n = 1 To ASectionLength
LResult = LResult + Chr(Asc("A") + RandomIntegerMySQL(0, 25))
Next
if i <> ASections Then LResult = LResult + "-" ' if not last section then add hyphen to separate the sections
Next
GetRandomKeyMySQL = LResult
End Function
' (SS,23/6/21) returns random integer between the two given numbers, this version uses MySQL RAND() function
Function RandomIntegerMySQL(AMin, AMax)
RandomIntegerMySQL = CLng(GetSQLValueAsString("SELECT FLOOR(" & AMin & " + (RAND() * (" & AMax + 1 & ")))"))
End Function
Sub ShowLicences
Dim LSQL
'LSQL = "SELECT *, DATEDIFF(ExpiryDate, CURRENT_DATE) AS DaysLeft FROM licences WHERE ResellerID = '" & GetResellerID & "' ORDER BY LicenceID"
' (SS,20/8/20) added AND NOT Cancelled to WHERE (added new Cancelled and Notes fields to licences table)
LSQL = "SELECT licences.*, " &_
"DATEDIFF(ExpiryDate, CURRENT_DATE) AS DaysLeft, " &_
"DATE(MAX(LastPrintDateTime)) AS LastPrint, " &_
"DATE(MIN(LastPrintDateTime)) AS FirstPrint, " &_
"DATEDIFF(CURRENT_DATE(), DATE(MAX(LastPrintDateTime))) AS DaysAgo, " &_
"ROUND(LastPrintCount / DATEDIFF(CURRENT_DATE(), DATE(MIN(LastPrintDateTime))) * 7, 0) AS WeeklyPrints " &_
"FROM licences " &_
"LEFT JOIN licence_check_log ON licence_check_log.LicenceID = licences.LicenceID " &_
"WHERE ResellerID = '" & GetResellerID & "' AND NOT Cancelled " &_
"GROUP BY LicenceID"
OpenQuery(LSQL)
ShowLicencesHeader
Do While Not EndOfQuery
ShowLicencesRowStart
ShowLicencesRowField "CompanyName", ""
ShowLicencesRowField "RNPSNo", "C"
ShowLicencesRowField "LicenceKey", ""
ShowLicencesRowField "Enabled", "C" ' (SS,28/5/21)
ShowLicencesRowField "Edit", "C" ' (SS,28/5/21)
ShowLicencesRowField "ExpiryDate", "C"
ShowLicencesRowField "Renew", "C"
ShowLicencesRowField "DaysLeft", "C"
ShowLicencesRowField "ComputerName", ""
ShowLicencesRowField "LastPrint", "C"
ShowLicencesRowField "LastPrintCount", "C"
ShowLicencesRowField "WeeklyPrints", "C"
ShowLicencesRowEnd
NextQueryRecord
Loop
ShowLicencesFooter
CloseQuery
End Sub
' (SS,27/5/21) allow expiry dates to be entered for particular resellers, i.e. IT Partnership and Northern Number Plates Limited
Function AllowExpiryDateEntry
' if IT Partnership or Northern Number Plates Limited
AllowExpiryDateEntry = GetResellerID = 1 Or GetResellerID = 7
End Function
' (SS,27/5/21) default is a year
Function GetDefaultExpiryDate
GetDefaultExpiryDate = ISODate(DateAdd("yyyy", 1, Date))
End Function
' (SS,27/5/21) min is one week
Function GetMinExpiryDate
GetMinExpiryDate = ISODate(DateAdd("d", 7, Date))
End Function
' (SS,27/5/21) max is a year
Function GetMaxExpiryDate
GetMaxExpiryDate = GetDefaultExpiryDate
End Function
' (SS,5/4/22) prefixes (escape) single quote with backslash (for Javascript string)
Function JSEscapeSingleQuote(AStr)
JSEscapeSingleQuote = ReplaceStr(AStr, "'", "\'")
End Function
%>