File: D:/web/castironradiatorcentre/changes prev/2024-02-29 (copies)/customutils - Copy (10).asp
<%
' ===============
' customutils.asp
' ===============
' Version 1.76 (07/12/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,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,02/10/20) Change to Function CustomOrderingCheckDailyQuota to show Non Local Mode and Local Mode radiators total on radiator-quota.asp
' (SS,06/11/20) Change to CustomGetDelivery allow radiatory delivery cost to override the normal delivery cost
' (SS,02/12/20) Change to Sub CustomGetProductSettings, added wider choice of sections using "Sections Available Local Mode" attribute if in local mode
' (SS,22/12/20) Change to Function CustomGetDeliveryadded to allow separate pallet delivery charge for Republic of Ireland
' (SS,08/01/21) Change to Function CustomFinalise to add Brexit to the caption
' (SS,21/04/21) Many new routines added for new despatch dates productivity rate feature
' New routines: CustomGetNextAvailableDespatchByDate, CustomGetRadiatorDespatchDaysForUSP, CustomGetRadiatorDespatchDays, CustomGetDailyRadProductionRate,
' CustomGetMinRadDespatchDays, CustomGetLastUsedRadDespatchByDate, CustomSetLastUsedRadDespatchByDate, CustomGetNADBD_SQL
' (SS,22/04/21) Change to Function CustomGetNADBD_SQL to include radiator, previous was it only showing the non-exchanges
' (SS,23/04/21) Change to Function CustomGetDeliveryDays to apply selected DespatchByDate in local mode for priority 9, added Function CustomIsLocalModeWithPriorityNine
' (SS,01/05/21) Change to Function CustomGetDeliveryDays to also handle clearance radiators as normal radiators, also changed Function CustomGetDespatchByDateList to default to 1st entry instead of 3rd
' (SS,07/06/21) Change to Function CustomGetDeliveryDays to return extended lead time attribute for clearance radiators
' added AReturnDaysOnly parameter to return LDays only with the extra prefix and suffix text, used by call in inc-template-product-detail.asp for clearance radiators
' (SS,16/06/21) Change to Function CustomGetDelivery to add setting of priority to 7 if clearance radiators and no bespoke radiators
' (SS,21/06/21) Change to Function CustomGetPriceWithoutOptions to set to 1p for "Warranty (FOC) Ireland" instead of 0, need to to do at option level
' (SS,03/08/21) Moved Touch Up Paint from bottom to top (change to Sub CustomShowRecommendationProducts)
' (SS,16/09/21) Modified Sub CustomGetLegMidSections so that all rads with 17 or more section have an extra leg, previously it was 16 or more for all except 460s
' (SS,17/09/21) Modified Function CustomGetDelivery added to setting of DeliveryOption to show "Kerbside Pallet Delivery" for radiators, also required a change to inc-template-basket.asp
' (SS,29/09/21) Modified Function CustomGetOptionsPriceAndWeight, change to AOptionsWeight to fix weight discrepancy for radiators, also change to apputils to include subproducts for weight calculation
' (SS,20/10/21) Modified Function CustomGetProductOptionHTML to not show "Antique Bronze" for CDC-PAINT product
' (SS,07/12/21) Modiied Function CustomGetNextAvailableDespatchByDate to ignore Christmas break days, also added Function CustomIsChristmasBreak
' (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
' (SS,6/11/20) change to allow radiatory delivery cost to override the normal delivery cost
' (SS,22/12/20) added separate pallet delivery charge for Republic of Ireland
' (SS,16/6/21) added setting of priority to 7 if clearance radiators and no bespoke radiators
' (SS,17/9/21) added setting of DeliveryOption to show "Kerbside Pallet Delivery" for radiators, also required a change to inc-template-basket.asp
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"
' (SS,22/12/20) adjustment for Republic of Ireland due to Brexit
'
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 = "R4" ' (SS,22/12/20) changed from "R3" to "R4"
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
' (SS,22/12/20) added following for Republic of Ireland
ElseIf LDeliveryRegionCode = "R4" Then
LRegionIndex = 4
Else ' i.e. ""
LRegionIndex = 5 ' (SS,22/12/20) changed from 4 for 5 due to Republic of Ireland using 4
End If
' if LRegionIndex is 4 then notify that they need to phone for delivery cost
' (SS,22/12/20) changed from 4 to 5, 4 now used for Republic of Ireland
If LRegionIndex = 5 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
' I'm ignoring the 0 elements, easier this way
' (SS,22/12/20) modified from 3, 3 to 4, 3 to handle new region for Republic of Ireland
Dim LDeliveryArray(4, 3)
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,22/12/20) for Republic of Ireland
' Paul's email:
' This is not required to be effective until 4th January, but I have just been emailed with the additional charges for customs clearance for Rep of Ireland pallet deliveries!! Nothing like being prepared ?
' We may need to set up a new zone for Rep of Ireland pallet deliveries in order to adjust their prices moving forward, but initially, I need to increase the pallet prices to the following:
' 1-3 = �145.00 + vat
' 4-7 = �170.00 + vat
' 8+ = �209.00 + vat
' Oversize surcharge remains at �40.00 per pallet.
'
' Added following
LDeliveryArray(4, 1) = 145
LDeliveryArray(4, 2) = 170
LDeliveryArray(4, 3) = 209
' (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
LDeliveryArray(4, 0) = 40 ' (SS,22/12/20) for new region Republic of Ireland
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
' (SS,6/11/20) Paul, CIRC, phoned regarding a possible anomaly, large order with oversize, should have been �85 for delivery, not �95
' was due to ANormalDeliveryCost being �95 due to large amount of non-radiator products. He said to use the radiator cost in such cases.
' added "If" to following to allow LRadiatorDeliveryCost to override the delivery cost
If LRadiatorDeliveryCost > 0 Then
CustomGetDelivery = LRadiatorDeliveryCost
Else ' (SS,6/11/20) as before (LRadiatorDeliveryCost has become redundant in following)
CustomGetDelivery = Max(Max(ANormalDeliveryCost, LRadiatorDeliveryCost), LDoorDeliveryCost)
End If
' ========== START OF SET PRIORITY ==========
' (SS,16/6/21) set priority to 7 if clearance radiator and no bespoke radiator in basket
' not in local mode or google shopping data feed
If Not IsLocalMode And Not InGoogleShoppingDataFeed Then
Dim LPriority, LRadiatorCount, LBespokeRadiatorCount
LRadiatorCount = GetAttributeInBasketCount("Product Type", "Radiator")
LBespokeRadiatorCount = GetAttributeWithOptionNameInBasketCount("Product Type", "Radiator", "Sections")
If LRadiatorCount > 0 And LBespokeRadiatorCount = 0 Then
LPriority = 7
Else
LPriority = 5
End If
SetPriority LPriority
End If
' ========== END OF SET PRIORITY ==========
' (SS,17/9/21) to show on basket, final checkout stage and confirmation email page "Kerbside Pallet" with kerbside in bold if order contains a radiator, else as before i.e. "Delivery"
If LRadiators > 0 Then
SetDeliveryOption "<b>Kerbside</b> Pallet"
Else
SetDeliveryOption ""
End If
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
' (SS,2/12/20) added wider choice of sections using "Sections Available Local Mode" attribute if in local mode
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)
' (SS,2/12/20) added following for local mode, i.e. wider choice of sections for local mode if set in new attribute "Sections Available Local Mode"
If IsLocalMode Then
Dim LSectionsAvailableLocalModeStr
LSectionsAvailableLocalModeStr = GetProductAttributeByName(AProductID, "Sections Available Local Mode")
If LSectionsAvailableLocalModeStr <> "" Then
LSectionsAvailableStr = LSectionsAvailableLocalModeStr
End If
End If
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
' (SS,20/10/21) change to not show "Antique Bronze" for CDC-PAINT product
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)
' (SS,20/10/21) added following "if" not now show "Antique Bronze" if "NAB" in extra settings of this option, i.e. as requested for CDC-PAINT product
If Not IsOption(AExtraSettings, "NAB") Then
LResult = LResult & CustomGetProductOptionValuePaintFinish(PF_ANTIQUE_BRONZE)
End If
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
' (SS,21/6/21) modified to set to 1p for "Warranty (FOC) Ireland" instead of 0, need to to do at option level
Function CustomGetPriceWithoutOptions(APriceWithoutOptions)
If IsLocalMode And IsExchange Then
' (SS,21/6/21) added "If" for 1p for FOC Ireland
If GetExchangeReason = "Warranty (FOC) Ireland" Then
CustomGetPriceWithoutOptions = 0.01 ' i.e. 1p
Else
CustomGetPriceWithoutOptions = 0
End If
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
' (SS,29/9/21) change to AOptionsWeight to fix weight discrepancy for radiators, also change to apputils to include subproducts for weight calculation
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)
' (SS,29/9/21) replaced above with following to fix discrepancy, now subproducts are used to calculate the weight, main product weight is used by specifications, and subtracted off below
AOptionsWeight = AOptionsWeight - AMainWeight
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)
' (SS,1/5/21) modified to also handle clearance radiators as normal radiators
' (SS,7/6/21) changed to return extended lead time attribute for clearance radiators
' added AReturnDaysOnly parameter to return LDays only with the extra prefix and suffix text, used by call in inc-template-product-detail.asp for clearance radiators
Function CustomGetDeliveryDays(AProductID, ASections, APaintFinish, AReturnDaysOnly)
Dim LSectionsReadyMade, LPrefix, LDays, LDeliveryExtendedLeadTime, LIsRadiator
' (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
' (SS,1/5/21) added following to also handle clearance radiators which don't have sections or paint finish
' product type attribute used to accurately detect that the product is a radiator
LIsRadiator = GetProductAttributeByName(AProductID, "Product Type") = "Radiator"
'If ASections = "" Or APaintFinish = "" Then ' i.e. not a radiator
' (SS,1/5/21) replaced above with following, more accurate and works for clearance radiators
If Not LIsRadiator Then
' (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,20/4/21) added following, new method that overrides the lead times from the attribute using a more accurate calculated one
' * code above can be commented out, left it in for now
If DespatchDatesEnabled Then
' (SS,7/6/21) modified to use the extended lead time attribute for clearance radiators
If ASections = "" And LDeliveryExtendedLeadTime <> "" Then
LDays = LDeliveryExtendedLeadTime
Else ' as before
LDays = CustomGetRadiatorDespatchDays(True)
End If
' (SS,22/4/21) override LDays in local mode with chosen date if priority is "9"
If CustomIsLocalModeWithPriorityNine Then
If GetPriority = "9" Then ' (SS,23/4/21) note that it's a string
Dim LDespatchByDate
LDespatchByDate = GetLocalModeDespatchByDate
If IsDate(LDespatchByDate) Then
Dim LDaysBetween
LDaysBetween = WorkingDaysBetween(Date, LDespatchByDate)
If LDaysBetween >= CustomGetMinRadDespatchDays Then
LDays = (LDaysBetween - 2) & " - " & LDaysBetween
End If
End If
End If
End If
Else ' (SS,20/4/21) as before
' (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
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>"
' (SS,20/4/21) added following to add the actual dates
If DespatchDatesEnabled Then
Dim LFromDate, LToDate
LFromDate = GetSQLValue("SELECT common.GetNthWorkingDay(CURDATE(), common.GetFirstInteger('" & CleanSQLStr(LDays) & "'))")
LToDate = GetSQLValue("SELECT common.GetNthWorkingDay(CURDATE(), common.GetSecondInteger('" & CleanSQLStr(LDays) & "'))")
LResult = LResult & " (from " & LFromDate & " to " & LToDate & ")"
End If
' if a radiator
' (SS,1/5/21) replaced ASections <> "" with LIsRadiator, commented out anyway due to not being used
'If LIsRadiator 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
' (SS,7/6/21) modified to return LDays only if AReturnDaysOnly is True
If AReturnDaysOnly Then
CustomGetDeliveryDays = LDays
Else
CustomGetDeliveryDays = LResult
End If
End Function
' (SS,23/4/21)
Function CustomIsLocalModeWithPriorityNine
Dim LResult
LResult = False
If IsLocalMode Then
LResult = GetPriority = "9" ' (SS,23/4/21) note that it's a string
End If
CustomIsLocalModeWithPriorityNine = LResult
End Function
' (SS,20/4/21) parses the ADeliveryInfo and returns the dates ADespatchFromDate and ADespatchByDate from it
' ADespatchFromDate and ADespatchByDate left unchanged if not found
' returns true if both dates found, called from TryProcessOrder
Function CustomGetDespatchDatesFromDeliveryInfo(ADeliveryInfo, ByRef ADespatchFromDate, ByRef ADespatchByDate)
Dim LPos, LDateStr
LPos = InStr(ADeliveryInfo, "from ")
ADespatchFromDate = ""
If LPos > 0 Then
LDateStr = Mid(ADeliveryInfo, LPos + 10, 10)
If IsDate(LDateStr) Then
ADespatchFromDate = CDate(LDateStr)
End If
End If
LPos = InStr(ADeliveryInfo, "to ")
ADespatchByDate = ""
If LPos > 0 Then
LDateStr = Mid(ADeliveryInfo, LPos + 8, 10)
If IsDate(LDateStr) Then
ADespatchByDate = CDate(LDateStr)
' save as the last used date, this routine is called from TryProcessOrder and updates the SiteDetails table and will need to update the sitedetails table
' only save if first int i.e. working days is > 2 i.e. radiators (5 - 7), normal orders are 1 - 2 working days (could use > 1)
If ParseFirstInt(ADeliveryInfo) > 2 Then
' (SS,23/4/21) if local mode with priority "9" then don't save because it's a special case manually entered despatch by date
If Not CustomIsLocalModeWithPriorityNine Then
CustomSetLastUsedRadDespatchByDate ADespatchByDate
End If
End If
End If
End If
CustomGetDespatchDatesFromDeliveryInfo = ADespatchFromDate <> "" And ADespatchByDate <> ""
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, False) ' (SS,7/6/21) added False for AReturnDaysOnly
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
' (SS,3/8/21) moved Touch Up Paint from bottom to top
Sub CustomShowRecommendationProducts
' (SS,24/8/16) added following
' (SS,3/8/21) moved from bottom to top of list
If oCustomRecommendToBuy.TouchUpPaintNeeded > 0 Then Response.Write oCustomRecommendToBuy.TouchUpPaintNeeded & " x <a href=""" & GetSubcategoryLink("Accessories & Spares", "Touch Up Paint") & """>Touch Up Paint</a><br>"
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>"
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
' (SS,7/6/21) added False for AReturnDaysOnly to call to CustomGetDeliveryDays
%>
<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, False)%><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
' (SS,16/9/21) modified to that all rads with 17 or more section have an extra leg, previously it was 16 or more for all except 460s
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
' (SS,16/9/21) modified to that all radiators behave the same 460s, i.e. only 17 or above have 3 sections, takes effect from midnight
If Date >= CDate("17/09/2021") Then
ALegSections = IIf(ARadSections <= 16, 2, 3)
Else ' (SS,16/9/21) as before
If CLng(AProductID) = RAD_460 Then
ALegSections = IIf(ARadSections <= 16, 2, 3)
Else
ALegSections = IIf(ARadSections <= 15, 2, 3)
End If
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("<table class=""table table2 table-responsive table-sm table-bordered table-striped"" style=""width: auto;"">")
Response.Write("<tr><th>Today's quota</th><td>" & LDayLimit & "</td><th>Radiators ordered</th><td>" & LTotalRadiators & "</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><th>Remaining</th><td>" & LDayLimit - LTotalRadiators & "</td></tr>")
' (SS,2/10/20) extra totals for sold, exchanges, non local mode and local mode
' added other useful info, including quota for each day
Dim LSoldTotal, LExchangesTotal, LNonLocalModeTotal, LLocalModeTotal
LSoldTotal = NZ(GetSQLValue(LSQL & " AND NOT Exchange"))
LExchangesTotal = NZ(GetSQLValue(LSQL & " AND Exchange"))
LNonLocalModeTotal = NZ(GetSQLValue(LSQL & " AND NOT LocalMode"))
LLocalModeTotal = NZ(GetSQLValue(LSQL & " AND LocalMode"))
Response.Write("<tr><th colspan=""4""></th></tr>")
Response.Write("<tr><th>Sold</th><td>" & LSoldTotal & "</td><th>Non Local Mode</th><td>" & LNonLocalModeTotal & "</td></tr>")
Response.Write("<tr><th>Exchanges</th><td>" & LExchangesTotal & "</td><th>Local Mode</th><td>" & LLocalModeTotal & "</td></tr>")
Response.Write("<tr><th>Total</th><td>" & LSoldTotal + LExchangesTotal & "</td><th>Total</th><td>" & LNonLocalModeTotal + LLocalModeTotal & "</td></tr>")
Response.Write("</table>")
' (SS,3/10/20) show the quota for each day
Response.Write("<table class=""table table2 table-responsive table-sm table-bordered table-striped"" style=""width: auto;"">")
Response.Write("<tr>")
Dim i, LDailyQuota, LWeeklyQuota
LWeeklyQuota = 0
For i = 1 To 7
Response.Write("<th>" & CustomGetDayName(i) & "</th>")
LDailyQuota = CustomGetRadiatorQuotaForDay(i)
Response.Write("<td>" & LDailyQuota & "</td>")
LWeeklyQuota = LWeeklyQuota + LDailyQuota
Next
Response.Write("<th>Total</th><td>" & LWeeklyQuota & "</td>")
Response.Write("</tr>")
Response.Write("</table>")
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
LDayName = CustomGetDayName(ADayNo)
' 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,3/10/20) moved here from CustomGetRadiatorQuotaForDay
Function CustomGetDayName(ADayNo)
Dim LDayName
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
CustomGetDayName = LDayName
End Function
' (SS,26/3/20)
' (SS,20/10/20) script will timeout at about 229 records
' *** need to increase this timeout period or do in batches
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) AND o.OrderNo > 531503 " &_
"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
' (SS,8/1/21) changed "Coronavirus update" to "Covid-19 & Brexit updates", also added Not IsPageName("coronavirus") to not show on this page
' (SS,8/1/21) then changed "Important notice: Covid-19 & Brexit update" i.e. ! to : and removed plural
Function CustomFinalise
If ScriptIsProducts And Not IsPageName("coronavirus") 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 & Brexit update
</a>
<%
End If
CustomFinalise = True
End Function
' (SS,9/4/21) returns next available date to use for a radiator order, minimum is 7 working days
' returns the date and/or number of working days from today
' *** To Do, only look this up every 5 or so minutes to prevent slowness, time how long this takes
' date is returned, AAvailableDayRange is returned in parameter e.g. 5 - 7
' (SS,20/4/21) added ADespatchFromDate
' (SS,7/12/21) added Christmas break count (LChristmasBreakDayCount), i.e. non-productive working days
Function CustomGetNextAvailableDespatchByDate(ByRef AAvailableDayRange, ByRef ADespatchFromDate)
'Const DAILY_RADIATOR_PRODUCTION_RATE = 20 ' 75
'Const MINIMUM_WORKING_DAYS = 7
Dim LSQL, LDailyProductionRate, LMinDespatchDays
LDailyProductionRate = CustomGetDailyRadProductionRate
LMinDespatchDays = CustomGetMinRadDespatchDays
' following query totals up the radiators per despatch by date
' it also links to common calendar table to get up to 180 following working days
LSQL = CustomGetNADBD_SQL
Dim LWorkingDayCount, LCumulativeRadCount, LAvailableDay, LAvailableDate, LDespatchByDate, LChristmasBreakDayCount
LWorkingDayCount = 0
LCumulativeRadCount = 0
LAvailableDay = 0
LChristmasBreakDayCount = 0 ' (SS,7/12/21)
' NB. using OpenQuery3, EndOfQuery3, GetQueryValue3, NextQueryRecord3, CloseQuery3 instead of OpenQuery etc to prevent clash which will occur in TryProcessOrder when cache miss
' probably could have used OpenQuery2, but thought OpenQuery3 was safe due to not being used elsewhere
OpenQuery3(LSQL)
Do While Not EndOfQuery3 And LAvailableDay = 0
' start from min days onwards i.e. 7
LCumulativeRadCount = LCumulativeRadCount + NZ(GetQueryValue3("Radiators"))
LWorkingDayCount = LWorkingDayCount + 1
LDespatchByDate = GetQueryValue3("DespatchByDate")
' (SS,7/12/21)
If CustomIsChristmasBreak(LDespatchByDate) Then
LChristmasBreakDayCount = LChristmasBreakDayCount + 1
End If
If (LWorkingDayCount >= LMinDespatchDays) And (LDespatchByDate >= CustomGetLastUsedRadDespatchByDate) Then
'Response.Write "CumulativeRadCount: " & LCumulativeRadCount & BR
'Response.Write "WorkingDayCount: " & LWorkingDayCount & BR
'If LCumulativeRadCount < (LWorkingDayCount * LDailyProductionRate) Then
' (SS,7/12/21) replaced above with following to ignore Christmas break days
If LCumulativeRadCount < ((LWorkingDayCount - LChristmasBreakDayCount) * LDailyProductionRate) Then
LAvailableDay = LWorkingDayCount
LAvailableDate = LDespatchByDate
'Response.Write "AvailableDay: " & LAvailableDay & BR
'Response.Write "AvailableDate: " & LAvailableDate & BR
End If
End If
NextQueryRecord3
Loop
CloseQuery3
' (SS,20/4/21) set the proper "from date" using GetNthWorkingDay 2 days earlier
ADespatchFromDate = GetSQLValue("SELECT common.GetNthWorkingDay(DATE(CURDATE()), " & LAvailableDay - 2 & ")")
AAvailableDayRange = LAvailableDay - 2 & " - " & LAvailableDay
CustomGetNextAvailableDespatchByDate = LAvailableDate
End Function
' (SS,21/4/21) called from home page for unique selling point
Function CustomGetRadiatorDespatchDaysForUSP
Const DEFAULT_DAYS = "20 - 25"
Dim LResult
If DespatchDatesEnabled Then
LResult = CustomGetRadiatorDespatchDays(True)
Else
LResult = DEFAULT_DAYS
End If
CustomGetRadiatorDespatchDaysForUSP = LResult
End Function
' (SS,20/4/21) cached version used by home page and radiator pages, updated every 10 minutes
' this is also called form the home page using True as the parameter
' returns the range e.g. "20 - 22"
Function CustomGetRadiatorDespatchDays(ACached)
Const CACHE_MINS = 10
Dim LFromCache
If ACached And Application("RadiatorDespatchDays") <> "" Then
' check that x minutes haven't passed
LFromCache = DateDiff("n", Application("RadiatorDespatchDaysTimestamp"), Now) < CACHE_MINS
Else
LFromCache = False
End If
If Not LFromCache Then
Dim LStartTimer, LTimeTaken
LStartTimer = Timer
Dim LDespatchByDate, LAvailableDayRange, LDespatchFromDate
LDespatchByDate = CustomGetNextAvailableDespatchByDate(LAvailableDayRange, LDespatchFromDate)
LTimeTaken = Timer - LStartTimer
Application.Lock
If Application("RadiatorDespatchEarliestTimestamp") = "" Then Application("RadiatorDespatchEarliestTimestamp") = Now
Application("RadiatorDespatchDaysTimestamp") = Now
Application("RadiatorDespatchDays") = LAvailableDayRange
Application("RadiatorDespatchByDate") = LDespatchByDate
Application("RadiatorDespatchFromDate") = LDespatchFromDate
' count how many non-cached calls
If Application("RadiatorDespatchRunCount") = "" Then Application("RadiatorDespatchRunCount") = 0
Application("RadiatorDespatchRunCount") = Application("RadiatorDespatchRunCount") + 1
' add to total time taken
If Application("RadiatorDespatchRunTimeTotal") = "" Then Application("RadiatorDespatchRunTimeTotal") = 0
Application("RadiatorDespatchRunTimeTotal") = Application("RadiatorDespatchRunTimeTotal") + LTimeTaken
' max time
If Application("RadiatorDespatchRunTimeMax") = "" Or LTimeTaken > Application("RadiatorDespatchRunTimeMax") Then Application("RadiatorDespatchRunTimeMax") = LTimeTaken
' min time
If Application("RadiatorDespatchRunTimeMin") = "" Or LTimeTaken < Application("RadiatorDespatchRunTimeMin") Then Application("RadiatorDespatchRunTimeMin") = LTimeTaken
Application.UnLock
End If
CustomGetRadiatorDespatchDays = Application("RadiatorDespatchDays")
End Function
' (SS,9/4/21)
Function CustomGetDailyRadProductionRate
Const DAILY_RADIATOR_PRODUCTION_RATE = 75
' get from token
Dim LDailyProductionRate
LDailyProductionRate = ParseFirstInt(GetTokenText("Radiator Daily Production Rate"))
' use default if not correctly defined in token
If LDailyProductionRate = 0 Then LDailyProductionRate = DAILY_RADIATOR_PRODUCTION_RATE
CustomGetDailyRadProductionRate = LDailyProductionRate
End Function
' (SS,9/4/21)
Function CustomGetMinRadDespatchDays
Const MINIMUM_WORKING_DAYS = 7
CustomGetMinRadDespatchDays = MINIMUM_WORKING_DAYS
End Function
' (SS,9/4/21) gets the last date used from token
Function CustomGetLastUsedRadDespatchByDate
Dim LResult, LLastSavedDate
LResult = CDate("27/05/2021") ' seemed like the appropriate value to use when going live on 21/4/21
' (SS,21/4/21) get last used date from token, use if valid
LLastSavedDate = Trim(GetTokenText("Radiator Last Used Despatch By Date"))
If LLastSavedDate <> "" Then
If IsDate(LLastSavedDate) Then
LResult = CDate(LLastSavedDate)
End If
End If
CustomGetLastUsedRadDespatchByDate = LResult
End Function
' (SS,21/4/21) this gets called from TryProcessOrder to save the last used despatch date
Sub CustomSetLastUsedRadDespatchByDate(ADate)
' (SS,23/4/21) only save if after existing date
If ADate > CustomGetLastUsedRadDespatchByDate Then
' save to token, which is also fetched by CustomGetLastUsedRadDespatchByDate
SetTokenText "Radiator Last Used Despatch By Date", CStr(ADate)
End If
End Sub
' (SS,9/4/21) used by CustomGetNextAvailableDespatchByDate above, also may be called from elsewhere for info and testing
' following query totals up the radiators per despatch by date
' it also links to common calendar table to get up to 180 following working days
' (SS,20/4/21) modified to always excluded rads already despatch and also mark as ready to despatch i.e. ReadyForDespatch IS NULL, last time it was set was 9/12/2020
Function CustomGetNADBD_SQL
Dim LSQL
LSQL = "SELECT 0 AS WorkingDayNo, DespatchByDate, SUM(Radiators) AS Radiators, 0 AS CumulativeRadiators, 0 AS ProductionRate, 0 AS ProductionRateCumulative, FALSE AS Availability" &_
" FROM" &_
"(" &_
"SELECT DespatchByDate, SUM(od.Qty) AS Radiators" & NL &_
"FROM orders o" & NL &_
"INNER JOIN orderdetails od ON od.OrderNo = o.OrderNo" & NL &_
"INNER JOIN products p ON p.ProductID = od.ProductID" & NL &_
"INNER JOIN product_attributes pa ON pa.ProductID = od.ProductID AND pa.AttributeID = 1" & NL &_
"LEFT JOIN common.calendar cc ON cc.CalendarDate = DespatchByDate AND cc.IsWorkingDay" & NL &_
"WHERE" & NL &_
"o.DespatchByDate >= CURDATE() + INTERVAL 1 DAY" & NL
LSQL = LSQL & "AND (o.Status = 'PAYMENT RECEIVED' OR o.Status = 'AWAITING PAYMENT') " & NL
LSQL = LSQL & "AND ReadyForDespatch IS NULL" & NL ' (SS,20/4/21)
LSQL = LSQL & "AND pa.AttributeValue = 'Radiator' AND od.SubproductOrderDetailID IS NULL" & NL
' (SS,22/4/22) removed following to include all
' LSQL = LSQL & "AND o.Exchange = FALSE" & NL
LSQL = LSQL &_
"GROUP BY DespatchByDate" & NL &_
"UNION ALL" & NL &_
"SELECT CalendarDate, 0 AS Radiators" & NL &_
"FROM common.calendar" & NL &_
"WHERE" & NL &_
"CalendarDate BETWEEN (CURDATE() + INTERVAL 1 DAY) AND (CURDATE() + INTERVAL 180 DAY) AND IsWorkingDay" & NL &_
") a" & NL &_
"GROUP BY DespatchByDate"
CustomGetNADBD_SQL = LSQL
End Function
' (SS,22/4/21) returns 25 working days in list for validation in local mode where date can be entered for priority 9
' (SS,23/4/21) added ADefaultDate
' (SS,1/5/21) changed default from 3rd to 1st entry
Function CustomGetDespatchByDateList(ByRef ADefaultDate, ByRef AMInDate, ByRef AMaxDate)
Dim LResult, LDate, LMinDays, i
LMinDays = CustomGetMinRadDespatchDays
LResult = "<datalist id=""despatchbydates"">"
' in format: <option label="Groundhog Day">2021-02-02</option>
For i = 0 To 24
LDate = ISODate(GetSQLValue("SELECT common.GetNthWorkingDay(CURDATE(), " & (i + LMinDays) & ")"))
If i = 0 Then
AMInDate = LDate
'ElseIf i = 2 Then ' default to the third entry
' (SS,1/5/21) removed above to default to first entry instead of 3rd
ADefaultDate = LDate
End If
LResult = LResult & NL & "<option label=""Working Day " & (i + LMinDays) & """>" & LDate & "</option>"
Next
AMaxDate = LDate
LResult = LResult & NL & "</datalist>"
CustomGetDespatchByDateList = LResult
End Function
' (SS,7/12/21) returns True if given date is a Christmas break date, i.e. no productivity on this date
' used by radiator-availability.asp and CustomGetNextAvailableDespatchByDate
Function CustomIsChristmasBreak(ADate)
Dim Result
Result = False
If ADate >= CDate("24/12/2021") And ADate <= CDate("31/12/2021") Then
Result = True
End If
CustomIsChristmasBreak = Result
End Function
%>