File: D:/web/coventrydemolition/customutils - Copy.asp
<%
' ===============
' customutils.asp
' ===============
' Version 1.27 (06/04/21)
' ============
' 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,26/06/15) Change to CustomProductNameWithBreakSingle and CustomProductNameWithBreak to handle from left also and different words for Vintage Door Knob Centre
' (SS,25/11/15) added "B" for "Holiday Notice Basket" to Sub CustomShowHolidayNotice
' (SS,01/02/16) Adjustment to Function CustomGetDelivery for doors
' (SS,13/05/16) Applied above two changes from CovDem version
' (SS,14/10/16) Change to CustomShowHolidayNotice to added type "C" for contact page
' (SS,05/04/17) Added Function CustomGetPriceWithoutOptions, changes to CustomGetOptionsPriceAndWeight for local mode exchange pricing. Also added CustomGetNormalOptionsPrice to ensure zero prices for door options.
' (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
' (SS,12/08/20) Minor text change to Function CustomFinalise (COVID-19)
' (SS,17/12/14) returns True for CIRC, False for CovDem to use to keep the same CustomGetDelivery function the same for both sites
' (SS,13/05/16) Moved CustomSiteIsCIRC to the top from below, *** perhaps change in future to look at domain to database name instead of fixed False or True value
Function CustomSiteIsCIRC
CustomSiteIsCIRC = False
End Function
' (SS,9/9/14) constants for paint finish options
Const PF_BLACK_PRIMER = "Black Primer"
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"
' (SS,10/10/14) added following class to store temporary values used by this unit/module for recommending products to buy
Class CustomRecommendToBuy
Private FValvesNeeded, FStaysNeeded, FShroudsNeeded
Private Sub Class_Initialize()
FValvesNeeded = 0
FStaysNeeded = 0
FShroudsNeeded = 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
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
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
Public Property Get Required()
Required = FValvesNeeded > 0 Or FStaysNeeded > 0 Or FShroudsNeeded > 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
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
' 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,1/2/16) adjusted delivery cost for doors from 25 to 10, and max from 100 to 60
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
LDeliveryRegionCode = GetDeliveryRegionFromPostcode(APostcode, "Pallet")
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)
' (SS,1/2/16) reverted back to 10 per door and cap to 60, above replaced with following
LDoorDeliveryCost = Min(LDoors * 10, 60)
' 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.
' (SS,10/5/16) for new CovDem reinstated original, i.e. commented out CustomPageExists = False
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
' CustomPageExists = False
End Function
' shows the content from third party table for given page
Sub CustomShowPageContent(APageName)
Dim AHeading, AText
AText = CustomGetPageContent(APageName, AHeading)
%>
<div class="heading"><h1><%=AHeading%></h1></div>
<div id="other-pages" style="margin-bottom:20px">
<%=AText%>
<a href="https://www.castironradiatorcentre.co.uk"><img src="banner/banner-radiators-3.jpg" class="img-responsive" style="margin-bottom:10px" alt="cast iron radiators"></a>
<p>
<b>For easy ordering of cast iron radiators please visit our dedicated website:</b>
</p>
<a class="btn btn-lg btn-primary btn-strong" target="_blank" href="https://www.castironradiatorcentre.co.uk" role="button">Visit Cast Iron Radiator Centre <i class="glyphicon glyphicon-chevron-right"></i></a>
</div>
<%
' shows products with attribute ID 19: "Show in Regional Matrix SEO" set to yes
ShowProducts "", "", "", "", "", "19", "", "", "Yes"
End Sub
' returns page content from third party table
Function CustomGetPageContent(APageName, ByRef AHeading)
Dim LResult
AHeading = GetSQLValueAsString("SELECT generated_h1 FROM cdc_generated WHERE generated_page_url = '" & CleanSQLStr(APageName) & "'")
AHeading = ""
LResult = ""
If GetSQL2Values("SELECT generated_h1, generated_content FROM cdc_generated WHERE generated_page_url = '" & CleanSQLStr(APageName) & "'", AHeading, LResult) Then
AHeading = NB(AHeading)
LResult = NB(LResult)
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
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
CustomGetTitleTagForPage = GetSQLValueAsString("SELECT " & LFieldName & " FROM cdc_generated WHERE generated_page_url = '" & CleanSQLStr(APageName) & "'")
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")
LHTML = LHTML & "<ul class=""regional-sitemap"">" & 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
Sub CustomGetProductSettings(ByRef AProductID, ByRef ASectionPrice, ByRef ASectionsAvailable, ByRef ASectionsReadyMade, ByRef AHeight, ByRef ALength, ByRef ASectionLength, ByRef ADepth, ByRef ASectionWeight, ByRef ABTURating)
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"))
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)
Function CustomBTUTokW(ABTU)
CustomBTUTokW = ABTU * 0.000293071
End Function
' (SS,22/8/14) custom specification table
' (SS,13/9/14) added footnote for ready made sections
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
LResult = ""
CustomGetProductSettings LProductID, LSectionPrice, LSectionsAvailable, LSectionsReadyMade, LHeight, LLength, LSectionLength, LDepth, LSectionWeight, LBTURating
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"">"
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 style=""vertical-align: middle"">BTU</th><th style=""vertical-align: middle"">kW</th><th style=""vertical-align: middle"">kg</th><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>"
LResult = LResult & "<td>" & LBTURating * LSectionsInt & "</td>"
LResult = LResult & "<td>" & FormatNumber(CustomBTUTokW(LBTURating * LSectionsInt), 2) & "</td>"
LResult = LResult & "<td>" & FormatNumber(LSectionWeight * LSectionsInt, 0) & "</td>"
LResult = LResult & "<td>" & "£" & FormatNumber(LSectionPrice * LSectionsInt, 2) & "</td>"
LResult = LResult & "</tr>"
Next
LResult = LResult & "</table>"
LResult = LResult & "</div>"
LResult = LResult & "<p><small>"
LResult = LResult & FOOTNOTE_SYMBOL_HEIGHT & " Height is for foot section."
LResult = LResult & BR & FOOTNOTE_SYMBOL_LENGTH & " All lengths approximate and include to bush ends - please allow 4% tolerance."
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
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 & FormatNumber(CustomBTUTokW(ABTURating * LSectionsInt), 2) & " kW" & 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
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_BLACK_PRIMER)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_GUNMETAL_GREY)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_SATIN_BLACK)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_LINEN_WHITE)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_CREAM_WHITE)
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_ANTIQUE_BRONZE)
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
Dim LProductID, LSectionPrice, LSectionsAvailable, LSectionsReadyMade, LHeight, LLength, LSectionLength, LDepth, LSectionWeight, LBTURating
CustomGetProductSettings LProductID, LSectionPrice, LSectionsAvailable, LSectionsReadyMade, LHeight, LLength, LSectionLength, LDepth, LSectionWeight, LBTURating
If UBound(LSectionsReadyMade) >= 0 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,5/4/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,5/4/17) adjusts the options price for local mode and exchange, i.e. sets to zero
Function CustomGetNormalOptionsPrice(AOptionsPrice)
If IsLocalMode And IsExchange Then
CustomGetNormalOptionsPrice = 0
Else
CustomGetNormalOptionsPrice = AOptionsPrice
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,5/5/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)
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
AOptionsPrice = AOptionsPrice + CustomGetRadiatorPrice(AMainPrice, LSections - 1) ' -1 because we're subtracting the main price which is used for the section price
AOptionsPrice = AOptionsPrice + CustomGetPaintFinishPrice(LPaintFinish, LSections)
AOptionsWeight = AOptionsWeight + AMainWeight * (LSections - 1)
' Response.Write "### AOptionsPrice: " & AOptionsPrice & "###" & BR
' (SS,5/4/17) zero the options price for local mode exchanges
If IsLocalMode And IsExchange Then
AOptionsPrice = 0
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
Function CustomGetPaintFinishPrice(APaintFinish, ASections)
Dim LPrice
If 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
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
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 delivery in" ' (SS,17/10/14)
End If
' CustomGetDeliveryDays = "Despatched in " + LResult + " working days"
' (SS,17/10/14) replaced above with following
CustomGetDeliveryDays = LPrefix + " <b>" + LDays + " working days</b>"
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
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", "Wall Stays") & """>Wall Stays</a><br>"
If oCustomRecommendToBuy.ShroudsNeeded > 0 Then Response.Write oCustomRecommendToBuy.ShroudsNeeded & " x <a href=""" & GetSubcategoryLink("Accessories", "Pipe Shrouds - Sleeves") & """>Pipe Shrouds and Base Plates</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)
%>
<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>
<h4 style="margin-bottom: 5px" class="text-success"><%=CustomGetDeliveryDays(LProductID, LSections, LPaintFinish)%><sup></sup></h4>
<small>All items delivered together. Actual delivery depends on item with greatest lead time.</small>
<%
End If
End Sub
' (SS,10/9/14) called from CustomProductNameWithBreak below
' (SS,26/6/15) added APosition which can be "L" for left, or "R" for right, improved to remove leading " - " from line 2
Function CustomProductNameWithBreakSingle(AProductName, ABreakText, APosition)
Const BREAK_TEXT = "cast iron radiator"
Dim LLen, LLine1, LLine2, LResult
LLen = Len(ABreakText)
If APosition = "R" And LCase(Right(AProductName, LLen)) = ABreakText Then
LLine1 = Left(AProductName, Len(AProductName) - LLen)
LLine2 = Right(AProductName, LLen)
ElseIf APosition = "L" And LCase(Left(AProductName, LLen)) = ABreakText Then
LLine1 = Left(AProductName, LLen)
LLine2 = Right(AProductName, Len(AProductName) - LLen)
Else
LLine1 = AProductName
LLine2 = ""
End If
If LLine2 <> "" Then
' remove leading " - " from line 2
LLine2 = Trim(LLine2)
If Left(LLine2, 2) = "- " Then
LLine2 = Mid(LLine2, 3)
End If
LResult = LLine1 + BR + LLine2
Else
LResult = LLine1
End If
CustomProductNameWithBreakSingle = LResult
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", "R")
'LResult = CustomProductNameWithBreakSingle(LResult, "radiator valve set", "R")
'LResult = CustomProductNameWithBreakSingle(LResult, "for cast iron radiators", "R")
LResult = CustomProductNameWithBreakSingle(AProductName, "victorian door knobs", "L")
LResult = CustomProductNameWithBreakSingle(LResult, "georgian door knobs", "L")
LResult = CustomProductNameWithBreakSingle(LResult, "edwardian door knobs", "L")
LResult = CustomProductNameWithBreakSingle(LResult, "keyhole cover escutcheon", "L")
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,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
' (SS,12/8/20) changed Coronavirus update text to COVID-19 update
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> COVID-19 update
</a>
<%
End If
CustomFinalise = True
End Function
%>