File: D:/web/castironradiatorcentre/changes prev/2020-10-02/new/customutils.asp
<%
' ===============
' customutils.asp
' ===============
' Version 1.56 (02/10/20)
' ============
' HISTORY
' ============
' (SS,21/10/08) First created
' (SS,12/01/10) Eire moved to region 3 and Mainland Europe to region 4
' (SS,04/10/11) Added door delivery cost
' (SS,19/07/11) Custom radiator builder AJAX routines
' (SS,18/04/12) Adjustments to radiator/pallet delivery, especially using postcodes for Scotland
' (SS,01/05/12) Further adjustments to Scottish postcodes, misunderstood original requirement, not specified accurately
' (SS,17/01/13) Added custom page content routines for third party SEO company, to get content from table provided
' (SS,06/02/13) Added Pipe Shrouds to radiator builder Ajax code
' (SS,19/02/13) Added GetCustomXMLSitemap
' (SS,20/05/13) Added Sub CustomShowPricePerSection to show price per section for radiators
' (SS,11/07/13) Correction to Sub CustomAjaxSelections, to add paint finish price to subtotal
' (SS,22/08/14) Added Function CustomGetTableHTML
' (SS,09/10/14) Added Function CustomGetOrderDeliveryInfo
' (SS,17/10/14) Changes to delivery text in CustomGetDeliveryDays. Added CustomCompareDeliveryDays.
' (SS,26/11/14) Adjusted days in function CustomGetDeliveryDays
' (SS,28/11/14) Added Sub CustomShowHolidayNotice(AType, AProductID) for holiday notices
' (SS,09/12/14) Added AByPriceDeliveryCost, AByWeightDeliveryCost to CustomGetDelivery to make compatible with latest apputils
' (SS,17/12/14) Change to Function CustomProductInBasket to determine whether there is an oversize radiator, also change to Function CustomGetDelivery to increase delivery by �20 for oversize radiator. Also added Function CustomSiteIsCIRC.
' (SS,16/01/15) Change to CustomGetDelivery, removed postcode code, ARegionCode supplied now is determined from new delivery_postcodes table for UK, no UK country variations due to PayPal Express integration
' (SS,11/02/15) Change to Function CustomGetDelivery, different zones for normal delivery, if radiator (pallet) then pallet postcode region is looked up and used for delivery calculation
' (SS,26/02/15) Change to Function CustomPageExists to fix error found in IIS log
' (SS,01/03/15) Change to CustomGetProductOptionLabelHTML to remove empty H4 tags, replaced with p because spacing was required
' (SS,06/05/15) Change to CustomGetDelivery, adjusted delivery cost for doors from 10 to 25, and max from 60 to 100
' (SS,03/06/15) Change to CustomGetDeliveryDays, added "Delivery Extended Lead Time" attribute which is used to override the normal delivery days
' (SS,01/10/15) Change to CustomGetDeliveryDays, change "Anticipated delivery" to "Anticipated despatch", also changed "delivered" to "sent" in CustomAjaxProductPrice
' (SS,15/10/15) Changes to CustomGetPageContent to add regional pages, converting CovDem to CIRC
' (SS,23/11/15) Changed to Function CustomGetProductOptionHTML to remove the quicker stock sizes for black primer / gun metal (requested by Tina)
' (SS,25/11/15) added "B" for "Holiday Notice Basket" to Sub CustomShowHolidayNotice
' (SS,18/12/15) Change to Function CustomGetTitleTagForPage to convert CovDem to CIRC in page title
' (SS,27/01/16) Added Function CustomGoogleShoppingProductAdjust which is called from Sub DoGoogleShoppingDataFeed in apputils.asp
' (SS,19/02/16) Added function CustomPriceAdjust and CustomGetSections for minimum price in rich snippets which matches Google Shopping
' (SS,09/03/16) Added some footer text to Function CustomGetTableHTML
' (SS,17/05/16) Change to functions CustomGetOptionsPriceAndWeight and CustomGetPaintFinishPrice, to returns correct price for non-radiator products to allow use of custom option with colour combo/image picker
' (SS,24/08/16) Added Touch Up Paint to CustomRecommendToBuy, new product type "Touch Up Paint" added to Product Type attribute
' (SS,14/10/16) Change to CustomShowHolidayNotice to added type "C" for contact page
' (SS,25/11/16) Change to function CustomGetDeliveryDays to add extra text to delivery info after certain dates, had to restructure the orders able to increase DeliveryInfo field from VARCHAR(100) to VARCHAR(255)
' (SS,13/01/17) Change to paint finish prices from 16/1/17 onwards (Function CustomGetPaintFinishPrice)
' (SS,28/03/17) Added Function CustomGetPriceWithoutOptions, changes to CustomGetOptionsPriceAndWeight for local mode exchange pricing
' (SS,01/06/17) Added functions CustomIsSaleBannerApplicable and CustomGetSaleBannerText to determine whether to show banner if applicable on product list and detail pages
' (SS,23/06/17) Change to Function CustomGetDelivery to set correct delivery for new country Channel Islands where VAT isn't charged. Need to come up with a correct postcode delivery solution with UK as country.
' (SS,03/08/17) Change to Function CustomGetPaintFinishPrice, changed price from 3.75 to 4.25 per section
' (SS,10/01/18) Change to Function CustomGetPaintFinishPrice, changed price from 4.25 to 4.50 per section (to take effect on 11/1/2018)
' (SS,21/08/18) Added Function CustomCheckSMS for SMS messages
' (SS,01/08/18) Added Function CustomAddMoreOptionsInfo(AProductID, AOptionsList) to return more info in basket and email confirmation
' (SS,18/10/18) v1.40 To 7/11/18, Added subproduct routines:
' Function CustomAddSubproductsToBasket, Sub CustomGetLegMidSections, Sub CustomAddSubproductToBasket
' Function CustomGetSubproductIDForSection, Sub CustomCreateSubproductRecordsForExistingOrders, Sub CustomAddSubproductToOrderDetail
' (SS,12/12/18) Changed to Function CustomGetPaintFinishPrice to apply price increase from 4.50 to 5.00 on and after 17/12/2018
' (SS,28/02/19) Change to Sub CustomAjaxProductPrice also added CustomGetHeatOutputInfo. To show heat output line. Added Delta T50 to function CustomGetTableHTML
' (SS,01/03/19) Renamed CustomBTUTokW to CustomerBTUToW, replaced kW with W
' (SS,10/05/19) Replaced W with Watts due to customers confusing W with Width (in a few places where CustomerBTUToW is used)
' (SS,14/05/19) Change to Function CustomGetDelivery to check postcodes for Channel Islands.
' (SS,23/10/19) Change to Function GetCustomHTMLSitemap to space out the regions to fix issue shown by Google Search Console.
' (SS,20/03/20) Changed to Sub CustomGetProductSettings to added AWaterContent. New attribute was added to radiators called "Water Content" shown in specification
' (SS,24/03/20) Added Function CustomOrderingSuspended to check it's a radiator
' (SS,26/03/20) Added Function CustomMailshotGetSQL for mailshots
' (SS,03/04/20) Temporary removal of linen white
' (SS,03/04/20) Added Function CustomFinalise for sticky important notice button for coronavirus
' (SS,06/04/20) Function CustomFinalise, made button bigger and brighter
' Modified Function CustomOrderingSuspended to AProductID paramater
' (SS,16/04/20) Modified Function CustomGetPaintFinishPrice to apply price increase from 5.00 to 5.50 on and after 17/04/2020
' (SS,21/05/20) Added linen white back in
' (SS,12/06/20) Removed linen white via change to Function CustomGetProductOptionHTML
' (SS,21/09/20) Change to function CustomGetSections(AProductID) to go back to single section price for Google Shopping and Rich Snippets,
' Google Merchant Centre not liking 3 section price (see email received from them on 10/9/2020)
' (SS,02/10/20) Changes to Function CustomOrderingSuspended to handle special case with AProductID equal to 0.
' Where it checks for existence of any suspended products in basket (used at checkout to fix loophole)
' (SS,9/9/14) constants for paint finish options
Const PF_BLACK_PRIMER = "Black Primer"
Const PF_MATT_BLACK = "Matt Black" ' (SS,26/4/16)
Const PF_GUNMETAL_GREY = "Gunmetal Grey"
Const PF_SATIN_BLACK = "Satin Black"
Const PF_LINEN_WHITE = "Linen White"
Const PF_CREAM_WHITE = "Cream White"
Const PF_ANTIQUE_BRONZE = "Antique Bronze"
' (SS,10/10/14) added following constants for product types
Const PT_RADIATOR = "Radiator"
Const PT_VALVE_SET = "Valve Set"
Const PT_WALL_STAY = "Wall Stay"
Const PT_PIPE_SHROUDS = "Pipe Shrouds"
Const PT_TOUCH_UP_PAINT = "Touch Up Paint" ' (SS,24/8/16)
' (SS,10/10/14) added following class to store temporary values used by this unit/module for recommending products to buy
' (SS,24/8/16) added TouchUpPaintNeeded
Class CustomRecommendToBuy
Private FValvesNeeded, FStaysNeeded, FShroudsNeeded, FTouchUpPaintNeeded
Private Sub Class_Initialize()
FValvesNeeded = 0
FStaysNeeded = 0
FShroudsNeeded = 0
FTouchUpPaintNeeded = 0
End Sub
Private Sub Class_Terminate()
End Sub
Public Sub AddProduct(AProductType, AQty, ASections)
If AProductType = PT_RADIATOR Then
AddRadiator AQty, ASections
ElseIf AProductType = PT_VALVE_SET Then
AddValve AQty
ElseIf AProductType = PT_WALL_STAY Then
AddStay AQty
ElseIf AProductType = PT_PIPE_SHROUDS Then
AddShroud AQty
' (SS,24/8/16) added touch up paint
ElseIf AProductType = PT_TOUCH_UP_PAINT Then
AddTouchUpPaint AQty
End If
End Sub
Private Sub AddRadiator(AQty, ASections)
FValvesNeeded = FValvesNeeded + AQty
FShroudsNeeded = FShroudsNeeded + AQty
If CInt(ASections) >= 11 Then
FStaysNeeded = FStaysNeeded + AQty * 2
Else
FStaysNeeded = FStaysNeeded + AQty
End If
FTouchUpPaintNeeded = 1 ' (SS,24/8/16) just one required for whole order
End Sub
Private Sub AddValve(AQty)
FValvesNeeded = FValvesNeeded - AQty
End Sub
Private Sub AddStay(AQty)
FStaysNeeded = FStaysNeeded - AQty
End Sub
Private Sub AddShroud(AQty)
FShroudsNeeded = FShroudsNeeded - AQty
End Sub
Private Sub AddTouchUpPaint(AQty)
FTouchUpPaintNeeded = FTouchUpPaintNeeded - AQty
End Sub
Public Property Get Required()
' (SS,24/8/16) added FTouchUpPaintNeeded
Required = FValvesNeeded > 0 Or FStaysNeeded > 0 Or FShroudsNeeded > 0 Or FTouchUpPaintNeeded > 0
End Property
Public Property Get ValvesNeeded()
ValvesNeeded = FValvesNeeded
End Property
Public Property Get StaysNeeded()
StaysNeeded = FStaysNeeded
End Property
Public Property Get ShroudsNeeded()
ShroudsNeeded = FShroudsNeeded
End Property
' (SS,24/8/16)
Public Property Get TouchUpPaintNeeded()
TouchUpPaintNeeded = FTouchUpPaintNeeded
End Property
End Class
' (SS,17/12/14) added FCustomOversizeRadiator
Dim oCustomRecommendToBuy, FCustomOversizeRadiator
' (SS,10/10/14)
Function CustomInitialise
' create the CustomRecommendToBuy object used to work out recommendations depending on what customer has in basket
Set oCustomRecommendToBuy = New CustomRecommendToBuy
FCustomOversizeRadiator = False ' (SS,17/12/14)
End Function
' (SS,10/10/14)
Function CustomFinialise
' destroy the object created in CustomInitalise
Set oCustomRecommendToBuy = Nothing
End Function
' (SS,17/12/14) returns True for CIRC, False for CovDem to use to keep the same CustomGetDelivery function the same for both sites
Function CustomSiteIsCIRC
CustomSiteIsCIRC = True
End Function
' this routine must exist if CustomDeliveryEnabled, -1 is returned if delivery cost could not be determined, user should be alerted using SetAlertMessage
' (SS,9/12/14) added AByPriceDeliveryCost, AByWeightDeliveryCost to make compatible with latest apputils
' (SS,16/1/15) simplified by removing the postcode code, new delivery_postcodes table now determines ARegionCode using postcode for UK, PayPal Express only has one UK country (no variations)
' (SS,11/2/15) modified radiator delivery cost to use postcode for pallet using GetDeliveryRegionFromPostcode, postcode zones are different for pallets
' (SS,6/5/15) adjusted delivery cost for doors from 10 to 25, and max from 60 to 100
' (SS,14/5/19) change to check postcodes for Channel Islands
Function CustomGetDelivery(ATotalValue, AValueOfNonWeightedGoods, ATotalWeight, AVATContent, ATotalItems, ANormalDeliveryCost, AByPriceDeliveryCost, AByWeightDeliveryCost, APostcode, ARegionCode, ADeliveryRegion, ACountry)
Dim LDelivery, LMinPrice, LFactor, LFixedPrice
' calculate delivery price for radiators, by counting number of radiators ordered (product names containing the word "radiator")
Dim LRadiators, LRadiatorDeliveryCost
LRadiators = GetFlaggedItemsInBasket(True) ' was GetProductNameTokensInBasket("radiator")
LRadiatorDeliveryCost = 0
If LRadiators > 0 Then
' following table used
' No of Mainland England, Wales and Scottish postcodes Scottish postcodes Northern Ireland
' Radiators DG, EH, FK, G, KA, KY, ML, PA 1-19, TD AB, DD, IV, KW, ND, PA 20+, PH & Dublin
' 1-3 45 58 68
' 4-7 47.50 68 75
' 8+ 50 78 85
' Other areas, i.e. For Isle of Man,Isle of White PO 30 � 41,Channel Islands,Rest of EIRE,Rest of EUROPE: Rates on Request
' (SS,7/11/08) changed to
' No of Mainland England, Northern Ireland Isle of Man, Isle of Wight PO30-41
' Radiators Wales and Scottish & Eire Channel Islands, Mainland Europe
' 1-3 45 68 105
' 4-7 50 75 130
' 8+ 65 85 169
' determine regions 1 to 4
' UK (England)
Dim LRegionIndex
' (SS,18/4/12) postcode split code moved here from ElseIf ACountry = "Isle of Wight", now used for "UK (Scotland)", also added UK (Offshore) which people might choose if isles off Scotland
' (SS,16/01/15) simplified, postcode now determines region from new delivery_postcodes table, not country, because UK country variations no longer used
' removed hardcoded postcode code
' (SS,11/2/15) postcode is now used to determine region code from delivery_postcodes table Group Name "Pallet"
' also replaced UK2 with R2 and EU with R3, added "Republic of Ireland" to "R3"
Dim LDeliveryRegionCode, LCountryISOCode
LCountryISOCode = GetCountryISOCode(ACountry)
If LCountryISOCode = "GB" Then ' i.e. UK
' (SS,23/6/17) added following for Channel Islands, quick fix, proper fix via postcode to be implemented ***
' (SS,14/5/19) removed following to also check the delivery post code
'If ACountry = "Channel Islands" then
' LDeliveryRegionCode = "R3"
'Else ' (SS,23/6/17) as before
LDeliveryRegionCode = GetDeliveryRegionFromPostcode(APostcode, "Pallet")
'End If
ElseIf LCountryISOCode = "IE" Then ' i.e. "Republic of Ireland"
LDeliveryRegionCode = "R3"
Else
LDeliveryRegionCode = ""
End If
' (SS,11/2/15) replaced ARegionCode with LDeliveryRecordCode
If LDeliveryRegionCode = "UK" Then
LRegionIndex = 1
ElseIf LDeliveryRegionCode = "R2" Then
LRegionIndex = 2
ElseIf LDeliveryRegionCode = "R3" Then
LRegionIndex = 3
Else ' i.e. "" or R4
LRegionIndex = 4
End If
' if LRegionIndex is 4 then notify that they need to phone for delivery cost
If LRegionIndex = 4 Then
' (SS,12/2/10) added order email
' SetAlertMessage("Please phone or email us for radiator delivery cost")
' (SS,18/4/12) replaced above with following
SetAlertMessage("Please contact us for delivery quote")
CustomGetDelivery = -1
Exit Function
End If
Dim LDeliveryArray(3, 3) ' I'm ignoring the 0 elements, easier this way
LDeliveryArray(1, 1) = 45
LDeliveryArray(1, 2) = 50
LDeliveryArray(1, 3) = 65
LDeliveryArray(2, 1) = 68
LDeliveryArray(2, 2) = 75
LDeliveryArray(2, 3) = 85
LDeliveryArray(3, 1) = 105
LDeliveryArray(3, 2) = 130
LDeliveryArray(3, 3) = 169
' (SS,17/12/14) added following, 0 element (Radiator Index 0) now holds the oversize charge for each region
LDeliveryArray(1, 0) = 20
LDeliveryArray(2, 0) = 20
LDeliveryArray(3, 0) = 40
Dim LRadiatorIndex
If LRadiators <= 3 Then
LRadiatorIndex = 1
ElseIf LRadiators <= 7 Then
LRadiatorIndex = 2
Else
LRadiatorIndex = 3
End If
LRadiatorDeliveryCost = LDeliveryArray(LRegionIndex, LRadiatorIndex)
' (SS,17/12/14) if oversize then add the oversize cost
' CovDem and CIRC have different attributes because Sections is an option in CIRC
If Not CustomSiteIsCIRC Then FCustomOversizeRadiator = GetAttributeInBasketCount("Oversize Radiator", "") > 0
If FCustomOversizeRadiator Then LRadiatorDeliveryCost = LRadiatorDeliveryCost + LDeliveryArray(LRegionIndex, 0)
End If
' (SS,4/10/11) delivery calculation for doors
Dim LDoors, LDoorDeliveryCost
LDoors = GetAttributeInBasketCount("Product Type", "Door")
' (SS,3/2/12) amended LDoors from 4 to 6
' (SS,6/5/15) amended from 10 to 25 per door
' (SS,6/5/15) replaced previous code (If statement) with following, now 25 per month with max cap of �100
LDoorDeliveryCost = Min(LDoors * 25, 100)
' delivery price is the maximum of delivery cost of normal items and radiator delivery cost, and now also door delivery cost
' CustomGetDelivery = Iif(ANormalDeliveryCost > LRadiatorDeliveryCost, ANormalDeliveryCost, LRadiatorDeliveryCost)
' (SS,4/10/11) replaced above with following to take into account LDoorDeliveryCost as well
CustomGetDelivery = Max(Max(ANormalDeliveryCost, LRadiatorDeliveryCost), LDoorDeliveryCost)
End Function
' -------------------------------- '
' Start of Custom Ajax Routines '
' Used by Radiator builder '
' (SS,19/7/11) '
' -------------------------------- '
' (SS,19/7/11)
Sub CustomAjax(AOptions)
If AOptions = "selections" Then
CustomAjaxSelections
ElseIf AOptions = "radiatorinfo" Then
CustomAjaxRadiatorInfo
ElseIf AOptions = "addtobasket" Then
CustomAjaxAddToBasket
ElseIf AOptions = "shoppingstatus" Then
ShowShoppingStatusSummary
' (SS,1/9/14) return the total price and delivery
ElseIf AOptions = "productprice" Then
CustomAjaxProductPrice
End If
End Sub
' (SS,20/7/11)
Sub CustomAjaxAddToBasket
CustomIncRBCounter ' increment build number
CustomAddToBasket "Radiator"
CustomAddToBasket "Wall Stay"
CustomAddToBasket "Valve Set"
CustomAddToBasket "Pipe Shrouds" ' (SS,6/2/13)
End Sub
Sub CustomIncRBCounter
If Session("RadiatorBuild") = "" Then Session("RadiatorBuild") = 0
Session("RadiatorBuild") = Session("RadiatorBuild") + 1
End Sub
Function CustomGetRBOptionTitle
Const RB_SHORT_TITLE = "Rads & Add-ons"
CustomGetRBOptionTitle = RB_SHORT_TITLE
End Function
' returns option value used by every item added to basket, numbers 1 to 26 are A to Z, > 27 returned as number
Function CustomGetRBOptionValue
Dim LNo, LResult
LNo = Session("RadiatorBuild")
If LNo >= 1 And LNo <= 26 Then
LResult = Chr(Asc("A") + LNo - 1)
Else
LResult = CStr(LNo)
End If
CustomGetRBOptionValue = LResult
End Function
Function CustomAddToBasket(AFormElement)
Dim LResult, LProductID, LQty
LResult = False
LProductID = Request.Form(AFormElement)
LQty = 1
If LProductID <> "" 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) = CustomGetRBOptionTitle
LValues(0) = CustomGetRBOptionValue
' get the option id and option value id for finish
If AFormElement = "Radiator" Then
Dim LPaintFinish, LProductOptionID, LProductOptionValueID
LPaintFinish = Request.Form("Paint Finish")
If GetIDsForProductOptionValue(LProductID, LPaintFinish, LProductOptionID, LProductOptionValueID) Then
ReDim Preserve LOptions(UBound(LOptions) + 1), LValues(UBound(LValues) + 1)
LOptions(UBound(LOptions)) = LProductOptionID
LValues(UBound(LValues)) = LProductOptionValueID
Else
LResult = False
End If
ElseIf AFormElement = "Wall Stay" Then
' lookup number of wall stays for radiator
LQty = CustomGetWallStays(Request.Form("Radiator"))
End If
End If
If LResult Then ProcessAddToBasketForOptions LProductCode, LQty, False, LOptions, LValues
End If
CustomAddToBasket = LResult
End Function
' (SS,20/7/11) was looking up the wall stay, but changed to 1 as a default
Function CustomGetWallStays(AProductID)
' Dim LQty
' If AProductID <> "" Then
' LQty = GetProductAttributeByName(AProductID, "Wall Stays Recommended")
' If LQty = "" Then
' LQty = 1
' Else
' NZ(LQty)
' End If
' Else
' LQty = 1
' End If
' CustomGetWallStays = LQty
CustomGetWallStays = 1
End Function
' (SS,19/7/11)
Sub CustomAjaxRadiatorInfo
Dim LProductID
LProductID = Request.Form("Radiator")
If LProductID <> "" Then
Dim LProductCode
LProductCode = GetProductCodeForProductID(LProductID)
If LProductCode <> "" Then
%>
<div style="float: left; border-right: 1px solid #CCC">
<a href="<%=GetProductLink(LProductCode)%>"><%=GetProductImgSrc(LProductCode, "s", "click for more details", "", 125, "t")%></a>
</div>
<table class="rb-table" style="font-size: 10px">
<%
CustomRadiatorAttributeRow LProductID, "Sections", "", ""
CustomRadiatorAttributeRow LProductID, "Columns", "", ""
CustomRadiatorAttributeRow LProductID, "Height", "", "mm"
CustomRadiatorAttributeRow LProductID, "Length", "", "mm"
CustomRadiatorAttributeRow LProductID, "Depth", "", "mm"
CustomRadiatorAttributeRow LProductID, "BTU Rating", "BTU", ""
Dim LBTU
LBTU = GetProductAttributeByName(LProductID, "BTU Rating")
If LBTU <> "" Then
CustomRadiatorAttributeRow LProductID, "", "Watts", Round2dp(LBTU * 0.2930711 / 1000) & "KW"
End If
%>
</table>
<%
End If
End If
End Sub
Sub CustomRadiatorAttributeRow(AProductID, AAttributeName, ATitle, AValueSuffix)
Dim LValue, LTitle, LValueSuffix
If AAttributeName <> "" Then
LValue = GetProductAttributeByName(AProductID, AAttributeName)
If LValue <> "" Then LValue = LValue & AValueSuffix
Else
LValue = AValueSuffix
End If
If LValue <> "" Then
If ATitle = "" Then
LTitle = AAttributeName
Else
LTitle = ATitle
End If
' in following found that table cell height in FireFox was 1 pixel or so taller, changing padding: 2px
' to padding: 0px 2px 0px 2px; height: 17px; provided the best compromise
%>
<tr>
<th width="20" align="center" style="padding: 0px 2px 0px 2px; height: 17px;"><%=LTitle%></th>
<td width="100%" align="center" style="padding: 0px 2px 0px 2px; height: 17px;"><%=LValue%></td>
</tr>
<%
End If
End Sub
' (SS,19/7/11)
Sub CustomAjaxSelections
If CustomRBIsSomethingSelected Then
CustomRBTableHeader
Dim LShowBuyButton, LInStock, LSubtotal, LPaintFinish
LPaintFinish = Request.Form("Paint Finish")
LSubtotal = 0
Dim LRadProductID
LRadProductID = Request.Form("Radiator")
LInStock = CustomRBProductLine("Radiator", "", 1, LSubtotal)
If LPaintFinish <> "" Then
Dim LPrice
' lookup price for paint option
If LRadProductID <> "" Then
If GetPriceForProductOptionValue(LRadProductID, LPaintFinish, LPrice) Then
CustomRBTableLine "Finish", LPaintFinish, 1, CorrectCurrency(LPrice)
LSubtotal = LSubtotal + LPrice ' (SS,11/7/13) somehow I managed to miss this before, paint option price wasn't being included in subtotal
Else
LShowBuyButton = False
End If
End If
End If
LInStock = LInStock And CustomRBProductLine("Wall Stay", "", CustomGetWallStays(LRadProductID), LSubtotal)
LInStock = LInStock And CustomRBProductLine("Valve Set", "", 1, LSubtotal)
LInStock = LInStock And CustomRBProductLine("Pipe Shrouds", "", 1, LSubtotal) ' (SS,6/2/13)
CustomRBTableLine "<b>Subtotal</b>", "", "", "<b>" & CorrectCurrency(LSubtotal) & "</b>"
CustomRBTableFooter
%>
<div style="float: left; margin-left: 10px">
<a class="button" onclick="frmRadiatorBuilder.reset(); rbSelect(); rbClearSelect()">Clear selection</a>
</div>
<div style="float: right; margin-right: 10px">
<%
' following worked well for moving up and down
'<div style="float: right; width: 93px">
'<a id="btn-add" style="position: absolute" class="button" onclick="rbAddToBasket()">Add to basket</a>
'</div>
' <a id="btn-add" class="button" onclick="rbAddToBasket()">Add to basket</a>
If LRadProductID <> "" And LInStock And LPaintFinish <> "" Then
%>
<div style="float: right; width: 93px">
<a id="btn-add" style="position: absolute" class="button" onclick="rbAddToBasket()">Add to basket</a>
</div>
<%
ElseIf Not LInStock Then
%>
<span style="color: red">*</span> Out of stock
<%
ElseIf LRadProductID = "" Then
%>
<span style="color: red">Please select radiator</span>
<%
ElseIf LPaintFinish = "" Then
%>
<span style="color: red">Please select paint finish</span>
<%
End If
%>
</div>
<%
Else
CustomRBDefaultText
End If
End Sub
Function CustomRBIsSomethingSelected
' (SS,6/2/13) added & Request.Form("Pipe Shrouds")
CustomRBIsSomethingSelected = Request.Form("Radiator") & Request.Form("Paint Finish") & Request.Form("Wall Stay") & Request.Form("Valve Set") & Request.Form("Pipe Shrouds") <> ""
End Function
Sub CustomRBTableHeader
%>
<div style="margin-bottom: 10px; border-bottom: 1px solid #ccc">
<table class="rb-table">
<tr>
<th width="100%" colspan="2">Product</th>
<th width="30px">Qty</th>
<th width="50px">Price</th>
</tr>
<%
End Sub
' returns false if item not in stock, true otherwise even if nothing selected
Function CustomRBProductLine(AFormElement, AProductName, AQty, ByRef ASubtotal)
Dim LResult, LProductName, LProductID, LPrice, LQty
LProductName = AProductName
LProductID = Request.Form(AFormElement)
If LProductID <> "" Then
LQty = AQty
LResult = GetPriceAndStockForProductID(LProductID, LQty, LPrice)
LPrice = LPrice * LQty
If Not LResult Then LQty = 0 ' tells CustomRBTableLine item out of stock an mark with a red *
If LProductName = "" Then
LProductName = GetProductAttributeByName(LProductID, "Short Name")
End If
If AFormElement = "Radiator" Then
If LProductName = "" Then LProductName = GetProductAttributeByName(LProductID, "Style")
LProductName = LProductName & " " & GetProductAttributeByName(LProductID, "Height") & "mm"
LProductName = LProductName & " " & GetProductAttributeByName(LProductID, "BTU Rating") & " BTU"
ElseIf AFormElement = "Valve Set" Then
Dim LStyle
LStyle = GetProductAttributeByName(LProductID, "Style")
' (SS,6/2/13) removed following shortening to "Thermo."
'If LStyle = "Thermostatic" And Len(LProductName) >= 21 Then
' LProductName = LProductName & " Thermo."
'Else
LProductName = LProductName & " " & LStyle
'End If
End If
ASubtotal = ASubtotal + LPrice
CustomRBTableLine AFormElement, LProductName, LQty, CorrectCurrency(LPrice)
Else
LResult = True ' i.e. in stock, but nothing selected
End If
CustomRBProductLine = LResult
End Function
Sub CustomRBTableLine(AType, AName, AQty, APrice)
%>
<tr>
<%If AName = "" Then%>
<%If AQty = "" Then%>
<%If AType = "" Then%>
<td colspan="4"></td>
<%Else%>
<td colspan="3"><%=AType%></td>
<%End If%>
<%Else%>
<td colspan="2"><%=AType%></td>
<%End If%>
<%Else%>
<td nowrap><%=AType%></td>
<td width="100%"><%=AName%></td>
<%End If%>
<%If AQty <> "" Then%>
<td align="center"><%=IIf(AQty = 0, "<span style=""color: red"">*</span>", AQty)%></td>
<%End If%>
<%If APrice <> "" Then%>
<td align="right"><%=APrice%></td>
<%End If%>
</tr>
<%
End Sub
Sub CustomRBDefaultText
%>
<br />
<p>Please select Radiator and Paint Finish.</p>
<p>Wall Stay, Valve Set and Pipe Shrouds are optional.</p>
<p>Paint Finish images shown are for reference only.</p>
<p>All radiators come with a FREE bleed/air vent valve.</p>
<%
End Sub
Sub CustomRBTableFooter
%>
</table>
</div>
<%
End Sub
' -------------------------------- '
' End of Custom Ajax Routines '
' -------------------------------- '
' (SS,17/1/13)
' ------------------------------------- '
' Start of Custom Page Content Routines '
' (SS,17/1/13) '
' ------------------------------------- '
' returns true if given page name exist in third party table
' (SS,26/2/15) found that this was being called inadvertently due to the way ASP (VB) handles If conditions (stick evaluating after the AND when first one is false)
' and resulted in error being logged in IIS Log file. Called from inc-pages.asp template. cdc_generated table doesn't exist. Commented put this line and now always returns false.
' it turned out that custom pages where enabled anyway when they shouldn't have been.
Function CustomPageExists(APageName)
CustomPageExists = GetSQLValue("SELECT COUNT(*) FROM cdc_generated WHERE generated_page_url = '" & CleanSQLStr(APageName) & "'") > 0
' (SS,26/2/15) replaced above with following
' (SS,14/10/15) added above back in, comment out below
'CustomPageExists = False
End Function
' shows the content from third party table for given page
Sub CustomShowPageContent(APageName)
Dim AHeading, AText, AID
' (SS,15/10/15) added AID
AText = CustomGetPageContent(APageName, AHeading, AID)
%>
<div class="heading"><h1><%=AHeading%></h1></div>
<div id="other-pages" style="margin-bottom: 5px">
<%=AText%>
</div>
<%
' shows products with attribute ID 19: "Show in Regional Matrix SEO" set to yes
'ShowProducts "", "", "", "", "", "19", "", "", "Yes"
' (SS,15/10/15) modified to show a list of random products
' to show a list of 6 random products, 3 of which are radiators, random generator is seeded with regional ID and week no
Dim LSeed, LWeekNo, LProductIDs
'Response.Write("#generated_id: " & AID & "#<br>")
'Response.Write("#Week: " & DatePart("ww", Now()) & "#<br>")
LSeed = AID * 100 + DatePart("ww", Now())
Randomize(LSeed)
'Response.Write("#Seed: " & LSeed & "<br>")
LProductIDs = CustomGetRandomProductList(3, "Radiator") & "," & CustomGetRandomProductList(3, "Valve Set")
'Response.Write("#List: " & LProductIDs& "#<br>")
DisableProductNavigation ' not applicable for just a few products
' (SS,15/10/15) AAttributeID = -1 means just the product IDs listed in the AVal parameter as comma separated values
ShowProducts "", "", "", "", "", "-1", "", "", LProductIDs
End Sub
' (SS,15/10/15) called with randomize function already seeded
Function CustomGetRandomProductList(ACount, AProductType)
Dim LSQL, LAttributeID, LRecCount, LResult, i, LRandomNo, LUniqueCount, LUniqueNos, LProductID, LProductIDs
LAttributeID = GetAttributeIDForName("Product Type")
LSQL = "FROM products p INNER JOIN product_attributes pa ON pa.ProductID = p.ProductID AND pa.AttributeID = " & LAttributeID & " AND pa.AttributeValue = '" & CleanSQLStr(AProductType) & "' WHERE ProductDisabled = FALSE"
' get list of unique numbers from 1 to record count
LRecCount = NZ(GetSQLValue("SELECT COUNT(*) " + LSQL))
LUniqueNos = ","
LProductIDs = ""
LUniqueCount = 0
' max repeat of 100 times the number of products required, should be enough to ensure unique values
For i = 1 To ACount * 100
LRandomNo = Int(LRecCount * Rnd + 1)
' if not found then add it to the list and look up the product ID
If InStr(LUniqueNos, "," + CStr(LRandomNo) + ",") = 0 Then
LUniqueNos = LUniqueNos & LRandomNo & ","
LUniqueCount = LUniqueCount + 1
' look up the product ID for nth record
LProductID = NZ(GetSQLValue("SELECT p.ProductID " + LSQL + " LIMIT " & LRandomNo - 1 & ", 1"))
LProductIDs = LProductIDs & iif(LProductIDs = "", "", ",") & LProductID
' if required amount found then exit loop
If LUniqueCount = ACount Then Exit For
End If
Next
CustomGetRandomProductList = LProductIDs
End Function
' returns page content from third party table
' (SS,15/10/15) added AID to pass back a unique ID, used as a seed for the random generator
Function CustomGetPageContent(APageName, ByRef AHeading, ByRef AID)
Dim LResult
AHeading = ""
LResult = ""
' (SS,15/10/15) added generated_id
If GetSQL3Values("SELECT generated_h1, generated_content, generated_id FROM cdc_generated WHERE generated_page_url = '" & CleanSQLStr(APageName) & "'", AHeading, LResult, AID) Then
AHeading = NB(AHeading)
LResult = NB(LResult)
' (SS,14/10/15) replaced "Coventry Demolition" with "Cast Iron Radiator Centre"
LResult = ReplaceStr(LResult, "Coventry Demolition", "Cast Iron Radiator Centre")
' (SS,14/10/15) replace CovDem URLs with CIRC, i.e. removed domain bit e.g. <a href=""http://www.coventry-demolition.co.uk/"products.asp?page=contact
LResult = ReplaceStr(LResult, "http://www.coventry-demolition.co.uk/", "")
End If
CustomGetPageContent = LResult
End Function
' returns page title, description meta or keywords meta tag from third party table
' AType can be T, D, or K for Title, Description Meta Tag or Keywords Meta Tag
Function CustomGetTitleTagForPage(AType, APageName)
Dim LFieldName, LFieldValue
If AType = "T" Then
LFieldName = "generated_page_title"
ElseIf AType = "D" Then
LFieldName = "generated_meta_description"
Else ' i.e. K
LFieldName = "generated_meta_keywords"
End If
' (SS,18/12/15) change to replace Coventry Demolition to Cast Iron Radiator Centre in page title
LFieldValue = GetSQLValueAsString("SELECT " & LFieldName & " FROM cdc_generated WHERE generated_page_url = '" & CleanSQLStr(APageName) & "'")
LFieldValue = ReplaceStr(LFieldValue, "Coventry Demolition", "Cast Iron Radiator Centre")
CustomGetTitleTagForPage = LFieldValue
End Function
' (SS,19/2/13)
Function GetCustomHTMLSitemap
Dim LHTML, LCity
LHTML = ""
OpenQuery("SELECT generated_h1, generated_page_url FROM cdc_generated ORDER BY generated_h1")
' (SS,23/10/19) added style="font-size: 2.5rem; line-height: 2" to increase spacing between the regions,
' Google Search Console was giving mobile usability issue: "Clickable elements too close together"
LHTML = LHTML & "<ul class=""regional-sitemap"" style=""font-size: 2.5rem; line-height: 2"">" & NL
Do While Not EndOfQuery
LCity = Trim(Replace(GetQueryValue("generated_h1"), "Cast Iron Radiators ", "")) ' (SS,20/2/13) remove the preceding "Cast Iron Radiators " text
LHTML = LHTML & " <li><a href=""" & GetURLForPage(GetQueryValue("generated_page_url")) & """>" & LCity & "</a></li>" & NL
NextQueryRecord
Loop
LHTML = LHTML & "</ul>" & NL
CloseQuery
GetCustomHTMLSitemap = LHTML
End Function
' ------------------------------------- '
' End of Custom Page Content Routines '
' ------------------------------------- '
' (SS,19/2/13) function used, but nothing is returned via function
' (SS,12/9/14) not used here
Function GetCustomXMLSitemap
Dim LSQL
'LSQL = "SELECT generated_h1, generated_page_url FROM cdc_generated ORDER BY generated_h1"
'AddGoogleSitemapLevel "", LSQL, "1.0", "generated_page_url", "page", "", ""
GetCustomXMLSitemap = ""
End Function
' (SS,20/5/13) show the price per section if product is a radiator
' if AProductID isn't product then it's looked up using AProductCode
Sub CustomShowPricePerSection(AProductID, AProductCode, ALineBreak)
Dim LProductID, LIsRadiator, LSections
' Lookup ProductID if blank using AProductCode
If AProductID = "" Then
LProductID = GetProductIDForProductCode(AProductCode)
Else
LProductID = AProductID
End If
LIsRadiator = GetProductAttributeByName(LProductID, "Product Type") = "Radiator"
If LIsRadiator Then
LSections = ParseInt(GetProductAttributeByName(LProductID, "Sections"))
If LSections <> 0 Then
If ALineBreak Then Response.Write BR
Response.Write(" (<b>" & CorrectCurrency(GetProductPrice / LSections) & "</b> per section)")
End If
End If
End Sub
' (SS,19/8/14)
Sub CustomShowPerSectionText(AProductID)
If ProductOptionExists(AProductID, "Sections") Then Response.Write(" per section")
End Sub
' (SS,26/8/14) called from CustomGetTableHTML and CustomGetProductOptionHTML below
' (SS,20/3/20) added AWaterContent
Sub CustomGetProductSettings(ByRef AProductID, ByRef ASectionPrice, ByRef ASectionsAvailable, ByRef ASectionsReadyMade, ByRef AHeight, ByRef ALength, ByRef ASectionLength, ByRef ADepth, ByRef ASectionWeight, ByRef ABTURating, ByRef AWaterContent)
Dim LSectionsAvailableStr, LSectionsReadyMadeStr
AProductID = GetProductID
ASectionPrice = GetProductPrice
LSectionsAvailableStr = GetProductAttributeByName(AProductID, "Sections Available")
LSectionsReadyMadeStr = GetProductAttributeByName(AProductID, "Sections Ready Made")
AHeight = ParseInt(GetProductAttributeByName(AProductID, "Height"))
ALength = ParseInt(GetProductAttributeByName(AProductID, "Length"))
ASectionLength = ParseInt(GetProductAttributeByName(AProductID, "Section Length"))
ADepth = ParseInt(GetProductAttributeByName(AProductID, "Depth"))
ASectionWeight = GetProductWeight ' ParseFloat(GetProductAttributeByName(AProductID, "Section Weight"))
ABTURating = ParseInt(GetProductAttributeByName(AProductID, "BTU Rating"))
AWaterContent = GetProductAttributeByName(AProductID, "Water Content") ' (SS,20/3/20)
Dim LSeparator
If InStr(LSectionsAvailableStr, "-") > 0 Then
LSeparator = "-"
Else
LSeparator = ","
End If
ASectionsAvailable = Split(LSectionsAvailableStr, LSeparator)
If InStr(LSectionsReadyMadeStr, "-") > 0 Then
LSeparator = "-"
Else
LSeparator = ","
End If
ASectionsReadyMade = Split(LSectionsReadyMadeStr, LSeparator)
End Sub
' (SS,22/8/14)
' (SS,1/3/19) renamed from CustomBTUTokW to CustomBTUToW, now rounds using FormatNumber and converts to an integer
Function CustomBTUToW(ABTU)
CustomBTUToW = CLng(FormatNumber(ABTU * 0.293071, 0)) ' (SS,1/3/19) was ABTU * 0.000293071
End Function
' (SS,22/8/14) custom specification table
' (SS,13/9/14) added footnote for ready made sections
' (SS,9/3/16) small change to add "from floor to top of radiator"
' (SS,27/2/19) added Delta T50
' (SS,1/3/19) replaced kW with W
' (SS,20/3/20) added Water Content
Function CustomGetTableHTML(ATitle)
Const FOOTNOTE_SYMBOL_HEIGHT = "<span style=""font-weight: normal""><sup>*</sup></span>" ' font-weight normal used to make it more readable in <th> which is bold
Const FOOTNOTE_SYMBOL_LENGTH = "<span style=""font-weight: normal""><sup>†</sup></span>"
Const FOOTNOTE_SYMBOL_PRICE = "<span style=""font-weight: normal""><sup>‡</sup></span>"
Const FOOTNOTE_SYMBOL_READY_MADE = "<sup>§</sup>"
Const FOOTNOTE_SYMBOL_READY_MADE_SMALL = "<small><sup>§</sup></small>"
Dim LResult, LProductID, LSectionPrice, LSectionsAvailable, LSectionsReadyMade, LHeight, LLength, LSectionLength, LDepth, LSectionWeight, LBTURating, LWaterContent
LResult = ""
' (SS,20/3/20) added LWaterContent
CustomGetProductSettings LProductID, LSectionPrice, LSectionsAvailable, LSectionsReadyMade, LHeight, LLength, LSectionLength, LDepth, LSectionWeight, LBTURating, LWaterContent
Dim LSection, LSectionsInt, LSectionReadyMade, LIsReadyMade
' table-specification is a custom class i.e. not Bootstrap
LResult = LResult & "<div class=""row"">" ' allows positioning close to edge
LResult = LResult & "<table class=""table table-specification table-striped table-condensed table-responsive"">"
' (SS,27/2/19) added @DT 50 to BTU and kW
' (SS,10/5/19) replaced W with Watts due to customers confusing W with Width
LResult = LResult & "<tr><th style=""vertical-align: middle""><small>Sections</small></th><th style=""vertical-align: middle""><small>Height" & BR & "(mm)" & FOOTNOTE_SYMBOL_HEIGHT & "</small></th><th><small>Length" & BR & "(mm)" & FOOTNOTE_SYMBOL_LENGTH & "</small></th>" &_
"<th><small>Depth" & BR & "(mm)</small></th>" &_
"<th><small>Content" & BR & "(litres)</small></th>" &_
"<th style=""vertical-align: middle"">BTU" & BR & "<small>@ΔT50</small></th><th style=""vertical-align: middle"">Watts" & BR & "<small>@ΔT50</small></th>" &_
"<th style=""vertical-align: middle"">kg</th>" &_
"</tr>"
' (SS,20/3/20) water content above replaced price (below)
' "<th>Price" & BR & "<small>(ex.VAT)" & FOOTNOTE_SYMBOL_PRICE & "</small></th></tr>"
For Each LSection In LSectionsAvailable
LSectionsInt = ParseInt(LSection)
LResult = LResult & "<tr>"
' (SS,13/9/14) added footnote if sections is one of the ready made options
LResult = LResult & "<td>" & LSectionsInt
LIsReadyMade = False
For Each LSectionReadyMade In LSectionsReadyMade
If LSection = LSectionReadyMade Then
LIsReadyMade = True
Exit For
End If
Next
If LIsReadyMade Then
LResult = LResult & FOOTNOTE_SYMBOL_READY_MADE_SMALL
Else ' to make it look tidier, i.e. equally centred as the sections without a footnote
LResult = LResult & "<sup> </sup>"
End If
LResult = LResult & "</td>"
LResult = LResult & "<td>" & LHeight & "</td>"
LResult = LResult & "<td>" & LLength + LSectionsInt * LSectionLength & "</td>"
LResult = LResult & "<td>" & LDepth & "</td>"
' (SS,20/3/20)
' (SS,24/3/20) added if check for blank string i.e. missing value to show "?" (using IIf didn't work, used If and LWaterContentStr)
Dim LWaterContentStr
If LWaterContent = "" Then
LWaterContentStr = ""
Else
LWaterContentStr = FormatNumber(LWaterContent * LSectionsInt, 1)
End If
LResult = LResult & "<td>" & LWaterContentStr & "</td>"
LResult = LResult & "<td>" & LBTURating * LSectionsInt & "</td>"
LResult = LResult & "<td>" & CustomBTUToW(LBTURating * LSectionsInt) & "</td>"
LResult = LResult & "<td>" & FormatNumber(LSectionWeight * LSectionsInt, 0) & "</td>"
' (SS,20/3/20) removed price
' LResult = LResult & "<td>" & "£" & FormatNumber(LSectionPrice * LSectionsInt, 2) & "</td>"
LResult = LResult & "</tr>"
Next
LResult = LResult & "</table>"
LResult = LResult & "</div>"
LResult = LResult & "<p><small>"
' (SS,9/3/16) changed from " Height is for foot section." to " Height is for foot section from floor to top of radiator."
LResult = LResult & FOOTNOTE_SYMBOL_HEIGHT & " Height is for foot section from floor to top of radiator."
LResult = LResult & BR & FOOTNOTE_SYMBOL_LENGTH & " All lengths approximate and include to bush ends - please allow 4% tolerance."
' (SS,20/3/20) removed following
'LResult = LResult & BR & FOOTNOTE_SYMBOL_PRICE & " Price for standard Black Primer finish, other finishes available at extra cost."
If UBound(LSectionsReadyMade) >= 0 Then LResult = LResult & BR & FOOTNOTE_SYMBOL_READY_MADE & " Available ready made for quicker 2 - 4 day delivery if Black Primer or Gunmetal."
LResult = LResult & "</small></p>"
CustomGetTableHTML = LResult
End Function
' (SS,26/8/14) custom product option label HTML building routine
Function CustomGetProductOptionLabelHTML(ADefaultOptionLabelHTML, AOptionName, AInputType, ARequired, AExtraSettings)
Dim LResult
LResult = ADefaultOptionLabelHTML
If LCase(AOptionName) = "paint finish" Then
' LResult = "<h4>Choose paint finish:</h4>"
' (SS,9/9/14) changed to use no label
'LResult = "<h4></h4>"
' (SS,1/3/15) changed to p because W3C validator gives empty heading warning
LResult = "<p></p>"
ElseIf LCase(AOptionName) = "sections" Then
' LResult = "<h4>Choose number of sections:</h4>"
' (SS,9/9/14) changed to use no label
'LResult = "<h4></h4>"
' (SS,1/3/15) changed to p because W3C validator gives empty heading warning, needed to added p for spacing
LResult = "<p></p>"
Else
LResult = ADefaultOptionLabelHTML
End If
CustomGetProductOptionLabelHTML = LResult
End Function
' (SS,26/8/14) called twice from CustomGetProductOptionHTML
' (SS,1/3/19) replaced kW with W, 2 dp to 0 dp
' (SS,10/5/19) replaced W with Watts due to customers confusing W with Width
Function CustomGetProductOptionHTMLSections(AOptGroup, ASections, ALength, ASectionLength, ABTURating, ASectionPrice)
Dim LResult, LSection, LSectionsInt, LSelectText, LSeparator
If AOptGroup <> "" Then
LResult = "<optgroup label=""" & AOptGroup & """>"
Else
LResult = ""
End If
LSeparator = " "
For Each LSection In ASections
LSectionsInt = ParseInt(LSection)
LSelectText = ""
LSelectText = LSelectText & LSectionsInt & " sections" & LSeparator
LSelectText = LSelectText & ALength + LSectionsInt * ASectionLength & " mm" & LSeparator
LSelectText = LSelectText & ABTURating * LSectionsInt & " BTU" & LSeparator
LSelectText = LSelectText & CustomBTUToW(ABTURating * LSectionsInt) & " Watts" & LSeparator
LSelectText = LSelectText & "£" & FormatNumber(ASectionPrice * LSectionsInt, 2)
' LResult = LResult & "<option value=""" & LOptionValueID & """>" & LOptionValueWithPrice & "</option>" & NL
LResult = LResult & "<option value=""" & LSection & """>" & LSelectText & "</option>" & NL
Next
CustomGetProductOptionHTMLSections = LResult
End Function
' (SS,9/9/14)
Function CustomGetProductOptionValuePaintFinish(APaintFinish)
Dim LResult
LResult = "<option value=""" & APaintFinish & """ data-img-src=""images/paint-finish/" & ReplaceStr(APaintFinish, " ", "-") & ".jpg"" data-img-label=""" & APaintFinish & """>" & APaintFinish & "</option>" & NL
CustomGetProductOptionValuePaintFinish = LResult
End Function
' (SS,26/8/14) custom product option HTML building routine
Function CustomGetProductOptionHTML(ADefaultOptionHTML, AProductOptionID, AOptionName, AOptionFieldName, AInputType, ARequired, AExtraSettings, ASplitIndex)
Dim LResult
If LCase(AOptionName) = "paint finish" Then
' LResult = ReplaceStr(ADefaultOptionHTML, "<select class=""""", "<select class=""image-picker show-labels show-html""") ' is there a better way, perhaps via a return parameter
' (SS,1/9/14) calls function itp_product_option_change when change to selection made
'LResult = ReplaceStr(ADefaultOptionHTML, "<select class=""""", "<select class=""image-picker show-labels show-html"" onchange=""itp_product_option_change('paint finish', this)""") ' is there a better way, perhaps via a return parameter
' (SS,9/9/14) new version which builds combo here
If AInputType = POIT_TEXT Then
LResult = "<select class=""form-control image-picker show-labels show-html"" name=""" + AOptionFieldName & """ id=""" & AOptionFieldName & """ onchange=""itp_product_option_change('paint finish', this)"">"
' (SS,9/9/14) replaced COMBO_PLEASE_SELECT with » " & "Select paint finish"
LResult = LResult & NL & "<option value="""">" & "» " & "Select paint finish" & "</option>" & NL
' (SS,28/4/16) rearranged order
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_BLACK_PRIMER)
' (SS,3/4/20) temporary removal of linen white
' (SS,21/5/20) added linen white back in by uncommenting following line
' (SS,12/6/20) temporary removal of linen white by uncommenting following line
'LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_LINEN_WHITE)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_CREAM_WHITE)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_ANTIQUE_BRONZE)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_GUNMETAL_GREY)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_MATT_BLACK) ' (SS,26/4/16)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_SATIN_BLACK)
LResult = LResult & "</select>"
Else
LResult = "<div class=""alert alert-danger"" role=""alert"">Error in Option Setup! Input Type must be " & POIT_TEXT & " not " & AInputType & "!</div>"
End If
ElseIf LCase(AOptionName) = "sections" Then
' (SS,28/8/14) only render if POIT_TEXT, i.e. Text Box which allows any value to be saved without validation into a basket option, combo does validation so won't insert into basket
' (SS,1/9/14) calls function itp_product_option_change when change to selection made
If AInputType = POIT_TEXT Then
LResult = "<select class=""form-control"" name=""" + AOptionFieldName & """ id=""" & AOptionFieldName & """ onchange=""itp_product_option_change('sections', this)"">"
' (SS,9/9/14) replaced COMBO_PLEASE_SELECT with » " & "Select number of sections"
LResult = LResult & NL & "<option value="""">" & "» " & "Select number of sections" & "</option>" & NL
' (SS,20/3/20) added LWaterContent
Dim LProductID, LSectionPrice, LSectionsAvailable, LSectionsReadyMade, LHeight, LLength, LSectionLength, LDepth, LSectionWeight, LBTURating, LWaterContent
CustomGetProductSettings LProductID, LSectionPrice, LSectionsAvailable, LSectionsReadyMade, LHeight, LLength, LSectionLength, LDepth, LSectionWeight, LBTURating, LWaterContent
' (SS,23/11/15) temporary removed quicker option by adding "And False", removed "And False" if adding back in in future, requested by Tina
If UBound(LSectionsReadyMade) >= 0 And False Then
LResult = LResult & CustomGetProductOptionHTMLSections("Stock sizes (quicker if black primer or gunmetal)", LSectionsReadyMade, LLength, LSectionLength, LBTURating, LSectionPrice)
End If
LResult = LResult & CustomGetProductOptionHTMLSections(IIf(UBound(LSectionsReadyMade) >= 0, "All sizes", ""), LSectionsAvailable, LLength, LSectionLength, LBTURating, LSectionPrice)
LResult = LResult & "</select>"
Else
LResult = "<div class=""alert alert-danger"" role=""alert"">Error in Option Setup! Input Type must be " & POIT_TEXT & " not " & AInputType & "!</div>"
End If
End If
CustomGetProductOptionHTML = LResult
End Function
' (SS,26/8/14) custom product option value HTML building routine
' (SS,9/9/14) no longer required, just returns the default
Function CustomGetProductOptionValueHTML(ADefaultOptionValueHTML, AOptionValueID, AOptionValueCount, AOptionValue, AOptionValueWithPrice, AOptionName, AInputType, AIsPicture)
Dim LResult
If LCase(AOptionName) = "paint finish" Then
' LResult = "<option value=""" & AOptionValueID & """ data-img-src=""" & IIf(AIsPicture, GetProductOptionValueImageLink(AOptionValueID), "") & """ data-img-label=""" & AOptionValue & """>" & AOptionValue & "</option>"
' (SS,9/9/14) replaced above with following
LResult = ADefaultOptionValueHTML
Else
LResult = ADefaultOptionValueHTML
End If
CustomGetProductOptionValueHTML = LResult
End Function
' (SS,27/8/14) removes the default "Available Options" title
Function CustomGetProductOptionsTitleDefault
CustomGetProductOptionsTitleDefault = ""
End Function
' (SS,28/3/17) adjusts the main price for local mode and exchange, i.e. sets to zero
Function CustomGetPriceWithoutOptions(APriceWithoutOptions)
If IsLocalMode And IsExchange Then
CustomGetPriceWithoutOptions = 0
Else
CustomGetPriceWithoutOptions = APriceWithoutOptions
End If
End Function
' (SS,28/8/14) returned value isn't important (therefore True is always returned), routine needs to modify AOptionsPrice and AOptionsWeight
' (SS,17/5/16) modified to work with non-radiator products returning correct price, i.e. not running CustomGetRadiatorPrice which won't be applicable
' (SS,28/3/17) modified to adjust for local mode / exchange, CustomGetPriceWithoutOptions above sets the AMainPrice to zero also
Function CustomGetOptionsPriceAndWeight(AobjOptionsDictionary, AMainPrice, AMainWeight, ByRef AOptionsPrice, ByRef AOptionsWeight)
Const WARRANTY_CHARGED_PRICE = 35
Dim LSections, LPaintFinish
LSections = AobjOptionsDictionary.Item("Sections")
LPaintFinish = AobjOptionsDictionary.Item("Paint Finish")
' debug code
'Response.Write "### Sections: " & LSections & "###" & BR
'Response.Write "### Paint Finish: " & LPaintFinish & "###" & BR
' (SS,17/5/16) added If LSections <> "" Then to allow this routine to work for non-radiator products, i.e. the special colour combo/picker, i.e. when LSections is blank there no need to call CustomGetRadiatorPrice
If LSections <> "" Then
AOptionsPrice = AOptionsPrice + CustomGetRadiatorPrice(AMainPrice, LSections - 1) ' -1 because we're subtracting the main price which is used for the section price
AOptionsWeight = AOptionsWeight + AMainWeight * (LSections - 1)
End If
' (SS,28/3/17) added special price for local mode exchange, either Warranty (FOC) or Warranty (Charged)
' LSections <> "" ensures radiators only i.e. not spares or paint pots
If IsLocalMode And IsExchange Then
If LSections <> "" And GetExchangeReason = "Warranty (Charged)" Then
AOptionsPrice = WARRANTY_CHARGED_PRICE
Else ' i.e. free of charge
AOptionsPrice = 0
End If
Else ' (SS,28/3/17) as before
AOptionsPrice = AOptionsPrice + CustomGetPaintFinishPrice(LPaintFinish, LSections)
End If
CustomGetOptionsPriceAndWeight = True
End Function
' (SS,28/8/14)
Function CustomGetRadiatorPrice(ASectionPrice, ASections)
CustomGetRadiatorPrice = ASectionPrice * ASections
End Function
' (SS,28/8/14)
' �30.00 per radiator upto 9 sections
' �40.00 per radiator 10 - 14 sections
' �50.00 per radiator 15 - 19 sections
' �65.00 per radiator 20 or more sections
' no cost for Black Primer
' (SS,17/5/16) now returns zero for non-radiator products (i.e. where ASections = "")
' (SS,13/1/17) new prices from 16/1/17 onwards
' (SS,3/8/17) changed price from 3.75 to 4.25 per section
' (SS,12/12/18) changed to apply price increase from 4.50 to 5.00 on and after 17/12/2018
' (SS,16/04/20) modified to apply price increase from 5.00 to 5.50 on and after 17/04/2020
' *** !!! (SS,27/04/20) had to modify the Paint Costs report and paint_costs table, perhaps in future modify this function to use the paint_costs table will require less maintenance
Function CustomGetPaintFinishPrice(APaintFinish, ASections)
Dim LPrice
' Response.Write "##P:" & APaintFinish & ", S:" & ASections & "##"
' (SS,17/5/16) added ASections = "" so that it returns 0 for non-radiator products i.e. where sections aren't applicable
' (SS,13/1/17) added new calculation to take effect from Monday 16/1/2017 6am, sections x �3.75 exc VAT
' (SS,3/8/17) modified price from 3.75 to 4.25 per section
' (SS,10/1/18) modified from 4.25 to 4.5 to take effect automatically on 11/1/2017
' (SS,12/12/18) modified to apply price increase from 4.50 to 5.00 on and after 17/12/2018
' (SS,16/04/20) modified to apply price increase from 5.00 to 5.50 on and after 17/04/2020
If Date() >= #01/16/2017# Then ' (SS,11/1/18) removed "And Hour(Now()) >= 6" which was a bug resulting in older prices below if purchases between midnight and 6am
If ASections = "" Or APaintFinish = PF_BLACK_PRIMER Then
LPrice = 0
ElseIf ASections > 0 Then
If Date() >= #04/17/2020# Then
LPrice = ASections * 5.50
ElseIf Date() >= #12/17/2018# Then
LPrice = ASections * 5.00
ElseIf Date() >= #01/11/2018# Then
LPrice = ASections * 4.50
Else
LPrice = ASections * 4.25 ' (SS,3/8/17) was 3.75
End If
Else ' i.e. nothing selected for paint finish (used by Ajax to get price)
LPrice = 0
End If
Else ' (SS,13/1/17) previous calculation, can be deleted after 16/1/17
If ASections = "" Or APaintFinish = PF_BLACK_PRIMER Then
LPrice = 0
ElseIf ASections <= 9 Then
LPrice = 30
ElseIf ASections <= 14 Then
LPrice = 40
ElseIf ASections <= 19 Then
LPrice = 50
ElseIf ASections >= 20 Then ' i.e. 20 or more
LPrice = 65
Else ' i.e. nothing selected for paint finish (used by Ajax to get price)
LPrice = 0
End If
End If
CustomGetPaintFinishPrice = LPrice
End Function
' (SS,1/9/14)
' (SS,10/10/14) added delivery for not radiator products
' (SS,3/6/15) added "Delivery Extended Lead Time" which is used to override the normal delivery days
' (SS,1/10/15) changed "Anticipated delivery" to "Anticipated despatch"
' (SS,25/11/16) changed to added extra text to delivery info after certain dates, had to restructure the orders able to increase DeliveryInfo field from VARCHAR(100) to VARCHAR(255)
Function CustomGetDeliveryDays(AProductID, ASections, APaintFinish)
Dim LSectionsReadyMade, LPrefix, LDays, LDeliveryExtendedLeadTime
' (SS,3/6/15) added following to override the normal days
LDeliveryExtendedLeadTime = GetProductAttributeByName(AProductID, "Delivery Extended Lead Time")
If LDeliveryExtendedLeadTime <> "" Then
LDays = LDeliveryExtendedLeadTime
Else
LDays = ""
End If
If ASections = "" Or APaintFinish = "" Then ' i.e. not a radiator
' (SS,3/6/15) added "If" to allow override via delivery extended lead time attribute
If LDays = "" Then
LDays = "1 - 2"
End If
LPrefix = "Despatched in" ' (SS,17/10/14)
Else
' (SS,3/6/15) added "If" to allow override via delivery extended lead time attribute
If LDays = "" Then
LSectionsReadyMade = ReplaceStr(GetProductAttributeByName(AProductID, "Sections Ready Made"), ",", "-")
If InStr("-" + LSectionsReadyMade + "-", "-" + ASections + "-") > 0 And (APaintFinish = PF_BLACK_PRIMER Or APaintFinish = PF_GUNMETAL_GREY) Then
LDays = "7 - 10" ' (SS,17/10/14) was "2 - 4" (SS,26/11/14) was "5 - 10"
Else
LDays = "10 - 14" ' (SS,17/10/14) was "7 - 10" (SS,26/11/14) was "7 - 14"
End If
End If
LPrefix = "Anticipated despatch in" ' (SS,17/10/14), (SS,1/10/15) replaced delivery with despatch
End If
' CustomGetDeliveryDays = "Despatched in " + LResult + " working days"
' (SS,17/10/14) replaced above with following
' (SS,24/1/16) added extra text info for radiator order between dates
Dim LResult
' (SS,25/11/16) added "full" in front of "working days"
LResult = LPrefix + " <b>" + LDays + " full working days</b>"
' if a radiator
If ASections <> "" Then
If Date >= #11/24/16# And Date <= #11/30/16# Then
LResult = LResult & ". <br><span style=""color:red"">Due to current order volumes slight adjustments may be made to lead time shown. Thank you for your understanding.</span>"
ElseIf Date >= #01/12/16# And Date <= #12/31/16# Then
LResult = LResult & ". <br><span style=""color:red"">However, please see our Christmas deliveries and opening times notice regarding current delivery time scales.</span>"
End If
End If
CustomGetDeliveryDays = LResult
End Function
' (SS,17/10/14) compares two strings containing delivery days and returns the greatest
Function CustomCompareDeliveryDays(ADeliveryDays1, ADeliveryDays2)
Dim LDeliveryDays1, LDeliveryDays2, LResult
If ParseFirstInt(ADeliveryDays1) > ParseFirstInt(ADeliveryDays2) Then
LResult = ADeliveryDays1
Else
LResult = ADeliveryDays2
End If
CustomCompareDeliveryDays = LResult
End Function
' (SS,9/10/14) looks up the delivery info for given product, returns the latest of this and order so far, text comparison works, eventually results delivery for order
Function CustomGetOrderDeliveryInfo(AOrderDeliveryInfo, AProductID, AobjOptionsDict)
Dim LSections, LPaintFinish, LProductDeliveryInfo, LResult
LSections = AobjOptionsDict.Item("Sections")
LPaintFinish = AobjOptionsDict.Item("Paint Finish")
LProductDeliveryInfo = CustomGetDeliveryDays(AProductID, LSections, LPaintFinish)
CustomGetOrderDeliveryInfo = CustomCompareDeliveryDays(LProductDeliveryInfo, AOrderDeliveryInfo)
End Function
' (SS,10/10/14) called for every item in basket on basket page, used to work out recommendation i.e. valves, wall stays and pipe shrouds
Function CustomProductInBasket(AProductID, AQty, AobjOptionsDict)
Dim LSections
LSections = AobjOptionsDict.Item("Sections")
oCustomRecommendToBuy.AddProduct GetProductAttributeByName(AProductID, "Product Type"), AQty, LSections
' (SS,17/12/14) following used to determine if radiator is oversize, to charge extra delivery for
' global flag FCustomOversizeRadiator will hold true if at lease one radiator is oversize
If Not FCustomOversizeRadiator And LSections <> "" Then
Dim LMinSectionsForOversize
LMinSectionsForOversize = GetProductAttributeByName(AProductID, "Min Sections Oversize")
If LMinSectionsForOversize <> "" Then
If CInt(LSections) >= CInt(LMinSectionsForOversize) Then
FCustomOversizeRadiator = True
End If
End If
End If
CustomProductInBasket = True ' return value is ignored, always True
End Function
' (SS,13/10/14) moved here from CustomShowRecommendation, called twice
' (SS,24/8/16) changed "Accessories" in GetSubcategoryLink to "Accessories & Spares", category name was recently changed when touch up paint was added
Sub CustomShowRecommendationProducts
If oCustomRecommendToBuy.ValvesNeeded > 0 Then Response.Write oCustomRecommendToBuy.ValvesNeeded & " x <a href=""" & GetCategoryLink("Valves") & """>Valve Sets</a><br>"
If oCustomRecommendToBuy.StaysNeeded > 0 Then Response.Write oCustomRecommendToBuy.StaysNeeded & " x <a href=""" & GetSubcategoryLink("Accessories & Spares", "Wall Stays") & """>Wall Stays</a><br>"
If oCustomRecommendToBuy.ShroudsNeeded > 0 Then Response.Write oCustomRecommendToBuy.ShroudsNeeded & " x <a href=""" & GetSubcategoryLink("Accessories & Spares", "Pipe Shrouds - Sleeves") & """>Pipe Shrouds and Base Plates</a><br>"
' (SS,24/8/16) added following
If oCustomRecommendToBuy.TouchUpPaintNeeded > 0 Then Response.Write oCustomRecommendToBuy.TouchUpPaintNeeded & " x <a href=""" & GetSubcategoryLink("Accessories & Spares", "Touch Up Paint") & """>Touch Up Paint</a><br>"
End Sub
' (SS,10/10/14)
Function CustomShowRecommendation
Dim LAlertType
If Request("alert") <> "" Then
LAlertType = Request("alert")
Else
LAlertType = "success" ' was "info" now defaulting to "success"
End If
If oCustomRecommendToBuy.Required Then
%>
<div class="alert alert-<%=LAlertType%>" role="alert">To complete your radiator order we recommend the following:<br>
<%CustomShowRecommendationProducts%>
</div>
<%
' (SS,22/1/15) moved code to new CustomShowRecommendationModal, a different one shown for PayPal Express
CustomShowRecommendationModal "N"
If GetPayPalExpressEnabled Then CustomShowRecommendationModal "P"
End If
End Function
' (SS,22/1/15) moved here from CustomShowRecommendation to allow two different versions, i.e. a different one for the PayPal Express checkout button
' AType can be "N" for normal and "P" for PayPal Express
Sub CustomShowRecommendationModal(AType)
Dim LModalSuffix, LButtonCaption
If AType = "P" Then
LModalSuffix = "-p"
LButtonCaption = "Checkout with PayPal"
Else
LModalSuffix = ""
LButtonCaption = "Proceed to checkout"
End If
%>
<div id="modal-content<%=LModalSuffix%>" class="modal fade">
<div class="modal-dialog">
<div class="modal-content">
<div class="modal-header">
<button type="button" class="close" data-dismiss="modal"><span aria-hidden="true">×</span><span class="sr-only">Close</span></button>
<h4 class="modal-title">To complete your radiator order we recommend the following:</h4>
</div>
<div class="modal-body">
<p><%CustomShowRecommendationProducts%></p>
<p>Click any of the above links to go to the appropriate category to purchase. Otherwise click "<%=LButtonCaption%>" below to continue.</p>
</div>
<div class="modal-footer">
<button type="button" class="btn btn-default" data-dismiss="modal">Close</button>
<%
If AType = "N" Then
Response.Write GetButtonProceedToCheckoutNoID
Else
%>
<a href="products.asp?cmd=checkout&stage=<%=CS_PAYPAL_EXPRESS_CHECKOUT%>">
<img src="https://www.paypal.com/en_US/i/btn/btn_xpressCheckout.gif" border="0" align="top" alt="Check out with PayPal"/>
</a>
<%
End If
%>
</div>
</div><!-- /.modal-content -->
</div><!-- /.modal-dialog -->
</div><!-- /.modal -->
<%
End Sub
' (SS,1/9/14)
' (SS,17/10/14) added class="text-info"
Sub CustomAjaxProductPrice
Dim LProductID, LSections, LPaintFinish, LProductPrice
LProductID = Request.QueryString("productid")
LSections = Request.QueryString("sections")
LPaintFinish = Request.QueryString("paintfinish")
If LProductID <> "" And LSections <> "" And LPaintFinish <> "" Then
GetPriceAndStockForProductID LProductID, 1, LProductPrice
LProductPrice = CustomGetRadiatorPrice(LProductPrice, LSections)
LProductPrice = LProductPrice + CustomGetPaintFinishPrice(LPaintFinish, LSections)
' (SS,01/10/15) replaced "All items delivered together" with "All items sent together"
' (SS,27/2/19) added heat output info including new delta T50 via CustomGetHeatOutputInfo
%>
<h3 style="margin-top: -5px; margin-bottom: 5px">
<small><%=LSections%> sections <%=CustomGetExtendedPaintFinishName(LPaintFinish)%></small>
</h3>
<h3 style="margin-top: -5px; margin-bottom: 10px">
<small class="text-danger"><%=CustomGetHeatOutputInfo(LProductID, LSections)%></small>
</h3>
<hr style="margin-top: 0px; margin-bottom: 10px">
<h3 style="margin-top: 0px; margin-bottom: 5px">
Total <span class="regular price-sale" itemprop="price"><%=CorrectCurrencyNV(LProductPrice)%></span>
<small><%=CorrectCurrencyWV(LProductPrice)%> inc. VAT</small>
</h3>
<hr style="margin-top: 10px; margin-bottom: 10px">
<h4 style="margin-bottom: 5px" class="text-success"><%=CustomGetDeliveryDays(LProductID, LSections, LPaintFinish)%><sup></sup></h4>
<small>All items sent together. Actual delivery depends on item with greatest lead time.</small>
<%
End If
End Sub
' (SS,28/4/16)
Function CustomGetExtendedPaintFinishName(APaintFinish)
Dim LResult
If APaintFinish = PF_BLACK_PRIMER Then
LResult = "in " + APaintFinish + " only"
Else
LResult = "primed and with " + APaintFinish + " top coat"
End If
CustomGetExtendedPaintFinishName = LResult
End Function
' (SS,27/2/19)
' (SS,10/5/19) replaced W with Watts due to customers confusing W with Width
Function CustomGetHeatOutputInfo(AProductID, ASections)
Const DELTA = "@ΔT50°C"
Dim LResult, LBTURating
LBTURating = ParseInt(GetProductAttributeByName(AProductID, "BTU Rating")) * ASections
LResult = "Heat Output: <strong>" & LBTURating & " BTU</strong> / <strong>" & CustomBTUToW(LBTURating) & " Watts</strong> " & DELTA
CustomGetHeatOutputInfo = LResult
End Function
' (SS,10/9/14) called from CustomProductNameWithBreak below
Function CustomProductNameWithBreakSingle(AProductName, ABreakText)
Const BREAK_TEXT = "cast iron radiator"
Dim LLen
LLen = Len(ABreakText)
If LCase(Right(AProductName, LLen)) = ABreakText Then
CustomProductNameWithBreakSingle = Left(AProductName, Len(AProductName) - LLen) + BR + Right(AProductName, LLen)
Else
CustomProductNameWithBreakSingle = AProductName
End If
End Function
' (SS,2/9/14) called from inc-template-product-list.asp to split the long name using break just before cast iron radiator
' (SS,10/9/14) now also handles "radiator valve set", calls CustomProductNameWithBreakSingle above
Function CustomProductNameWithBreak(AProductName)
Dim LResult
LResult = CustomProductNameWithBreakSingle(AProductName, "cast iron radiator")
LResult = CustomProductNameWithBreakSingle(LResult, "radiator valve set")
LResult = CustomProductNameWithBreakSingle(LResult, "for cast iron radiators")
CustomProductNameWithBreak = LResult
End Function
' (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,27/1/16) to make adjust to product for Google Shopping, only arguments prefixed by ByRef can be adjusted
' this is to get the correct price for the minimum number of sections for each radiator, rather than per section price which Google are complaining about
' (SS,21/9/20) change made to CustomGetSections to always return 0, to keep Google Merchant Center happy, it's no longer like the 3 section price
Function CustomGoogleShoppingProductAdjust(AProductID, AProductCode, ByRef AProductName, ByRef AProductPrice, ByRef ANonWeightPrice, ByRef AWeight, ByRef AFlaggedWeight, ByRef ANonFlaggedWeight)
' get minimum number of sections, multiply price and weight by this figure
Dim LSections
LSections = CustomGetSections(AProductID)
If LSections <> 0 Then
AProductPrice = Round2dp(AProductPrice * LSections)
ANonWeightPrice = Round2dp(ANonWeightPrice * LSections)
AWeight = Round2dp(AWeight * LSections)
AFlaggedWeight = Round2dp(AFlaggedWeight * LSections)
ANonFlaggedWeight = Round2dp(ANonFlaggedWeight * LSections)
End If
End Function
' (SS,19/2/16) used by Rich Snippets in inc-template-product-detail.asp for price to match Google Shopping
' returns the given price multiplied by minimum number of sections
' (SS,21/9/20) change made to CustomGetSections to always return 0, to keep Google Merchant Center happy, it's no longer like the 3 section price
Function CustomPriceAdjust(AProductID, AProductPrice)
Dim LSections
LSections = CustomGetSections(AProductID)
If LSections <> 0 Then
CustomPriceAdjust = FormatNumber(AProductPrice * LSections, 2)
Else
CustomPriceAdjust = AProductPrice
End If
End Function
' (SS,19/2/16) returns number for sections for given product, called from CustomGoogleShoppingProductAdjust and CustomPriceAdjust above
' (SS,21/9/10) reverted back to one section price due to complaint email from Google Merchant Center on 10/9/2020 saying price on feed doesn't match the landing page
' Did this by adding replacing CustomGetSections = ParseInt(GetProductAttributeByName(AProductID, "Sections Available"))
' with CustomGetSections = 0
' Also used by rich snippets in product page (inc-template-product-detail.asp)
Function CustomGetSections(AProductID)
' CustomGetSections = ParseInt(GetProductAttributeByName(AProductID, "Sections Available"))
' (SS,21/9/20) replaced above with following
CustomGetSections = 0
End Function
' (SS,1/6/17) returns true if sale banner is applicable for given product
Function CustomIsSaleBannerApplicable(AProductID, ASalePrice)
Dim Result
Result = False
If ASalePrice <> "" Then
If GetProductAttributeByName(AProductID, "Product Type") = "Radiator" Then
Result = True
End If
End If
CustomIsSaleBannerApplicable = Result
End Function
' (SS,1/6/17)
Function CustomGetSaleBannerText
' (SS,15/9/17) replaced "Summer Sale" with "Sale"
CustomGetSaleBannerText = "Sale"
End Function
' (SS,21/3/18) used to only send despatch SMS if it's a radiator order,
' simplified this by checking for delivery agent of "Mobile PPL radiator pallet"
Function CustomCheckSMS(AOrderNo, ASMSType)
Dim LResult
LResult = ASMSType
If ASMSType = ST_ORDER_DESPATCHED Then
Dim LDeliveryAgentName
LDeliveryAgentName = GetOrderFieldValue(AOrderNo, "DeliveryAgentName")
' don't send SMS if delivery agent isn't Mobile PPL (for despatched confirmations)
If LDeliveryAgentName <> "Mobile PPL radiator pallet" Then
LResult = ""
End If
End If
CustomCheckSMS = LResult
End Function
' (SS,1/8/18) added to return more info to show on each radiator item in basket and email i.e. BTU and length of radiator
' AOptionsList should start with Sections
' This is called from ShowBasket and GetOrderEmailProductItem in AppUtils.asp
' (SS,2/8/18) Now returns original info with extra added if applicable
' (SS,1/3/19) replaced kW with W
' (SS,10/5/19) replaced W with Watts due to customers confusing W with Width
Function CustomAddMoreOptionsInfo(AProductID, AOptionsList)
Dim LResult, LSections, LLength, LSectionLength, LBTURating
LResult = AOptionsList
' only if product is a radiator, return the extra info i.e. length, BTU and kW
If GetProductAttributeByName(AProductID, "Product Type") = "Radiator" Then
LSections = ParseFirstInt(AOptionsList) ' AOptionsList should start with Sections, ParseFirstInt returns first integer i.e. sections as integer
LLength = ParseInt(GetProductAttributeByName(AProductID, "Length"))
LSectionLength = ParseInt(GetProductAttributeByName(AProductID, "Section Length"))
LBTURating = ParseInt(GetProductAttributeByName(AProductID, "BTU Rating"))
If LSections > 0 Then
LResult = LResult & BR ' HTML line break
LResult = LResult & "Length: " & LLength + LSections * LSectionLength & "mm"
LResult = LResult & ", " & LBTURating * LSections & " BTU"
LResult = LResult & ", " & CustomBTUToW(LBTURating * LSections) & " Watts"
End If
End If
CustomAddMoreOptionsInfo = LResult
End Function
' (SS,18/10/18) added following to add subproducts for given product to basket
Function CustomAddSubproductsToBasket(AProductID, AItemID, AQtyInBasket, AQtyToAdd)
' look at the main product check whether any subproducts defined for it, exit if there aren't
' (may be better to delete any subproducts already existing in basket)
' Delete the subproducts already added to basket for this
' may need to add SubproductItemID to link to main product
' built the correct subproduct records with correct quantity, num in stock needs to work
' look for subproducts belonging to this product
' determine the colour and no of sections, no of legs and mid sections
' add the appropriate subproduct records to the basket
' new field and index added
' ALTER TABLE shoppingbaskets
' ADD SubproductItemID INTEGER(11) DEFAULT NULL COMMENT 'Added 18/9/18, for CIRC, Schema 4' AFTER Qty,
' ADD KEY idxSubproductItemID (SubproductItemID);
' exit if product isn't a radiator
If Not GetProductAttributeByName(AProductID, "Product Type") = "Radiator" Then
Exit Function
End If
' determine new qty (i.e. what's already in the basket + qty to add)
Dim LNewQty
LNewQty = AQtyInBasket + AQtyToAdd
' determine paint finish and sections from basket options
Dim LPaintFinish, LSections, LLegSections, LMidSections
LPaintFinish = GetBasketOptionValueForItemID(AItemID, "Paint Finish")
' determine qty of leg and mid sections, then multiply by new qty
LSections = CLng(GetBasketOptionValueForItemID(AItemID, "Sections"))
' following returns LLegSections and LMidSections for given qty and sections
CustomGetLegMidSections AProductID, LNewQty, LSections, LLegSections, LMidSections
' add the determined subproducts in appropriate amounts
' add each of the applicable subproducts i.e. the leg sections in the correct primer, and mid sections in the correct primer
Dim LSubproductID, LProductCode, LProductName
LSubproductID = CustomGetSubproductIDForSection(AProductID, "Leg", LPaintFinish, LProductCode, LProductName)
' call routine to add the basket record
If LSubproductID <> 0 Then CustomAddSubproductToBasket LSubproductID, LProductCode, LLegSections, AItemID
LSubproductID = CustomGetSubproductIDForSection(AProductID, "Mid", LPaintFinish, LProductCode, LProductName)
' call routine to add the basket record
If LSubproductID <> 0 Then CustomAddSubproductToBasket LSubproductID, LProductCode, LMidSections, AItemID
End Function
' (SS,30/10/18) determines number of leg and mid sections for given qty and sections of a radiator
' (SS,22/10/18) following formula exists in the "Stock Used (including sections)" report in Shopping Admin
' both this and the above must match
'IF(odo.OptionName = "Sections", IF(INSTR(od.OptionsList, "white") > 0, "White", "Black"), "") AS SectionColour,
'SUM(od.Qty) AS Qty, SUM(IF(odo.OptionName = "Sections", odo.OptionValue, NULL) * od.Qty) AS Sections,
'SUM(IF(odo.OptionName = "Sections", od.Qty * IF(odo.OptionValue > 14, 3, 2), NULL)) AS LegSections,
'SUM(IF(odo.OptionName = "Sections", od.Qty * (odo.OptionValue - IF(odo.OptionValue > 14, 3, 2)), NULL)) AS MidSections
' (SS,7/11/18) added AProductID because it's product dependant
Sub CustomGetLegMidSections(AProductID, ARadQty, ARadSections, ByRef ALegSections, ByRef AMidSections)
Const RAD_460 = 193
' (SS,7/11/18) now 1 to 15 is 2 legs, 16 or above is 3 (was IIf(ARadSections > 14, 3, 2))
' for 460 rad (ProductID 193), its 1 to 16 for 2 legs, 17 or above for 3
' CLng necessary due to AProductID being a string
If CLng(AProductID) = RAD_460 Then
ALegSections = IIf(ARadSections <= 16, 2, 3)
Else
ALegSections = IIf(ARadSections <= 15, 2, 3)
End If
AMidSections = ARadSections - ALegSections
ALegSections = ALegSections * ARadQty
AMidSections = AMidSections * ARadQty
End Sub
Sub CustomAddSubproductToBasket(AProductID, AProductCode, AQty, ASubproductItemID)
Dim LWhere
' if already exists then update the qty, else insert
LWhere = "SessionID = '" & CleanSQLStr(GetSessionID) & "' AND ProductID = '" & AProductID & "' AND SubproductItemID = '" & ASubproductItemID & "'"
If GetSQLRecordExists("SELECT * FROM shoppingbaskets WHERE " & LWhere) Then
ExecuteQuery("UPDATE shoppingbaskets SET Qty = " & AQty & " WHERE " & LWhere)
Else
ExecuteQuery("INSERT INTO shoppingbaskets SET SessionID = '" & CleanSQLStr(GetSessionID) & "', ProductID = '" & AProductID & "', ProductCode = '" & CleanSQLStr(AProductCode) & "', Qty = " & AQty & ", SubproductItemID = '" & ASubproductItemID & "'")
End If
End Sub
' (SS,22/10/18) returns the subproduct ID and the product code for given section type and primer for given product code
' routine to be used in two places. Also to build historical list in orderdetails.
Function CustomGetSubproductIDForSection(AProductID, ASectionType, APaintFinish, ByRef AProductCode, ByRef AProductName)
' 26 is section type, 27 is section primer
Const SECTION_TYPE_ATTRIBUTE_ID = 26
Const SECTION_PRIMER_ATTRIBUTE_ID = 27
Dim LSectionPrimer, LSQL, LSubproductID
LSectionPrimer = IIf(InStr(1, APaintFinish, "white", vbTextCompare) = 0, "Black", "White")
LSQL = "SELECT ps.SubproductID, p.ProductCode, p.ProductName" &_
" FROM product_subproducts ps" &_
" INNER JOIN products p ON p.ProductID = ps.SubproductID" &_
" INNER JOIN product_attributes pa1 ON pa1.ProductID = ps.SubproductID AND pa1.AttributeID = " & SECTION_TYPE_ATTRIBUTE_ID & " AND pa1.AttributeValue = '" & ASectionType & "'" &_
" INNER JOIN product_attributes pa2 ON pa2.ProductID = ps.SubproductID AND pa2.AttributeID = " & SECTION_PRIMER_ATTRIBUTE_ID & " AND pa2.AttributeValue = '" & LSectionPrimer & "'" &_
" WHERE ps.ProductID = '" & CleanSQLStr(AProductID) & "'"
' get the values, default to 0 and blanks if not found
If Not GetSQL3Values(LSQL, LSubproductID, AProductCode, AProductName) Then
LSubproductID = 0
AProductCode = ""
AProductName = ""
End If
CustomGetSubproductIDForSection = LSubproductID
End Function
' (SS,30/10/18) when making live we need to make sure we have no shopping baskets, perhaps do at midnight
' Routine called only once to add the subproducts for radiators previously ordered, for historical data
Sub CustomCreateSubproductRecordsForExistingOrders
' scan all records in orderdetails table in order no and OrderDetailID order where the product "HasSubproducts"
' and perhaps SubproductOrderDetailID is null
'
' for each order detail record, add the subproduct records
' determine the qty, section size and paint finish
' add the leg and mid sections
' (SS,8/11/18) did in two steps due to script time second time used od.Order > 512662
Dim LSQL
LSQL = "SELECT * FROM orderdetails od" &_
" INNER JOIN products p ON p.ProductID = od.ProductID" &_
" WHERE od.SubproductOrderDetailID IS NULL AND p.HasSubproducts" &_
" ORDER BY OrderNo, OrderDetailID"
Dim LOrderDetailID, LOrderNo, LQty, LPaintFinish, LSections, LLegSections, LMidSections
Dim LProductID, LSubproductID, LProductCode, LProductName
OpenQuery(LSQL)
Do While Not EndOfQuery
LOrderDetailID = GetQueryValue("OrderDetailID")
LOrderNo = GetQueryValue("OrderNo")
LProductID = GetQueryValue("ProductID")
LQty = GetQueryValue("Qty")
' determine paint finish and sections from order detail options
LPaintFinish = GetOrderOptionValueForOrderDetailID(LOrderDetailID, "Paint Finish")
LSections = CLng(GetOrderOptionValueForOrderDetailID(LOrderDetailID, "Sections"))
CustomGetLegMidSections LProductID, LQty, LSections, LLegSections, LMidSections ' (SS,7/11/18) added LProductID
' add the subproduct records
' add the determined subproducts in appropriate amounts
' add each of the applicable subproducts i.e. the leg sections in the correct primer, and mid sections in the correct primer
LSubproductID = CustomGetSubproductIDForSection(LProductID, "Leg", LPaintFinish, LProductCode, LProductName)
' call routine to add the order details record
If LSubproductID <> 0 Then CustomAddSubproductToOrderDetail LOrderNo, LSubproductID, LProductCode, LProductName, LLegSections, LOrderDetailID
LSubproductID = CustomGetSubproductIDForSection(LProductID, "Mid", LPaintFinish, LProductCode, LProductName)
' call routine to add the order details record
If LSubproductID <> 0 Then CustomAddSubproductToOrderDetail LOrderNo, LSubproductID, LProductCode, LProductName, LMidSections, LOrderDetailID
NextQueryRecord
Loop
CloseQuery
End Sub
' (SS,30/10/18)
Sub CustomAddSubproductToOrderDetail(AOrderNo, AProductID, AProductCode, AProductName, AQty, ASubproductOrderDetailID)
Dim LWhere
' if already exists then update the qty, else insert
LWhere = "OrderNo = '" & CleanSQLStr(AOrderNo) & "' AND ProductID = '" & AProductID & "' AND SubproductOrderDetailID = '" & ASubproductOrderDetailID & "'"
If GetSQLRecordExists("SELECT * FROM orderdetails WHERE " & LWhere) Then
ExecuteQuery("UPDATE orderdetails SET Qty = " & AQty & " WHERE " & LWhere)
Else
ExecuteQuery("INSERT INTO orderdetails SET OrderNo = '" & CleanSQLStr(AOrderNo) & "', ProductID = '" & AProductID & "', ProductCode = '" & CleanSQLStr(AProductCode) & "', ProductName = '" & CleanSQLStr(AProductName) & "', Qty = " & AQty & ", SubproductOrderDetailID = '" & ASubproductOrderDetailID & "'")
End If
End Sub
' (SS,24/3/20) don't allow ordering of radiators (due to coronavirus)
' (SS,6/4/20) added AProductID and removed LProductID = GetProductID
' (SS,2/10/20) changed to handle special case with AProductID equal to 0
' where it checks for existence of any suspended products in basket (used at checkout to fix loophole)
Function CustomOrderingSuspended(AProductID)
Dim Result
Result = False ' default to not suspended
' if local mode then no suspension
If Not IsLocalMode Then
Dim LCheckRequired
LCheckRequired = False
If AProductID = 0 Then ' basket check
LCheckRequired = GetAttributeInBasketCount("Product Type", "Radiator") > 0
Else ' single product check
LCheckRequired = GetProductAttributeByName(AProductID, "Product Type") = "Radiator"
End If
' check if required and return true if quota reached
If LCheckRequired Then
Result = Not CustomOrderingCheckDailyQuota(False)
End If
End If
CustomOrderingSuspended = Result
End Function
' (SS,3/4/20) returns true if daily quota not reached, AShowInfo is normally False, set to True to display info
Function CustomOrderingCheckDailyQuota(AShowInfo)
' start from 6th April (following date in US format)
Const START_DATE = #04/06/2020#
'Const START_DATE = #04/03/2020#
If Date() < START_DATE Then
If AShowInfo Then
Response.Write("<tr><th>Quota start date</th><td>" & START_DATE & "</td></tr>")
End If
CustomOrderingCheckDailyQuota = False
Exit Function
End If
Dim LSQL, LTotalRadiators, LDay, LDayLimit
LSQL = "SELECT SUM(od.Qty) AS TotalRadiators " &_
"FROM orderdetails od " &_
"INNER JOIN orders o ON o.OrderNo = od.OrderNo " &_
"INNER JOIN products p ON p.ProductID = od.ProductID " &_
"LEFT JOIN product_attributes pa ON pa.ProductID = od.ProductID AND pa.AttributeID = 1 " &_
"WHERE " &_
"DATE(o.DateTimeOrdered) = CURDATE() AND " &_
"(o.Status = 'PAYMENT RECEIVED' OR o.Status = 'AWAITING PAYMENT') AND " &_
"AttributeValue = 'Radiator' AND SubproductOrderDetailID IS NULL"
' get number of radiators ordered today
LTotalRadiators = NZ(GetSQLValue(LSQL))
' get day of week 1 to 7 where Monday is 1, Sunday is 7
LDay = NZ(GetSQLValue("SELECT WEEKDAY(CURDATE()) + 1"))
' (SS,9/4/20) get daily quota limit using new CustomGetRadiatorQuotaForDay which allows values to be changed via tokens
LDayLimit = CustomGetRadiatorQuotaForDay(LDay)
' Response.Write ("###" & LDay & "###" & LTotalRadiators & "###" & LDayLimit & "###" & BR)
'LTotalRadiators = 50
If AShowInfo Then
Response.Write("<tr><th>Today's quota</th><td>" & LDayLimit & "</td></tr>")
Response.Write("<tr><th>Radiators ordered today</th><td>" & LTotalRadiators & "</td></tr>")
Response.Write("<tr><th>Quota reached</th><td>" & IIf(LTotalRadiators >= LDayLimit, "Yes", "No") & "</td></tr>")
End If
CustomOrderingCheckDailyQuota = LDayLimit > LTotalRadiators
End Function
' (SS,9/4/20) called with day number 1 to 7, returns the daily limit from
' tokens : "Radiator Quota - 1 - Mon" to "Radiator Quota - 7 - Sun"
' if these contain no value then default to following:
' Mon � Fri � 35 radiators per day
' Sat & Sun � 20 radiators per day
Function CustomGetRadiatorQuotaForDay(ADayNo)
Dim LDayName, LDayLimit
Select Case ADayNo
Case 1
LDayName = "Mon"
Case 2
LDayName = "Tue"
Case 3
LDayName = "Wed"
Case 4
LDayName = "Thu"
Case 5
LDayName = "Fri"
Case 6
LDayName = "Sat"
Case Else
LDayName = "Sun"
End Select
' get value from tokens
LDayLimit = ParseFirstInt(GetTokenText("Radiator Quota - " & ADayNo & " - " & LDayName))
' if zero then use defaults
If LDayLimit = 0 Then
' Mon to Fri
If ADayNo >= 1 AND ADayNo <= 5 Then
LDayLimit = 35
Else ' Sat & Sun
LDayLimit = 20
End If
End If
CustomGetRadiatorQuotaForDay = LDayLimit
End Function
' (SS,26/3/20)
Function CustomMailshotGetSQL(AMailshotName)
Dim LResult
If AMailshotName = "OutstandingRadiatorOrders" Then
LResult = "SELECT DISTINCT " &_
"DATE(o.DateTimeOrdered) AS OrderDate, o.OrderNo, o.Priority, o.Status, o.LocalMode, o.DeliveryInfo, " &_
"o.ReadyForDespatch, o.Title, o.FirstName, o.Surname, o.Telephone, o.EmailAddress " &_
"FROM orderdetails od " &_
"INNER JOIN orders o ON o.OrderNo = od.OrderNo " &_
"INNER JOIN products p ON p.ProductID = od.ProductID " &_
"LEFT JOIN product_attributes pa ON pa.ProductID = od.ProductID AND pa.AttributeID = 1 " &_
"WHERE o.Status = 'PAYMENT RECEIVED' AND AttributeValue = 'Radiator' AND SubproductOrderDetailID IS NULL " &_
"AND (DATE(o.DateTimeOrdered) >= 20200318 OR o.OrderNo = 527221 OR o.OrderNo = 527271)" &_
"ORDER BY OrderNo"
Else
LResult = ""
End If
CustomMailshotGetSQL = LResult
End Function
' (SS,3/4/20) for new important notice button on every page (i.e. products.asp script (not other scripts))
' (SS,6/4/20) made button bigger and brighter, was btn-warning, now btn-lg btn-danger
Function CustomFinalise
If ScriptIsProducts Then
%>
<a class="btn btn-lg btn-danger" style="position: fixed; bottom: 10px; right: 10px" href="products.asp?page=coronavirus">
<strong>Important notice!</strong> Coronavirus update
</a>
<%
End If
CustomFinalise = True
End Function
%>