File: D:/web/circ.itp/2025-10-28/new/customutils.asp
<%
' ===============
' customutils.asp
' ===============
' Version 2.18 (28/10/25)
' ============
' 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) Modified Function CustomGetNextAvailableDespatchByDate to ignore Christmas break days, also added Function CustomIsChristmasBreak
' (SS,10/02/22) Modified Function CustomGetPaintFinishPrice to apply price increase from 5.50 to 6.00 on and after 11/02/2022
' (SS,01/03/22) Applied pallet delivery price increases to Function CustomGetDelivery
' (SS,12/04/22) Change to Function CustomGetProductOptionHTML to not show "Matt Black" for CDC-PAINT product
' (SS,21/04/22) Change to Function CustomGetProductOptionHTML to not show "Black Primer"
' (SS,22/04/22) Modified function CustomGetProductOptionHTML to make use of new CustomIncludePaintOption, exclusion now works for all colours
' (SS,24/05/22) Change to Function CustomFinalise for covid/brexit
' (SS,06/07/22) Changes to Sub CustomAjaxProductPrice and Function CustomGetDeliveryDays, Function CustomFinalise, for delivery message and button on bottom of page
' (SS,03/08/22) Change to Sub CustomAjaxProductPrice to add PayPal Pay Later message
' (SS,21/09/22) Changed Function CustomGetOptionsPriceAndWeight - WARRANTY_CHARGED_PRICE from 35 to 45
' (SS,28/09/22) Change to Function CustomGetDelivery to not allow delivery for Republic of Ireland, i.e. they contact for delivery cost
' (SS,16/12/22) Modified Sub CustomGetLegMidSections to ensure 17 is 2 legs and 18 is 2, simplified by saying 19 or above have 3 legs (even numbers never have 3 legs to maintain symmetry
' (SS,20/12/22) Correction to Sub CustomGetLegMidSections, 17 should be 3 legs, 18 is 2.
' (SS,08/02/23) Corrected link to touch up paint in Sub CustomShowRecommendationProducts
' (SS,06/03/23) Replaced PF_MATT_BLACK with PF_BASE_COAT_ONLY, i.e. "Black Primer" with "Base Coat only", also changed order of paint options in Function CustomGetProductOptionHTML
' (SS,08/03/23) Change to CustomGetDelivery to call to GetDeliveryRegionFromPostcode, changed from "Pallet" to "Pallet 2" i.e. new postcode group
' (SS,13/07/23) Added Sub CustomShowPayPalPayLaterBanner i.e. moved this code here from main template
' (SS,27/11/23) Change to Function CustomOrderingCheckDailyQuota to fix the sold/exchange discrepancy between top and bottom sections of the radiator-quota report, also added second parameter AIsDateOrdered because there's a checkbox to allow DatePaid instead
' (SS,08/12/23) Change to Function CustomIsChristmasBreak
' (SS,29/01/24) Change to Function CustomProductInBasket to determine the correct wall stays for clearance radiators using the sections attribute, previously defaulting to 1
' (SS,15/02/24) Change to min lead time days from 5 - 7 to 4 - 6, for clearance rads changed the value for the "Delivery Extended Lead Time" attribute for each clearance rad product from 5 - 7 to 4 - 6
' Also added 4 - 6 entry to the order_progress_email_days table. Changed the constant MINIMUM_WORKING_DAYS in Function CustomGetMinRadDespatchDays from 7 to 6
' (SS,20/02/24) Change to CustomShowPayPalPayLaterBanner to not show in checkout pages
' (SS,24/02/24) Change to Function CustomGetHeatOutputInfo, separated some code to CustomGetHeatOutputInfoFromBTU and CustomGetDeltaLabel
' (SS,01/03/24) Change to GetDeliveryCost to fix issue with over size charge not showing on basket page after changes applied earlier today
' Global FCustomOversizeRadiator dropped and replaced with GetBasketOptionValueComparedWithAttributeCount function in apputils
' (SS,19/04/24) Change to Function CustomInitialise to call SetBootstrap5
' (SS,12/07/24) New version of Function CustomGetPageContent, to modify the main content for these regional pages
' (SS,03/09/24) Changes to recommendation text
' (SS,04/09/24) More changes to Function CustomShowRecommendation, also added form-select-custom to section option in Function CustomGetProductOptionHTML
' (SS,04/09/24) Further improvements to CustomShowRecommendation, removed form-select-custom, added label to CustomGetProductOptionHTML for section combo
' (SS,30/09/24) Footnote symbol change in Function CustomGetTableHTML due to discount * being added to home USP bar
' (SS,10/10/24) Function CustomGetDespatchByDateList, changed MinDays from 6 (CustomGetMinRadDespatchDays) to the second integer from CustomGetRadiatorDespatchDays, i.e. normal lead days
' (SS,18/10/24) For new bundle products feature, added ABundleProductItemID parameter to Sub CustomAddSubproductToBasket Function CustomAddSubproductsToBasket
' (SS,05/11/24) Change to Sub CustomGetProductSettings to get section weight from new attribute "Section Weight" if GetProductWeight is 0 (for bundles)
' Added Function CustomRestoreBasketRemapProductCode to map old product codes to new for order/basket restore
' (SS,28/11/24) Added Function CustomIsBlackFridaySale
' (SS,02/12/24) Change to Function CustomIsChristmasBreak for this year's Christmas dates
' (SS,20/12/24) Added Function CustomIsVoucherValidForBasket
' (SS,25/03/25) Change to Function CustomGetSaleBannerText to allow different text for bundle product, also new constants, BUNDLE_DISCOUNT_PERCENTAGE_RADS, BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES
' and new Function CustomBundleProductDiscountPercentage
' (SS,29/04/25) Added Function CustomProductHasSections and change to Sub CustomShowPerSectionText
' (SS,04/06/25) Added PT_INHIBITOR, and change to Sub CustomShowRecommendationProducts to recommend inhibitor, also added CustomSpecialProductPrice
' (SS,01/09/25) Added Sub CustomSendDespatchDaysToWooCommerce, called from radiator-despatch-cache.asp
' (SS,28/10/25) Modified Function CustomGetPaintFinishPrice to apply �3 to base coat on and after 24/10/2025
' (SS,18/6/24) used to enable additional development features like breakpoint display, extra version dropdowns
Const DEV_FEATURES = False
EnableDevFeatures DEV_FEATURES, ""
' (SS,9/9/14) constants for paint finish options
'Const PF_BLACK_PRIMER = "Black Primer"
' (SS,6/3/23) replaced above with following ie. renamed from "Black Primer" to "Base Coat only", also all 3
Const PF_BASE_COAT_ONLY = "Base Coat only"
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)
Const PT_INHIBITOR = "Inhibitor" ' (SS,3/6/25)
' (SS,25/3/25) special bundle discount, 0% off radiator, 20% of accessories, previously it was 10% of all items (set by StdPrice to SalePrice)
' constants used by sale banner and custom bundle calc from apputils
Const BUNDLE_DISCOUNT_OVERRIDE = True
Const BUNDLE_DISCOUNT_PERCENTAGE_RADS = 0
Const BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES = 20
' (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
' (SS,3/6/25) added InhibitorNeeded
Class CustomRecommendToBuy
Private FValvesNeeded, FStaysNeeded, FShroudsNeeded, FTouchUpPaintNeeded, FInhibitorNeeded
Private Sub Class_Initialize()
FValvesNeeded = 0
FStaysNeeded = 0
FShroudsNeeded = 0
FTouchUpPaintNeeded = 0
FInhibitorNeeded = 0 ' (SS,3/6/25)
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
' (SS,3/6/25) added inhibitor
ElseIf AProductType = PT_INHIBITOR Then
AddInhibitor 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
FInhibitorNeeded = 1 ' (SS,3/6/25) just 500ml bottle for now
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
' (SS,3/6/24)
Private Sub AddInhibitor(AQty)
FInhibitorNeeded = FInhibitorNeeded - 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
' (SS,3/6/25)
Public Property Get InhibitorNeeded
InhibitorNeeded = FInhibitorNeeded
End Property
End Class
' (SS,17/12/14) added FCustomOversizeRadiator
' (SS,1/3/24) removed FCustomOversizeRadiator
Dim oCustomRecommendToBuy
' (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) ' (SS,1/3/24) removed
SetBootstrap5 ' (SS,19/4/24)
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
' (SS,1/3/22) applied pallet delivery price increases
' (SS,28/9/22) change to not allow delivery for Republic of Ireland, i.e. they contact for delivery cost
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
' (SS,08/03/23) changed from "Pallet" to "Pallet 2" i.e. new postcode group
LDeliveryRegionCode = GetDeliveryRegionFromPostcode(APostcode, "Pallet 2")
'End If
' (SS,28/9/22) commented out following two lines, "Republic of Ireland" now treated like RegionIndex 5 i.e. contact for delivery quote
'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)
' (SS,1/3/22) applied �10 increase for pallet delivery all zones
LDeliveryArray(1, 1) = 55
LDeliveryArray(1, 2) = 60
LDeliveryArray(1, 3) = 75
LDeliveryArray(2, 1) = 78
LDeliveryArray(2, 2) = 85
LDeliveryArray(2, 3) = 95
LDeliveryArray(3, 1) = 115
LDeliveryArray(3, 2) = 140
LDeliveryArray(3, 3) = 179
' (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) = 155
LDeliveryArray(4, 2) = 180
LDeliveryArray(4, 3) = 219
' (SS,17/12/14) added following, 0 element (Radiator Index 0) now holds the oversize charge for each region
' (SS,1/3/22) applied �5 increase for oversize radiators (all 4)
LDeliveryArray(1, 0) = 25
LDeliveryArray(2, 0) = 25
LDeliveryArray(3, 0) = 45
LDeliveryArray(4, 0) = 45 ' (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
ShowDebug "LRadiatorIndex: " & LRadiatorIndex
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)
' (SS,1/3/24) replaced above with following, FCustomOversizeRadiator global now removed
If GetBasketOptionValueComparedWithAttributeCount("Sections", ">=", "Min Sections Oversize") > 0 Then
LRadiatorDeliveryCost = LRadiatorDeliveryCost + LDeliveryArray(LRegionIndex, 0)
End If
End If
ShowDebug "GetBasketOptionValueComparedWithAttributeCount: " & GetBasketOptionValueComparedWithAttributeCount("Sections", ">=", "Min Sections Oversize")
' (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_old(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 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
' (SS,12/7/24) new version with text, first bit with <h2> tag taken from generated_content field
Function CustomGetPageContent(APageName, ByRef AHeading, ByRef AID)
Dim LResult, LContent, LFirstPara, LPos, LLocation
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, LContent, AID) Then
AHeading = NB(AHeading)
LContent = NB(LContent)
LPos = InStr(1, LContent, "</h2>", vbTextCompare)
' if H2 tag end found
If LPos > 0 Then
LFirstPara = Mid(LContent, 1, LPos + 4)
LFirstPara = ReplaceStr(LFirstPara, " ", " ") ' noticed the source contains 2 spaces after "find a", not really an issue
LFirstPara = ReplaceStr(LFirstPara, "<h2>", "<h2 class=""fs-4"">") ' text looks too big, make it smaller
LResult = LFirstPara
LLocation = ReplaceStr(AHeading, "Cast Iron Radiators ", "") ' separate location into LLocation
Dim LNewText
LNewText = "<p>" &_
"Our family run business was established in 1985 and is now one of the leading suppliers of cast iron radiators, valves and accessories to both public and trade customers throughout the UK & Europe." &_
"</p>" & NL
LNewText = LNewText &_
"<p>" &_
"We sell our cast iron radiators nation-wide, including to [location] and the nearby area and are happy to help you find the best possible period cast iron radiators, for your interior design requirements." &_
"</p>" & NL
LNewText = LNewText &_
"<p>" &_
"We have a huge stock of radiators in different styles including; Traditional Column cast iron radiators, Princess (school style radiators), Art Nouveau, Ascot, Balmoral and Ornate. " &_
"We also hold a large stock of valves, wall stays, pipe shrouds and accessories, everything you need for a successful installation of your new radiator." &_
"</p>" & NL
LNewText = LNewText &_
"<p>" &_
"All our radiators are hand built and painted to order and we pride ourselves with a quick turn around. Please check our product pages for our current lead time (normally around 4-6 days)." &_
"</p>" & NL
LNewText = LNewText &_
"<p>" &_
"We�ve sold over " & CustomGetRadiatorsSold & " radiators to thousands of happy customers in the UK including in [location] and we've got over 300 five star reviews on Trustpilot." &_
"We also offer a price promise guarantee - we will never be beaten on price." &_
"</p>" & NL
LNewText = LNewText &_
"<p>" &_
"Please take time to look through our product range and if you have any questions please do not hesitate to get in touch with our team on <a href=""tel:08002948603"">0800 294 8603</a> or drop us a line via our <a href=""products.asp?page=contact"">contact page</a>. " &_
"We�d be more than happy to answer any questions you have about purchasing a cast iron radiator in [location]." &_
"</p>"
LNewText = ReplaceStr(LNewText, "[location]", LLocation)
LResult = LResult & NL & LNewText
End If
' (SS,12/7/24) following now redundant due to new text from a token placed after h2 tag
' (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,29/4/25) called separated to get rather than CustomShowPerSectionText which just renders
Function CustomProductHasSections(AProductID)
CustomProductHasSections = ProductOptionExists(AProductID, "Sections")
End Function
' (SS,19/8/14)
' (SS,29/4/25) modified to call new CustomProductHasSections for ProductOptionExists(AProductID, "Sections")
Sub CustomShowPerSectionText(AProductID)
If CustomProductHasSections(AProductID) 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
' (SS,5/11/24) change to get section weight from new attribute "Section Weight" if GetProductWeight is 0 (for bundles)
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,5/11/24) for bundles, if ASectionWeight is 0 (from GetProductWeight) then use "Section Weight" attribute
If ASectionWeight = 0 Then
ASectionWeight = ParseFloat(GetProductAttributeByName(AProductID, "Section Weight"))
End If
' (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
' (SS,30/9/24) changed FOOTNOTE_SYMBOL_HEIGHT from * to † and FOOTNOTE_SYMBOL_LENGTH from &dagger to ‡
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
' (SS,4/6/24) for BS5 replaced table-condensed with table-sm
LResult = LResult & "<table class=""table table-specification table-striped table-sm table-responsive align-middle"">"
' (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
' (SS,4/6/24) added ­ i.e. hidden hyphen to "Sections", removed style=""vertical-align: middle"" from each th replaced with align-middle in table tag above
' (SS,12/6/24) added thead to start grey background from second row (not head row), also added tbody for completeness
LResult = LResult & "<thead><tr>" &_
"<th><small>Sec­tions</small></th>" &_
"<th><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>BTU" & BR & "<small><small>@ΔT50</small></small></th>" &_
"<th>Watts" & BR & "<small><small>@ΔT50</small></small></th>" &_
"<th>kg</th>" &_
"</tr></thead>"
' (SS,20/3/20) water content above replaced price (below)
' "<th>Price" & BR & "<small>(ex.VAT)" & FOOTNOTE_SYMBOL_PRICE & "</small></th></tr>"
LResult = LResult & "<tbody>" ' (SS,12/6/24)
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 & "<tbody>" ' (SS,12/6/24)
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
' (SS,28/6/24) removed spaces before mm and other spaces and CustomGetDeltaLabel and units to lowercase etc.
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 = " " ' (SS,28/6/24) removed leading " "
For Each LSection In ASections
LSectionsInt = ParseInt(LSection)
LSelectText = ""
LSelectText = LSelectText & LSectionsInt & " sections" & LSeparator ' (SS,28/6/24) leading " " replaced with
LSelectText = LSelectText & ALength + LSectionsInt * ASectionLength & "mm" & LSeparator ' (SS,28/6/24) removed leading " " before mm
LSelectText = LSelectText & ABTURating * LSectionsInt & "btu" & LSeparator ' (SS,28/6/24) removed leading " " before BTU and changed to lower case
LSelectText = LSelectText & CustomBTUToW(ABTURating * LSectionsInt) & "watts" & LSeparator ' (SS,28/6/24) removed leading " " before Watts and changed to lower case
' (SS,4/6/24) removed price from the end, added @?T50�C
' LSelectText = LSelectText & "£" & FormatNumber(ASectionPrice * LSectionsInt, 2)
' (SS,28/6/24) removed CustomGetDeltaLabel
' LSelectText = LSelectText & CustomGetDeltaLabel
' 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
' (SS,12/4/22) change to not show "Matt Black" for CDC-PAINT product
' (SS,21/4/22) change to not show "Black Primer"
' (SS,22/4/22) modified to make use of new CustomIncludePaintOption, exclusion now works for all colours
' (SS,30/4/24) for Bootstrap 5, replaced class="form-control" with "form-select" (two places), also added div class row and col-auto
' (SS,04/9/24) added form-select-custom to section option
Function CustomGetProductOptionHTML(ADefaultOptionHTML, AProductOptionID, AOptionName, AOptionFieldName, AInputType, ARequired, AExtraSettings, ASplitIndex)
Dim LResult
LResult = "" ' (SS,30/4/24)
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
' (SS,30/4/24) for Bootstrap 5, row and col-auto allows the width to be resized to a minimum
' jQuery script in inc-template-main.asp, later moved this div wrap and initialisation code to Sub ScriptImagePicker in inc-template-product-detail.asp
' LResult = LResult & NL & "<div class=""row gx-0"">"
' (SS,30/4/24) removed show-labels and show-html from class
LResult = LResult & "<select class=""form-select image-picker"" name=""" + AOptionFieldName & """ id=""" & AOptionFieldName & """ onchange=""itp_product_option_change('paint finish', this)"">"
' (SS,9/9/14) replaced COMBO_PLEASE_SELECT with » " & "Select paint finish"
' (SS,12/6/24) replaced "Select paint finish" with "Paint finish.." to shorten the combo width to width colours on iPhone SE
LResult = LResult & NL & "<option value="""">" & "» " & "Paint finish" & "</option>" & NL
' (SS,28/4/16) rearranged order
' (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)
' (SS,22/4/22) improved code by replacing CustomGetProductOptionValuePaintFinish with new CustomIncludePaintOption, exclude setting now works for all
' (SS,6/3/23) changed order from PF_BLACK_PRIMER, PF_CREAM_WHITE, PF_ANTIQUE_BRONZE, PF_GUNMETAL_GREY, PF_MATT_BLACK, PF_SATIN_BLACK
' to PF_GUNMETAL_GREY, PF_MATT_BLACK, PF_SATIN_BLACK, PF_ANTIQUE_BRONZE, PF_CREAM_WHITE, PF_BLACK_PRIMER
LResult = LResult & CustomIncludePaintOption(AExtraSettings, PF_GUNMETAL_GREY, "NGG")
LResult = LResult & CustomIncludePaintOption(AExtraSettings, PF_MATT_BLACK, "NMB")
LResult = LResult & CustomIncludePaintOption(AExtraSettings, PF_SATIN_BLACK, "NSB")
LResult = LResult & CustomIncludePaintOption(AExtraSettings, PF_ANTIQUE_BRONZE, "NAB")
LResult = LResult & CustomIncludePaintOption(AExtraSettings, PF_CREAM_WHITE, "NCW")
LResult = LResult & CustomIncludePaintOption(AExtraSettings, PF_BASE_COAT_ONLY, "NBP") ' (SS,6/3/23) replaced PF_BLACK_PRIMER with PF_BASE_COAT_ONLY
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
AddScript("ScriptImagePicker") ' (SS,1/5/24) to trigger adding of appropriate script used for imagepicker to initialise and position imagepicker, Sub ScriptImagePicker is in inc-template-product-detail
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
' (SS,30/4/24) for Bootstrap 5
LResult = LResult & NL & "<div class=""row"">"
LResult = LResult & NL & "<div class=""col-auto"">" & NL
' (SS,4/9/24) added label for the select
' (SS,4/9/24) made grean and bold by adding text-success fw-bold, also added mb-1 to make it closer to the box
LResult = LResult & "<label for=""" & AOptionFieldName & """ class=""form-label text-success fw-bold mb-1"">" & "Choose by sections, length or heat output" & "</label>"
' (SS,4/9/24) added class form-select-custom to allow override of style i.e. border colour
' (SS,4/9/24) removed form-select-custom due to adding of label above
' (SS,4/9/24) changed the text colour to red by add "text-danger"
' (SS,4/9/24) reverted back but made border black by adding border-dark
LResult = LResult & "<select class=""form-select border-dark"" 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,3/9/24) replaced above with following (see Liam's email of 2/9/24)
' (Ss,4/9/24) replaced Choose by length/heat output/sections with Sections, heat output or sections",
LResult = LResult & NL & "<option value="""">" & "» " & "Sections / length / heat output" & "</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>"
' (SS,30/4/24) for Bootstrap 5
LResult = LResult & NL & "</div>"
LResult = LResult & NL & "</div>" & NL
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
' (SS,3/5/24) moved following here from inc-template-product-detail.asp
AddScript("ScriptProductOptionChange")
CustomGetProductOptionHTML = LResult
End Function
' (SS,22/4/22) added following to reduce repetitive code in CustomGetProductOptionHTML when exclusive option used
' if given setting (AExcludeSetting) used in AExtraSettings then exclude this paint option, else include
Function CustomIncludePaintOption(AExtraSettings, APaintFinish, AExcludeSetting)
Dim LResult
If IsOption(AExtraSettings, AExcludeSetting) Then
LResult = ""
Else
LResult = CustomGetProductOptionValuePaintFinish(APaintFinish)
End If
CustomIncludePaintOption = 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
' (SS,21/9/22) changed WARRANTY_CHARGED_PRICE from 35 to 45
Function CustomGetOptionsPriceAndWeight(AobjOptionsDictionary, AMainPrice, AMainWeight, ByRef AOptionsPrice, ByRef AOptionsWeight)
Const WARRANTY_CHARGED_PRICE = 45 ' (SS,21/9/22) changed from 35 to 45
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,10/02/22) modified to apply price increase from 5.50 to 6.00 on and after 11/02/2022
' (SS,28/10/25) modified to apply �3 to base coat on and after 24/10/2025
' *** !!! (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
' (SS,10/02/22) modified to apply price increase from 5.50 to 6.00 on and after 11/02/2022
' (SS,28/10/25) modified to apply �3 per section to base coat on and after 24/10/2025
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_BASE_COAT_ONLY Then ' (SS,6/3/23) replaced PF_BLACK_PRIMER with PF_BASE_COAT_ONLY
If Date() >= #24/10/2025# Then
LPrice = ASections * 3
Else
LPrice = 0
End If
ElseIf ASections > 0 Then
If Date() >= #02/11/2022# Then
LPrice = ASections * 6.00
ElseIf 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_BASE_COAT_ONLY Then ' (SS,6/3/23) replaced PF_BLACK_PRIMER with PF_BASE_COAT_ONLY
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
' (SS,6/7/22) minor change to function without ASections being supplied for bespoke radiators to always show the delivery lead time before selection of sections and paint finish
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
' (SS,6/7/22) we're no longer passing on sections and paintfinish i.e. need to no before selection, so replaced [ASections = "" And ] with Not ProductOptionExists(AProductID, "Sections")
' to determine clearance radiator so that we use LDeliveryExtendedLeadTime because ASections can now be "" for bespoke
If Not ProductOptionExists(AProductID, "Sections") And LDeliveryExtendedLeadTime <> "" Then
LDays = LDeliveryExtendedLeadTime
Else ' as before
LDays = CustomGetRadiatorDespatchDays(True)
End If
' (SS,6/7/22) replaced above with following because we're no longer passing on the sections and paintfinish
' LDays = CustomGetRadiatorDespatchDays(True)
' (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"), ",", "-")
' (SS,6/3/23) replaced PF_BLACK_PRIMER with PF_BASE_COAT_ONLY
If InStr("-" + LSectionsReadyMade + "-", "-" + ASections + "-") > 0 And (APaintFinish = PF_BASE_COAT_ONLY 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
' (SS,29/1/24) fix to determine the correct wall stays for clearance radiators using the sections attribute, previously defaulting to 1
Function CustomProductInBasket(AProductID, AQty, AobjOptionsDict)
Dim LSections
LSections = AobjOptionsDict.Item("Sections")
' (SS,29/1/24) stays recommendation for clearance was always 1, added following lookup the Sections attribute for the clearance rads and pass this onto oCustomRecommendToBuy for it to determine the wall stays required
Dim LProductType
LProductType = GetProductAttributeByName(AProductID, "Product Type") ' this was in oCustomRecommendToBuy.AddProduct below, made in variable
If LProductType = PT_RADIATOR Then
' no sections set, i.e. a clearance radiator, then get the sections from the product's "Sections" attribute
If LSections = "" Then
LSections = ParseInt(GetProductAttributeByName(AProductID, "Sections"))
End If
End If
oCustomRecommendToBuy.AddProduct LProductType, 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
' (SS,1/3/24) code before removed, now implemented via call to new GetBasketOptionValueComparedWithAttributeCount added in GetDeliveryCost
'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
' (SS,8/2/23) corrected link to touch up paint
Sub CustomShowRecommendationProducts_old
' (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>"
' (SS,8/2/23) replaced above with following, subcategory had changed, also there is now just the one product
If oCustomRecommendToBuy.TouchUpPaintNeeded > 0 Then Response.Write oCustomRecommendToBuy.TouchUpPaintNeeded & " x <a href=""" & GetProductLink("CDC-400MLPAINT") & """>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,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
' (SS,8/2/23) corrected link to touch up paint
' (SS,3/9/24) new version with touch up paint moved to the bottom, removed text " and Base Plates" from before Pipe Shrouds, added addtional text after href e.g. Essential to operate radiator(s)
' (SS,4/9/24) further change to wording, made smaller and added brackets
' (SS,3/6/25) added inhibitor
Sub CustomShowRecommendationProducts
' (SS,3/6/25) added inhibitor
If oCustomRecommendToBuy.InhibitorNeeded > 0 Then Response.Write "<a href=""" & GetProductLink("CIRC-INHIBITOR-500") & """>Inhibitor</a> <small>(essential to protect heating system)</small><br>"
If oCustomRecommendToBuy.ValvesNeeded > 0 Then Response.Write oCustomRecommendToBuy.ValvesNeeded & " x <a href=""" & GetCategoryLink("Valves") & """>Valve Sets</a> <small>(essential to operate radiators)</small><br>"
If oCustomRecommendToBuy.StaysNeeded > 0 Then Response.Write oCustomRecommendToBuy.StaysNeeded & " x <a href=""" & GetSubcategoryLink("Accessories & Spares", "Wall Stays") & """>Wall Stays</a> <small>(essential to secure radiators)</small><br>"
If oCustomRecommendToBuy.ShroudsNeeded > 0 Then Response.Write oCustomRecommendToBuy.ShroudsNeeded & " x <a href=""" & GetSubcategoryLink("Accessories & Spares", "Pipe Shrouds - Sleeves") & """>Pipe Shrouds</a> <small>(to hide pipes and match valves)</small><br>"
' (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>"
' (SS,8/2/23) replaced above with following, subcategory had changed, also there is now just the one product
' (SS,3/9/24) moved from top to bottom
If oCustomRecommendToBuy.TouchUpPaintNeeded > 0 Then Response.Write oCustomRecommendToBuy.TouchUpPaintNeeded & " x <a href=""" & GetProductLink("CDC-400MLPAINT") & """>Touch Up Paint</a> <small>(handy colour match aerosol)</small><br>"
End Sub
' (SS,10/10/14)
Function CustomShowRecommendation_old
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"
' (SS,7/6/24) removed following
' If GetPayPalExpressEnabled Then CustomShowRecommendationModal "P"
' (SS,6/6/24) added following to show the script that hooks into the checkout button, changed for BS5 and moved here from inc-template-main.asp
' used AddScript do ensure it's run after jQuery has loaded
AddScript "CustomScriptRecommendationModalTrigger"
End If
End Function
' (SS,10/10/14)
' (SS,12/6/24) new version with danger and icon
' (SS,3/9/24) replaced "To complete your radiator order we recommend the following:" with "To complete your radiator order don't forget the following:"
' (SS,4/9/24) replaced with new version below to fit better on mobile
Function CustomShowRecommendation_prev
If oCustomRecommendToBuy.Required Then
%>
<div class="alert alert-warning p-2 ps-3 mt-3" role="alert">
<div class="d-flex align-items-center">
<div>
<i class="text-danger fa-solid fa-triangle-exclamation fa-3x"></i>
</div>
<div class="ms-3">
<p class="fw-bold mb-1">To complete your radiator order don't forget the following:</p>
<%CustomShowRecommendationProducts%>
</div>
</div>
</div>
<%
' (SS,22/1/15) moved code to new CustomShowRecommendationModal, a different one shown for PayPal Express
CustomShowRecommendationModal "N"
' (SS,7/6/24) removed following
' If GetPayPalExpressEnabled Then CustomShowRecommendationModal "P"
' (SS,6/6/24) added following to show the script that hooks into the checkout button, changed for BS5 and moved here from inc-template-main.asp
' used AddScript do ensure it's run after jQuery has loaded
AddScript "CustomScriptRecommendationModalTrigger"
End If
End Function
' (SS,10/10/14)
' (SS,12/6/24) new version with danger and icon
' (SS,3/9/24) replaced "To complete your radiator order we recommend the following:" with "To complete your radiator order don't forget the following:"
' (SS,4/9/24) exclamation smaller from x3 to x2, also moved to top line on left of heading
' (SS,4/9/24) further improvement
Function CustomShowRecommendation
If oCustomRecommendToBuy.Required Then
%>
<div class="alert alert-warning p-2 ps-3 mt-3" role="alert">
<div class="d-flex align-items-center mb-1">
<div>
<i class="text-danger fa-solid fa-triangle-exclamation fa-2x align-middle me-2"></i>
</div>
<div>
<p class="fw-bold mb-1">To complete your radiator order don't forget the following:</p>
</div>
</div>
<%CustomShowRecommendationProducts%>
</div>
<%
' (SS,22/1/15) moved code to new CustomShowRecommendationModal, a different one shown for PayPal Express
CustomShowRecommendationModal "N"
' (SS,7/6/24) removed following
' If GetPayPalExpressEnabled Then CustomShowRecommendationModal "P"
' (SS,6/6/24) added following to show the script that hooks into the checkout button, changed for BS5 and moved here from inc-template-main.asp
' used AddScript do ensure it's run after jQuery has loaded
AddScript "CustomScriptRecommendationModalTrigger"
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
' (SS,7/6/24) renamed modal-content to modal-recommendation, added class="btn-close", data-bs-dismiss="modal" aria-label="Close"
' (SS,3/9/24) replaced "To complete your radiator order we recommend the following:" with "To complete your radiator order don't forget the following:"
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-recommendation<%=LModalSuffix%>" class="modal fade" aria-labelledby="recommendationModalLabel">
<div class="modal-dialog modal-dialog-centered">
<div class="modal-content">
<div class="modal-header">
<h5 class="modal-title" id="recommendationModalLabel">Recommendation</h5>
<button type="button" class="btn-close" data-bs-dismiss="modal" aria-label="Close"></button>
</div>
<div class="modal-body">
<p>To complete your radiator order don't forget the following:</p>
<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" data-bs-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,6/6/24) moved here from inc-template-main.asp
' wasn't working in Bootstrap 5, removed the PayPal version to simplify
' not working due to jQuery being loaded later, hooked in the proper way by adding attributes, and using new IDs
Sub CustomScriptRecommendationModalTrigger
%>
<!-- show proceed to checkout modal if it exists when button clicked -->
<script>
$("#btnProceedToCheckout,#btnProceedToCheckoutTop").attr("data-bs-toggle", "modal");
$("#btnProceedToCheckout,#btnProceedToCheckoutTop").attr("data-bs-target", "#modal-recommendation");
</script>
<%
End Sub
' (SS,1/9/14)
' (SS,17/10/14) added class="text-info"
' (SS,6/7/22) removed delivery days message, now shown on main product page
' (SS,3/8/22) added PayPal Pay Later message
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
' (SS,6/7/22) removed following from the end, now always shown non page and section and paint finish selection not applicable
'<h4 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>
' (SS,4/6/24) replaced h3 with p
' (SS,4/6/24) removed Heat Output line <p class="fs-4 text-danger">.%=CustomGetHeatOutputInfo(LProductID, LSections)%.</p>
' <h3 style="margin-top: 0px; margin-bottom: 5px">
' <hr style="margin-top: 0px; margin-bottom: 10px">
' (SS,28/6/24) added Heat output line back in, change fs-4 to fs-6 and added mb-0
%>
<p class="fs-5 mt-2 mb-0"><%=LSections%> sections <%=CustomGetExtendedPaintFinishName(LPaintFinish)%></p>
<p class="fs-6 text-danger mb-0"><%=CustomGetHeatOutputInfo(LProductID, LSections)%></p>
<hr class="mt-2 mb-2">
<h3 class="mt-0 mb-1">
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">
<%
' (SS,3/8/22) added PayPal Pay Later message, value with VAT, currency symbol removed to work
If GetPayPalPayLaterMessagesEnabled Then
%>
<div data-pp-message data-pp-style-layout="text" data-pp-style-logo-type="inline" data-pp-style-text-color="black" data-pp-amount="<%=RemoveCurrencySymbol(CorrectCurrencyWV(LProductPrice))%>"></div>
<%
End If
End If
End Sub
' (SS,28/4/16)
Function CustomGetExtendedPaintFinishName(APaintFinish)
Dim LResult
' (SS,6/3/23) replaced PF_BLACK_PRIMER with PF_BASE_COAT_ONLY
If APaintFinish = PF_BASE_COAT_ONLY Then
' LResult = "in " + APaintFinish + " only"
' (SS,6/3/23) replaced above with following i.e. removed "only" because it already has "only" at the end
LResult = "in " + APaintFinish
Else
' LResult = "primed and with " + APaintFinish + " top coat"
' (SS,4/6/24) replaced above with following, i.e. removed "primed and "
LResult = "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
' (SS,24/2/24) separated code to CustomGetHeatOutputInfoFromBTU and CustomGetDeltaLabel
' (SS,28/6/24) changed "Heat Output:" to "Heat output:"
Function CustomGetHeatOutputInfo(AProductID, ASections)
Dim LResult, LBTURating
LBTURating = ParseInt(GetProductAttributeByName(AProductID, "BTU Rating")) * ASections
LResult = "Heat output: " & CustomGetHeatOutputInfoFromBTU(LBTURating)
CustomGetHeatOutputInfo = LResult
End Function
' (SS,24/2/24) separated from CustomGetHeatOutputInfo, returns info given BTU
Function CustomGetHeatOutputInfoFromBTU(ABTU)
Dim LResult
LResult = "<strong>" & ABTU & " BTU</strong> / <strong>" & CustomBTUToW(ABTU) & " Watts</strong> " & CustomGetDeltaLabel
CustomGetHeatOutputInfoFromBTU = LResult
End Function
' (SS,24/2/24) separated from CustomGetHeatOutputInfoFromBTU
Function CustomGetDeltaLabel
Const DELTA = "@ΔT50°C"
CustomGetDeltaLabel = DELTA
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
' (SS,5/12/24) added LProductType = "Bundle" for radiator message
Sub CustomShowHolidayNotice(AType, AProductID)
Dim LProductType, LToken
If AType = "P" Then
LProductType = GetProductAttributeByName(AProductID, "Product Type")
If LProductType = "Radiator" Or LProductType = "Bundle" 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
' (SS,28/10/24) removed If GetProductAttributeByName line so that it applies to all products not just radiators
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)
' (SS,25/3/25) added AIsBundle
Function CustomGetSaleBannerText(AIsBundle)
' (SS,15/9/17) replaced "Summer Sale" with "Sale"
If AIsBundle Then
CustomGetSaleBannerText = "Sale: " & BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES & "% off accessories"
Else
CustomGetSaleBannerText = "Sale"
End If
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
' (SS,18/10/24) added ABundleProductItemID for new bundle products feature, this can be a null value i.e. "NULL" as a string
Function CustomAddSubproductsToBasket(AProductID, AItemID, AQtyInBasket, AQtyToAdd, ABundleProductItemID)
' 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
' (SS,11/10/24)
ShowDebug "CustomAddSubproductsToBasket = AProductID: " & AProductID & ", AItemID: " & AItemID & ", AQtyToAdd: " & 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
' (SS,18/10/24) added ABundleProductItemID
If LSubproductID <> 0 Then CustomAddSubproductToBasket LSubproductID, LProductCode, LLegSections, AItemID, ABundleProductItemID
LSubproductID = CustomGetSubproductIDForSection(AProductID, "Mid", LPaintFinish, LProductCode, LProductName)
' call routine to add the basket record
' (SS,18/10/24) added ABundleProductItemID
If LSubproductID <> 0 Then CustomAddSubproductToBasket LSubproductID, LProductCode, LMidSections, AItemID, ABundleProductItemID
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
' (SS,16/12/22) modified to ensure 17 is 2 legs and 18 is 2, simplified by saying 19 or above have 3 legs
' (SS,20/12/22) correction, 17 should be 3 legs, 18 is 2.
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)
' (SS,16/12/22) replaced above with following, in reality even numbered sections never have 3 legs because they need to be symmetrical
'ALegSections = IIf(ARadSections <= 18, 2, 3)
' (SS,20/12/22) replaced above with following to ensure 17 is 3, 18 is 2 etc.
If ARadSections = 17 Or ARadSections >= 19 Then
ALegSections = 3
Else
ALegSections = 2
End If
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
' (SS,18/10/24) added ABundleProductItemID for new bundle products feature, this can be a null value i.e. "" is converted to NULL
Sub CustomAddSubproductToBasket(AProductID, AProductCode, AQty, ASubproductItemID, ABundleProductItemID)
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
' (SS,18/10/24) added BundleProductItemID, "" is converted to "NULL"
ExecuteQuery("INSERT INTO shoppingbaskets SET SessionID = '" & CleanSQLStr(GetSessionID) & "', ProductID = '" & AProductID & "', ProductCode = '" & CleanSQLStr(AProductCode) & "', Qty = " & AQty & ", SubproductItemID = '" & ASubproductItemID & "', BundleProductItemID = " & IIf(ABundleProductItemID = "", "NULL", ABundleProductItemID))
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, True) ' (SS,27/11/23) added True second parameter for DateOrdered
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
' (SS,27/11/23) fix to the sold/exchange discrepancy between top and bottom sections of the radiator-quota report, also added second parameter AIsDateOrdered because there's a checkbox to allow DatePaid instead
Function CustomOrderingCheckDailyQuota(AShowInfo, AIsDateOrdered)
' 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"
' (SS,27/11/23) if date paid then change the field to DateTimePaid
If Not AIsDateOrdered Then
LSQL = ReplaceStr(LSQL, "(o.DateTimeOrdered)", "(o.DateTimePaid)")
End If
' 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"))
' (SS,27/11/23) replaced above with following, i.e. Sold includes damaged in transit exchanges (radiator-quota was previously using different criteria at top and bottom of the report)
LSoldTotal = NZ(GetSQLValue(LSQL & " AND (NOT Exchange OR ExchangeReason = 'Damaged in transit')"))
LExchangesTotal = NZ(GetSQLValue(LSQL & " AND Exchange AND ExchangeReason <> 'Damaged in transit'"))
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
' (SS,24/5/22) replaced <strong>Important notice:</strong> Covid-19 & Brexit update with:
' <strong>Important notice:</strong> Deliveries to Ireland & Returns/Collection
' also changed link from "products.asp?page=coronavirus" to "products.asp?page=brexit"
' also replaced Important notice: with Info: to keep it short, later slight change to text
' (SS,6/7/22) removed this large button by adding False to the If
Function CustomFinalise
If False And ScriptIsProducts And Not IsPageName("coronavirus") Then
%>
<a class="btn btn-lg btn-danger" style="position: fixed; bottom: 10px; right: 10px" href="products.asp?page=brexit">
<strong>Info:</strong> Ireland Deliveries & Returns/Collections
</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)
' (SS,15/2/24) changed from 7 to 6, i.e. 5 - 7 to 4 - 6
Function CustomGetMinRadDespatchDays
Const MINIMUM_WORKING_DAYS = 6
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
' (SS,10/10/24) changed MinDays from 6 (CustomGetMinRadDespatchDays) to the second integer from CustomGetRadiatorDespatchDays, i.e. normal lead days
Function CustomGetDespatchByDateList(ByRef ADefaultDate, ByRef AMInDate, ByRef AMaxDate)
Dim LResult, LDate, LMinDays, i
'LMinDays = CustomGetMinRadDespatchDays
' (SS,10/10/24) replaced above with following to use the current lead time in this local mode
LMinDays = ParseInt(NthSeparatedValue(CustomGetRadiatorDespatchDays(True), " - ", 2))
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
' (SS,8/12/23) added following
' (SS,18/12/23) corrected <= CDate("31/12/2024") to ADate <= CDate("31/12/2023")
ElseIf ADate >= CDate("24/12/2023") And ADate <= CDate("31/12/2023") Then
Result = True
' (SS,2/12/24) added following for Christmas 2024, open on 19 and 20 Dec, but no shipping
ElseIf ADate >= CDate("19/12/2024") And ADate <= CDate("31/12/2024") Then
Result = True
End If
CustomIsChristmasBreak = Result
End Function
' (SS,11/10/22) PayPal Pay Later above home page banner
' (SS,29/6/23) added Or GetPageName = "customerphotos" to not show on (new) customer photos page
' (SS,13/7/23) moved below main jumbo text and USP on home page, code moved here from main template (called from home page to show later on the page)
' (SS,20/2/24) added Or InCheckout to not show in checkout pages
Sub CustomShowPayPalPayLaterBanner
' (SS,22/2/24) removed this horrible top banner altogether by adding following exit sub
Exit Sub
If GetPayPalPayLaterMessagesEnabled And Not (IsProductDetailsPage Or IsBasketPage Or InCheckout Or GetPageName = "customerphotos" Or GetPageName = "blog") Then%>
<div class="container" style="margin-top: -10px; margin-bottom: <%=IIf(IsHomePage, "15px", "10px")%>; margin-left: -15px">
<div class="row" style="">
<div class="col-lg-12 col-md-12">
<div data-pp-message data-pp-style-layout="flex" data-pp-style-ratio="20x1" data-pp-style-color="blue" data-pp-amount="0"></div>
</div>
</div>
</div><%
End If
End Sub
' (SS,13/6/24) override the default image in basket
Function CustomGetBasketImage(AItemID, AProductID, AProductCode, AProductName, AOptionsList, AImageSrc)
Dim LResult, LPaintFinish
LResult = AImageSrc
If InStr(1, AOptionsList, "Sections:", vbTextCompare) > 0 And InStr(1, AOptionsList, "Paint Finish:", vbTextCompare) > 0 Then
LPaintFinish = GetBasketOptionValueForItemID(AItemID, "Paint Finish")
If LPaintFinish <> "" Then
If LPaintFinish <> PF_BASE_COAT_ONLY Then
LPaintFinish = LPaintFinish + "-paint-finish"
End If
LPaintFinish = ReplaceStr(LCase(LPaintFinish), " ", "-")
LResult = ReplaceStr(LResult, "-160w.jpg", "-" + LPaintFinish + "-160w.jpg")
'Response.Write "###<code>" & HTMLEncode(AImageSrc) & "</code>###" & BR
'Response.Write "###<code>" & HTMLEncode(LResult) & "</code>###" & BR
'Response.Write "###" & GetBasketOptionValueForItemID(AItemID, "Paint Finish") & "###" & BR
End If
End If
CustomGetBasketImage = LResult
End Function
' (SS,18/6/24) shown on home page, total qty sold using following SQL, and rounded down:
' SELECT #YEAR(DateTimePaid) AS Period, "ALL" AS Period, SUM(od.Qty) AS RadQty FROM orderdetails od INNER JOIN orders o ON o.OrderNo = od.OrderNo INNER JOIN product_attributes pa ON pa.ProductID = od.ProductID AND pa.AttributeID = 1 AND pa.AttributeValue = "Radiator" AND NOT o.Exchange WHERE o.Status = "COMPLETED" GROUP BY Period
' CDC gives 4752
' CIRC 111956 on 18/6/24 at 9:34am
' (SS,28/6/24) replaced with 200000
Function CustomGetRadiatorsSold
Dim LNoSold
' LNoSold = 4752 + 111956
LNoSold = 200000
CustomGetRadiatorsSold = FormatNumber(Int(LNoSold / 1000) * 1000, 0)
End Function
' (SS,5/11/2024) map old product codes to new for order/basket restore
Function CustomRestoreBasketRemapProductCode(ByRef AProductCode, ByRef AClearOptions)
Dim LResult
LResult = True
ShowDebug "CustomRestoreBasketRemapProductCode: " & AProductCode
If AProductCode = "OLD-760-10-MBAB-BUND" Then
AProductCode = "CDC-760-10-MBAB-BUND"
ElseIf AProductCode = "OLD-760-18-MBAB-BUND" Then
AProductCode = "CDC-760-18-MBAB-BUND"
ElseIf AProductCode = "OLD-760-10-GMGM-BUND" Then
AProductCode = "CDC-760-10-GMGM-BUND"
ElseIf AProductCode = "OLD-760-18-GMGM-BUND" Then
AProductCode = "CDC-760-18-GMGM-BUND"
ElseIf AProductCode = "OLD-BAL-10-ABAB-BUND" Then
AProductCode = "CDC-BAL-10-ABAB-BUND"
Else
LResult = False
End If
If LResult Then
AClearOptions = True
ShowDebug "CustomRestoreBasketRemapProductCode: remap = " & AProductCode
End If
CustomRestoreBasketRemapProductCode = LResult
End Function
' (SS,28/11/24) returns true if Black Friday sale is active, i.e. between 29/11/2024 and 04/11/2024 for CIRC
Function CustomIsBlackFridaySale
Dim LResult
LResult = False
If Date() >= CDate("29/11/2024") And Date() <= CDate("04/12/2024") Then
'If Date() >= CDate("28/11/2024") And Date() <= CDate("04/12/2024") Then
LResult = True
End If
CustomIsBlackFridaySale = LResult
End Function
' (SS,20/12/24) returns true if given voucher is a valid for current basket
Function CustomIsVoucherValidForBasket(AVoucherCode, AVoucherName)
Dim LResult, LCount
LResult = True
' check if voucher name contains "(includes radiator)", products in bundles are excluded
If InStr(1, AVoucherName, "(includes radiator)", vbTextCompare) > 0 Then
LCount = GetMainCategoryInBasketCount("Cast Iron Radiators", False)
LResult = LCount > 0
End If
CustomIsVoucherValidForBasket = LResult
End Function
' (SS,25/3/25) returns the special override discount percentage i.e. 0% for radiator and 20% for accessories, ACustomFlag will be True for radiator
' New constants (see up of this module) BUNDLE_DISCOUNT_OVERRIDE, BUNDLE_DISCOUNT_PERCENTAGE_RADS, BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES
Function CustomBundleProductDiscountPercentage(ACalculatedDiscountPercentage, AProductID, ACustomFlag)
Dim LResult
If BUNDLE_DISCOUNT_OVERRIDE Then
If ACustomFlag Then ' if radiator
LResult = BUNDLE_DISCOUNT_PERCENTAGE_RADS
Else ' else acccessory
LResult = BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES
End If
Else ' as before
LResult = ACalculatedDiscountPercentage
End If
CustomBundleProductDiscountPercentage = LResult
End Function
' (SS,3/6/25) special price when inhibitor when ordering 2 or more
Function CustomSpecialProductPrice(AProductID, AProductCode, AQty, APriceEach)
If AProductCode = "CIRC-INHIBITOR-500" Then
If AQty = 2 Then
'CustomSpecialProductPrice = APriceEach - 1
' 5% instead of �1
CustomSpecialProductPrice = Round2dp(APriceEach * 0.95)
ElseIf AQty >= 3 Then
'CustomSpecialProductPrice = APriceEach - 2
' 10% instead of �2
CustomSpecialProductPrice = Round2dp(APriceEach * 0.9)
Else ' i.e. 1
CustomSpecialProductPrice = APriceEach
End If
Else
CustomSpecialProductPrice = APriceEach
End If
End Function
' (SS,1/9/25) gets the latest despatch days and sends to WooCommerce i.e. circ_penn.wc_settings
Sub CustomSendDespatchDaysToWooCommerce
Dim LLatestDespatchDays, LDespatchDaysAtWoo
LLatestDespatchDays = CustomGetRadiatorDespatchDays(True)
LDespatchDaysAtWoo = GetSQLValueAsString("SELECT SettingValue FROM circ_penn.wc_settings WHERE SettingName = 'RadiatorDespatchDays'")
' Response.Write BR & "DespatchDays: " & LLatestDespatchDays & BR
Response.Write BR & "Despatch Days At Woo: " & LDespatchDaysAtWoo & BR
If LLatestDespatchDays <> LDespatchDaysAtWoo And LLatestDespatchDays <> "" Then
ExecuteQuery "UPDATE circ_penn.wc_settings SET SettingValue = '" & CleanSQLStr(LLatestDespatchDays) & "' WHERE SettingName = 'RadiatorDespatchDays'"
Response.Write BR & "Despatch Days At Woo Upated to : " & LLatestDespatchDays & BR
End If
End Sub
%>