File: D:/web/groundscrewcentre/customutils.asp
<%
' ===============
' customutils.asp
' ===============
' Version 1.18 (17/01/24)
' ============
' HISTORY
' ============
' (SS,29/08/19) First version for Ground Screw Centre
' (SS,10/06/20) Various changes to calculator
' (SS,23/06/20) Added SIP Base
' (SS,03/07/20) Minor text change and bug fix
' (SS,10/03/21) Price change to Function CustomGetFittingCost
' (SS,10/03/21) Added CustomGSCShowProfessionalTotalAlert to show when 15 or more screws required, alert text added to inc-template-calculator.asp
' (SS,10/06/21) Price change to Function CustomGetFittingCost
' (SS,02/11/21) Changes to handle new structure type "Extension" which emails fields entered in the new enquiry modal form (see inc-template-calculator.asp)
' (SS,09/11/21) Cleaned code in Function CustomGetDelivery
' (SS,18/11/21) Improvements
' (SS,20/11/21) Added CustomCheckAddressDetails to disallow delivery to Northern Ireland (collection allowed)
' (SS,08/09/23) Change to Function CustomGetDelivery, added additional delivery charge of �35 if new attribute "Additional Delivery Charge" is in basket i.e. product code GS-1100
' (SS,17/01/24) Temporary adjustment (in Function CustomGetCalcSpecJSON) from "750mm" to "850mm" due to low stock of "750mm" (applied on 19/1/24)
' consts for product types
Const PT_SCREW = "Screw"
Const PT_BRACKET = "Bracket"
'Const PT_DECKBASE = "Deck Base"
Const PT_BASE = "Base" ' (SS,23/6/20) replaced above with this
Const PT_TOOL = "Tool"
Const PT_FITTING = "Fitting"
Const PT_ACCESSORY = "Accessory" ' (SS,26/5/29)
Const ADDITIONAL_ITEM_NAME = "AdditionalItem" ' (SS,4/11/20)
' (SS,8/10/20) *** perhaps create a custom object (check CIRC)
Dim FCustomGroupNamePrev
FCustomGroupNamePrev = ""
' (SS,5/11/20)
Dim FCustomForEmail
FCustomForEmail = False
' this routine must exist if CustomDeliveryEnabled, -1 is returned if delivery cost could not be determined, user should be alerted using SetAlertMessage
' (SS,9/11/21) cleaned code
' (SS,8/9/23) added additional delivery charge of �35 if new attribute "Additional Delivery Charge" is in basket i.e. product code GS-1100
Function CustomGetDelivery(ATotalValue, AValueOfNonWeightedGoods, ATotalWeight, AVATContent, ATotalItems, ANormalDeliveryCost, AByPriceDeliveryCost, AByWeightDeliveryCost, APostcode, ARegionCode, ADeliveryRegion, ACountry)
' (SS,1/11/21)
'Response.Write "###Postcode: " & APostcode & BR
'Response.Write "###Regioncode: " & ARegionCode & BR
'Response.Write "###DeliveryRegion: " & ADeliveryRegion & BR
'Response.Write "###Country: " & ACountry & BR
' (SS,8/9/23) added additional "freight" delivery charge of �35 if product with this new attribute i.e. GS-1100 is in the basket
If GetAttributeInBasketCount("Additional Delivery Charge", "") > 0 Then
CustomGetDelivery = ANormalDeliveryCost + 35
Else ' as before
CustomGetDelivery = ANormalDeliveryCost
End If
End Function
' (SS,20/11/21) added following to check for Northern Ireland at checkout stage and don't allow unless collected
' AType = "B" for billing address, "D" for delivery address
Function CustomCheckAddressDetails(AType, ACompanyName, APostcode, ACountry, ADeliveryWillCollect)
Dim LResult
If IsNorthernIreland(ACountry, APostcode) And Not ADeliveryWillCollect Then
LResult = "Due to current restrictions, delivery to Northern Ireland is temporarily unavailable. Please order your products for collection or contact " &_
"<a href=""mailto:" & GetStoreEmail & """>" & GetStoreEmail & "</a> and we will notify you when delivery to Northern Ireland becomes available."
Else
LResult = ""
End If
CustomCheckAddressDetails = LResult
End Function
' -------------------------------- '
' Start of Custom Ajax Routines '
' Used by Ground Screw Calculator '
' (SS,23/8/19) '
' -------------------------------- '
' (SS,23/8/19) for Ground Screw calculator
Sub CustomAjax(AOptions)
If AOptions = "calculator" Then
' (SS,2/11/21) check for extension enquiry and send it, else as before
If Request.QueryString("extensionenquiry") = "yes" Then
'Response.Write "#Enquiry:" & CleanRequest("Enquiry") & "#" & BR
'Response.Write "#Message:" & CleanRequest("Message") & "#" & BR
'Response.Write "#Type:" & CleanRequest("Type") & "#" & BR
'Response.Write "#Postcode:" & CleanRequest("Postcode") & "#" & BR
If Trim(CleanRequest("Email")) <> "" And Trim(CleanRequest("Name")) <> "" And Trim(CleanRequest("Message")) <> "" Then
AddContactToDatabaseAndEmail "Contact", "Name, Postcode, Telephone, Email", "Type, Message", True
CustomShowAlert "Thank you for your enquiry. We will get back to you shortly."
Else
CustomShowAlertError "Email, Name or Message missing. No enquiry sent."
End If
Exit Sub
End If
' (SS,6/11/20) added following two temporarily store both return HTML and email HTML
' HTML for email is saved for use by addtobasket option
Dim LHTMLReturn, LHTMLEmail
' (SS,6/11/20) call CustomAjaxCalculator to create the HTML to return
CustomAjaxCalculator False ' (SS,15/10/20) added new parameter False, to indicate not for email
' (SS,9/11/20) if error then return (settings would have been saved above)
If Request.QueryString("Error") <> "false" Then
Exit Sub
End If
LHTMLReturn = CustomGetHTMLCalc
' (SS,6/11/20) call CustomAjaxCalculator again to create the HTML for email and to save it
CustomAjaxCalculator True
LHTMLEmail = CustomGetHTMLCalc
' (SS,6/11/20) save the HTML for Email in the build settings to be saved in the Extra field of orders later (to include in the confirmation email)
CustomSaveBuildProperty "HTMLForEmail", LHTMLEmail
' (SS,6/11/20) render the return HTML, needs to be done even if email calculation button is used
Response.Write LHTMLReturn
' (SS,14/10/20) send calculation in email
If Request.QueryString("sendemail") = "yes" Then
' (SS,4/11/20) save the settings in saved baskets table to restore later
Dim LSavedBasketID
LSavedBasketID = SaveBasketExtras(CustomGetBuildSettings)
' (SS,13/11/20)
If Request.QueryString("request") = "yes" Then
SendSavedBasketEmailExtra "EmailCalculationRequestTemplate", LSavedBasketID, LHTMLEmail
CustomShowAlert "Thank you for your request. We will get back to you shortly."
Else
' (SS,4/11/20) send the email using routine in AppUtils.asp
SendSavedBasketEmailExtra "EmailCalculationTemplate", LSavedBasketID, LHTMLEmail
CustomShowAlert "Your calculation has been emailed to you."
End If
End If
ElseIf AOptions = "addtobasket" Then
CustomAjaxAddToBasket
' (SS,8/6/20)
ElseIf AOptions = "spec" Then
CustomAjaxGetCalcSpecJSON
End If
End Sub
' (SS,13/11/20)
Sub CustomShowAlert(AMessage)
%>
<div class="alert alert-primary mt-3" role="alert">
<%=AMessage%>
</div>
<%
End Sub
' (SS,18/11/21)
Sub CustomShowAlertError(AMessage)
%>
<div class="alert alert-danger mt-3" role="alert">
<%=AMessage%>
</div>
<%
End Sub
Sub CustomAjaxAddToBasket
CustomIncGSCCounter ' increment build number
CustomAddToBasket PT_SCREW
CustomAddToBasket PT_BRACKET
CustomAddToBasket PT_BASE
CustomAddToBasket PT_TOOL
CustomAddToBasket PT_FITTING
CustomAddToBasket PT_ACCESSORY ' (SS,26/5/20)
' (SS,15/10/20) add to session variable to save to order later
CustomAddNewBuildProperties
End Sub
Sub CustomIncGSCCounter
If Session("GroundScrewBuildNo") = "" Then Session("GroundScrewBuildNo") = 0
Session("GroundScrewBuildNo") = Session("GroundScrewBuildNo") + 1
End Sub
' (SS,15/10/20)
Function CustomGetBuildNo
CustomGetBuildNo = Session("GroundScrewBuildNo")
End Function
' (SS,6/11/20)
Sub CustomClearBuildNo
Session("GroundScrewBuildNo") = ""
End Sub
Function CustomGetGSCOptionTitle
CustomGetGSCOptionTitle = "Build"
End Function
' returns option value used by every item added to basket, number followed by build name in brackets (i.e. structure type, base type etc.)
Function CustomGetGSCOptionValue
CustomGetGSCOptionValue = CStr(Session("GroundScrewBuildNo")) & " (" & Request.Form("BuildName") & ")"
End Function
' (SS,26/5/20) modified to add multiples for accessories, by adding i and Do Loop
Function CustomAddToBasket(AFormElement)
Dim LResult, LProductID, LQty, i
LResult = False
i = 0
Do
i = i + 1
LProductID = Request.Form(AFormElement & i & "-ID")
LQty = Request.Form(AFormElement & i & "-Qty")
If LProductID <> "" And LQty <> "" Then
Dim LProductCode, LOptions, LValues
LProductCode = GetProductCodeForProductID(LProductID)
If LProductCode <> "" Then
LResult = True
' set up the arrays with no elements
ReDim LOptions(0), LValues(0)
LOptions(0) = CustomGetGSCOptionTitle
LValues(0) = CustomGetGSCOptionValue
End If
If LResult Then AddProductToBasketIncludingOptions LProductCode, LQty, 0, False, False, LOptions, LValues
End If
Loop Until LProductID = ""
CustomAddToBasket = LResult
End Function
' (SS,8/6/20) calls CustomGetCalcSpecJSON to get the calculator spec from table in JSON format, returns it as a response
Sub CustomAjaxGetCalcSpecJSON
Response.ContentType = "application/json"
Response.Write CustomGetCalcSpecJSON
End Sub
' (SS,8/6/20) returns the calculator spec from table in JSON format, as a string
' (SS,17/1/24) temporary adjustment from "750mm" to "850mm" due to low stock of "750mm"
Function CustomGetCalcSpecJSON
Dim LJSON, LCount, LArrayValues
' LJSON = "{""structureTypes"":[" + NL
LJSON = LJSON & "[" + NL
OpenQuery("SELECT * FROM calculator_spec WHERE Enabled ORDER BY SortOrder")
LCount = 0
Do While Not EndOfQuery
' add comma separator
LCount = LCount + 1
If LCount > 1 Then LJSON = LJSON + "," & NL
' start record
LJSON = LJSON + "{"
' structure type name
LJSON = LJSON + """structureType"":""" + GetQueryValue("StructureType") + ""","
' base types
LJSON = LJSON + """baseTypes"":["
LJSON = LJSON + """Joist"""
If BoolToInt(GetQueryValue("AllowSIP")) Then
LJSON = LJSON + ","
LJSON = LJSON + """SIP"""
End If
LJSON = LJSON + "],"
' including decking area
LJSON = LJSON + """includeDeckingArea"":" + IIf(BoolToInt(GetQueryValue("IncludeDeckingArea")), "true", "false") + ","
' screw lengths
LJSON = LJSON + """screwLengths"":["
LArrayValues = ""
If BoolToInt(GetQueryValue("ScrewLength550")) Then
LArrayValues = LArrayValues + IIf(LArrayValues = "", "", ",")
LArrayValues = LArrayValues + """550mm"""
End If
If BoolToInt(GetQueryValue("ScrewLength750")) Then
LArrayValues = LArrayValues + IIf(LArrayValues = "", "", ",")
' LArrayValues = LArrayValues + """750mm"""
LArrayValues = LArrayValues + """850mm""" ' (SS,17/1/24) temporary adjustment to "850mm" due to low stock, need to revert back
End If
LJSON = LJSON + LArrayValues + "],"
' joist sizes
LJSON = LJSON + """joistSizes"":["
LArrayValues = ""
If BoolToInt(GetQueryValue("JoistSize3x2")) Then
LArrayValues = LArrayValues + IIf(LArrayValues = "", "", ",")
LArrayValues = LArrayValues + """3\"" x 2\"""""
End If
If BoolToInt(GetQueryValue("JoistSize4x2or6x2")) Then
LArrayValues = LArrayValues + IIf(LArrayValues = "", "", ",")
'LArrayValues = LArrayValues + """4\"" x 2\"" or 6\"" x 2\"""""
' (SS,16/11/20) changed to 4�, 5�, 6� x 2�
' LArrayValues = LArrayValues + """4\"", 5\"", 6\"" x 2\"""""
' (SS,8/4/22) changed above to following, replaced "," with "or"
LArrayValues = LArrayValues + """4\"", 5\"" or 6\"" x 2\"""""
End If
LJSON = LJSON + LArrayValues + "]"
' end record
LJSON = LJSON + "}"
NextQueryRecord
Loop
CloseQuery
LJSON = LJSON + NL + "]"
CustomGetCalcSpecJSON = LJSON
End Function
' (SS,10/6/20) for subcategory menue off "Ground Screw Calculator", built from structure types in calculator_spec table
Sub CustomCalculatorMenu
Dim LStructureType
OpenQuery("SELECT StructureType FROM calculator_spec WHERE Enabled ORDER BY SortOrder")
Do While Not EndOfQuery
LStructureType = GetQueryValue("StructureType")
%><a class="dropdown-item" href="products.asp?page=calculator&structuretype=<%=ReplaceStr(LStructureType, " ", "+")%>"><%=LStructureType%></a>
<%
NextQueryRecord
Loop
CloseQuery
End Sub
' (SS,23/8/19) for Ground Scew calculator
' (SS,26/5/20) added extra screws for additional heavy loads
' (SS,15/10/20) added AForEmail parameter
' (SS,24/11/20) renamed FittingOptions to FittingOption
Sub CustomAjaxCalculator(AForEmail)
Dim LStructureType, LBaseType, LScrewLength, LLength, LWidth, LJoistSize, LSecuringBrackets, LFittingOption, LAdditionalLoads, LToolType
FCustomForEmail = AForEmail ' (SS,5/11/20)
' (SS,13/10/20) replaced above with following
' (SS,11/11/20) added LToolType
CustomSaveBuildSettings LStructureType, LBaseType, LScrewLength, LJoistSize, LSecuringBrackets, LFittingOption, LLength, LWidth, LAdditionalLoads, LToolType
' (SS,9/11/20) get values to restore if user happens to navigate to another page and back to the calculator page
CustomCalculationSetRestore CustomGetBuildSettings
' (SS,9/11/20) added check for new Error parameter, so that nothing is returned, just a save is done to restore later
If Request.QueryString("Error") <> "false" Then
Exit Sub
ElseIf LStructureType <> "" And LBaseType <> "" And LScrewLength <> "" Then
' calculate screws required
' for SIP distance is 1.22m
' for joist it's 1.70m
Const SIP_GAP = 1.22
Const SIP_ALLOWANCE = 0.2
Const JOIST_GAP = 1.5 ' (SS,16/11/20) changed form 1.7 to 1.5
Const JOIST_ALLOWANCE = 0.2
Const ROUNDING = 0.2
Dim LScrewGap, LScrewAllowance, LScrewsRequiredForLength, LScrewsRequiredForWidth, LGroundScrewsRequired, LArea, LAreaFt, LAreaRoundedUp, LIsSIP
If LBaseType = "SIP" Then
LScrewGap = SIP_GAP
LScrewAllowance = SIP_ALLOWANCE
LIsSIP = True
Else
LScrewGap = JOIST_GAP
LScrewAllowance = JOIST_ALLOWANCE
LIsSIP = False
End If
LScrewsRequiredForLength = CustomGetScrewsRequired(LLength, LScrewGap, LScrewAllowance)
LScrewsRequiredForWidth = CustomGetScrewsRequired(LWidth, LScrewGap, LScrewAllowance)
' (Round(LLength / LScrewGap) + 1) * (Round(LWidth / LScrewGap) + 1)
LGroundScrewsRequired = LScrewsRequiredForLength * LScrewsRequiredForWidth
LArea = Round2dp(LLength * LWidth)
LAreaFt = Round2dp(CustomMetresToFeet(LLength) * CustomMetresToFeet(LWidth))
' following used in deck base calc to next whole number
LAreaRoundedUp = Int(LArea)
If LArea > LAreaRoundedUp Then LAreaRoundedUp = LAreaRoundedUp + 1
' look up the screw (need info earlier)
Dim LScrewProductID, LMaxWeightPerScrew, LMaxWeightPoorGroundPerScrew, LMaxWeight, LMaxWeightPoorGround, LInstallRange
LScrewProductID = CustomGSCGetProductID(PT_SCREW, "Screw Length", ParseInt(LScrewLength), "", "", "", "", 1)
LMaxWeightPerScrew = GetProductAttributeByName(LScrewProductID, "Load Capacity")
LMaxWeight = LMaxWeightPerScrew * LGroundScrewsRequired
LMaxWeightPoorGroundPerScrew = LMaxWeightPerScrew / 2
LMaxWeightPoorGround = LMaxWeightPoorGroundPerScrew * LGroundScrewsRequired
LInstallRange = GetProductAttributeByName(LScrewProductID, "Install Range")
' LGroundScrewsRequired * (430 / 2)
' show info
' (SS,26/5/20) removed row "Recommended Load in Poor Ground"
' renamed "Maximum Load Capacity" to "Maximum Load in Solid Ground"
' (SS,26/5/20) add extra screws for additional load
'1. None.
'2. 1000kg � 2000kg � add 4 more screws & brackets
'3. 2001kg to 3000kg � add 8 more screws & brackets
'4. 3001kg to 4000kg � add 12 more screws and brackets
' (SS,28/5/20) changed to
' Option 1� �up to 1000kg� (adds 4 screws)
' Option 2� �1500kg� (adds 6 screws)
' Option 3� �2000kg� (adds 8 screws)
' Option 4� �2500kg� (adds 12 screws)
' Option 5� �3000kg� (adds 16 screws)
Dim LAdditionalGroundScrewsRequired, LAdditionalLoadsInt
LAdditionalLoadsInt = ParseFirstInt(LAdditionalLoads)
If LAdditionalLoadsInt = 1000 Then
LAdditionalGroundScrewsRequired = 4
ElseIf LAdditionalLoadsInt = 1001 Then
LAdditionalGroundScrewsRequired = 6
ElseIf LAdditionalLoadsInt = 1501 Then
LAdditionalGroundScrewsRequired = 8
ElseIf LAdditionalLoadsInt = 2001 Then
LAdditionalGroundScrewsRequired = 12
ElseIf LAdditionalLoadsInt = 2501 Then
LAdditionalGroundScrewsRequired = 16
Else
LAdditionalGroundScrewsRequired = 0
End If
' (SS,26/5/20) new total
Dim LGroundScrewsRequiredTotal
LGroundScrewsRequiredTotal = LGroundScrewsRequired + LAdditionalGroundScrewsRequired
' (SS,10/5/20) to check if fitting applicable, to only allow fitting if 12 or more screws
' (SS,9/10/20) following moved here from below, due to some of the info not to be shown for fitting/install option
Dim LFittingChosen, LFittingApplicable
'Const MINIMUM_SCREWS_FOR_FITTING = 12
' (SS,18/11/20) replaced above with following, now 12 sqm
Const MINIMUM_SQM_FOR_FITTING = 12
' (SS,30/6/20) replaced "fitting" with "installation"
' (SS,16/11/20) replaced "installation" with "install", then "install" with "professional"
LFittingChosen = InStr(1, LFittingOption, "professional", 1) > 0
'LFittingApplicable = LGroundScrewsRequiredTotal >= MINIMUM_SCREWS_FOR_FITTING
' (SS,18/11/20) above replaced with following
LFittingApplicable = LAreaRoundedUp >= MINIMUM_SQM_FOR_FITTING
' (SS,2/6/20) slight text change for Ground Screws and Extra Screws
' (SS,13/10/20) changed to space in string (to allow sending in email and saving in field)
CustomHTMLCalcClear
CustomHTMLCalcAdd "<table class=""table"">"
CustomHTMLCalcAdd "<tr><th>Structure Type</th><td>" & LStructureType & "</td></tr>"
CustomHTMLCalcAdd "<tr><th>Base Type</th><td>" & LBaseType & "</td></tr>"
CustomHTMLCalcAdd "<tr><th>Base Dimensions</th><td>" & LLength & " m x " & LWidth & " m (" & CustomMetresToFeet(LLength) & " ft x " & CustomMetresToFeet(LWidth) & " ft)</td></tr>"
CustomHTMLCalcAdd "<tr><th>Base Area</th><td>" & LArea & " m<sup>2</sup> (" & LAreaFt & " ft<sup>2</sup>)</td></tr>"
If LBaseType = "Joist" Then
CustomHTMLCalcAdd "<tr><th>Joist Size</th><td>" & LJoistSize & "</td></tr>"
End If
CustomHTMLCalcAdd "<tr><th>Additional Loads</th><td>" & LAdditionalLoads & "</td></tr>"
If Not LFittingChosen Then
CustomHTMLCalcAdd "<tr><th>Ground Screw Length</th><td>" & LScrewLength & "</td></tr>"
CustomHTMLCalcAdd "<tr><th>Securing Brackets</th><td>" & LSecuringBrackets & "</td></tr>"
End If
CustomHTMLCalcAdd "<tr><th>Fitting Option</th><td>" & LFittingOption & "</td></tr>"
If Not LFittingChosen Then
CustomHTMLCalcAdd "<tr><th>Ground Screws for Base Area</th><td>" & LGroundScrewsRequired & " (" & LScrewsRequiredForLength & " rows of " & LScrewsRequiredForWidth & ")</td></tr>"
' (SS,17/11/20) added following, only for joists
If Not LIsSIP Then
CustomHTMLCalcAdd "<tr><th>Maximum Joist Span</th><td>" & JOIST_GAP & " m</td></tr>"
End If
If LAdditionalGroundScrewsRequired > 0 Then
CustomHTMLCalcAdd "<tr><th>Extra Screws for Heavy Load Areas</th><td>" & LAdditionalGroundScrewsRequired & "</td></tr>"
End If
CustomHTMLCalcAdd "<tr><th>Recommended Install Range</th><td>Ground level to " & LInstallRange & "mm above ground</td></tr>"
CustomHTMLCalcAdd "<tr><th>Maximum Load in Solid Ground</th><td>" & FormatNumber(LMaxWeight, 0) & " kg (" & FormatNumber(LMaxWeightPerScrew, 0) & " kg per screw)</td></tr>"
End If
CustomHTMLCalcAdd "</table>"
' list the products needed
' find ground screw matching the screw length
' find bracket matching base type and joist size (also quality), if SIP then no joist size
' routine to get certain attributes for given ground screw, i.e. Load Capacity, Install Range,
' first word is the quality e.g. Premium or Budget
Dim LQuality
LQuality = NthSeparatedValue(LSecuringBrackets, " ", 1)
' joist size and quality not applicable for SIP, so ensure they're blank
If LBaseType = "SIP" Then
LJoistSize = ""
LQuality = ""
End If
' look up the non screw products
Dim LBracketProductID, LToolProductID, LBaseProductID, LFittingProductID
LBracketProductID = CustomGSCGetProductID(PT_BRACKET, "Base Type", LBaseType, "Joist Size", LJoistSize, "Quality", LQuality, 1)
LBaseProductID = ""
LToolProductID = ""
LFittingProductID = ""
If LFittingChosen Then
LBaseProductID = CustomGSCGetProductID(PT_BASE, "Base Type", LBaseType, "", "", "", "", 1)
LFittingProductID = CustomGSCGetProductID(PT_FITTING, "", "", "", "", "", "", 1)
Else
' add tool if not already in basket
If GetAttributeInBasketCount("Product Type", PT_TOOL) = 0 Then
' (SS,11/11/20) added "Tool Type" and LToolType parameters because there can know be a manual, professional or rental tool
If LToolType <> "" Then ' (SS,11/11/20) added this to prevent any tool from being added if LToolType is ""
LToolProductID = CustomGSCGetProductID(PT_TOOL, "Tool Type", LToolType, "", "", "", "", 1)
End If
End If
End If
' (SS,10/5/20) show an alert if fitting chosen and not applicable
If LFittingChosen And Not LFittingApplicable Then
CustomHTMLCalcAdd "<div class=""alert alert-danger"" role=""alert"">"
'CustomHTMLCalcAdd "The fitting option is only available if " & MINIMUM_SCREWS_FOR_FITTING & " or more screws required."
' (SS,18/11/20) replaced above with following
CustomHTMLCalcAdd "The professional fitting option is only available from " & MINIMUM_SQM_FOR_FITTING & " m<sup>2</sup>"
CustomHTMLCalcAdd "</div>"
Else ' (SS,10/5/20) as before
' list the products and prices
' (SS,17/11/20) renamed ASubtotal to LSubtotal
Dim LSubtotal, LInStock
LSubtotal = 0
LInStock = True ' (SS,17/11/20)
CustomGSCTableHeader LFittingChosen, LStructureType & " - " & LBaseType & " - " & LScrewLength & " - " & LLength & "m x " & LWidth & "m"
' (SS,17/11/20) added "If Not LFittingChosen Then" because products are no longer applicable for fitting option, no longer an add to basket feature
' only request details and availability feature when fitting chose, also no need to check the stock
If Not LFittingChosen Then
' (SS,26/5/20) added 1 for AIndex (new parameter)
' (SS,2/11/20) replaced 2nd parameter True with Not LFittingChosen to not show line if full professional installation
LInStock = CustomGSCProductLine(PT_SCREW, Not LFittingChosen, 1, LScrewProductID, LGroundScrewsRequiredTotal, LSubtotal)
LInStock = LInStock And CustomGSCProductLine(PT_BRACKET, Not LFittingChosen, 1, LBracketProductID, LGroundScrewsRequiredTotal, LSubtotal)
LInStock = LInStock And CustomGSCProductLine(PT_TOOL, Not LFittingChosen, 1, LToolProductID, 1, LSubtotal)
End If
' (SS,10/6/20) modified to show a combined line for deck base and fitting
If LFittingChosen Then
' (SS,17/11/20) removed following 3 lines, no longer applicable
'Dim LFittingInStock, LFittingTotal
'LFittingTotal = LSubtotal
'LFittingInStock = CustomGSCProductLine(PT_BASE, False, 1, LBaseProductID, LAreaRoundedUp, LSubtotal)
' (SS,13/11/20) get fitting cost for m2 area, use this as qty for �1 fitting product
' (SS,17/11/20) renamed LFittingCostAndQty to LFittingCost
Dim LFittingCost
LFittingCost = CustomGetFittingCost(LAreaRoundedUp) ' LAreaRoundedUp used instead of LArea
LSubtotal = LFittingCost
' (SS,13/11/20) replaced LGroundScrewsRequiredTotal with LFittingCostAndQty
' (SS,17/11/20) removed, no longer applicable
'LFittingInStock = LFittingInStock And CustomGSCProductLine(PT_FITTING, False, 1, LFittingProductID, LFittingCostAndQty, LSubtotal)
'LFittingTotal = LSubtotal - LFittingTotal
'LInStock = LInStock And LFittingInStock
' following is the combined line (above are the hidden values for two different products)
' (SS,23/6/20) replaced "Supply and fit deck base, ground screws and associated brackets"
' with "Supply and fit ground screws, associated brackets and " + iif(LBaseType = "SIP", "SIP", "deck") + " base"
'CustomGSCTableLine "Supply and fit ground screws, associated brackets and " + iif(LBaseType = "SIP", "SIP", "deck") + " base", 0, "", CorrectCurrency(LFittingTotal), LFittingInStock
' (SS,30/6/20) replaced above with following
' (SS,3/11/20) replaced CorrectCurrency(LFittingTotal) with CorrectCurrency(LSubtotal)
' (SS,11/12/20) added "" as first parameter for AProductCode
' (SS,17/11/20) replaced LSubtotal with LFittingCost, and LFittingInStock with True
' (SS,8/4/22) changed word "deck" to "frame"
CustomGSCTableLine "", "Full professional installation by The Ground Screw Centre <br><small>(Includes supply and install of all ground screws, brackets, fixings and timber joist frame)</small>", 0, "", CorrectCurrency(LFittingCost), True
End If
' (SS,26/5/20) added the selected additional items
' (SS,30/5/20) added if to only add if fitting not chosen
If Not LFittingChosen Then
Dim i, LValue, LQty
i = 0
Do
i = i + 1
LValue = CleanSQLStr(Request.QueryString(ADDITIONAL_ITEM_NAME & i)) ' (SS,4/11/20) replaced "product" with ADDITIONAL_ITEM_NAME
If LValue <> "" Then
' If LValue <> "false" Then
' (SS,6/11/20) replaced If above with following to fix bug where these items were only being added if there were no gaps
' i.e. if it encountered a false it would stop, e.g. if first item not selected and next 3 were, then no items would be added
' Fix required holding a hidden empty value with zero quality
If LValue = "false" Then
LValue = "0"
LQty = 0
Else
LQty = 1
End If
'Response.Write "###" & PT_ACCESSORY & "/" & ADDITIONAL_ITEM_NAME & i & "=" & LValue & "###Qty:" & LQty & "###" & BR
' (SS,6/11/20) removed CLng from LValue because it can be a string
LInStock = LInStock And CustomGSCProductLine(PT_ACCESSORY, True, i, LValue, LQty, LSubtotal)
End If
Loop Until LValue = ""
End If
' (SS,17/11/20) added LFittingChosen
CustomGSCTableFooter LFittingChosen, CorrectCurrency(LSubtotal), LInStock
' (SS,15/10/20) added Not AForEmail
If Not AForEmail Then
' (SS,10/11/20) different button shown for professional fitting
If LFittingChosen Then
CustomGSCRequestDetailsButton
CustomGSCInstallationInfo True ' show the installation info, which is applicable for pro install
' (SS,16/11/20) added following temporarily for testing
'If LInStock Then
' CustomGSCAddToBasketButton
'End If
Else
CustomGSCEmailCalculationButton ' (SS,14/10/20) new Email Calculation button
If LInStock Then
CustomGSCAddToBasketButton
End If
CustomGSCInstallationInfo False ' (SS,11/11/20) hide the install info if it was show, it's not applicable for self-install
End If
' (SS,10/3/21) to professional tool info if >= 15 screws
CustomGSCShowProfessionalTotalAlert Not LFittingChosen And LGroundScrewsRequiredTotal >= 15
Else ' (6/11/20) for email
CustomAdjustHTMLCalcForEmail ' make some adjustments, i.e. improvements for email display
End If
End If
End If
End Sub
' (SS,29/8/19) converts metres to feet also rounds up or down if ending in .01 or .99
Function CustomMetresToFeet(AMetres)
Dim LResult, LFraction
LResult = Round2dp(AMetres * 100 / 2.54 / 12)
' if .99 then add .01, if 0.01 then subtract 0.01 (to nicely round)
LFraction = Right(CStr(LResult), 3)
If LFraction = ".99" Then
LResult = LResult + 0.01
ElseIf LFraction = ".01" Then
LResult = LResult - 0.01
End If
LResult = Round2dp(LResult) ' round again due to possible adding of fractions above
CustomMetresToFeet = LResult
End Function
' (SS,13/11/20) returns fitting cost total in pounds using given base area (rounded up to next integer)
' use following table:
' 15-20sq m �100psqm
' 21-25sq m �90psqm
' 26-30sq m �85psqm
' 31-35sq m �80psqm
' 36sq me + �73psqm
' (SS,10/3/21) adjusted to (see email from Tom):
' 12sqm � 16sqm : �120 per Sqm
' 17sqm - 25sqm: �105 per sqm
' 26sqm � 30sqm : �100 per sqm
' 31 sqm + : �95 per sqm
' (SS,10/6/21) adjusted to (see email from Tom):
' 12-16 sqm - �135
' 17-25sqm - �120
' 26 � 30 sqm - �115
' 31 + �110
' Please also change the recommended install range in the calculated requirements of the 750mm to 200mm instead of 300mm
' The install range was changed in the "Install Range" attribute of the 750mm screw from 300 to 200.
Function CustomGetFittingCost(AAreaSQM)
Dim LPriceSQM
If AAreaSQM >= 31 Then
LPriceSQM = 110
ElseIf AAreaSQM >= 26 Then
LPriceSQM = 115
ElseIf AAreaSQM >= 17 Then
LPriceSQM = 120
Else
LPriceSQM = 135
End If
CustomGetFittingCost = AAreaSQM * LPriceSQM
End Function
' (SS,13/10/20)
Sub CustomHTMLCalcClear
Session("CustomHTMLCalc") = ""
End Sub
Function CustomGetHTMLCalc
CustomGetHTMLCalc = Session("CustomHTMLCalc")
End Function
' (SS,6/11/20)
Sub CustomSetHTMLCalc(AHTMLContent)
Session("CustomHTMLCalc") = AHTMLContent
End Sub
' (SS,13/10/20)
Sub CustomHTMLCalcAdd(AHTMLContent)
Session("CustomHTMLCalc") = Session("CustomHTMLCalc") & AHTMLContent & NL
End Sub
' (SS,6/11/20) adjust the CustomGetHTMLCalc HTML to make it more suitable for display in a HTML email
Sub CustomAdjustHTMLCalcForEmail
Dim Result
Result = CustomGetHTMLCalc
' add border to th and td
' adjust table style from Bootstrap 4 in browser to email
Result = ReplaceStr(Result, "<table class=""table"">", "<table style=""border-spacing: 0; border-collapse: collapse; padding: 10px; font-family: Arial, Helvetica, sans-serif;"" cellpadding=""10"">")
Result = ReplaceStr(Result, "<th style=""", "<th style=""border: 1px solid #CCC; ")
Result = ReplaceStr(Result, "<td style=""", "<td style=""border: 1px solid #CCC; ")
Result = ReplaceStr(Result, "<th>", "<th style=""border: 1px solid #CCC; text-align:left"">")
Result = ReplaceStr(Result, "<td>", "<td style=""border: 1px solid #CCC;"">")
' ??? to improve
'Result = ReplaceStr(Result, "<td colspan=""3"">", "<td colspan=""3"" style=""border: 1px solid #CCC;"">")
CustomSetHTMLCalc Result
End Sub
' (SS,26/8/19)
Function CustomGetScrewsRequired(ADistance, AScrewGap, AScrewAllowance)
Dim LResult, LQuotient, LRemainder
LQuotient = Int(ADistance / AScrewGap)
LRemainder = ADistance - (LQuotient * AScrewGap)
LResult = LQuotient + 1
' if remainder is larger than the allowance then add an extra one
If LRemainder > AScrewAllowance Then LResult = LResult + 1
'Response.Write("###Remainder: " & LRemainder & BR)
CustomGetScrewsRequired = LResult
End Function
' (SS,28/8/19) returns ProductID for given product type and up to 3 matching attributes
' (SS,26/5/20) added additional parameter called ANthRecord, which should be 1 in most cases to fetch first record, 2 to fetch 2nd record, 3 to fetch 3rd etc.
Function CustomGSCGetProductID(AProductType, AAttribute1Name, AAttribute1Value, AAttribute2Name, AAttribute2Value, AAttribute3Name, AAttribute3Value, ANthRecord)
Dim LSQL, LWhere, LProductID
LSQL = "SELECT p.ProductID " &_
"FROM products p " &_
"INNER JOIN product_attributes pa ON pa.ProductID = p.ProductID "
' create the where clause to find correct product with matching attributes
LWhere = "pa.AttributeID = '" & GetAttributeIDForName("Product Type") & "' AND pa.AttributeValue = '" & CleanSQLStr(AProductType) & "'"
If AAttribute1Name <> "" AND AAttribute1Value <> "" Then
LSQL = LSQL + "INNER JOIN product_attributes pa1 ON pa1.ProductID = p.ProductID "
LWhere = LWhere & " AND pa1.AttributeID = '" & GetAttributeIDForName(AAttribute1Name) & "' AND pa1.AttributeValue = '" & CleanSQLStr(AAttribute1Value) & "'"
End If
If AAttribute2Name <> "" AND AAttribute2Value <> "" Then
LSQL = LSQL + "INNER JOIN product_attributes pa2 ON pa2.ProductID = p.ProductID "
LWhere = LWhere & " AND pa2.AttributeID = '" & GetAttributeIDForName(AAttribute2Name) & "' AND pa2.AttributeValue = '" & CleanSQLStr(AAttribute2Value) & "'"
End If
If AAttribute3Name <> "" AND AAttribute3Value <> "" Then
LSQL = LSQL + "INNER JOIN product_attributes pa3 ON pa3.ProductID = p.ProductID "
LWhere = LWhere & " AND pa3.AttributeID = '" & GetAttributeIDForName(AAttribute3Name) & "' AND pa3.AttributeValue = '" & CleanSQLStr(AAttribute3Value) & "'"
End If
LSQL = LSQL &_
"WHERE ProductDisabled = False AND " &_
LWhere &_
"GROUP BY ProductID " &_
"ORDER BY SortOrder"
' (SS,26/5/20) added following to get nth record
LSQL = LSQL + " LIMIT 1 OFFSET " & ANthRecord - 1
' Response.Write LSQL & BR
CustomGSCGetProductID = GetSQLValueAsString(LSQL)
End Function
' (SS,28/8/19)
' (SS,13/10/20) modified to use CustomHTMLCalcAdd
' (SS,17/11/2020) added AForFitting to show different heading when full professional install
Sub CustomGSCTableHeader(AForFitting, ABuildName)
If Not FCustomForEmail Then ' (SS,5/11/20) don't show for email
CustomHTMLCalcAdd "<form action="""" method=""post"" name=""frmGroundScrewCalculator"">"
CustomHTMLCalcAdd "<input type=""hidden"" name=""BuildName"" value=""" & ABuildName & """>"
Else
' just add a break for email for separation, later changed to <p></p> because <br> ended up being too tall when <h1> or <h2> used
' (SS,17/11/20) tried various methods, nothing works for email
' CustomHTMLCalcAdd "<p style=""height:10px""> </p>"
' CustomHTMLCalcAdd "<div style=""margin-top:10px"">"
' (SS,18/11/20) finally managed to add a space between tables by adding another table
' NB. <td > with a space to prevent replacement in CustomAdjustHTMLCalcForEmail
' to increase the height use in the cell
CustomHTMLCalcAdd "<table>"
CustomHTMLCalcAdd "<tr><td ></td></tr>"
CustomHTMLCalcAdd "</table>"
End If
CustomHTMLCalcAdd "<table class=""table"">"
CustomHTMLCalcAdd "<tr>"
If AForFitting Then
CustomHTMLCalcAdd "<th>Description</th>"
Else
CustomHTMLCalcAdd "<th>Product</th>"
CustomHTMLCalcAdd "<th style=""text-align:right"">Qty</th>"
CustomHTMLCalcAdd "<th style=""text-align:right"">Each</th>"
End If
CustomHTMLCalcAdd "<th style=""text-align:right"">Total</th>"
CustomHTMLCalcAdd "</tr>"
End Sub
' (SS,28/8/19)
' returns false if item not in stock, true otherwise even if nothing selected
' ProductD of "" is allowed and ignore for convenience
' Added AIndex parameter to allow multiples for accessories, it's normally 1 for non-accessories
' (SS,10/6/20) added AShow parameter to allow not show for combined fitting line
Function CustomGSCProductLine(AProductType, AShow, AIndex, AProductID, AQty, ByRef ASubtotal)
Dim LResult
If AProductID <> "" Then
' (SS,6/11/20) modified to handle special case of "0" for accessories, to ensure hidden value with qty 0 is shown for accessories/additional items not ticked
If AProductID = "0" Then
LResult = True
Else
Dim LProductCode, LProductName, LPrice, LTotalPrice
LProductCode = GetFieldForProductID(AProductID, "ProductCode")
LProductName = GetFieldForProductID(AProductID, "ProductName")
LResult = GetPriceAndStockForProductID(AProductID, AQty, LPrice) ' false is returned if not enough in stock
LTotalPrice = LPrice * AQty
ASubtotal = ASubtotal + LTotalPrice
' LResults tells CustomGSCTableLine whether item in stock, and mark with * if not in stock
' (SS,10/6/20) added If AShow removed AProductType, AIndex, AProductID
If AShow Then
' (SS,11/12/20) added LProductCode
CustomGSCTableLine LProductCode, LProductName, AQty, CorrectCurrency(LPrice), CorrectCurrency(LTotalPrice), LResult
End If
End If
' (SS,10/6/20) separated from CustomGSCTableLine due to combined fitting line
CustomGSCProductValues AProductType, AIndex, AProductID, AQty
' If Not LResult Then Response.Write "###" & AProductType & "###" & BR
Else
LResult = True ' i.e. in stock, but nothing selected
End If
CustomGSCProductLine = LResult
End Function
' (SS,28/8/19)
' (SS,26/5/20) added AIndex parameter, also added HTMLEncode to AProductName
' (SS,10/6/20) separated input hidden to Sub CustomGSCProductValues, also modified to not show qty and price each if qty is 0
' also moved the red out of stock * from after qty to before product name (with a space)
' (SS,13/10/20) modified to use CustomHTMLCalcAdd
' (SS,11/11/20) added AProductCode to show a link to the product if applicable
' (SS,17/11/20) modified to remove colspan
Sub CustomGSCTableLine(AProductCode, AProductName, AQty, APrice, ATotalPrice, AInStock)
' (SS,30/6/20) added following to only HTML encode if the text doesn't already contain a tag (i.e. <)
Dim LDesc
LDesc = AProductName
If InStr(1, LDesc, "<") = 0 Then LDesc = HTMLEncode(LDesc)
' (SS,11/11/20) if product code defined then add a link, full link used because it needs to work from an email
If AProductCode <> "" Then
LDesc = "<a href=""" & GetFullProductLink(AProductCode) & """>" & LDesc & "</a>"
End If
CustomHTMLCalcAdd "<tr>"
CustomHTMLCalcAdd "<td>" & IIf(Not AInStock, "<span style=""color: red"">* </span>", "") & LDesc & "</td>"
If AQty <> 0 Then
CustomHTMLCalcAdd "<td style=""text-align:right"">" & AQty & "</td>"
CustomHTMLCalcAdd "<td style=""text-align:right"">" & APrice & "</td>"
End If
CustomHTMLCalcAdd "<td style=""text-align:right"">" & ATotalPrice & "</td>"
CustomHTMLCalcAdd "</tr>"
End Sub
' (SS,10/6/20) separated from CustomGSCTableLine, to allow a combined table line for fitting
' (SS,13/10/20) modified to use CustomHTMLCalcAdd *** not really applicable for email
Sub CustomGSCProductValues(AProductType, AIndex, AProductID, AQty)
If Not FCustomForEmail Then ' (SS,5/11/20) don't show for email
CustomHTMLCalcAdd "<input type=""hidden"" name=""" & AProductType & AIndex & "-ID"" value=""" & AProductID & """>"
CustomHTMLCalcAdd "<input type=""hidden"" name=""" & AProductType & AIndex & "-Qty"" value=""" & AQty & """>"
End If
End Sub
' (SS,28/8/19)
' (SS,13/10/20) modified to use CustomHTMLCalcAdd, *** form not applicable for email
' (SS,17/11/20) added AForFitting and adjust to remove the colspan="3" for AFitting
' (SS,18/11/20) added + VAT
Sub CustomGSCTableFooter(AForFitting, ASubtotal, AInStock)
CustomHTMLCalcAdd "<tr>"
CustomHTMLCalcAdd "<th>Subtotal</th>"
CustomHTMLCalcAdd "<th style=""text-align:right"""
If Not AForFitting Then CustomHTMLCalcAdd "colspan=""3"""
CustomHTMLCalcAdd ">" & ASubtotal & "<small> + VAT</small></td>"
CustomHTMLCalcAdd "</tr>"
CustomHTMLCalcAdd "</table>"
If Not AInStock Then
CustomHTMLCalcAdd "<p><span style=""color: red"">* Out of stock</span></p>"
End If
If Not FCustomForEmail Then ' (SS,5/11/20) not applicable for email
CustomHTMLCalcAdd "</form>"
'Else
' CustomHTMLCalcAdd "</div>" ' (SS,17/11/20)
End If
End Sub
' (SS,28/8/19)
' (SS,13/10/20) modified to use CustomHTMLCalcAdd
Sub CustomGSCAddToBasketButton
CustomHTMLCalcAdd " "
CustomHTMLCalcAdd "<button class=""btn btn-default btn-success mb-3"" onclick=""gscAddToBasket()"">Add to Basket <span class=""fa fa-shopping-cart""></span></button>"
End Sub
' (SS,11/11/20)
Sub CustomGSCInstallationInfo(AShow)
Dim LMethod
If AShow Then
LMethod = "show"
Else
LMethod = "hide"
End If
%>
<script>
$('#collapseInstallInfo').collapse('<%=LMethod%>');
</script>
<%
End Sub
' (SS,10/3/21)
Sub CustomGSCShowProfessionalTotalAlert(AShow)
If AShow Then
%>
<script>
$("#ProfessionalToolAlert").removeClass('d-none');
</script>
<%
Else
%>
<script>
$("#ProfessionalToolAlert").addClass('d-none');
</script>
<%
End If
End Sub
' (SS,15/10/20)
Sub CustomGSCEmailCalculationButton
' (SS,14/10/20) added Email Calculation button
' (SS,24/11/20) made smaller than add to basket button by removing btn-lg from class
CustomHTMLCalcAdd "<a href=""#modal-content-email-calculation"" role=""button"" class=""btn btn-success mb-3"" data-toggle=""modal"" title=""Click this button to email yourself or a friend a copy of this calculation"">Email Calculation</a>"
' CustomHTMLCalcAdd " "
End Sub
' (SS,10/11/20)
Sub CustomGSCRequestDetailsButton
' CustomHTMLCalcAdd " "
' CustomHTMLCalcAdd "<button class=""btn btn-default btn-success btn-lg"" onclick=""gscAddToBasket()"">Request Details & Availability</button>"
CustomHTMLCalcAdd "<a href=""#modal-content-email-request"" role=""button"" class=""btn btn-success btn-lg"" data-toggle=""modal"" title=""Click this button to email yourself or a friend a copy of this calculation"">Request Details & Availability</a>"
End Sub
' (SS,12/10/20) routine to save the build properties and the rendering HTML passed back
' ByRef used to pass back the values
' need to email this build info and populate the calculator with it via URL
' new field called Extras added to orders
' ALTER TABLE orders ADD COLUMN Extras MEDIUMTEXT COMMENT 'Added 12/10/2020';
' also added to saved_baskets table:
' ALTER TABLE saved_baskets ADD COLUMN Extras MEDIUMTEXT COMMENT 'Added 12/10/2020';
' *** may also need to add to saved_baskets table
' held in Session("Extras") until it's saved in basket
' also Session("CustomSaveBuildProperties") used to save the settings and HTML
' and Session("CustomSaveBuildHTMLResult")
' (SS,4/11/20) renamed from CustomSaveBuild to CustomSaveBuildSettings, modified to also save additional items
' (SS,11/11/20) added AToolType
Sub CustomSaveBuildSettings(ByRef AStructureType, ByRef ABaseType, ByRef AScrewLength, ByRef AJoistSize, ByRef ASecuringBrackets, ByRef AFittingOption, ByRef ALength, ByRef AWidth, ByRef AAdditionalLoads, ByRef AToolType)
' clear the previously saved properties
Session("CustomSaveBuildProperties") = ""
' (SS,13/10/20) get the values, also place in session variable
AStructureType = CustomSaveBuildProperty("StructureType", "")
ABaseType = CustomSaveBuildProperty("BaseType", "")
AScrewLength = CustomSaveBuildProperty("ScrewLength", "")
AJoistSize = CustomSaveBuildProperty("JoistSize", "")
ASecuringBrackets = CustomSaveBuildProperty("SecuringBrackets", "")
AFittingOption = CustomSaveBuildProperty("FittingOption", "")
ALength = CustomSaveBuildProperty("Length", "")
AWidth = CustomSaveBuildProperty("Width", "")
AAdditionalLoads = CustomSaveBuildProperty("AdditionalLoads", "") ' was added on (SS,26/5/20)
AToolType = CustomSaveBuildProperty("ToolType", "") ' (SS,11/11/20)
' (SS,4/11/20)
' the additional items
' *** perhaps change product1...x to additionalitem1...x
' *** need a maximum item or count value as well passed on from form
' (SS,26/5/20) added the selected additional items
' (SS,30/5/20) added if to only add if fitting not chosen
' If Not LFittingChosen Then
Dim i, LValue
i = 0
Do
i = i + 1
LValue = CleanSQLStr(Request.QueryString(ADDITIONAL_ITEM_NAME & i))
If LValue <> "" Then
If LValue <> "false" Then ' i.e. the product ID
'LInStock = LInStock And CustomGSCProductLine(PT_ACCESSORY, True, i, CLng(LValue), 1, ASubtotal)
CustomSaveBuildProperty ADDITIONAL_ITEM_NAME, LValue & ", " & GetProductNameForProductID(LValue)
End If
End If
Loop Until LValue = ""
' End If
End Sub
' (SS,4/11/20) returns the settings previously saved by CustomSaveBuildSettings
Function CustomGetBuildSettings
CustomGetBuildSettings = Session("CustomSaveBuildProperties")
End Function
' (SS,12/10/20)
' *** to use the special form checker to prevent script injection?
' (SS,4/11/20) added AValue which can be "" to get value from QueryString specified in AName, if not "" then this value is used
Function CustomSaveBuildProperty(AName, AValue)
Dim Result
If AValue = "" Then
Result = Request.QueryString(AName)
' (SS,6/11/20) special value to which we had delimiters because it's across many lines and will be retrieved later for including in order confirmation emails
ElseIf AName = "HTMLForEmail" Then
Result = NL & "<START_HTML>" & NL
Result = Result & AValue & NL
Result = Result & "<END_HTML>" & NL
Else
Result = AValue
End If
' add to end of session variable
Session("CustomSaveBuildProperties") = Session("CustomSaveBuildProperties") & IIf(Session("CustomSaveBuildProperties") = "", "", NL) & AName & "=" & Result
CustomSaveBuildProperty = Result
End Function
' (SS,15/10/20) Hook into TryProcessOrder to save extra details i.e. build details into order record
' AType "O" for saving in order record, in which case AExtras is blank
' AType "E" for rendering in email order confirmation, AExtras is set to value in the Extras field
Function CustomGetExtras(AType, AExtras)
Dim Result, i
Result = ""
If AType = "O" Then
' for each build that's set up and added to basket
If Session("GroundScrewBuildNo") <> "" Then
Dim LBuildProperties
For i = 1 To Session("GroundScrewBuildNo")
' *** Result = Result Build No
' LBuildValue = Session("CustomBuild" & CustomGetBuildNo & "Properties")
' LSessionValueName = "CustomBuild" & CustomGetBuildNo & "Properties"
' Result = Result & Session("CustomBuild" & CustomGetBuildNo & "Properties") & NL
LBuildProperties = CustomGetBuildProperties(i)
If LBuildProperties <> "" Then
Result = Result & "[" & CustomGetGSCOptionTitle & "]" & NL ' i.e. [Build]
Result = Result & CustomGetBuildProperties(i) & NL
Result = Result & NL
End If
Next
End If
ElseIf AType = "E" Then
'Result = AExtras ' *** just return the field for now
' (SS,6/11/20) replaced above with following to create more suitable content for the order confirmation email
Dim LLines, LLine, LPos, LName, LValue, LInHTML
LLines = Split(AExtras, NL, -1, 0)
LInHTML = False
For i = 0 To UBound(LLines)
LLine = LLines(i)
LPos = InStr(LLine, "=")
If Not LInHTML And LPos > 0 Then
LName = Mid(LLine, 1, LPos - 1)
LValue = Mid(LLine, LPos + 1, 999)
If LName <> "" Then
' get the build name to show as a heading
If LName = "Name" Then
Result = Result & NL & "<h2>" & LValue & "</h2>" & NL
ElseIf LName = "HTMLForEmail" Then
LInHTML = True
End If
End If
ElseIf LInHTML Then ' we're in HTML, just keep adding until <END_HTML> found, <START_HTML> is just ignored
If LLine = "<END_HTML>" Then
LInHTML = False ' get out of HTML mode
ElseIf LLine <> "<START_HTML>" Then ' add the line
Result = Result & LLine & NL
End If
End If
Next
' if build found then prefix with a title
If Result <> "" Then Result = "<h1>Your Build Details<h1>" & NL & Result
End If
CustomGetExtras = Result
End Function
' (SS,6/11/20) after the order is completed, the values held in session need to be clear read for next session
' This routine will be called, to ensure the same values don't get used again for the next order
Function CustomClearExtras
' clear the build properties
If Session("GroundScrewBuildNo") <> "" Then
Dim i
For i = 1 To Session("GroundScrewBuildNo")
CustomSetBuildProperties i, ""
Next
End If
' celar the build no
CustomClearBuildNo
End Function
' (SS,16/10/20)
Function CustomGetBuildSessionName(ABuildNo)
CustomGetBuildSessionName = "CustomBuild" & ABuildNo & "Properties"
End Function
' (SS,15/10/20) add to session variable to save to order later
' (SS,16/10/20) called after adding build to basket to save for using in order / extras field
Sub CustomAddNewBuildProperties
CustomSetBuildProperties CustomGetBuildNo, Session("CustomSaveBuildProperties")
End Sub
' (SS,16/10/20)
Function CustomGetBuildProperties(ABuildNo)
CustomGetBuildProperties = Session(CustomGetBuildSessionName(ABuildNo))
End Function
' (SS,16/10/20)
' (SS,6/11/20) can also be called with AValues set to "" to clear the values
Sub CustomSetBuildProperties(ABuildNo, AValues)
' add the name of this build which includes the build no, gets from CustomGetGSCOptionValue, only if AValues isn't blank
Dim LValues
LValues = AValues
If LValues <> "" Then
LValues = "Name=" & CustomGetGSCOptionTitle & ": " & CustomGetGSCOptionValue & NL & LValues
End If
' save in separate session variable
Session(CustomGetBuildSessionName(ABuildNo)) = LValues
End Sub
' (SS,2/11/20) no value is returned, not required, has to be a function to allow FunctionExists function to work
Function CustomRemoveItemsGroup(AOptionsList)
' Response.Write "###CustomRemoveItemsGroup: " & AOptionsList & BR
Dim LBuildNo
LBuildNo = ParseFirstInt(AOptionsList)
'Response.Write "###LBuildNo: " & LBuildNo & BR
CustomRemoveBuildProperties LBuildNo
End Function
' (SS,16/10/20)
Sub CustomRemoveBuildProperties(ABuildNo)
Session(CustomGetBuildSessionName(ABuildNo)) = ""
End Sub
' (SS,5/11/20)
Sub CustomCalculationSetRestore(ASettings)
Session("CustomCalculationRestore") = ASettings
End Sub
' (SS,5/11/20) allows a restore of calculation via Restore button in email, returns True if a restore was done
' it also sets up a javascript to do the restore
Function CustomCalculationDoRestore
Dim Result
Result = Session("CustomCalculationRestore") <> ""
If Result Then
' content below appears in javascript function gscOnLoad()
Dim LSettings, i, LLine, LPos, LName, LValue
LSettings = Split(Session("CustomCalculationRestore"), NL, -1, 0)
Response.Write(" var LAdditionalItems = [];") ' set up dynamic array
For i = 0 To UBound(LSettings)
LLine = LSettings(i)
LPos = InStr(LLine, "=")
If LPos > 0 Then
LName = Mid(LLine, 1, LPos - 1)
' (SS,6/11/20) abort if it reaches the HTMLForEmail name, which is HTML content not applicable here
If LName = "HTMLForEmail" Then Exit For
LValue = Mid(LLine, LPos + 1, 999)
If LName <> "" Then
' if name contains AdditionalItem then get the first integer from the value
If InStr(LName, "AdditionalItem") > 0 Then
LValue = ParseFirstInt(LValue)
Response.Write(" LAdditionalItems.push('" & LValue & "')") ' add to the array
Else
Response.Write(" var L" & LName & " = ")
Response.Write("'" & LValue & "'")
End If
Response.Write(";" & NL)
End If
End If
Next
End If
Session("CustomCalculationRestore") = "" ' clear so that no further restore is done
CustomCalculationDoRestore = Result
End Function
' (SS,4/11/20) called when user restores calculation, redirects to the calculation page and fills in the values
Function CustomRestoreBasketExtras(AExtras)
'Response.Write "### REACHED HERE !!! ###" & BR
'Response.Write ReplaceStr(AExtras, NL, BR)
CustomCalculationSetRestore AExtras
Response.Write "Calculation has been restored." & BR
SetPageRedirection "products.asp?page=calculator"
CustomRestoreBasketExtras = True ' True indicates to calling routine to exit because process has been done here
End Function
' -------------------------------- '
' End of Custom Ajax Routines '
' -------------------------------- '
' (SS,28/10/14) "P" for product page, "H" for home, AProductID is applicable
' call added to inc-template-product-details.asp and inc-template-home.asp
' also three tokens: Holiday Notice Radiators, Holiday Notice Other, Holiday Notice Home
' (SS,25/11/15) added "B" for "Holiday Notice Basket"
' (SS,14/10/16) added "C" for contact page
Sub CustomShowHolidayNotice(AType, AProductID)
Dim LProductType, LToken
If AType = "P" Then
LProductType = GetProductAttributeByName(AProductID, "Product Type")
If LProductType = "Radiator" Then
LToken = "Holiday Notice Radiators"
Else
LToken = "Holiday Notice Other"
End If
' (SS,25/11/15) added AType = "B"
ElseIf AType = "B" Then
LToken = "Holiday Notice Basket"
ElseIf AType = "C" Then ' (SS,14/10/16)
LToken = "Holiday Notice Contact"
Else
LToken = "Holiday Notice Home"
End If
If LToken <> "" Then
Dim LNotice, LStartDate, LEndDate, LPos
LNotice = ComposeDescription("{" & LToken & "}", False, False)
' get date range from first line
If Left(LNotice, 6) = "[DATE:" Then
LStartDate = Mid(LNotice, 7, 10)
LEndDate = Mid(LNotice, 18, 10)
' if not valid start date then default to a very early date
If IsDate(LStartDate) Then
LStartDate = CDate(LStartDate)
Else
LStartDate = CDate("01/01/2000")
End If
' if not valid end date then default to a very late date
If IsDate(LEndDate) Then
LEndDate = CDate(LEndDate)
Else
LEndDate = CDate("01/01/2200")
End If
' remove the date bit
LPos = InStr(LNotice, "]")
If LPos > 0 Then LNotice = Mid(LNotice, LPos + 1)
If LStartDate > Date() Or LEndDate < Date() Then LNotice = ""
End If
Response.Write LNotice
End If
End Sub
' (SS,4/5/18) to show discount messages from token, AType not used yet, perhaps "P" for product page
Sub CustomShowDiscountMessage(AType)
Dim LMessage
LMessage = ComposeDescription("{Bulk Discount}", False, False)
Response.Write LMessage
End Sub
' (SS,30/5/18) returns true if sale banner is applicable for given product, called from inc-template-product-details.asp and inc-template-product-list.asp
Function CustomIsSaleBannerApplicable(AProductID, ASalePrice)
CustomIsSaleBannerApplicable = ASalePrice <> ""
End Function
' (SS,30/5/18) returns sale banner text, called from inc-template-product-details.asp and inc-template-product-list.asp
Function CustomGetSaleBannerText
CustomGetSaleBannerText = "Sale"
End Function
' (SS,7/10/20)
Function CustomBasketItemChangeAllowed(AProductID, AProductCode, AProductName, AOptionsList, AQty)
Dim Result
Result = InStr(1, AOptionsList, CustomGetGSCOptionTitle + ": ", vbTextCompare) = 0 ' CustomGetGSCOptionTitle is "Build"
' Response.Write "###" & AOptionsList & "###"
CustomBasketItemChangeAllowed = Result
End Function
' (SS,8/10/20)
Function CustomBasketItemGroupIsFirst(ProductID, AProductCode, AProductName, AOptionsList, AQty)
Dim Result, LCustomGroupName
LCustomGroupName = AOptionsList
Result = FCustomGroupNamePrev <> LCustomGroupName
FCustomGroupNamePrev = LCustomGroupName
CustomBasketItemGroupIsFirst = Result
End Function
' (SS,27/10/20) returns true if given category is a special one for case studies or testimonials with hidden / disabled products
Function CustomIsSpecialCategory(ACategory)
Dim Result, LCategory
LCategory = LCase(ACategory)
Result = LCategory = "case studies" Or LCategory = "testimonials"
If Result Then DisableProductNavigation ' disable the product navigation for special category, not applicable
CustomIsSpecialCategory = Result
End Function
' (SS,30/10/20)
Function CustomGetWebTextOld(AName, AOptions)
Dim Result
Result = "AName: " & AName & BR
Result = Result + "AOptions: " & AOptions & BR
Dim LProductID, LProductCode, LProductName, LProductDescription, LDimensions
' start product list, repeat until no more or max reached
StartSpecialProductList "Testimonials", "", ""
Do While Not EndOfSpecialProductList
' following also does a next record
GetSpecialProductListItem LProductID, LProductCode, LProductName, LProductDescription, LDimensions
Result = Result + "<div>"
Result = Result + "<h4>" & HTMLEncode(LProductName) & "</h4>" & NL
Result = Result + "<img class=""product-list-item-image img-fluid"" src=""" + GetProductImageLink(LProductCode, "l") + """ width=""300"">"
'Result = Result + HTMLEncode(LProductDescription) & NL
Result = Result + LProductDescription & NL
Result = Result + "</div>"
NextSpecialProductList
Loop
CloseSpecialProductList
CustomGetWebText = Result
End Function
' (SS,30/10/20)
Function CustomGetWebText(AName, AOptions)
Dim Result, LParameters, LMaxToShow, LSortOrderToShow
'Result = "AName: " & AName & BR
'Result = Result + "AOptions: " & AOptions & BR
' first parameter is the count, second is sort order, assume -1 if not set
LParameters = Split(AOptions, ",")
LMaxToShow = -1
LSortOrderToShow = -1
If UBound(LParameters) >= 0 Then LMaxToShow = ParseInt(Trim(LParameters(0)))
If UBound(LParameters) >= 1 Then LSortOrderToShow = ParseInt(Trim(LParameters(1)))
'Result = Result + "LMaxToShow: " & LMaxToShow & BR
'Result = Result + "LSortOrderToShow: " & LSortOrderToShow & BR
Dim LProductID, LProductCode, LProductName, LProductDescription, LDimensions, LCount, LSortOrder
' start product list, repeat until no more or max reached
LCount = 0
' (SS,13/11/20) replaced "Testimonials" with "Case Studies"
StartSpecialProductList "Case Studies", "", ""
Do While Not EndOfSpecialProductList
' get the product details
GetSpecialProductListItem LProductID, LProductCode, LSortOrder, LProductName, LProductDescription, LDimensions
' if sort order to show is set then only do the following if it matches
If LSortOrderToShow = -1 Or LSortOrderToShow = LSortOrder Then
Result = Result + "<div class=""row"">"
Result = Result + "<div class=""span-testimonial"">"
' Result = Result + "<img class=""img-right img-fluid "" src=""" + GetProductImageLink(LProductCode, "l") + """ width=""350"">"
' float right if medium size port or higher, prevents unideal word wrap on small port
Result = Result + "<a href=""" & GetProductLink(LProductCode) & """><img class=""float-md-right"" src=""" + GetProductImageLink(LProductCode, "l") + """ width=""350""></a>"
'LProductName = ReplaceStr(HTMLEncode(LProductName), " ", " ")
Result = Result + "<div><h3>" & HTMLEncode(LProductName) & "</h3></div>"
' Result = Result + "<div><h3>" & LProductName & "</h3></div>"
If LDimensions <> "" Then
Result = Result + "<h4>Size: " & LDimensions & "</h4>"
End If
Result = Result + "<blockquote>" & ComposeDescription(LProductDescription, False, False) & "</blockquote>"
Result = Result + "</div>"
Result = Result + "</div>"
LCount = LCount + 1
' exit if maximum to show reached
If LMaxToShow <> -1 And LCount = LMaxToShow Then Exit Do
End If
NextSpecialProductList
Loop
CloseSpecialProductList
CustomGetWebText = Result
End Function
%>