File: D:/web/secure/itpplates/admin/apputils - Copy (2).asp
<%
' ============
' apputils.asp
' ============
' Version 1.01 (20/08/20)
' ============
' 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.
' ============'
' 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,27/7/20)
Sub DoOperation
' do nothing if not signed in
If Not IsAuthenticated Then Exit Sub
Dim LCmd, LCompanyName
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
If GetNewLicenceCountToday(GetResellerID) >= 10 Then
SetAlertMessage "Error code: MLR. Please contact IT Partnership for support."
Else
CreateNewLicence(LCompanyName)
End If
End If
ElseIf LCmd = "renewlicence" Then
Dim LLicenceID
LLicenceID = Trim(Request("LicenceID"))
RenewLicence(LLicenceID)
End If
End Sub
' (SS,27/7/20)
Sub CreateNewLicence(ACompanyName)
Dim LSQL, LLicenceKey
LLicenceKey = GetRandomKey(6, 5)
LSQL = "INSERT INTO licences SET" &_
" ResellerID = '" & CleanSQLStr(GetResellerID) & "'" &_
", CompanyName = '" & CleanSQLStr(ACompanyName) & "'" &_
", LicenceKey = '" & CleanSQLStr(LLicenceKey) & "'" &_
", StartDate = CURRENT_DATE()" &_
", ExpiryDate = DATE_ADD(CURRENT_DATE(), INTERVAL 1 YEAR)" &_
", Enabled = TRUE"
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 LLicenceID, True
End Sub
' (SS,30/7/20)
Function GetNewLicenceCountToday(AResellerID)
GetNewLicenceCountToday = GetSQLValue("SELECT COUNT(*) FROM licences WHERE ResellerID = '" & CleanSQLStr(AResellerID) & "' AND StartDate = CURRENT_DATE")
End Function
Sub RenewLicence(ALicenceID)
Dim LSQL
' validate that licence is for logged in reseller and expiry is less than equal to 30 days
LSQL = "SELECT LicenceID FROM licences WHERE ResellerID = '" & CleanSQLStr(GetResellerID) & "' AND LicenceID = '" & CleanSQLStr(ALicenceID) & "' AND DATEDIFF(ExpiryDate, CURRENT_DATE) <= 30"
' exit if not valid
If GetSQLValueAsString(LSQL) = "" Then
SetAlertMessage "Licence could not be renewed"
Exit Sub
End If
' increase expiry date by one year
LSQL = "UPDATE licences SET" &_
" ExpiryDate = DATE_ADD(ExpiryDate, INTERVAL 1 YEAR)" &_
" 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 ALicenceID, False
End Sub
' (SS,28/7/20) moved code here, called from two places
Sub EmailLicence(ALicenceID, AIsNew)
' 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 AIsNew Then
LSubject = LSubject + "Key"
Else
LSubject = LSubject + "Renewal"
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")
' 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
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,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
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 "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
%>