File: D:/web/hyperflight/! previous changes 2/2025-07-15/old/apputils.asp
<!--#include file="gtm-lib.asp"-->
<%
' (SS,13/10/23) included "gtm-lib.asp" above
' ============
' apputils.asp
' ============
' Version 6.30g (02/07/25)
' Requires dbfunctions.asp version 2.02 (04/10/2023) or later
' Also requires latest "gtm-lib.asp"
' ============
' HISTORY
' ============
' (SS,20/06/05) added ShowSubCategoryMenu
' (SS,20/06/05) added SUBSTRING(highlights.ProductCode FROM 1 FOR 8) <> 'WEBTEXT-' to Sub ShowHighlights
' (SS,20/06/05) added Function GetWebText(AWebTextCode) to get text from hightlights page
' (SS,24/06/05) improved Sub ShowDeliveryCostInfo to not show duplicate info if below and above values the same
' (SS,27/06/05) improved Sub ShowHighlights so that nothing shows if no product highlights, and invalid
' products do not show instead of causing error
' (SS,06/07/05) added to Sub ShowDeliveryCostInfo: Iif(Application("UKText") etc to override the default country names
' (SS,06/08/05) Major changes for direct credit card payments
' (SS,08/08/05) Started using UltraEdit instead of TextPad for editing
' (SS,09/08/05) Add () to end of all functions and subs that had no parameters to ensure they appear in function list in UltraEdit
' (SS,03/03/06) Changes to Sub ShowCategoryMenu() to allow alternate colour category menu
' (SS,22/03/06) Added Left(,255) to AddReferrerToDatabase to limit size of strings to 255
' (SS,29/04/06) Added new ComposeTables feature to allow tables in description field of product
' (SS,08/05/06) Added ComposeTables to Sub ShowHighlights()
' (SS,07/07/06) Added Application("ProductsAcrossMax") to ShowProducts
' Added ShowProductMoreImages and ShowProductFiles.
' Modified GetProductLink, added GetProductLinkWithImageNo, GetProductImageLink,
' GetProductFileLink for extra images and files feature
' (SS,07/09/06) Add ePDQ payment feature
' (SS,13/09/06) Adding New Delivery calculation feature,
' including major mod to GetDeliveryCostForCountry
' New tables deliverycosts and deliveryregions
' (SS,15/09/06) Multicurrency feature
' (SS,20/09/06) Extra search engine promotion stuff
' (SS,17/10/06) Added ShowDeliveryMatrix feature
' (SS,18/10/06) Corrected VAT added to delivery in GetDeliveryCostForCountry
' (SS,01/11/06) Correction to ShowProductFiles
' (SS,02/11/06) Made a change to ShowProducts to search for ProductCode ignoring the dashes, or treating dashes as spaces
' (SS,26/03/07) Version 1.30
' Added GetGroupLink and Sub ShowGroupMenu() new 3 level menu
' (SS,27/03/07) Changes to Sub ShowProducts to show new summary list, also added functions CategoryListEnabled, SubcategoryListEnabled, SummaryListEnabled
' Added Hidden Grp to Sub ShowSearch()
' Also added grp to function itp_setsearch() in javascript.js
' Add new function GetGroupForCategory
' (SS,17/04/07) Added ShowShoppingStatusSummary summary version of ShowShoppingStatus, code from ShowShoppingStatus moved to new ShowShoppingStatusMain
' Add DoBasketOperation due to ExpressMusic have shopping status before inc-pages.asp
' DoBasketOperation is called at end of inc-main.asp
' Changed to ShowProducts to pass picture size to inc-template-product-list.asp
' (SS,14/05/07) Modified ShowGroupMenu by adding 'If Application("EnableGroups") Then' to select Main group if groups aren't enabled
' Used by Galleon Supplies' two level menu
' (SS,15/05/07) Made a change in GetProductsPageTitle to fix "Product" showing instead of "Products"
' Made a change ShowProducts to add description to
' ShowProductSummaryListItem and ShowProductListItem
' (SS,17/05/07) Fixed bug in Function ComposeTables which was causing endless loop if ProductDescription was Null
' Added GetProductImgSrcThumbnailSmall
' Added ShowProductRelated
' Added Sub GetSettings (called from Initialise)
' Added Function GetPriceValue, Function GetDiscountedPrice, Function IsDiscounted
' Mods to ShowSingleProduct to get the new price fields
' (SS,18/05/07) Added Function FixLinkForJavascript to fix itp_subcat problem with quote (")
' Mod to Sub ShowSpecialOffers and Sub ShowProducts to use new discount field if enabled
' Added Sub SetAtFirstProduct, Sub SetAtLastProduct, Function AtFirstProduct, Function AtLastProduct
' Eventually replaced SetAtFirstProduct and SetAtLastProduct with SetAtFirstOrLastProduct
' to help inc-template-product-list.asp/inc-template-product-detail.asp determine first or last product
' (SS,21/05/07) Added Function RemoveTable, GetProductDescription, Sub SetProductDescription
' Added SetProductDescription to ShowProducts
' Added Function GetTotalItemsInBasket
' Added <!--#include file="customutils.asp"--> to inc-main.asp
' Also added new customutils.asp file to store customised utilities specific for customers
' Modified Function GetWebText to only open database when required
' New functions FourPricingFieldsEnabled, PricesEnteredIncludeVAT, UseDiscountFieldForSpecialOffers, VATBandsEnabled
' New function GetPricingFieldsForSQL
' (SS,22/05/07) Moved GetPriceValue to customutils.asp and renamed to CustomGetPrice
' Modified GetProductPrice, GetStdPrice, GetSalePrice to remove parameters to use FProductCode, FStdPrice, FSalePrice instead
' also added CustomGetStdPrice and CustomGetSalePrice calls
' (SS,26/05/07) Moved code from GetDeliverySettings to GetSettings, rewrote it
' Removed Sub GetShoppingStatus, doesn't appear to be used anywhere
' Added GetProductDimensions, SetProductDimensions
' Added GetDiscountPercentage (code from ShowSpecialOffers)
' Added Sub Finalise
' Removed all OpenDatabase and CloseDatabase calls, only one kept in Initialise and Finalise
' Finalise added to worldpay-callback.asp, paypal-callback.asp, epqd-callback.asp & epdq-return.asp
' (SS,27/05/07) Added function UseVATFlagFromCountries and global FUseVATFlagFromCountries
' Renamed function IsVATable to IsCountryVATable
' Added GetVATRateForProduct, GetVATForProduct
' Added GetDeliveryCountry
' GetDeliveryCostForCountry renamed to GetDeliveryCost
' Replaced GetCurrencyCountry with GetDeliveryCountry, GetCurrencyCountry with GetInvoiceCountry
' (SS,28/05/07) Added GetVATLabel, SetVATLabel and FVATLabel, Function IsVATRegistered, GetVATAmountToAddNR
' Mods to ShowOrderDetails and EmailOrder to not Show VAT if not registered, and not show "Included" if prices entered don't include VAT
' Mode javascript in SetAlertMessage to new ShowAlertMessage. This fixed problem where stock message was appeared too early and not working
' Added function itp_buyc to javascript.js to allow buying from product list
' (SS,07/06/07) Numerous changes up to this point.
' Scrapped the DeliveryRegion field after making Countries table more flexible with new RegionCode and SortOrder fields
' (SS,14/06/07) Completed moving of settings from global.asa to settings table
' Renamed GetAppSetting in dbfunctions to GetSetting and SetAppSetting to SetSetting
' (SS,22/06/07) Added GetPayPalShippingAddressFlag to Sub SetUpPayPalForm
' Added TotalWeight to html email confirmation
' (SS,29/06/07) Added feature to Sub ShowEmailConfirmationHTML to send an email when cmd=email
' Modified Sub EmailOrder to add two constants to force Dundas to be used or CDO to send without URL
' This was to investigating a hanging bug that occurred for a galleon order which caused worldpay callback failure
' and email not to be sent.
' (SS,06/07/07) Added HTMLEncode to ShowSearch, SetUpWorldPayForm, SetUpPayPalForm, SetUpEPDQForm
' Also to most form fields in inc-template-acount.asp, inc-template-checkout.asp
' This is to allow quotes to be entered in name or address fields.
' Mainly to fix a bug in Galleon, where a customer had useds quotes in the first address line
' and WorldPay payment failed with error "an account holder address is required"
' this is because quotes are part of HTML and when value of a form field is say ""Snowhill", the receive will see ""
' (SS,07/07/07) Added SetProductDimensions(GetFieldValue("Dimensions")) to ShowHighlights
' (SS,11/07/07) Changed FDefaultCountry in GetSettings to "" was United Kingdom
' Added "Please select..." to GetCountryCombo, also added GetImportantCountryMessage (inc-template-checkout.asp)
' next to country combos in inc-template-account.asp and inc-template-checkount
' (SS,20/07/07) Changes to ShowGroupMenu to show non-javascript urls for selected category, javascript for others
' and non-javascript if no menu item selected
' Added GetSubcategoryJavaLink, changed GetSubcategoryLink to use normal normal instead of JavaScript
' (SS,23/07/07) Sub EmailOrder, set CDO_SEND_VIA_URL to False, because there was another callback failure
' i.e. when sending email.
' (SS,01/08/07) Added {bullet} {endbullet} feature to Compose routines
' renamed ComposeTables to ComposeDescription, added ComposeDescWith and GetBulletHTML
' renamed RemoveTables to RemoveComposes, added RemoveCompose
' (SS,24/08/07) Added GetPricingFromProductRecord(0) to Sub ShowHighlights to fix "from" showing highest price in highlights
' (SS,07/09/07) Replaced Switch payment with Maestro, renamed CC_SWITCH to CC_MAESTRO
' Changed ValidateCardNumber to validate Maestro credit card number
' (SS,10/09/07) Added LCase for FDeliveryType in Sub GetSettings (to allow use of leading uppercase letter in Admin settings)
' (SS,11/09/07) Removed SpecialRegionLimitCountries code, now redundant
' (SS,13/09/07) Replaced Application("CompanyName") with GetStoreName, also replaced Application("PayPal..") with Get...
' Application("UseAlternateColorForCategories") moved to settings
' Also FDefaultTitle, FMulticurrencyEnabled, FAllowedCurrencies for Application("DefaultTitle"),
' Application("Multicurrency") and Application("AllowedCurrencies")
' Replaced Application("UseAlternateColorForCategories") with UseAlternateColorForCategories
' Replaced Application("DefaultTitle") with GetDefaultTitle
' changes to functions IsMulticurrency, IsAllowedCurrency to use new settings instead of Application()
' Replaced FCustomDeliveryEnabled with DT_CUSTOM for FDeliveryType
' Added GetDeliveryType
' (SS,14/09/07) Sub GetPricingFromProductRecord added FSalePrice which was missed and causing prices to zero
' Sub UpdateExchangeRate, changed ExecuteQuery to ExecuteQueryCommon
' (SS,05/10/07) Google checkout facility including SetUpGoogleCheckoutPayForm, ProcessGoogleCheckoutCallback
' (SS,06/11/07) Removed FBestSellersCost, setting not used
' (SS,07/11/07) Minor change to DoCreateAccountForm to correct behaviour for toner2desk
' (SS,08/11/07) Defaulted Subscribe to True in SetCheckoutAccountDefaults
' Added GetStoreLogoLink used by inc-template-email-html.asp
' Modified GetEmailBody to added Order Date to ShowEmailOrderHeader
' also changed 'ordering with' to 'order from'.
' (SS,09/11/07) Function GetNextOrderNo, change CInt to CLng to five overflow error when OrderNo > 32767
' (SS,13/11/07) Added Function ConvertCurrencyInternal used by customutils.asp
' (SS,14/11/07) Added FShowRelatedProductsInGroup, changes to ShowProductRelated to show related products in group
' Added Allow Collection feature, and Schema Version checked and restructuring
' (SS,15/11/07) Added Function ProductDiscontinued
' Changes to hold DEFAULT_CURRENCY_CODE etc in settings to allow default currency values to be set per shopping site
' e.g. this allows a different default currency with different exchange rate
' (SS,16/11/07) Added SetStockInfo, GetStockInfo
' Handling of IntraCommunity no VAT etc, and various other changes
' Change to Function GetEmailBody to show collection message
' (SS,22/11/07) Minor fix to SetStockInfo
' (SS,27/11/07) Added Euro html for Euro symbol to GetCurrencyExchangeRate
' (SS,30/11/07) Added IsAllowedCountry and changes to CheckValidPersonalDetails & CheckValidDeliveryAddress
' (SS,11/12/07) Added ShowCheckoutMessage to Sub CheckOut. ShowCheckoutMessage added to inc-templatate-checkout.asp
' GetCheckoutMessage add GetBasketNote added to inc-template-messages.asp
' GetBasketNote added to ShowBasketFooter in inc-template-basket.asp
' (SS,28/01/08) Added FProductNameTokensInBasket and GetProductNameTokensInBasket. Mainly to not charge delivery if pallet item ordered
' Used by customutils.asp
' (SS,29/01/08) Change to GetWorldPayExchangeRates do to WorldPay change to URL
' (SS,30/01/08) Added SendEmailByITPEmailer, also changed Sub EmailOrder to use SendEmailByITPEmailer instead of SendEmailByCDO
' (SS,13/02/08) Removed forcing of Postcode from DoCreateAccountForm, CheckValidPersonalDetails, CheckValidDeliveryAddress
' Also removed the bold from Postcode fields in inc-template-account.asp and inc-template-checkout.asp
' (SS,19/02/08) Changes to Sub ProcessPayPalCallback to handle "Pending" echeque payments
' (SS,01/07/08) Changes to Function GetHTMLTitle to move ProductName to the front and some other minor changes
' (SS,12/08/08) Change Sub ProcessWorldPayCallbackreplaced all Request.Form with Request,
' allowing the query string to be pasted into URL to manually perform a failed callback
' (SS,17/09/08) Added Sub SetDefaultCategory for showing content for doorway domains/pages
' Also added Function HasDefaultCategory, GetCategory and GetDefaultCategory
' GetCategory used in Sub ProductsMain, also change to Sub ShowSearch,
' Also added Function AddStoreURL, and various places where required
' Added Sub CustomInitialise to Sub Initialise
' Also added FSearchIsVisible, Function IsSearchVisible and Sub HideSearch
' (SS,20/10/08) Modified Function CorrectCurrencyNV so that it doesn't deduct VAT if prices not already contain VAT
' To correctly show price in product and status sections (for CovDem, it was incorrectly reducing the price shown, thinking it contained VAT)
' (SS,21/10/08) Added newlines to end of table rows in Sub ShowDeliveryMatrix to make code more readable
' (SS,21/10/08) Amendments to Function GetDeliveryCost for custom delivery to pass on postcode and to work in conjunction with normal by price/weight calculations
' Added Sub UpgradeSchemaTo144
' (SS,22/10/08) Added products.CustomFlag to SQL in Function GetOrderItemsQuery(ASessionID)
' (SS,23/10/08) Added Sub ShowCheckoutAlertMessage to show holiday message, called from Sub Checkout
' (SS,30/10/08) Added Function GetFlaggedItemsInBasket
' Modified Function IsIntraCommunitySupply to use countries table if VATIntraCommunityCountries set to "USE TABLE"
' (SS,10/11/08) Added GoogleAnalytics feature also Ecommerce tracking, new routines DoGoogleAnalytics etc
' Also added ShowCheckoutNextStageButton to inc-template-checkout.asp
' Changes to payment forms to run the javascript tracking function before going to payment site
' (SS,12/11/08) Added GoogleAdWords conversion tracking
' Added forcing of Postcode back in (DoCreateAccountForm, CheckValidPersonalDetails, CheckValidDeliveryAddress)
' This was removed on 13/02/08
' (SS,14/11/08) Renamed FGoogleAnalyticsAccountID back to FGoogleAnalyticsWebPropertyID
' (SS,17/11/08) Change to DoGoogleAdWordsConversionTracking, "&" replaced with "&". Purchase tracking was working.
' Wrote getpictest.asp to test with ct_test table in periodproducts
' (SS,18/11/08) In DoGoogleAdWordsConversionTracking reverted the first "&" back to "amp;" because it's HTML. Only the javascript one wasn't working.
' In Sub DoGoogleAnalyticsEcommerce replaced HTMLEncode with DoubleQuotedJavascriptString
' (SS,20/11/08) GoogleAdWords purchase conversion tracking wasn't working too well via indirect mode
' Implemented via payment redirection, i.e. extra page that does the ecommerce and conversion tracking before redirecting to payment site
' (SS,25/11/08) Corrected bug in GetDeliveryCost which was including delivery by price even when price was 0 (same for weight)
' Also added Sub CheckVAT to change VAT from 17.5% to 15% on 1/12/2008
' (SS,03/12/08) To Sub DoPaymentRedirection added window.setTimeout to add a 2 second delay to hopefully fix the adwords conversion not working issue
' (SS,15/12/08) Added GetTotalAndVATRateForGoogleCheckout for GoogleCheckout to show proper VAT Rate
' (SS,16/12/08) Change to DoGoogleAdWordsConversionTracking to use image method for purchase adword tracking because
' Javascript method not working too well even after adding 2 second delay
' (SS,21/01/09) Correction to Sub SetStockInfo
' (SS,17/03/09) Correction to Sub GetSettings to get the FAllowDifferentDeliveryAddress setting
' which somehow I previously missed. Express Music do not want to allow delivery to different address.
' Also minor change to Sub CheckOut to ensure Session("DeliveryAddressSameAsInvoice") is set
' (SS,18/03/09) In GetEmailBody changed "Invoice.." to "Billing.."
' (SS,19/03/09) Added SmallThumbnailWidth & SmallThumbnailHeight getting settings
' (SS,31/03/09) Change to Sub ShowGroupMenu, added c.GroupName to ORDER BY
' (SS,01/04/09) Changes to ShowShoppingStatusMain and ShowBasket to display prices including VAT (for petfood site)
' (SS,15/04/09) Changes to Sub ShowHighlights and Function GetWebText to use data from sitedetails table instead of highlights
' (SS,17/04/09) Change to Sub DoContactForm to add security code check, also added global FErrorSecurityCode and Function EmailSecurityCodeEnabled
' Added 3 more settings FChooseDeliveryDate, FMaxDeliveryDays, FMobileEnabled
' Added Sub UpgradeSchemaTo145
' Added new Mobile field to GetPersonalDetailsFromForm, GetAccountDetails, TryProcessOrder, GetEmailBody
' Also added to inc-template-account.asp.
' Added DeliveryDate to GetPersonalDetailsFromForm, TryProcessOrder, GetEmailBody
' Added functions GetMobile, GetDeliveryDate
' Changes to Function GetEmailBody to add Mobile, DeliveryDate, VoucherCode and Discount
' (SS,22/04/09) Changes to Sub CopyMainSessionToSecureSession, added new fields
' Added VoucherCode to Sub GetPersonalDetailsFromForm
' (SS,23/04/09) Changes to Sub ShowGroupMenu to show MenuShortName if assigned
' Various changes for new VoucherCode/Discount feature
' (SS,01/05/09) Added FStorePlaceOfRegistration and FStoreRegisteredCompanyNo
' (SS,06/05/09) Bug fix to Function GetWebText
' (SS,08/04/09) Finished adding product review feature
' New routines: GetReviewRatingHTML, GetReviewRatingAndCount, GetShowReviewsLink, GetShowReviewsLink, GetWriteReviewLink
' InProductDescription, InShowReviews, InWriteReview, ShowReviews, WriteReview, CheckReviewDetails, SaveReview
' Also new template inc-template_reviews.asp
' Correction to Sub TryProcessOrder for DeliveryDate (removed quotes to allow Null to be saved
' also change to Function ConvertUKToMySQLDate in dbfunctions.asp
' Added productcategories READ to ProcessOrder
' (SS,11/05/09) Added setting of default of False for FUseVATFlagFromCountries to GetSettings
' Small change to Function IsCountryVATable because ChargeVAT field is now a TinyInt
' (SS,13/05/09) Changes to vouchers, single usage per customer feature, vouchers per product code
' (SS,14/05/09) Improvements to vouchers, also added GetDeliveryInfo token
' (SS,15/05/09) Improvements to reviews, improvements to voucher error message
' (SS,18/05/09) Improvements to reviews and added stock notification feature
' (SS,19/05/09) Added Function IsValidEmailAddress, minor change to Sub DoForgotPassword
' Change to Sub ShowProductRelated
' (SS,22/05/09) Improvements to email/order confirmation, adding of MessageToCustomer and tracking details
' (SS,28/05/09) Optional accounts, New cheque and bank transfer payment features
' (SS,04/06/09) Various improvements over the past week. Also added Recently viewed feature.
' (SS,12/06/09) Minor change to recently viewed feature, added Sub ShowCustomBanners
' (SS,15/06/09) Minor change to AccountsCompulsory, AccountsOptional, AccountsAdmin to only return True if AccountsEnabled
' (SS,16/06/09) Minor improvements mainly to do with payment button logos and entered notes for googlecheckout payment
' (SS,17/06/09) Added validation of VAT numbers when CustomValidVATNumber routine is defined in customutils.asp
' (SS,18/06/09) Added functions to returne site seal settings GetGoogleSiteSeal, also WorldPay and PayPal
' (SS,19/06/09) Minor change to GetWebText to Get Delivery prices excluding VAT
' also slight change to Sub DoCreateAccountForm to not validate delivery address when different address not allowed
' (SS,19/06/09) Added Function GetVoucherCodeForVoucherID used by Sub CopyMainSessionToSecureSession to get VoucherCode for direct payments
' (SS,23/06/09) Added Function GetVATNumberHelpMessage
' Change to Sub DoGoogleSitemap to also show site pages from sitedetails if they exists e.g. CovDem
' Change to Sub CheckOut to get payment on account to work for toner2desk with current apputils
' (SS,16/07/09) Added extra "" parameter to end of GetLookupCombo in GetTitleCombo, GetCountryCombo and ShowSearch
' due to change in dbfunction.asp
' removed Function GetDeliveryRegionCombo, not used anymore
' (SS,31/07/09) Added FCheckoutAlertMessage setting. Change to ShowCheckoutAlertMessage to show FCheckoutAlertMessage if not blank
' (SS,22/09/09) Change to Sub ProductsMain and added Functions CheckEnabledProductExists and GetSearchForPhraseFromReferrer
' Added after Clifton complained about disabled product being found in Google and was linking
' to "product not found" page, e.g. "Swarovski Christmas Star". If no enabled product found it now
' does a search for the search phrase in the referrer URLs query string i.e. q=
' (SS,28/10/09) To fix HTML email not showing USD or EUR currency symbol. Changes to GetEmailBody, SetCurrencyCode, GetCurrencyExchangeRate
' New routines SetCurrencySymbol
' (SS,02/11/09) Change to Function GetEmailBody, replaced "VAT" with LVATLabel, because VAT Deducted/Included not appear on HTML email for clifton
' (SS,10/11/09) Change to CreateAccount, GetSettings and added new subs CheckCustomerRecordChange, CheckCustomerFieldChange
' Also added new globals FNotifyCustomerRecordUpdate, FCustomerFieldChange, FCustomerDetailsOld, FCustomerDetailsNew, FCustomerFieldsChangedList
' This new feature sends notification emails when customer changes billing address details
' (SS,23/11/09) Added Sub UpgradeSchemaTo146 to add new NewCustomer flag to orders table
' Change to Sub UpdateOrderStatusForOrderPlaced to set the NewCustomer flag field if first order, i.e. no previous valid orders
' (SS,22/12/09) Changed to Sub CheckVAT to change VAT to 17.5% on 1/1/2010
' (SS,06/01/10) To functions DoAccountLogin & CreateAccount added calls to new Sub DoLoginLog to help diagnose a problem. Log added to new loginlog table
' also 07/01/10, currently only in petfood may add to others later
' (SS,27/01/10) Added Sub UpgradeSchemaTo147 called from CheckSchema to add new loginlog table
' Changed WorldPay URL in Sub SetUpWorldPayForm to sort "not redirecting" issue
' Change to Function GetDiscountUsingVoucherCode i.e. > to >=
' Added Function GetRegionCodeOrPostalArea, ShowBasket now calls this instead of GetCurrencyPostalArea to show e.g. USA instead of RW
' (SS,02/02/10) Added Sub DisableCache to fix problems some users were having placing orders
' (SS,24/02/10) Change to Function GetProductImageLinkWithImageNo to get around Magic Zoom Plus bug (i.e. moved code2 to the front)
' (SS,17/03/10) Added translation functions
' included "tr" translate given string to different language uses the new translation table
' also SetUpTranslation and Dim FTranslationEnabled, FTranslationLanguage, FTransArrayEnglish(), FTransArrayLanguage()
' New table called "translation" added to common database, two new application settings TranslationEnabled and TranslationLanguage
' Calls to tr, trx, trl in various places.
' (SS,26/04/10) Added Function ReallyInStock (for ExpressMusic 20-04-10)
' (SS,28/04/10) Added UpgradeSchemaTo148 to modify length of Category and Subcategory fields from 50 to 75 for Galleon French/German longer names
' (SS,30/04/10) Added language to WorldPay form i.e. Sub SetUpWorldPayForm, also Function GetWorldPayLanguageCode
' (SS,06/05/10) Added Function GetBuyLLink(AProductCode)
' (SS,07/05/10) Added button functions for translated buttons to replace bitmap
' (SS,08/05/10) Changes to ShowProductListJumpFooterNext and ShowProductListJumpFooterPrevious in Sub ShowProducts
' (SS,12/05/10) Added Function SwapCommasAndDP to show correct decimal separator and point for French/German
' Also added AddCurrencySymbol and GetLanguageDateFormat for correct date format. Added GetReviewCombo
' (SS,13/05/10) Added SPECIAL_OFFERS_SEARCH_TEXT constant
' (SS,15/05/10) Rewrote Function GetCountryISOCode, added Function IsVATNumberValid and Function GetCountryVATNumberFormat
' (SS,17/05/10) Added FButtonType global, setting, including change to GetButton
' (SS,21/05/10) Added IsEnglish, GetPaymentHideCurrency and new FPaymentHideCurrency global setting
' and change to Sub SetUpWorldPayForm to hide currency in payment pages for certain sites, requested by Tim, Galleon
' (SS,25/05/10) Change to Function IsVATNumberValid to save VAT Number Example if VATNumber is invalid,
' added SetVATNumberExample, GetVATNumberExample and global FVATNumberExample, also change to CheckValidPersonalDetails
' (SS,26/05/10) Added GetButtonOutOfStock, and changes to GetStockInfo to use tr() and change to ShowProducts to call SetStockInfo
' (SS,28/05/10) Change to Sub Finalise to call FinaliseDBFunctions and add time taken comments to bottom of page
' Improvements to ShowBestSellers, now much faster, new table called bestsellers is created once per day
' (SS,03/06/10) Category sort order correction to Sub ShowProducts
' (SS,14/06/10) Added EmailConfirmationIsVATReceipt feature, for Galleon, to add VAT receipt to Confirmed received email subject
' added Invoice number to email. Changes made to Sub EmailOrder, Function GetEmailBody, Sub GetSettings,
' added Function EmailConfirmationIsVATReceipt
' (SS,21/06/10) Renamed SwapCommasAndDP to CorrectCommasAndDP
' (SS,22/06/10) Change to GetVATAmountToAddNR to take CountryIsVATable into account
' Also added GetVATAmountToAddNC to prevent issue with GetDeliveryMatrix
' Change to CorrectCurrencyWV to use GetVATAmountToAddNC instead of GetVATAmountToAdd
' Also change to GetWebText to improvement speed by not doing delivery check unless really required
' (SS,23/06/10) Added stock available feature which can show e.g. "Available in 2 to 3 days" on product details page
' Various product and stock routines changed and stock availability functions added
' New suppliers table added, and 3 new fields to products table called SupplierID, AvailabilityDaysFrom and AvailabilityDaysTo
' Also schema version incremented to 1.49, added Sub UpgradeSchemaTo149.
' (SS,24/06/10) Minor change to SetStockInfo for DateDue to override stock availability info
' (SS,25/06/10) Added FShowStockAmount and Function ShowStockAmount and change to SetStockInfo
' to show just "In stock" instead of "x in stock".
' (SS,25/06/10) Change to Sub AddToBasket and Function GetOutOfStockDetails to allow ordering if not in stock but available to order
' Added Function GetStockAvailabilityFieldList, Sub GetStockAvailabilityFieldList to reduce repetitive code
' Added LOCK suppliers READ to Function ProcessOrder, due to suppliers being now used by GetOutOfStockDetails
' Also changed ProcessOrder to add message to a log file using LogErrorToFile in dbfunctions.asp
' (SS,28/06/10) In SetStockAvailablity changed "Available in" to "Delivery"
' Change Sub AddContactToDatabaseAndEmail to prefix email subject with store name
' (SS,29/06/10) Schema updated to 1.50 new Sub UpgradeSchemaTo150, for picture renumbering
' New stored function and procedure added, called from admin app
' RenumberPicturesSingleProduct and RenumberPicturesAllProducts
' (SS,30/06/10) Changed contact form subject "Contact Form" to "Enquiry" in Sub AddContactToDatabaseAndEmail
' (SS,06/07/10) Changed to help with SEO (Clifton) by adding product name to product URL
' New routine GetProductLinkWithName, change to Function ForProductList
' Changes to following templates, renaming GetProductLink to GetProductLinkWithName:
' inc-template-product-list.asp, inc-template-highlights.asp, inc-template-product-details.asp, inc-template-best-sellers.asp
' (SS,19/07/10) In Function GetProductLinkWithName replaced Server.URLEncode(AProductName) with SEOFriendlyStr(AProductName)
' (SS,20/07/10) CustomStockInfo feature and new field called AllowOutOfStockOrdering in products table, various changes to include this feature
' (SS,22/07/10) Bug fix to SetAlertMessage, i.e. added escape for double quote, also to TryProcessOrder, added CleanSQL to LOutOfStockDetails
' Schema updated to 1.51 new Sub UpgradeSchemaTo151, for new field added to products and orderst tables
' (SS,03/08/10) Bug fix to Function IsStockAvailable
' (SS,21/10/10) Added Sub ShowHomePagePictures to show extra pictures on home page
' (SS,26/10/10) Minor change to ShowHomePagePictures to start with random number
' (SS,11/11/10) Added FValidateVATNumber setting and change to Function IsVATNumberValid to return True if validation not enabled
' This was done to fix in in CovDem which uses VATNumber but VATNumberFormat was missing from countries table.
' i.e. Forgot to check other sites use IntraCommunitySupply after adding validation to Galleon sites
' Missing field error was occurring when user entered VAT Number at checkout stage.
' (SS,15/11/10) Changed to Sub GetLatestExchangeRatesIfNeeded, to return straightaway
' Code moved to D:\web\common\exchange-rate-update, scheduled once per day
' We think Clifton's site going done on 13 and 14/11/10 was due to this
' (SS,09/12/10) Changes to ShowHighlights, added ShowHighlightsGrid, ShowHighlightsMain for new product highlights grid
' (SS,17/12/10) Changed Sub AddSearchToLog to only save to log when search string is not blank and not special offers
' (SS,21/12/10) Changed CheckVAT to change VAT rate from 17.5% to 20% from 4/1/2010
' (SS,20/01/11) Change to GetButton to use normal button instead if image if image specified is blank
' Due to change in inc-template-checkout.asp Sub ShowCheckoutOrderDetailsFooter or make printer friendly link into button
' Also added new function IsOption, and target="_blank" options and improvements to option handling
' (SS,07/02/11) Change to GetProductLinkWithName to reverse code and name, as requested by Neil
' (SS,15/02/11) Added order number to end of subject in Sub EmailOrder
' (SS,16/02/11) Added tr to INTRA_COMMUNITY_SUPPLY_MESSAGE in GetEmailBody also added text to status message for English version
' (SS,21/03/11) Added banner routine ShowBanner (calls header, item and footer in inc-template-other)
' and UpgradeSchemaTo152 to add Extra field to files table
' (SS,12/04/11) Add product, category and subcategory redirection (for Clifton)
' New subs ProcessRedirections, GetSubcategory, GetProductCode
' (SS,14/04/11) Added token replacement facility, where tokens in curly brackets, e.g. {catalogue} are replaced with content from site details table
' Changes to ComposeDescription and added new functions ReplaceTokens, GetToken
' (SS,12/05/11) Added Sub ShowProductPriceV2 new version for clifton
' Added ProductsPerPageFixed setting to force so many products per page, i.e. from AcrossMax, DownMax, and change to ShowProducts to make use of this
' (SS,13/05/11) Renamed ShowProductRelated to ShowRelatedProducts, added code to prevent it from being called twice
' Moved code to ShowViewOtherProduct, and also prevent it from being called twice
' (SS,16/05/11) Recently viewed i.e. MAX_RECENTLY_VIEWED was 5, adjusted for clifton to allow more, via new setting MaxRecentlyUsed
' Added Sub SetNumInStock, Function GetNumInStock and global FNumInStock, for use my template functions to which NumInStock isn't passed
' (SS,16/05/11) Added GetBuyLinkPreviousOrders and GetReplacementProductCode, for galleon to allow customers to order from viewing order orders replacement products
' Also made change to inc-template-checkout.asp to called GetBuyLinkPreviousOrders instead of GetBuyLink
' (SS,17/05/11) Added Function GetGroup
' Also added routines GetProductsPageTitleV2, GetBreadcrumb, GetBreadcrumbLink, GetBreadcrumbSeparator
' Changed some calls to ConvertNewlinesToHTML to ConvertNewlinesEtcToHTML for quotes and pounds to show correctly
' (SS,19/05/11) Added CurrencyCharToHTML to a line in GetSettings
' (SS,23/05/11) Added call to ComposeDescription in ReplaceTokens so that bullets, tables and further tokens can be used in tokens themselves.
' This will result in recursion due to ComposeDescription called ReplaceTokens. Added code to prevent too many recursions and stack overflow.
' Also changed to ReplaceTokens to handle comma separated parameters.
' (SS,25/05/11) Changes to ComposeDescription so that it also converts newlines and special chars.
' ComposeDescription also added to category and subcategory to process tokens.
' (SS,03/06/11) Change to ComposeDescription to fix too many newlines issue when ReplaceTokens used, also made "@@@" a global constant
' (SS,06/06/11) Change to ComposeDescWith, GetTableHTML, GetBulletHTML to work correctly when {endbullet} {endtable} don't start on a new line
' ComposeDescription added to GetWebText, to allow tables, bullets, tokens to work for PageContent, new lines handled differently
' Change to ComposeDescription, added a new parameter AConvertNewLines, to stop new lines from being converted to <br>s when called from GetWebText
' (SS,07/06/11) Added SetConfirmDialog to show confirm dialog for account log on or proceed without logon, also added itp_ConfirmMessage to javascript.js
' Change to ShowCategoryMenu to only show category when it contains at least one enabled product
' (SS,08/06/11) Fix to Function GetTableHTML, previous amendment had resulted in extra blank row after header line
' (SS,16/06/11) Added Function RemoveHashCommentLines, called by ComposeDescription to ignore lines beginning with hash #, used for comments
' (SS,16/06/11) Various changes to checkout, accounts, payment, to incorporate new div templates, changes made over the past few days
' (SS,17/06/11) Added new Products / DescriptionTabs setting i.e. FProductDescriptionTabs
' (SS,30/06/11) New product attributes and product options
' (SS,30/06/11) Added ProductID field to shoppingbaskets table, changes to AddToBasket routine
' (SS,01/07/11) Changes to Sub ShowProducts to search for attributes, using attributeid, min and max
' New function GetBuyOLink to buy with options
' Added Sub DoRedirect, which handles all redirects, ProcessRedirections calls this
' (SS,06/07/11) Numerous changes to handle options
' Changes to GetPricingFromProductRecord, ABasketQty unused parameter, replaced with calculate options prices flag
' GetPricingFromProductRecord now calculates the Options Price, FOptionsPrice added to GetProductPrice
' (SS,14/07/11) Schema changes to 1.53, first version to go live (covdem)
' (SS,15/07/11) Changes for new split combo product option input type
' (SS,18/07/11) Added functions GetPageName and IsPageName
' (SS,19/07/11) Change to Function GetProductImgSrc, add AOptions, with "t" to allow title to be set
' (SS,20/07/11) Changes to ProcessAddToBasketForOptions to allow it to be used directly from code as well as from form
' (SS,22/07/11) Minor fix to SQL in ShowCategoryMenu
' (SS,24/07/11) Added Function GetProductDescriptionForID to get just description for shopping admin
' (SS,26/07/11) Change to SetStockInfo to shorten stock info text, added HTMLEncode to references to ProductName, due to it containing pound sign etc for clifton
' Also had to add HTMLDecode to GetProductLinkWithName, also assed HTMLEncode to GetBreadcrumb
' Added functions GetShortNameForCategory, GetShortNameForSubcategory, changes to ShowMenuSubcategory to use short name and HTMLEncode
' (SS,27/07/11) Added HTMLEncode to GetHTMLTitle, GetHTMLDescription, GetHTMLKeyWords
' Sorted product list navigation, moved code from ShowProducts to new routines ShowProductListNavigation, GetProductListNavItem
' (SS,28/07/11) Added FDefaultGroup and GetDefaultGroup to set default group for ShowCategoryMenu when groups enabled
' Added GroupOnlySpecified and change to ShowCategoryMenu to clear previously saved category/subcategory when group specified
' (SS,01/08/11) Added FAlwaysDefaultGroupForMenu, AlwaysDefaultGroupForMenu to allow menu to be shown for same group always
' Improved breadcrumb accuracy, added routines GetBreadcrumbGroupCatSubcatForProduct, IsValidCatSubcatForProduct,
' SetBreadcrumbCategory, SetBreadcrumbSubcategory, GetBreadcrumbCategory, GetBreadcrumbSubcategory, also added GetDefaultGroupCatSubcatForProduct
' In ShowMainMenu changed GetFirstCatSubcatForProduct to GetBreadcrumbGroupCatSubcatForProduct
' (SS,02/08/11) Added IncludeGroupInHTMLTitleTag and FIncludeGroupInHTMLTitleTag to exclude group name from title tag for clifton, i.e. we don't want "Brands" to be in the title tag
' Changes to GetHTMLTitle to exclude group and also use short names for categories and subcategories when groups enabled
' (SS,04/08/11) Removed GetProductDescriptionForID, added GetProductDescriptionScratch for use by shopping admin product description browser preview
' (SS,05/08/11) Changed bank transfer constant from "BANKTRANSFER" to "BANK TRANSFER", and google from "GOOGLECHECKOUT" to "GOOGLE CHECKOUT"
' (SS,10/08/11) Added ShowFacebookLikeImageMeta and GetFullProductImageLink, to help facebook like pick the correct image
' (SS,11/08/11) Changed WorldPay URL to latest in SetUpWorldPayForm
' (SS,06/09/11) Removed Sub DisableCache, which had been moved to dbfunctions.asp on 27/5/10 but accidentally left in apputils.asp
' (SS,19/09/11) Added ComposeDescription to Function GetProductDescription because it was missing tokens feature
' (SS,20/09/11) Changes to SetUpPaymentButton and GetButtonPayment, to allow cheque and bank transfer payment options to be buttons instead of gifs
' (SS,22/09/11) Added HTMLEncodeSpecialChars to GetWebText
' (SS,27/09/11) Added functions PageExists, GetPageContent
' (SS,04/10/11) Added Function GetAttributeInBasketCount, to count how many of an item in basket, i.e. for custom delivery purposes, e.g. how many doors in basket (covdem)
' (SS,05/10/11) Added product_attributes and attributes to LOCK TABLE in ProcessOrder, missed from change made yesterday, caused error in checkout
' Also modified RemoveHTMLTags to replace breaks with a space
' Added GetButtonSubmitCreateAccountVAT, for VAT number validation via javascript, change also made to javascript.js
' (SS,06/10/11) Improved VAT Validation, ajax, javascript also used.
' New Sub NoteVATValidation and AddVATNumberValidationHTML, change to TryProcessOrder and CreateAccount
' Changes to GetCheckoutSubmitLink, GetButtonSubmitCreateAccount, GetButtonProceedToNextStage
' Changes GetButton and new function GetOptionEquals
' (SS,01/11/11) Change to SetUpGoogleCheckoutPayForm to fix VAT not being charged for countries outside the UK
' (SS,24/11/11) Change to ProcessGoogleCheckoutCallback to send an alert email when payment received doesn't match the order total,
' Also added new Sub SendPaymentMismatchEmail, new Function CleanNum added to dbfunction.asp,
' GetSQLValueAsString in dbfunction.asp now always returns a string, added CDbl to GetPriceForProductOptionValue
' (SS,25/11/11) Change to AddContactToDatabaseAndEmail, added GetSQLLastInsertID to subject, to keep enquiry threads separate in Outlook, requested by Neil, I have the same issue in my Outlook
' (SS,05/12/11) Added Function GetStockAmountInfo, new setting StockAmountInfoSpec, change to SetStockInfo
' (SS,12/12/11) Change to Sub ShowHighlightsMain to fix disabled products showing
' (SS,12/01/12) Change to subs SetStockInfo and SetStockAvailability to show "Preorder" if availability from days is negative
' Change to Sub ShowRelatedProducts to remove SortOrder from ORDER BY
' (SS,13/01/12) Fixed & being encoded as & in stock notifications emails for ProductName, added Function GetProductNameNoHTMLEncode, change in Sub SendStockNotificationEmails to call it, also Sub SendStockNotificationReceivedEmail
' (SS,02/02/12) Change to GetProductOptionComboBox to allow all options to be shown when none in stock, avoiding empty combo box, so a preorder can be done
' (SS,02/02/12) Added auto href feature to automatically try to add ahref links to comma separated list of products
' Change to function GetTableHTML, new functions AddAutoProductHRefs and GetProductCodeForAutoHRef
' Change to GetHTMLTitle to fix product name being HTML encoded twice
' (SS,07/02/12) Change to Sub CheckOut to no longer default delivery address to invoice address when different delivery address chosen
' Requested by Neil, customer had changed the delivery address but forgot to change the postcode, decided best to leave blank
' (SS,14/02/12) New feature - allow out of stocks to be list and stock notification.
' New field "ExtraSettings" added to table product_options and "ProductOption" to table stocknotifications, schema version 1.54
' Changes to Sub ShowProductOptions and Sub ShowProductOption to use ExtraSettings, when set to LO it'll stick the options
' Changes also made to Function GetProductOptionComboBox to pass back array of option values out of stock
' New function GetStockNotificationWithOptionLink, change to Sub StockNotify, Sub SaveStockNotification, Sub SendStockNotificationReceivedEmail
' and Sub SendStockNotificationEmails.
' (SS,15/02/12) Fixed issue/bug when searching for a product and it automatically goes to the single found product the stock notification link is missing the productcode
' Fixing involved new Sub SetProductCode and changes to ShowSingleProduct, Sub Initialise, Function GetProductCode
' (SS,15/02/12) Added new reviews page and recent review on the left. New template inc-template-reviews.asp, new reviews-page styles to styles.css
' New subs DoReviewsPage and ShowRecentReviews, change to inc-pages.asp to called DoReviewsPage and inc-template-main.asp to call ShowRecentReviews
' (SS,16/02/12) Change to Sub AddReferrerToDatabase to only add if referrer isn't blank, most records were blank due to search engine hits
' New function GetPageLink
' Added DeliveryCountry combobox to basket page to allow customer to see delivery cost before checking out.
' Changes made to inc-template-basket.asp. Change to Sub RecalculateBasket to store the value from new delivery country combo.
' Change to Sub ShowBasket to correctly default the delivery country used by basket page new delivery country combo.
' Change to sub CheckOut to default to same country for different delivery address, this was previously removed.
' Fixed bug in function GetCountryCombo added new function SetDeliveryCountry. Change to function GetDeliveryCountry to use default country if currency country is also blank
' Added new function ParagraphiseText to dbfunctions.asp and change to GetLookupCombo to add ID to allow onchange event via jquery.
' (SS,17/02/12) PayPal bug fix for multi-currency, changes to SetUpPayPalForm to fix issue which was resulting on PayPal purchases from another currency to be charged in Euro or Dollar amount in pounds, i.e. overcharged.
' New function IsCurrencyGBP. Changed to function AllowCheques to allow cheques only for GBP.
' (SS,20/02/12) Changes to SetUpPayPalForm to fix issue which was resulting on PayPal purchases from another currency to be charged in Euro or Dollar amount in pounds, i.e. overcharged.
' Improvements to multi-currency VAT. New function GetCountryChargeVATFlag. Sub GetCurrencyExchangeRate, now sets FCurrencyShowVAT using settings from the countries table rather than the common exchangerates.
' This overcomes issue in hyperflight using flat rate VAT, which was showing prices ex VAT for USA.
' Correction to function GetDeliveryCost, VAT wasn't being added to delivery cost when country was not vatable and prices include VAT.
' Fixed by changing GetVATAmountToAdd to GetVATAmountToAddNC.
' Added new cookie routines SetCookie and GetCookie to dbfunctions.asp.
' Changes to GetBankTransferDetails to allow separate setting details for EUR and USD currencies.
' Delivery County now also held in a cookie, change to Function GetDeliveryCountry. New sub SetDeliveryCountryCookie called fron Initialise.
' (SS,21/02/12) Change to GetDeliveryCost to make sure delivery cost is rounded to 2dp, had noticed some values in orders table for clifton with more than 2dp.
' (SS,14/03/12) Improvements to Sub SendStockNotificationEmails to add a staggered (delay) facility, amount of emails sent per product are equal to the number in stock. Rest are delayed by 23 (x) hours.
' Routine was split into EmailSendStockNotificationEmailsResult, StockNotificationHeader, StockNotificationFooter, StockNotificationRow, SendStockNotificationEmail.
' Result email also sent. New field called DelayUntil added to stocknotifications table via Sub UpgradeSchemaTo155.
' (SS,14/03/12) Change to Sub ShowProducts, adding new AVal parameter to search for exact attribute value instead of min/max
' (SS,14/03/12) Added code Sub ShowViewOtherProducts to show related category if set in product attribute, allows miscellaneous link to be added to categories without listing related products
' (SS,15/03/12) Removed DoLoginLog, dropping the table, commented out the sub
' Minor change to ShowViewOtherProducts to use \ or � as separator instead of /
' (SS,16/03/12) Modified GetHTMLTitle, GetHTMLDescription, GetHTMLKeyWords to get the keywords meta tag if available from categories, subcategories, groups, product_attributes and sitedetails tables
' New functions GetTitleTagForPage, GetTitleTagForProduct, GetTitleTagForCategory, GetTitleTagForSubcategory, GetTitleTagForGroup, GetTagNameForType, IsGroupPage
' Schema changes to tables categories, subcategories, groups, sitedetails, attributes, product_attributes via UpgradeSchemaTo156, also dropped loginlog, add adding of title/meta tag records to attributes table
' Removed references to ProductListCategorySuffix field in groups table, field has been dropped, also commented out Sub GetProductListCategorySuffixForGroup
' (SS,21/03/12) Slight change to function GetHTMLDescription, improvement for product page, to not prefix with product name if description is longer than name
' (SS,23/03/12) Improved writing reviews security. Spam reviews were bypassing existing security. Improved by adding forcing email to be entered and checking if email address has been used to place an order.
' Changes to CheckReviewDetails, new function Function EmailAddressHasOrdered. Also changes to Sub ShowReviewEntryForm (inc-template-other.asp)
' (SS,11/04/12) Modified UpdateOrderStatusForOrderPlaced to set new PaymentReceived field in orders table
' New PaymentReceived field added to orders table, manually, not via schema update
' ALTER TABLE orders ADD PaymentReceived TINYINT(1) NOT NULL DEFAULT 0 AFTER PaymentReference
' Also ran the following SQL to populate the new field
' UPDATE orders SET PaymentReceived = TRUE
' WHERE Status = "COMPLETED" OR Status = "PAYMENT RECEIVED" OR Status = "PAYMENT ON ACCOUNT" OR (Status = "CANCELLED" AND PaymentMethod <> "" AND RefundAmount <> 0)
' (SS,17/04/12) Added Special Offers to ShowCategoryMenu
' (SS,18/04/12) Add CollectionOnlyOrder feature, including new function HasCollectionOnlyInBasket, shows message and disables DeliveryWillCollect checkbox
' when a product in basket has an attribute of CollectionOnly = "Yes". New Session("CollectionOnlyOrder") used.
' (SS,19/04/12) Changes to CheckOut to bypass confirm page for Bank Transfer and Cheque payments
' Changes to functions RemoveHashCommentLines, ReplaceTokens and added new function HasScriptOrStyle, to allow script and stylesheet in page content held in sitedetails
' Because {} and # are used by stylesheets and scripts, this also means tokens can't be used if page content / description contains a style or script html tag
' (SS,27/04/12) OptionValue resized from 100 to 150 via UpgradeSchemaTo157
' Improvements to options radio, Function GetProductOptionComboBox, better alignment, semicolons converted to breaks. If only one option when it is checked.
' Price difference shown at the end.
' Bug fix to Function GetProductAttributeByName, to handle the case where ID might be blank.
' Changes to stock notifications, Sub SendStockNotificationEmails, to remove duplicates (new Sub StockNotificationsRemoveDuplicates).
' Also added BackInStockNotificationsStockMultiplier to send x many emails per number in stock.
' Bug fix to query in SendStockNotificationEmails for options, it wasn't delaying when Option was blank when options enabled.
' (SS,10/05/12) Modifications to ePDQ facility to get it working for CovDem
' Under Offer attribute feature for products, to show "Currently under offer" if product has 0 stock and "Under Offer" attribute
' New function ProductAttributeExistsm change to sub SetStockInfo, new function GetSQLRecordExists added to dbfunctions.asp
' (SS,15/05/12) Change to ProcessPayPalCallback and ProcessOrderThirdPartyPayment to set status to either AWAITING PAYMENT or PAYMENT RECEIVED
' (SS,18/05/12) New "Main" field added to productcategories table, populated using special query which looks at priorty field.
' Change to Function GetCategoryListSQL to use this new Main instead of Priority from categories and subcategories, which may be dropped in future
' Change to related products to show related products in category/subcategory order, also to move out of stock products to the end or hide them.
' To implement this, changes were made to ShowRelatedProducts, new setting RelatedProductsOutOfStock was added.
' Implemented per category/subcategory best sellers, changes to Sub ShowBestSellers, new table create by ShowBestSellers called bestsellers_per_category
' (SS,22/05/12) Fixed bug on best sellers for category where product is in more than one subcategory for same category and it showed duplicates.
' Added best totals when querystring has bstotals=y
' Change to GetAccountDetails to allow login with special password, for internal use
' (SS,25/05/12) Changed to Sub UpdateOrderStatusForOrderPlaced to allow status to be updated when it's currently awaiting payment, for PayPal echecks that have cleared
' (SS,29/05/12) Change to ShowBestSellers orderdetails.ProductName with products.ProductName
' (SS,30/05/12) New NumInStock field to orderdetails table to hold number in stock just before the product was purchased, i.e. a historical value for stocking checking purposes.
' Change to insert query in TryProcessOrder to set this new field. Also change to Function GetOrderItemsQuery to include this new field
' Added new sub StockSnapshot, to log the stock levels in new stock_snapshots table. Schedule once a day via stock-snapshot.asp called via d:\bin\scripts\StockSnapshot.vbs
' (SS,01/06/12) Renamed field NumInStock added to orderdetails (30/5/12) to PrevStock to fix ambigious error in Stock Required report and other potient issues
' (SS,12/06/12) Added CleanSQLStr to prevent SQL injection, most queries already had this, made sure all parameters/values passed to SQL used CleanSQLStr and also start and end in "'"
' Hyperflight was hacked, on 1/6/12 by somebody using a tool called Havij from http://itsecteam.com/en/projects/project1.htm
' Using a FireFox addon, determined that page and code were vulnerable form/query string variables.
' These changes should prevent future attacks.
' (SS,13/06/12) Change to Sub TryProcessOrder, insert query with PrevInStock, changed NB to new NNULL routine to handle null
' (SS,13/06/12) Change to Sub ShowProducts to use ParseInt instead of CInt to prevent error if SQL Injection used for PageNo
' (SS,18/06/12) Various changes to improve password security, password is now stored hashed and encrypted. Password is no longer email, password reset URL emailed instead.
' (SS,19/06/12) Continued with various changes to improve password security including UpgradeSchemaTo159.
' Also removed old redundant login using Account ID which was only used by Toner2Desk.
' Added new Sub DoResetPassword. Changes were also made to inc-template-account.asp, including new reset password routines.
' (SS,05/07/12) Added new function GetAttributeInBasketCountNumValCompare used by hyperflight to add extra delivery via customutils.asp if certain item in basket
' (SS,01/08/12) Change to Sub UpgradeSchemaTo153 to make sure OptionValue is 150 long, and OptionName is 50 long.
' (SS,21/08/12) Added Function GetMaxMessageLength to restrict customer message entered in check to 600.
' This is called by Sub CheckOut and ShowCheckoutPersonalDetailsEntryForm in inc-template-checkout.asp.
' (SS,29/08/12) Added function GetFeefoLogon and function IsDiscountedOver2PC (for Galleon)
' (SS,31/08/12) Added function function GetProductCodeForName
' (SS,12/09/12) Changed to Sub DoBasketOperation for shopping status deduct, now can also use xcode
' Added Sub SingleProductRedirect, now called when search finds single product
' Improvements to ShowRecentlyViewed to not show current product (originally done 5/9/12), new functions GetProductCodeQS and GetRecentlyViewedCount
' New function GetProductFileLinkCached used by banner to cache, calls existing GetProductFileLink, change to ShowBanner to call GetProductFileLinkCached instead
' New sub GetButtonYourAccount (replaces GetButtonMyAccount)
' New routines ShowFavourites, GetCustomerNameUsingCookie, GetSetCookieCustomerID
' (SS,20/09/12) Change to ProcessWorldPayCallback to trap test payments made in live mode
' Added Auto log in feature, which replaces previous GetSetCookieCustomerID which was being used to retrieve just the customer name and favourites.
' Now the customer stays logged in until they log out.
' New setting FAutoLoginEnabled and ACustomerID parameter added to GetAccountDetails (and "" to most calls to this routine)
' New routines AutoLoginEnabled, SetDateTimeOfLastLogin, DoAutoLogin, SaveAutoLoginToCookie, ClearAutoLoginFromCookie.
' Routine GetCustomerNameUsingCookie renamed to GetCustomerNameForWelcome and modified.
' (SS,28/09/12) Added review requests facility, both Feefo and internal
' New routines: SendReviewRequests, EmailReviewRequestsResult, ReviewRequestResultHeader, ReviewRequestResultFooter, ReviewRequestResultRow,
' SendReviewRequestEmail, SetFeefoFileName, AddFeefoField, AddFeefoRecord, GetFeefoFTPHost, GetFeefoFTPUser, GetFeefoFTPPassword, ReviewTypeIsFeefo
' Change to SendEmailByCDO to allow image to be embedded in email, new parameter added.
' Added FTPFile to dbfunctions.asp
' Also added UpgradeSchemaTo160 to add new field orders table and some extra indexes
' (SS,04/10/12) Replaced GetAttributeInBasketCountNumValCompare with new function GetAttributeInBasketMaxOptionValue, used by hyperflight in customutils.asp
' (SS,02/11/12) Changes to functions GetEmailBody, GetInvoiceCountry, CorrectCurrencyNV, CorrectCurrencyWV, SignedCurrencyPrice to correctly show prices exc VAT
' for stores that have prices including VAT, i.e. HyperFlight, also change to ShowBasketFooter in inc-template-basket.asp
' and change to ShowEmailOrderFooter in inc-template-email-html.asp.
' Change to Sub SendReviewRequestEmail to show Order No in email subject.
' (SS,03/11/12) Change to function GetEmailBody to SetInvoiceCountry for correct VAT deducted figures for confirmation emails due to change made yesterday
' which resulting in emails without VAT deducted from figures although GrandTotal itself was fine.
' (SS,08/11/12) Added new min USD and EUR price feature to allow a minimum price to be set in USD or EUR.
' New functions IsCurrencyUSD, IsCurrencyEUR, MinCurrencyPricesEnabled, changes to GetPricingFromProductRecord, GetProductPrice, GetStdPrice, GetSalePrice, GetPricingFieldsForSQL.
' 3 new fields added to products table including DateAdded, schema update to 161 via UpgradeSchemaTo161.
' (SS,09/11/12) Made a correction to min currency price feature to work correct with negative credit prices by only adjusting price if it's greater than 0
' (SS,14/11/12) Change to SetUpWorldPayForm to add MD5 Secret for more security i.e. to prevent sabotage of form fields sent to WorldPay.
' Also new routine GetWorldPayMD5SecretKey and payment setting value WorldPayMD5SecretKey.
' (SS,16/11/12) Removed products2.asp from DoGoogleSitemap, changed to Function GetPostalArea to not use OpenQuery (oRs), created issue in Clifton when applying latest apputils
' (SS,22/11/12) Added Function GetMaxPicturesPerProduct
' Change to Sub ShowProductMoreImages and added Sub ShowProductMoreImages(AProductCode)
' (SS,27/11/12) Added alert email when order eventually paid for becomes cancelled due to inactivity delay which cna cause stock to go wrong (i.e. high)
' Added Sub SendAlertEmail and change to Sub UpdateOrderStatusForOrderPlaced to check for cancelled status and send alert email
' (SS,06/12/12) New order reminder facility, two new fields added to orders table (UpgradeSchemaTo162)
' New routines SendOrderReminders, EmailOrderRemindersResult, OrderReminderResultHeader, OrderReminderResultFooter, OrderReminderResultFooter, OrderReminderResultRow, SendOrderReminderEmail, OrderReminderOptOut
' New asp file order-reminders.asp. Change to inc-pages.asp to handle the opt-out and added Sub ShowPageContentGiven to inc-template-page-content.asp.
' (SS,11/12/12) Change to Function GetProductImageLinkWithImageNo to fix Magic Zoom / Magic 360 issue.
' (SS,12/12/12) Added Intra-Community alert email if enabled. Also corrected VAT not being deducted for Intra-Community when prices include VAT.
' (SS,13/12/12) Change to Sub RecalculateBasket to fix issue where it was taking into account the reserved items via Order Placed, if customer changes his/her mind after proceeding to second stage
' and goes to basket to make adjustment.
' (SS,19/12/12) Change to Sub SendOrderReminders to also assume PAYMENT RECEIVED is an order, to prevent customers who ordered after closing time today and hadn't ordered for a month from receiving a reminder
' (SS,10/01/13) Changes to allow a heading in category/subcategory other than category/subcategory name.
' Also to allow description text in category/subcategory page header and footer.
' These were part of the SEO changes for CovDem. New fields Footer and Heading were added to the category and subcategory tables.
' Also added Sub UpgradeSchemaTo163 to add the new fields.
' (SS,11/01/13) Further change to ShowProducts to pass the heading to ShowProductListHeaderForCategory in inc-template-product-list.asp.
' Also corrected GetShortNameForSubcategory by added the missing ACategory parameter.
' Correction in GetProductsPageTitleV2 for breadcrumb sometimes showing in category or subcategory page.
' (SS,15/01/13) Added settings ReviewRequestsEnabled and ReviewRequestsDays and change to SendReviewRequests to make use of these settings.
' (SS,16/01/13) "inc VAT" was incorrectly showing for clifton when RW country chosen. Fixed by replacing IsCurrencyVATable with IsCountryVATable in
' routines ShowProductPrice, ShowProductPriceExcVAT and ShowProductPriceV2.
' Added facility to initially not search the description (for galleon because it was returning too many products when search product code).
' Change made to Sub ShowProducts, including moved code to new Function GetProductSearchSQL and IsNormalSearch, also new setting ProductSearchWithoutDescFirst.
' (SS,17/01/13) Added Function GetBasketLink which is now used by inc-template-shopping-status.asp instead of GetCheckoutLink.
' Added ShowNewProducts to show newly added products via new template inc-template-new-products.asp.
' Added custom pages facility, including changes to GetTitleTagForPage and PageExists, new CustomPagesEnabled
' Also corrected HTML errors in Sub ShowSearch and Sub ShowSearchForStreamline.
' Made other HTML corrections, including change & to & in links.
' (SS,18/01/13) Added new products search facility to list newest products. New contant NEW_PRODUCTS_SEARCH_TEXT, change to Function GetProductSearchSQL.
' New template inc-template-new-products.asp.
' (SS,24/01/13) Change to Sub ShowProducts to not show number of products found if AttributeID used.
' (SS,01/02/13) Changes Sub SendOrderReminders etc. to improve the look of order reminders on iPhone, Android and Gmail
' (SS,05/02/13) Change to Function PageExists to return True when page name is blank i.e. home page
' (SS,05/02/13) In Function SignedCurrencyPrice(APrice) replaced "-" with "‑" to prevent wordwrap after "-" in product option prices.
' (SS,05/02/13) Change to Function GetProductOptionComboBox to default first item in radio group, also added NumInStock to sort order
' (SS,14/02/13) Added chasing of cancelled orders facility via Sub SendChaseCancelledOrderEmails
' New field CancelledOrderChasedDate added to orders table via UpgradeSchemaTo164
' New script chase-cancelled-orders.asp added which calls SendChaseCancelledOrderEmails.
' This can be called via Shopping Admin or via schedule on server.
' (SS,15/02/13) Changed to Sub SendChaseCancelledOrderEmails to allow order no to be specified for testing purposes
' Also added FirstName and Surname tokens, requested by Neil.
' (SS,19/02/13) Change to ProductsMain to remove call sitemap. Rewrote ShowFullList, now called GetHTMLSiteMap.
' Menu SQL code moved to new function GetCategoryMenuSQL.
' Change to Function GetWebText to also handle SITEMAP and CUSTOM-SITEMAP tokens from page content.
' Change to DoGoogleSitemap to also GetCustomXMLSitemap if such function exists.
' Template inc-template-main-streamline.asp replaced with inc-template-sitemap.asp.
' Added function GetURLForPage to create page URLs.
' (SS,20/02/13) Change to Sub AddGoogleSitemapLevel, replacing "&" with "&"
' Modified GetWebText to bypass ComposeDescription when {SITEMAP} or {CUSTOM-SITEMAP} tokens used, for much faster large sitemaps.
' (SS,21/02/13) Removed functions GetProductsForFullListSQL, OpenProductsForFullListQuery, OpenProductsForFullListQuery2, Sub OpenCategoriesAndSubcategoriesQuery
' ShowProductsOnFullListCat setting is now redundant.
' Changes to Function GetHTMLSiteMap to add Group.
' (SS,22/02/13) Email Marketing facility
' Following changes were originally made on 19/12/12:
' New Sub UpdateCustomerRecord, call added to subs ProcessOrderFinalise, ProcessOrderThirdPartyPayment
' Change to Function AccountExists
' Changes to Function CreateAccount and Sub UpdateCustomerRecord.
' These ensure than the customer record is updated or new one created where buyer hasn't created an account.
' (SS,26/02/13) Completed the Marketing Emails facility.
' (SS,28/02/13) Added UpgradeSchemaTo165 to add the new MarketingEmailSentDate field.
' This also runs queries for shopping sites that have optional accounts to create a customer record for every customer who
' has an order but no CustomerID assigned.
' (SS,28/02/13) Manually added new table "google_adwords_groups" and field "AdWordsGroupID" to subcategories table.
' Also attribute "Exclude from Google Shopping". These are used by Shopping Admin for Google Shopping.
' (SS,01/03/13) Change to Sub ProcessRedirections to allow semicolon for separation.
' Added Session.Abandon to Sub CheckOut, mainly to empty session variables from previous order, requested by Neil.
' Improvement to Sub SendReviewRequests to allow OrderNo to be specified for testing purposes.
' (SS,05/03/13) Change to UpgradeSchemaTo165 to only had customer records if customer has a valid order. New Function GetWebTextDef.
' Improvements to Sub DoContactForm and Sub DoCreateAccountForm.
' (SS,06/03/13) Added Sub UpgradeSchemaTo166 to change CustomerID in orders from varchar to int. Improvements to AddContactToDatabaseAndEmail and Sub DoContactForm.
' (SS,07/03/13) Bug fix to Sub TryProcessOrder, due to '' now being assigned to CustomerID which had changed from VARCHAR to INT, '' to NULL fixes it.
' Removed references to contracts including FContractsEnabled, functions LookupPriceForContract, OnContract, ContractsEnabled removed.
' Removed contract code from functions GetStdPrice and GetSalePrice
' (SS,08/03/13) Improve the order history page, including change "COMPLETED" to "DESPATCHED" status and show extra details, also tracking URL.
' Changes made to routines GetStoreAddress, ShowPreviousOrders, GetEmailBody, ShowOrderDetailsMaster.
' New functions StatusForCustomer, GetTrackingURLForCourier added.
' Also removed Session.Abandon (added 1/3/13) which was cause alert payment to be sent when PayPal callback was delayed.
' (SS,21/03/13) Change to function RemoveHTMLTags, to fix issue when tags within HTML comment tags.
' (SS,22/03/13) Changes to add Sage Pay (search for 3/13 to find all the changes made). Changes were applied to expressmusic old apputils, later added here as well.
' Changes included new sub CheckPaymentProviderTestMode and functions IsPaymentProviderTestModeActivated, IsSagePayTestMode and GetUniquePaymentProviderSuffix
' Also made a change to dbfunctions to include Sage Pay's encryption functions in common/asp/rijndael.asp
' Added new table called sagepaycallbacks.
' (SS,23/03/13) Change to Sub SetUpSagePayForm, added URLEncode to ptSagePay because it now contains a space
' (SS,23/04/13) Added rounding to 2dp to FMinCurrencyPrice to Sub GetPricingFromProductRecord
' (SS,30/04/13) Added rounding to 0dp to Sub ShowBestSellers, for special total values visible via ?bstotals=y, also made bold
' (SS,10/05/13) Added Sub ShowCanonicalLink for CovDem version, also added to latest AppUtils.asp.
' Also added NL to Sub ShowFacebookLikeImageMeta
' (SS,16/05/13) Change to function GetTrackingURLForCourier and calls to this function to add tracking for APC, had to add postcode parameter
' (SS,20/06/13) Change to Sub SetUpWorldPayForm to fix issue where amounts over 1000 were failing due to comma separator
' (SS,02/07/13) Change to Sub SetUpPayPalForm to not send the delivery address to PayPal, this change was made on 2007, but no longer necessary
' PayPal customers with different delivery address were having problems.
' (SS,16/07/13) Change to use function ComposeDescription for to convert tokens and suffix with "..." if longer than max length
' Also added Function ProductDescriptionListForGoogleShopping to send product description list
' (SS,17/07/13) Improvements to Best Sellers to exclude products that have the attribute "Exclude from Best Sellers".
' Change to sub Sub ShowBestSellers and added new function GetAttributeIDForName
' (SS,04/10/13) Added SortOrder to Sub ShowRelatedProducts
' (SS,14/10/13) Added Function IsSalesPostalAreaInvoice and change to function IsCountryVATable
' This sorts issue where invoice country is RW and delivery country is UK (or EU) and VAT wasn't being charged. It is now.
' (SS,11/11/13) Change to Sub CheckSchema to only upgrade schema if cmd=upgrade is in query string
' Change to Sub UpgradeSchemaTo165 to set the DateTimeCreated to today's date, noticed it was being set to null.
' Also added DebugLog -1, ... just before each ExecSQL to help debug why it was taking a very long time for clifton
' (SS,13/11/13) Added Address and Postcode back to Sub DoContactForm, required by some sites for sample requests.
' (SS,13/11/13) Change to Sub ShowPreviousOrders to only show despatch details if such details exist for customer
' (SS,18/11/13) Change to Sub Finalise to only call DoGoogleAnalytics if page is product.asp. This removes the Google Analytics javascript from the order confirmation emails.
' Also added function called ScriptIsProducts. Also made change in Sub Finalise to only show timer if in products.asp
' (SS,22/11/13) Added Function GetProductCodePrefixesInBasket
' (SS,28/11/13) Changed Google Analytics from synchronous to asynchronous version. Add dynamic remarketing tag. Various changes to incorporate this.
' Head tag in inc-template-main.asp should contain (just before the end head tag) a call to DoGoogleAnalytics(True) for the asynchronous javascript.
' (SS,29/11/13) Change to Function ProductDescriptionListForGoogleShopping to replaced tabs with a space for google shopping (was causing problems in products containing a tab in description)
' (SS,29/11/13) Change to Sub DoGoogleAdWordsRemarketingTag to show remarketing tag without a conversion label.
' (SS,06/12/13) Change to Sub DoGoogleAdWordsRemarketingTag to fix issue with "purchase" ecomm_pagetype not showing ("other" was being shown")
' (SS,13/12/13) Added picture to product option value. New Picture flag field added to product_option_values_table. New function GetProductOptionValueImageLink and
' change to Function GetProductOptionComboBox.
' (SS,17/12/13) Change to Function GetProductOptionComboBox to underline the option value picture link
' (SS,18/12/13) Change to Function GetProductOptionComboBox, added class=""MagicThumb"" for Magic Zoom popup, also a title for caption
' (SS,19/12/13) Change to GetProductOptionComboBox to optimise the Magic Zoom popup
' Fixed VAT No check issue for Greece, which uses code "EL" not ISO "GR". Change made to function IsVATNumberValid and added new function GetEUCountryCode
' (SS,19/12/13) Change to GetProductOptionComboBox to improve radio alignment in IE using new div with class option-radio-div
' (SS,20/12/13) Change to Function IsVATNumberValid to only validate VAT if intra-community supply
' (SS,23/12/13) Change to Sub SendMarketingEmails, commented out date limit, to allow Christmas emails to be sent
' (SS,18/02/14) Change to add to basket to redirect to shopping basket page. Experimented with adding a popup after adding to basket. Decided going to basket was the better option.
' (SS,19/02/14) Added a redirect for checkout when filling in the details so that the page URL becomes unique i.e. products.asp?cmd=checkout&xcmd=filled (for AdWords requested by Clifton)
' (SS,20/02/14) Change to Sub CheckOut to fix stuck in "account already exists" alert loop due to change made yesterday
' (SS,20/02/14) Modified the add to basket alert to also do popup via new Sub ShowPopUpMessage, routine called SetAddToBasketAlert, does either redirect or popup or neither depending on setting
' (SS,21/02/14) Update to Sub CheckOut and Sub SetUpChequeOrBankTransferPayForm to allow Cheque/BankTransfer payment to have the same URL as return from third party payment (i.e. stage=co at the end)
' (SS,24/02/14) Change to Sub CheckOut to improve message shown when returning direct from payment provider e.g. WorldPay or PayPal
' (SS,03/03/14) Modified Sub ProcessWorldPayCallback to call ProcessOrderThirdPartyPayment. It wasn't automatically creating customer records when paying by WorldPay
' Added Function IsReturnFromPaymentProviderPage and change to Sub DoGoogleAdWordsRemarketingTag to show purchase remarketing tag when returning from payment provider.
' (SS,14/04/14) Added UKMail and UPS to Function GetTrackingURLForCourier
' (SS,05/06/14) New function GetGeoIPCountry added
' (SS,10/06/14) New multicurrency method added which uses local currencies table. Used by HyperFlight only currently.
' New routines added: GetCurrencyCombo, GetCurrencyCodeForCountry, SetCurrencyAndDeliveryCountryCookieFromGeoIP
' Changes made to GetCurrencyExchangeRate, SetCurrencySymbol, IsAllowedCurrency.
' New settings FMulticurrencyMethod, FExchangeRateAdjustmentRatio and FGeoIPEnabled
' Change to SaveReview to show reviews immediately if new setting FProductsShowReviewsImmediately is true, default is false.
' Two new fields Currency and SortOrderISOCode added to countries table (added to all sites).
' New fields SymbolHTML, CurrencyName and SortOrder added to currencies table.
' (SS,11/06/14) Change to Sub ShowPopUpMessage to position popup just below the shopping status div
' (SS,23/06/14) Added new Function GetPriceIncVAT, used to calculate VAT inclusive price, required by Galleon because Google Shopping now insists that inc VAT prices are show on site.
' (SS,14/08/14) Added Sub ShowMenuForCategories, ShowMenuForCategory to use for bootstrap (popup) type menu
' (SS,15/08/14) Added new setting FResponsiveWebDesign and Function IsRWD, used to allow different HTML to be sent where applicable and held in apputils.asp
' (SS,15/08/14) Added functions GetBreadcrumbHeader and GetBreadcrumbFooter in addition to existing GetBreadcrumbLink and GetBreadcrumbSeparator
' These four functions can also exist in inc-template-products.asp to override these default ones
' (SS,19/08/14) Added new function ProductOptionExists. Used to find if Sections option exists in Cast Iron Radiator Centre.
' Added function Sub ShowProductPriceSimple.
' (SS,20/08/14) Added Sub ShowProductPriceIncVAT
' (SS,21/08/14) Correction to Function GetTrackingURLForCourier for UPS. Tracking No had been hardcoded by mistake.
' (SS,22/08/14) Change to Function RemoveHashCommentLines to allow special #SECTION used to separate description text into sections
' New Function GetDescriptionSection, Sub ShowProductDescriptionSections
' New Function GetProductID
' (SS,26/08/14) Change to Function GetButton to use difference class names for Bootstrap and remain compatible with previous versions
' Change to Sub ShowRecentReviews, added new Sub ShowRecentReviewsV2, both call new ShowRecentReviewsMain (with contains code from ShowRecentReviews)
' Change to Sub ShowProductOption to allow default option HTML to be overridden via custom routine
' (SS,28/08/14) Change to GetPricingFromProductRecord to call CustomGetOptionsPriceAndWeight routine if CUSTOM extra setting in settings
' Added PostalWeight field to Function GetPricingFieldsForSQL to allow it to be passed to CustomGetOptionsPriceAndWeight
' (SS,11/09/14) Added two new parameters to Sub ShowProductMoreImagesV2, removed old ShowProductMoreImages and ShowProductMoreImagesExclude, renamed ShowProductMoreImagesV2 to ShowProductMoreImages
' Change to Function GetProductImageLink for compatibility
' (SS,12/09/14) Added ParcelForce to Function GetTrackingURLForCourier
' (SS,13/09/14) Added generic counter routines Sub ClearCounter, IncCounter, Function GetCounter and Dim FCounter, can be used by templates
' (SS,01/10/14) Added Facebook conversion tracking code as requested by Clifton, new setting FFacebookConversionTrackingID, new Sub DoFacebookConversionTracking
' (SS,02/10/14) Change to Sub SetUpEPDQForm to add PARAMVAR to allow more than one site to use same ePDQ account, also added FEPDQPARAMVAR setting
' (SS,09/10/14) Added getting and setting of DeliveryInfo via CustomGetOrderDeliveryInfo to determine the likely delivery date of order, new field DeliveryInfo added to orders table
' (SS,10/10/14) Added call to CustomFinalise in Finalise. Change to ShowBasket to call CustomProductInBasket
' (SS,16/10/14) Change to Function IsVATNumberValid to bypass VAT number validation if it ends in [NV], on rare occasions the checking site might say it's not valid when it actually is
' (SS,20/10/14) New review and Feefo settings FReviewsType, FFeefoLogon, FFeefoFTPHost, FFeefoFTPUser, FFeefoFTPPassword.
' (SS,23/10/14) Bugfix to Function GetDiscountPercentage to prevent overflow error when standard price is 0
' (SS,09/12/14) Change to Function GetDeliveryCost, added LByPriceDeliveryCost, LByWeightDeliveryCost parameters to CustomGetDelivery (for Clifton, UK ignores by weight delivery)
' (SS,09/12/14) Changes to incorporate PayPal Express (various changes made 18/11/14 to 24/11/14)
' (SS,18/12/14) & 19/12/14 Various changes made to implement default payment currency and improved bank transfer details Changes also made to inc-template-checkout.asp (ShowOrderThankYou)
' Schema change made to orders tableadd new DefaultPaymentCurrencyCode and Rate and PaymentLog fields, need to apply to all shopping sites due to shopping admin:
' ALTER TABLE orders
' ADD DefaultPaymentCurrencyCode CHAR(3) DEFAULT 'GBP' COMMENT 'Added 19/12/2012' AFTER ExchangeRate,
' ADD DefaultPaymentCurrencyRate DOUBLE DEFAULT '1' COMMENT 'Added 19/12/2012' AFTER DefaultPaymentCurrencyCode,
' ADD PaymentLog MEDIUMTEXT DEFAULT NULL COMMENT 'Added 19/12/2012' AFTER CancelledOrderChasedDate;
'
' New currencies table, kept empty if not used:
'
' CREATE TABLE currencies (
' Currency CHAR(3) NOT NULL DEFAULT '',
' ExchangeRate DECIMAL(11,4) DEFAULT NULL,
' SymbolHTML VARCHAR(50) DEFAULT NULL,
' CurrencyName VARCHAR(50) DEFAULT NULL,
' DefaultPaymentCurrency CHAR(3) DEFAULT NULL,
' SortOrder INTEGER(11) DEFAULT NULL,
' PRIMARY KEY (Currency)
' )ENGINE=MyISAM
' AVG_ROW_LENGTH=116 ROW_FORMAT=FIXED CHARACTER SET 'latin1' COLLATE 'latin1_swedish_ci';
' (SS,28/12/14) Change to Sub EmptyBasket to delete from shopping_basket_options, missing from when options first added in July 2011
' (SS,30/12/14) New version of Sub ShowRelatedProducts to use union instead of creating temporary table to prevent adding to binary log for replication
' (SS,15/01/15) Added Function GetButtonBasketApplyVoucherCode
' (SS,21/01/15) New APaymentInfo parameter added to Sub UpdateOrderStatusForOrderPlaced and to new PaymentInfo field to orders
' ALTER TABLE orders
' ADD PaymentInfo VARCHAR(255) DEFAULT '' AFTER PaymentReference;
' (SS,03/02/15) Minor change to Sub DoPayPalExpress(ALaterStage) to improve error display
' (SS,04/02/15) Change to Sub SendReviewRequests, to fix feature not working when CustomerID is null, added NB so line becomes LCustomerID = NB(GetQueryField("CustomerID"))
' (SS,04/02/15) Change to Function GetButtonPayment to improve layout of payment logs for non RWD
' (SS,06/02/15) Bug fixes to GeoIP Locate, delivery country on cookie not valid then clear it. Also GBP value not being passed to final stage of PayPal Express
' (SS,06/02/15) Added ShowCheckoutMakePayPalPaymentText to Sub SetUpPaymentButton, also to inc-template-checkout.asp
' (SS,11/02/15) Added GroupName parameter to Function GetDeliveryRegionFromPostcode, new field "GroupName" added to delivery_postcodes table
' (SS,12/02/15) Modified Sub DoGoogleAnalytics to allow different DoubleClick.Net URL depending on new setting FGoogleAnalyticsUseDoubleClickDotNet, requested by Miromedia for CovDem
' Change to Sub AppUtilsAddToPaymentLog, now calls new Sub AddToPaymentLog
' Change to Sub ProcessOrderChequeOrBankTransferPayment to log bank transfer details in PaymentLog
' Change to Sub DoPayPalExpress to add Description
' (SS,16/02/15) Added Auto voucher code feature, Voucher Type "A"
' New routines Function IsVoucherCodeAuto, Function GetDiscountUsingAutoVoucherCode
' Changes made to Sub GetOrderTotalsForBasket, Sub SetVoucherCode
' Change to Function GetDetailsFromPayPalExpress to replace telephone prefix "+44 " with 0, requested by Deborah
' (SS,17/02/15) Improvements to PayPal Express checkout. Including handling of error "10486" by redirecting back to PayPal.
' Change to Function IsVoucherCodeValid, added voucher type "MC" multiple user per customer
' (SS,18/02/15) Improvement to Function GetDeliveryRegionFromPostcode to handle, which now calls CorrectPostcodeForUK, and handles special London postcodes like SW1A 2AA, EC2M 2RH, E1W 2AB
' (SS,20/02/15) Added Save Basket and Restore Basket feature
' (SS,21/02/15) Correct to GetVoucherIDForVoucherCode. GetValueFromQuery was returning Null when voucher code not found, modified to convert this to NULL as a string
' this was occurring when invalid voucher code entered e.g. 'RAD-5' containing actual quotes, when PayPal Express Checkout Used
' which allows an invalid voucher code get past the order creation stage
' (SS,25/02/15) Basket saving facility added. New routines SaveBasket, RestoreBasket, SendSavedBasketEmail.
' New tables saved_baskets, saved_basket_items and saved_basket_options.
' (SS,26/02/15) Fix to basket page issue when same product ID added more than once. Caused by yesterday's Email basket update. Overcome by adding new OriginalBasketItemID field in
' saved_basket_items table. OriginalBasketItemID now used as a key instead of ProductID in the session dictionary object.
' Also added title option to Function GetButton for add tooltip.
' (SS,26/02/15) Change to Function CorrectCurrencyWV, to log to TempDebugLog to help diagnose issue with inc VAT prices sometimes showing the same as exc VAT price for CIRC.
' Changes to functions GetDeliveryCountry, GetInvoiceCountry, GetCountryChargeVATFlag to fix the VAT bug, occurred when DeliveryCountry cookie invalid, and
' because " = Null" check not behaving as it should, now using IsNull function. Delivery cookie is also now deleted if invalid.
' (SS,01/03/15) Replaced replaced & with & Functions GetButtonLogOut, GetButtonCreateAccount, GetButtonEditAccount
' (SS,02/03/15) Change to ShowCanonicalLink to include link to product details page if code only, canonical is with name=
' Change to Sub DoGoogleSitemap, Sub AddGoogleSitemapLevel, to add product name to product page URL
' (SS,04/03/15) Fixed issue where delivery price not calculated as on basket page, due to missing call to CustomProductInBasket.
' This was resulting in oversize pallet charge not being added in checkout stage out for CIRC.
' (SS,18/03/15) Added Google Shopping data feed routines e.g. Sub DoGoogleShoppingDataFeed and others
' google-shopping.asp is the page used to generate the feed and the URL supplied to Google.
' Had to adjust GetAttributeInBasketCount, GetFlaggedItemsInBasket.
' (SS,19/03/15) Modified Function GetDeliveryRegionFromPostcode to allow all postcodes, default to DEFAULT_DELIVERY_REGION_UK if not found, also send alert email if an invalid postcode is entered
' Added Function GetDefaultCurrencyCode
' (SS,10/04/15) Added FUseDeliveryPostcodes setting
' (SS,14/05/15) Menu changes, including new multi menu for Bootstrap
' Following new routines added StartMultiMenu, SetMultiMenuType, IsMultiMenuTypeGroup, AddMultiMenu, AddMultiMenuLevel, MultiMenuAdditions, EndMultiMenu
' (SS,18/06/15) Change to Function GetTableHTML work with RWD (Bootstrap) which has it's own special table classes
' (SS,01/07/15) Changed Sub AddMultiMenuLevel to not show menu item if SortOrder field is negative, allows hiding of categories or subcategories.
' (SS,23/07/15) Changes to SagePay to migrate from 2.23 to 3.00. 5 new fields added to sagepaycallbacks table and changes made to SetUpSagePayForm, ProcessSagePayCallback and GetSagePayToken
' (SS,12/08/15) Removed FSearchIsVisible, Function IsSearchVisible and Sub HideSearch
' ... various changes to be documented
' (SS,11/09/15) Change to Sub Initialise to no longer call AddReferrerToDatabase, referrers table now removed, Sub AddReferrerToDatabase routine can be removed
' (SS,16/09/15) Change to Sub AddMultiMenuLevel to only show subcategory if it contains at least one enabled product added via option. Also option to show all levels even if there is only one subcategory.
' (SS,17/09/15) Change Function AdjustForFullTextSearch to allow "or" when prefixed with "||"
' ....
' (SS,12/10/15) Added showing of category description and footer when there are no products in the category, changes made to Sub ShowProducts
' (SS,15/10/15)
' (SS,19/10/15) Bug fix to Function RemoveHTMLTags, causing error in googleshopping (also product page fetch) when first or second character of description was a ">"
' (SS,23/10/15) Change to Function GetEmailBody to not show order details when status is order completed, now text is taken from message to customer field
' (SS,26/10/15) modified Function GetEmailBody to use custom confirmation email text from GetSiteDetail("Other", "ConfirmationEmailTemplate")
' (SS,30/10/15) Improvements to Function GetEmailBody, also changes to inc-template-email-html.asp
' (SS,03/11/15) minor change to Sub ShowProducts to sort navigation issue
' (SS,03/12/15) Change to Sub EmailOrder to VAT deducted Intra-Community supply alert email to check VAT no. One of the URLs: isvat.appspot.com had stopped working replaced with vatlayer.com
' In javascript.js change to functions itp_validate_vat and itp_validate_vat_callback to make it work with vatid.eu
' (SS,10/12/15) Change to Function SendEmailByITPEmailer because itpEmailer can't handle SSL (https://) URLs, fixed by fetching the body of AURL using new GetWebPage routine in dbfunctions.asp
' (SS,16/12/15) Change to Sub ShowCanonicalLink to add missing name= from canonical link also removed URL Encode,
' Also to functions GetProductLink and GetProductLinkWithName, to remove URL Encode to prevent duplicates.
' (SS,07/01/16) Rewrite/cleanup of GetEmailBody which was getting complicated and difficult to maintain
' Split to new routines: GetEmailBodyOrderDetails, GetEmailBodyAddressDetails, GetEmailBodyOrderItems, GetEmailBodyMessage
' Moved Function GetWebPageContents to dbfunctions.asp, replaced by GetWebPage which is also in dbfunctions.asp
' (SS,13/01/16) Change to Function GetTrackingURLForCourier for APC tracking
' (SS,26/01/16) For confirming terms and conditions before payment:
' Change to Sub Checkout, moved call to ShowCheckoutTermsAndConditionsCheckBox here from Sage section in SetUpPaymentButton
' Also added new setting Checkout / ConfirmTermAndConditions to make this optional
' (SS,27/01/16) Change to Sub DoGoogleShoppingDataFeed to call optional custom function CustomGoogleShoppingProductAdjust to make adjustments
' E.g. For CIRC to set the correct price and weight for minimum sections for a radiator, Google had complained that the price in datafeed doesn't match the site
' (SS,28/01/16) Fix to Function GetEmailBodyMessage to prevent MessageToCustomer from being added twice when EmailUseMessageToCustomerForDespatch is True, via LMessageToCustomerAlreadyUsed
' (SS,01/02/16) Change to Sub SetStockInfo to show "Out of stock, please contact for availability" with link on "contact" instead of "Out of stock, more due soon"
' In two places, also added Function GetPleaseContactForAvailabilityInfo which can also be called from CustomUtils (i.e. as does HyperFlight) which has CustomGetStockInfo
' (SS,06/02/16) Change to Sub AddMultiMenu to allow up to 3 levels separated by "|" to be passed to AMenuName parameter
' (SS,17/02/16) New functions to help with Rich Snippets / Microdata GetProductPriceSimple, GetStockAvailabilityMicrodata, RemoveCurrencySymbol, GetBrandAndMPN
' (SS,03/03/16) Change to Function GetEmailBodyMessage to show date on despatch emails
' Changes to Sub DoGoogleAnalytics to use the latest method (analytics.js) also to add optional cross domain tracking (for CDC) via new setting FGoogleAnalyticsCrossDomainTrackingList
' (SS,09/03/16) Change to Function GetBulletHTML to allow embedded tokens, i.e. fetch common bullet points from a token
' (SS,24/03/16) Change to Function GetEmailBodyMessage, text "was despatched for delivery" removed "for delivery"
' (SS,11/04/16) Change to Sub DoGoogleAnalyticsEcommerce to fix ecommerce conversions which had stopped working since 3/3/16 when changing to new Universal Analytics, had forgotten to convert to new format for ecommerce tracking
' (SS,15/04/16) Changes to properly handle stock for options, changes were made to routines:
' AddProductToBasketIncludingOptions, AddToBasket, RecalculateBasket, TryProcessOrder, TakeProductsFromStock
' New routines CheckProductInBasketInStock, ClearExistingOrderPlaced, AlertMessageContains,
' ClearBasketOutOfStockMessage, AddBasketOutOfStockMessage, GetBasketOutOfStockMessage
' (SS,15/04/16) Change to Sub GetEmailBody, to also add the order details to bottom of despatch confirmation email.
' (SS,15/04/16) Change to Sub ShowBasketFooter in inc-template-basket.asp to not show VAT Deducted bit.
' (SS,19/04/16) Further improvements to stock handling, especially at check out stage where it redirects to basket page if basket not completely in stock
' Changes made to routines ShowBasket, CheckOut, ProcessOrder, TryProcessOrder, UpdateOrderStatusForOrderPlaced, CheckProductInBasketInStock
' New function CheckProductInBasketInStock
' Bug fix to prevent same order number being used again in same session, new function ClearOrderNo
' Tracking improvements to Function GetTrackingURLForCourier
' Change to ProcessOrderFinalise to clear Order No
' (SS,20/04/16) More elegant solution to reusing same OrderNo. Changes to TryProcessOrder, GetNextOrderNo, ClearOrderNo.
' New routines SetOrderNo, OrderNoCanBeReused, StopOrderNoReuse (renamed from ClearOrderNo)
' This allows OrderNo to be kept for PayPal payment at later stage to show specific URL which was losing the OrderNo and not showing the correct Thank You message.
' Previous solution from yesterday involving clearing order no after the redirect was not so elegant.
' (SS,20/04/16) Change to Sub ClearExistingOrderPlaced to fix issue where order lines for previous order in same session were deleted because it didn't look at new OrderNoCanBeReused
' (SS,10/05/16) Change to GetEmailBodyMessage, to add the text "Tracking may not start working for a few hours"
' (SS,12/05/16) Change to Sub ProcessRedirections to redirect to category/subcategory page if product detail page and product is disabled
' (SS,13/05/16) Change to Sub AddMultiMenuLevel to allow special dummy group/category to have a link set when prefixed with "URL:"
' (SS,19/05/16) Change to Sub DoGoogleShoppingDataFeed to add gtin and identifier_exists, also not to default mpn to product code
' Schema change to all sites manually via: ALTER TABLE products ADD COLUMN GTIN VARCHAR(50) NOT NULL DEFAULT '' AFTER BrandID;
' (SS,27/07/16) Change to Function GetNextOrderNo, and added new Function CheckOrderInStatus to fix issue where Order No was being reused in CIRC after previous order was paid for using PayPal/EPDQ
' (SS,05/07/16) Added SendOrderProgressEmails feature for CIRC, new routines SendOrderProgressEmails, IsTodayWorkingDay, OrderProgressEmailResultHeader, OrderProgressEmailResultFooter, OrderProgressEmailResultRow
' New stored functions GetFirstInteger, GetNthWorkingDay, IsWorkingDay added to common database, and table calender for working day calculations, execute access granted to common database to access these functions
' common.calendar table has working days up to and including 2110.
' It's called via order-progress-emails.asp (and task scheduled to run each weekday)
' (SS,06/07/16) Change to Sub SendOrderProgressEmails to show WorkingDaysToDespatch
' (SS,11/08/16) Added VAT number checking via official website, new routines:
' CheckVATNumber, CheckVATNumberViaWebsite, GetVATCheckResultFromXML, EmailOrderVATAlertAddFields
' Changes to NoteVATValidation and moved to VAT section. Change to Function CheckValidPersonalDetails to call CheckVATNumber to do an extra check.
' Changes to javascript.js to no longer do a VAT check in browser.
' Renamed IsVATNumberValid to IsVATNumberFormatValid
' Also separated alert email code from EmailOrder to Sub SendVATNumberAlertEmail
' (SS,11/08/16) Change to IsCountryVATable, delivery country now used to decide whether VAT is charged
' (SS,21/09/16) Changes to Sub ClearExistingOrderPlaced, Function GetNextOrderNo, Function OrderNoCanBeReused
' To prevent order detail records from being deleted if same customer tries to place another order in same session, previous order's detail records were being wrongly deleted.
' (SS,28/09/16) Changes to Sub DoGoogleShoppingDataFeed, added extra product attributes for google shopping, also added new field to attributes table
' i.e GoogleShopping TINYINT(1) DEFAULT '0' COMMENT 'Added 28/9/2016 to specify if it\'s for Google Shopping'
' To add extra attributes add to attributes table and set the GoogleShopping field to True. They will automatically get added to the data feed
' (SS,24/10/16) Various changes to implement local mode, address lookup
' (SS,02/11/16) Change to Function ProcessOrder to return False when there's a failure, e.g. delivery couldn't be calculated
' It was always returning True and therefore allowing orders with delivery cost of -1 to be placed
' (SS,04/11/16) Minor change to function IsDeliveryCostOverride and sub ClearLocalModeDetails to use IsEmpty and Empty. IsDeliveryCostOverride was returning True when Session("DeliveryCostOverride") was setting i.e. Empty converts to 0
' (SS,11/11/16) Change to Sub AddMultiMenuLevel and others to allow first menuitem to be a group (Clifton)
' (SS,24/11/16) Change to Function GetProductSearchSQL to add filter for min and max price
' (SS,25/11/16) Change to Sub GetEmailBody to show "Order Confirmation & Invoice" in header of email
' (SS,01/12/16) Change to add setting of order priority, new routines SetPriorityDefault, SetPriority, GetPriority, GetDeliveryWillCollect and changes to TryProcessOrder
' (SS,23/01/17) Change to Sub EmailOrder, email subject, now store name, followed by Order Confirmation (& VAT Invoice) / Despatched / Cancelled then order no (no hyphen)
' (SS,27/01/17) Change to Sub NoteVATValidation fixed bug which caused when saving account details because PaymentLog field doesn't exist in customers table, now Notes used if table is customers
' (SS,08/03/17) Change to Sub SendOrderProgressEmails, adjusted gap from 4 to 2 days
' (SS,10/03/17) Change to Sub SetUpPaymentButton (for Clifton), WorldPay logo extension changed from .gif to .png
' (SS,04/04/17) Improvements to local mode/exchange feature for CIRC
' (SS,05/04/17) Change to GetPricingFromProductRecord to add CustomGetNormalOptionsPrice
' (SS,05/04/17) Minor change to Function GetBankTransferPaymentLine. Fix to GetCurrencyFormattedValue to default to pound symbol if currencies table not set up. Also fix to GetLocalModeDetailsFromForm.
' (SS,06/04/17) Change to Sub ClearLocalModeDetails to clear all session variables except LocalMode. Change to GetBankTransferPaymentLine to remove default extra text.
' Renamed ClearLocalModeDetails to ClearLocalModeSettings.
' (SS,13/04/17) Added Sub SendRefundEmail and refund-details.asp
' (SS,27/04/17) Special token handling, change to ReplaceTokens, added new functions IsSpecialToken, HandleSpecialToken, HandleSpecialTokenNumber, FF
' Also added Sub FetchRecordToSession, Function FetchFieldFromSession to dbfunctions.pas to fetch record and fields for above
' (SS,28/04/17) Improvements to special token handling, added new function GetRecordHTML, changes to ComposeDescription and GetTableSetting
' (SS,18/05/17) Added feature to send Trustpilot review requests via AFS when sending order despatched (completed) comfirmation emails
' New routines Sub SendTrustpilotAFSEmail and function GetTrustpilotAFSEmailAddress, change to ShowEmailConfirmationHTML.
' (SS,18/05/17) Change to Sub SendSavedBasketEmail to add DeliveryInfo for CIRC. Also added GetDeliveryInfoForSavedBasket.
' (SS,19/05/17) Changes to Sub SendSavedBasketEmail and SaveBasket to also send name and address as part of email (required for CIRC proforma quotes)
' ---- to be filled in for recent changes
' (SS,13/06/17) Added Function GetSubcategoryLinkForRedirect and made change to ProcessRedirections to call GetSubcategoryLinkForRedirect instead of GetSubcategoryLink, to fix subcategory redirect issue
' (SS,30/06/17) Change to Function GetProductSearchSQL, full text search to order by relevance if no sort field set
' (SS,25/07/17) Various changes for HyperFlight, including changes to and adding of some new routines:
' Sub ShowProducts, Function GetProductSearchSQL, Sub ShowNewProducts, Sub ShowCheckoutFormFooter, Sub SetUpPaymentButton,
' Function GetPaymentBankTranferOptionSubmitLink, Function GetShowReviewsLink, Sub ShowReviews, Function GetProductOptionComboBox
' Function GetGrandTotalForOrder, Sub UpdateOrderDefaultPaymentCurrency, Sub UpdateBankTransferDetails
' (SS,28/07/17) Change to Function GetProductOptionComboBox to move option image rendering to Function GetProductDetailOptionImageHTML in inc-template-product-detail.asp
' (SS,31/07/17) Change to Sub DoGoogleAnalyticsEcommerce added order no existence check to prevent error when no session
' Added date/time (now) to Sub AddToPaymentLog to help with PayPal debugging
' Change to Sub CheckOut, to ensure PaymentLog is saved when returning from payment provider
' (SS,01/08/17) Added new Sub SetCurrencyForOrder, and changes to GetEmailBodyOrderDetails, ShowOrderDetailsMaster, ShowPreviousOrders to call it,
' previously the code existing GetEmailBodyOrderDetails. Now needed by ShowOrderDetailsMaster and ShowPreviousOrders to show correct historical currency values for order orders
' (SS,03/08/17) Change to Function GetLocalModeExchangeReasons, GetLocalModePaymentMethods to return a default value when blank
' (SS,04/08/17) Added new bank transfer methods ptBankTransferEUR = "BANK TRANSFER - EUR" and ptBankTransferUSD = "BANK TRANSFER - USD"
' (SS,08/08/17) Change to Sub ProductOptionsToArrayfixed, fix bug where comma entered into a text input type was result in extra option values to be incorrectly added (call to new GetInputTypeForProductOptionID)
' (SS,08/08/17) Change to Sub GetEmailBodyOrderDetails, call to ShowEmailOrderHeader to also pass on GBP Grand Total. Change also made to inc-template-email-html.asp to include the new parameter.
' (SS,09/08/17) Change to improve showing of bank transfer details and allow simpler (non HTML table entry) in settings.
' Changes to GetBankTransferDetails and GetBankTransferDetailsAsHTML. Added new GetBankTransferDetailsForCurrency and GetTextAsHTMLTable. Also test page via local mode: bank-details.asp.
' (SS,10/08/17) Change to Function GetWebText to include BANK_TRANSFER_DETAILS tokens and added new function BankTransferDetailsToHTML
' (SS,11/08/17) Added Sub SendPaymentReceivedEmail and new template payment-received-email.asp to allow payment received emails to be sent via Shopping Admin
' (SS,23/08/17) Changes to fix VAT No Check not being corrected saved and sent in alert email. Removed SavePaymentLog, changes to AddToPaymentLog, AppUtilsAddToPaymentLog, added GetPaymentLogSeparator and GetPaymentLogSection
' (SS,24/08/17) Changes to prevent XSS injection, notified to use via https://www.openbugbounty.org/reports/281769/
' Improvement to SendVATNumberAlertEmail to send a better formatted email and not with Alert prefix if VAT No valid. Also added SendNotificationEmail.
' Change to Sub UpdateOrderStatusForOrderPlaced to not SendAlertEmail "Cancelled order paid for. Stock automatically decreased.", LBody, False, requested by Neil
' (SS,25/08/17) Added new Function GetActiveProductCode to also return product code set via SetProductCode, rather from query string or SetProductCode, fixes nofity me link issue for wrong product in related products (for HF)
' (SS,12/09/17) Change to Function GetBankTransferPaymentLine to only show one option for GBP (e.g. not GBP or CHF) if currency other than GBP, EUR or USD. Due to HSBC charging high rates if non GBP paid into their account.
' (SS,14/09/17) Changes to Sub ShowRecentReviewsMain and Sub DoReviewsPage, to prevent duplicate reviews from appearing and harming SEO. Customers sometimes post the same review text across several products they purchased.
' (SS,15/09/17) Added Sub ShowProductReviewsInDesc for short reviews in product description
' (SS,20/09/17) Added Sub ProcessTransferWiseCallback to process TransferWise bank transfer payments from email
' (SS,22/09/17) Change to Google Shopping Data feed (subs DoGoogleShoppingDataFeed and AddGoogleShoppingField) to add "condition" attribute. Previously this was defaulting to "new". Now if a product attribute with name "condition" is set then this overrides this default.
' Also added functions GetProductPriceForMicrodata, GetProductConditionForMicrodata.
' (SS,25/09/17) Change to Sub AddGoogleShoppingField to convert "damaged" for Condition to "used". Microdata can be damaged but Google Shopping must map to "used"
' (SS,26/09/17) Change to Sub SendOrderProgressEmails, amended gap from 2 to LTemplateGapsDays, i.e. now getting from email templates
' Change to Function GetStockAvailabilityMicrodata and added new Function GetProductAvailabilityForMicrodata
' (SS,27/09/17) Change to Sub SendOrderProgressEmails to prevent 0-3 i.e. ensure minimum is 1, i.e. 1-3
' (SS,29/09/17) Change to allow extra GBP (TransferWise) account for Bank Transfer
' Changes made to Sub ProcessTransferWiseCallback and GetBankTransferDetailsForCurrency, added ptBankTransferGBP, FBankTransferDetailsGBP
' For HF Modified CustomShowBankTransferModal in custutils.asp
' (SS,04/10/17) Changes to CreateAccount, CheckOut, GetPersonalDetailsFromForm to improvements messages shown when customer can't log in. Improvement to bypass to work when password entered in lower section.
' New function GetCheckoutAccountBypassTextAndLink added.
' Changes to GetDeliveryCost, added new CustomerHasExistingOrder to only give free delivery for add to existing order if existing non-despatched order exists
' (SS,10/10/17) Added Facebook Pixel code to track Facebook adverts.
' DoFacebookConversionTracking is now redundant, renamed to DoFacebookConversionTrackingOld
' Facebook ConversionTrackID setting renamed to PixelID
' new functions added, ActivateFacebookPixelPurchaseConversion, GetConversionValue, DoFacebookPixel
' (SS,03/11/17) Change to Sub DoFacebookPixel, removed the noscript tag, causing missing alt tag error in W3C Validator
' (SS,06/02/18) Improvements to Sub SendOrderProgressEmails to make use of order_progress_email_days table. Also improved fields shown in results email.
' (SS,02/03/18) to 06/03/18 (Version 5.00) (was 4.94)
' Changes to migrate from old version of Google Analytics and AdWords conversion to new Global Site Tag i.e. analytic.js to gtag.js
' Simplified and cleaned existing tracking code. Also corrected any discrepancies e.g. Discount not being taking into account.
' All of this script is now in the HTML head tag as recommended by Google.
' New routines HTMLHeadStart, HTMLHeadEnd, IncrementPageViewCount, GetPageViewCount
' TrackPurchaseConversion, TrackPurchaseConversionDone, TrackPurchaseConversionAddToLog, GoogleAnalyticsEcommerceAddItem
' DoWebAnalytics, FinaliseWebAnalytics, TrackPurchaseConversionUpdateLog
' Complete rewrite of Sub DoGoogleAnalytics
' DoGoogleAnalytics no longer called from inc-template-main.asp. Replaced by HTMLHeadStart and HTMLHeadEnd.
' DoFacebookPixel now called from HTMLHeadEnd instead of Finalise.
' Conversion now only done when returning from payment provider.
' Following references removed: FEcommerceTrackingActivated, FAdWordsPurchaseConversionActivated, FFacebookPurchaseConversionActivated, FGoogleAnalyticsDone
' Following routines removed Sub DoGoogleAdWordsRemarketingTag, Sub SetRemarketingTagTotalValue, Sub ClearRemarketingTagProductIDs, Sub AddRemarketingTagProductID, Function GetRemarketingTagProductIDs,
' Sub ActivateGoogleAnalyticsEcommerceTracking, Sub ActivateGoogleAdWordsPurchaseConversion, Sub ActivateFacebookPixelPurchaseConversion
' !! NB. Need to amend inc-template-main.asp, replacing DisableCache with HTMLHeadStart and add HTMLHeadEnd to end of head tag.
' Also need to enable Enhanced Ecommerce features in Google Analytics.
' !! Don't forget to add the new conversion_tracking_log table.
' (SS,07/03/18) Added to Sub SetUpEPDQForm(AOrderNo), hidden ACCEPTURL to redirect back to site automatically, but wasn't working
' Google AdWords tracking not working. I realised it could be due to missing "AW-" prefix from gtag config and send to. Added the prefix in DoGoogleAnalytics.
' Still was tracking conversions. Later found settings in the AdWords account showing event 'conversion' not 'purchase', so renamed purchase to conversion.
' (SS,12/03/18) Improvements to order confirmation emails. Sorted issue which was resulting in emails appearing with empty attachment in Outlook 2016, even worse in some other email clients.
' Changes made in inc-template-email-html.asp and order-details.asp. Also need to amend inc-main.asp to include inc-template-email-html.asp
' Also to Sub EmailOrder, Sub ShowEmailConfirmationHTML, Function GetEmailBody, Function GetEmailBodyOrderDetails, Function GetEmailBodyAddressDetails, Sub GetEmailBodyOrderItems
' Some subs are now functions which a return a string. We're no longer fetching a webpage to get the content and no longer sending via the ITPEmailer.
' This method should be more reliable and hopefully avoid the empty attachments in some email clients.
' ===============
' MIGRATION NOTES (from 02/03/18 to 13/03/18)
' ===============
' 1. Template inc-template-main.asp, remove DoGoogleAnalytics and DisableCache. Add HTMLHeadStart and HTMLHeadEnd.
' 2. Add new versions of apputils.asp, inc-template-email-html.asp, order-details.asp. Modify inc-main.asp to include inc-template-email-html.asp.
' 3. Add new table conversion_tracking_log
' 4. Make sure Enchanced Ecommerce enabled in Google Analytics.
' (SS,22/03/18) Added SMS feature, new SMS routines: Sub SendSMS, Function SMSEnabled, Function TelephoneIsMobile
' Templates held in "SMS Templates" in sitedetails table. New setting SMS / Enabled.
' ===============
' MIGRATION NOTES
' ===============
' Need to include the latest order-details.asp file because customutils.asp is now included in it. This was due to call to possible function CustomCheckSMS.
' (SS,23/03/18) Added new payment method/type/provide called Payzone. New table called payzonecallbacks was added.
' (SS,06/04/18) Improvements to Payzone.
' (SS,09/04/18) Added GetPayPalUKOnlyCheckout to Sub SetUpPaymentButton, to only show PayPal at normal checkout for UK (if enabled)
' Normal PayPal Express Checkout is shown for all regions.
' New setting Payment / PayPalUKOnlyCheckout, which defaults to False
' (SS,12/04/18) Changes to Sub SetUpPayzonePayForm, and AddPayzoneField, added Function IsPayzoneSafeString.
' To get around character issues with Payzone, i.e. non-ascii and special chars.
' (SS,16/04/18) Removed the direct (2 second) delay pay to payment provide
' Replaced SetUpChequeOrBankTransferPayForm with SetUpChequePayForm and SetUpBankTransferPayForm
' Changes made to javascript.js
' (SS,17/04/18) Removed Const PAYMENT_CONFIRMED and references to it, not used (i.e. there appears to be a Const PAYMENT_CONFIRMED which doesn the same thing)
' Removed payment redirect code: Sub ShowPaymentDirectionInfo, Sub DoPaymentRedirection, Sub DoPaymentRedirection, Sub ActivatePaymentRedirection
' References to Dim FPaymentRedirectionActivated, const REDIRECT_TO_PAYMENT_SITE deleted.
' Removed Sub SetUpPayment (only used for redirection)
' Removed references to DirectPay i.e. taking payments directly from customer. Was used for ExpressMusic but not anymore.
' Removed code for redundant payment methods GoogleCheckout and Direct Pay
' Including functions GetDirectPaySecureSite, GetDirectPayAllowedCardTypes
' Removed Functions IsCreditCardType, CheckValidCreditCardType, CheckValidCreditCardDetails, ValidateCardNumber, AreNumericDigits, ValidCardLengthPrefix, ValidCardCheckDigit
' Removed Subs GetCreditCardTypeFromForm, GetCreditCardDetailsFromForm, SetUpDirectPayForm
' Removed credit card constants Const CC_MASTERCARD, CC_VISA, CC_VISA_DELTA, CC_VISA_ELECTRON, CC_VISA_PURCHASING, CC_JCB, CC_MAESTRO, CC_SOLO, CC_AMERICAN_EXPRESS.
' Removed Dims FDirectPaySecureSite, FDirectPayAllowedCardTypes, FGoogleCheckoutMerchantID, FGoogleCheckoutSiteSeal
' Removed Const ptDirect = "DIRECT" and ptGoogleCheckout = "GOOGLE CHECKOUT"
' Also removed functions IsDirectPayment, IsPayPalPayment, IsWorldPayPayment, IsEPDQPayment, IsSagePayPayment
' Removed routines SetUpGoogleCheckoutPayForm, GetGoogleCheckoutMerchantID, GetDescriptionForGoogleCheckout, GetTotalAndVATRateForGoogleCheckout, GetGoogleCheckoutSiteSeal
' Modified GetCriteriaForCountryCombo to work using only the Enabled field.
' (SS,18/04/18) Added Sub SendWebLogEmail which calls new GetWebLog function in dbfunctions.asp.
' Removed consts for credit card payments:
' Const GET_CREDIT_CARD_TYPE = "GetCreditCardType"
' Const GET_CREDIT_CARD_DETAILS = "GetCreditCardDetails"
' Also removed credit card (If) code from Sub CheckOut
' Following removed from inc-template-check.asp:
' Sub ShowCreditCardTypeForm, Sub ShowCreditCardDetailsForm, Sub ShowCardType, Sub ShowCustomerInfoDirectCardTypes, Sub ShowCheckoutPayNowWithCreditCardButton
' !!! Need to remove credit card fields from orders table
' Change to Sub CheckOut to no longer show account already exists warning and dialog if existing email address used, just continues
' Change to Function TryProcessOrder, to preserve payment log which was being lost when this routine called again for same order
' (SS,19/04/18) Changes to fix PayPal Express when used via PayPal checkout on basket page. Change to inc-template-checkout.asp to add new ShowCheckoutMakePayPalPaymentButton
' (SS,20/04/18) Changes to Sub SetUpPaymentButtons, Sub SetUpPaymentButton. Added Function IsHyperFlight to allow Bank Transfer button to be shown higher for HF.
' Added SetCreditCardPaymentProviderFailure and IsCreditCardPaymentProviderFailure, to override PayPal not being shown by default
' (SS,23/04/18) Added FPayPalExpressShowOnBasketPage, Function GetPayPalExpressShowOnBasketPage to allow PayPal Express checkout button to be optionally show in basket page. Default is True.
' Also made a change to Sub ShowBasketFooter in inc-template-basket.asp to make use of this.
' (SS,25/04/18) Change to Function GetEncryptedEPDQData to use Function GetWebPageViaPOST instead of ASP object SOFTWING.ASPtear
' (SS,30/04/18) Various changes to EPDQ to work using the new method, returning from browser, new table epdq_redirect_callbacks
' ===============
' MIGRATION NOTES
' ===============
' For EPDQ new table epdq_redirect_callbacks, and new Payment / ePDQTestMode setting
'
' (SS,01/05/18) Change to Function EPDQSuccessfulPayment to also allow Status 9. Change also to ProcessEPDQRedirectCallback to call EPDQSuccessfulPayment.
' (SS,22/05/18) Changes in inc-template-checkout.asp and inc-template-account.asp remove HearAboutUs and Subscribe me fields from first stage of checkout.
' Subscribe moved to Thank you page. Terms and condition default can be ticked.
' (SS,23/05/18) Added subscription routines GetCustomerIDForOrder, IsCustomerOptedIn, SetCustomerSubscribed, GetSubscribeLink
' Changes also made to inc-template-checkout.asp and inc-template-account.asp
' (SS,08/06/18) Added ability to add a surcharge for PayPal (non-UK)
' Changes made to PayPalExpressConfirmPayment, UpdateOrderStatusForOrderPlaced
' New setting FPayPalNonUKSurchargePercentage
' New routines GetPayPalSurchargePercentage, IsPayPalSurcharge, PayPalAmountWithSurcharge
' New field added to orders:
' ALTER TABLE orders ADD PaymentAmountReceived DOUBLE NOT NULL DEFAULT '0' COMMENT 'Added 8/3/2018 for HF, Schema 3' AFTER PaymentReceived;
' (SS,25/06/18) Two more feeds added to hold surcharge about and fee separately.
' ALTER TABLE orders
' ADD PaymentProviderSurcharge DOUBLE NOT NULL DEFAULT '0' COMMENT 'Added 11/6/2018 for HF, Schema 3' AFTER PaymentAmountReceived,
' ADD PaymentProviderFee DOUBLE NOT NULL DEFAULT '0' COMMENT 'Added 11/6/2018 for HF, Schema 3' AFTER PaymentProviderSurcharge;
' (SS,25/06/18) Changes to UpdateOrderStatusForOrderPlaced and ProcessOrderThirdPartyPayment to add new PaymentProviderSurcharge and PaymentProviderFee parameters
' (SS,26/06/18) Renamed orders field PaymentAmountReceived to PaymentReceivedAmount, added new field PaymentReceivedCurrencyCode
' Changes made to ProcessOrderThirdPartyPayment, UpdateOrderStatusForOrderPlaced, PayPalExpressConfirmPayment
' Also added new PaymentReceivedCurrencyCode field (PaymentReceivedCurrencyCode CHAR(3) DEFAULT NULL)
' (SS,28/06/18) Correction to Sub ProcessWorldPayCallback
' Added code for DeliveryOption, currently Tracked Delivery, implemented for HyperFlight
' New routines: TrackedDeliveryOptionEnabled, SetTrackedDeliverySelected, GetTrackedDeliverySelected,
' SetTrackedDeliverySelectionAllowed, GetTrackedDeliverySelectionAllowed, SetDeliveryOption, GetDeliveryOption, GetCountryOptions
' Change to Function TryProcessOrder to save DeliveryInfo field
' New Options field added to Countries table via:
' ALTER TABLE countries ADD Options VARCHAR(100) DEFAULT NULL COMMENT 'Added 28/6/2018 for HF, Schema 4' AFTER VATNumberFormat;
' Added TrackedDelivery checkbox to basket page in inc-template-basket.asp
' Change made to Sub SetCountryFromBasketForm. Also to CustomGetDelivery in customutils.asp
' (SS,29/06/18) Minor change to Sub SetCountryFromBasketForm
' (SS,03/07/18) Change to Function GetTrackingURLForCourier to add tracking for new delivery agent names "Tracked Airmail" and "Untracked Royal Mail"
' (SS,19/07/18) Added HTMLEncode in inc-template-subcategory-list.asp to ShowSubcategoryListHeader, ShowSubcategoryListItem and ShowSubcategoryListItemWithPicture
' to prevent XSS (notified to use by OpenBounty checker (see email on this date for further info)
' Also to FPageName in inc-pages.asp.
' (SS,01/08/18) Added additional options info for CIRC radiators via custom call to CustomAddMoreOptionsInfo in customutils.asp
' Via new function AddMoreOptionsInfo, called from Sub ShowBasket, Function GetEmailBodyOrderItems, Sub SendSavedBasketEmail
' Additional info, e.g. Length, BTU, kW, only shown in basket, email and email basket. It's not actually held in the database.
' (SS,02/08/18) Refinement to AddMoreOptionsInfo, to keep the adding code in CustomAddMoreOptionsInfo rather than in AddMoreOptionsInfo
' (SS,10/08/18) Changes to the images references, getpic.asp replaced with jpg file name if new setting UseGetPicASP is False.
' See "Image / Picture Naming Routines" section at the end fo more details.
' Changes made to image URL fetching routines.
' (SS,11/08/18) Change to GetProductImageNameForPictureID to not add caption if SortOrder is 10, i.e. main image.
' (SS,16/08/18) Change to Sub Initialise, call to SetPriorityDefault change from integer 5 to string "5" to fixed issue where it was defaulting to 9 instead of 5.
' (SS,28/09/18) Change to Sub ShowCheckoutFormFooter, removed banktransferoption, not required here, it's passed on via frmBankTransferPay (SetUpBankTransferPayForm)
' Also had to make a fix in javascript.js function itp_payment_banktransfer to refer to frmBankTransferPay (not frmCheckout which was a bug)
' It was result in the wrong bank details being shown and emailed to customer.
' (SS,15/10/18) Change to Sub SendContactEmail and Sub AddContactToDatabaseAndEmail to send email as HTML instead of plain text.
' To help Paul (CIRC), he wants to add signature with less hassle.
' (SS,18/10/18) New setting FProductSubproductsEnabled.
' Change to AddProductToBasketIncludingOptions to call custom function CustomAddSubproductsToBasket
' New functions GetFieldForProductID, GetBasketOptionValueForItemID
' (SS,19/10/18) Change to Function to not fail with delivery error if in local mode.
' (SS,26/10/18) Added Function GetShoppingBasketFilter and change to Function GetOrderItemsQuery to call GetShoppingBasketFilter to ignore subproducts where applicable.
' New parameter AIncludeSubproducts added to Function GetOrderItemsQuery and to all calls to his with either False or True.
' Also change to Sub ShowShoppingStatusMain, added GetShoppingBasketFilter to query to exclude subproducts.
' (SS,29/10/18) Change to Function TryProcessOrder to set new SubproductOrderDetailID field for subproducts
' (SS,30/10/18) New function GetOrderOptionValueForOrderDetailID
' Modified Sub SaveBasket and Sub RestoreBasket to handle subproducts, i.e. not saved in basket, but created when basket restored
' (SS,31/10/18) Added Function GetOrderDetailsFilter, similar to GetShoppingBasketFilter, but works to filter order detail records
' Changes to make use of GetOrderDetailsFilter where applicable i.e. most places where "FROM orderdetails" is used
' Added Function GetProductsFilter, to filter out subproducts from products table. Changes to call this in various places where "FROM products" / "INNER JOIN products" is used.
' (SS,07/11/18) Change to Function GetProductCodeQS to force upper case. Replaced all occurrences of Request.QueryString("code") with GetProductCodeQS
' Following schema changes applied (schema 4):
' CREATE TABLE product_subproducts (
' ProductSubproductID INTEGER(11) NOT NULL AUTO_INCREMENT,
' ProductID INTEGER(11) NOT NULL,
' SubproductID INTEGER(11) NOT NULL,
' PRIMARY KEY (ProductSubproductID),
' UNIQUE KEY idxProductIDSubproductID (ProductID, SubproductID),
' KEY idxProductID (ProductID),
' KEY idxSubproductID (SubproductID)
' )ENGINE=MyISAM
' AUTO_INCREMENT=1 ROW_FORMAT=FIXED CHARACTER SET 'latin1' COLLATE 'latin1_swedish_ci';
'
' ALTER TABLE products
' ADD HasSubproducts TINYINT(1) NOT NULL DEFAULT '0' COMMENT 'Added 27/9/18, for CIRC, Schema 4' AFTER CustomFlag,
' ADD IsSubproduct TINYINT(1) NOT NULL DEFAULT '0' COMMENT 'Added 27/9/18, for CIRC, Schema 4' AFTER HasSubproducts;'
'
' ALTER TABLE shoppingbaskets
' ADD SubproductItemID INTEGER(11) DEFAULT NULL COMMENT 'Added 18/10/18, for CIRC, Schema 4' AFTER Qty,
' ADD KEY idxSubproductItemID (SubproductItemID);
' ALTER TABLE orderdetails
' ADD SubproductOrderDetailID INTEGER(11) DEFAULT NULL COMMENT 'Added 29/10/18, for CIRC, Schema 4' AFTER PrevStock,
' ADD KEY idxSubproductOrderDetailID (SubproductOrderDetailID);
' (SS,16/11/18) An order for HyperFlight had HTML stuffed into the form fields. Possibly a virus adding HTML and javsacript to each form field
' This could result in a malicious site being access when order confirmation details are rendered in a browser.
' Although no harm was done with this example (Order 52961)
' To get around this I added new function CleanRequestForm to dbfunctions.asp which strips HTML tags and converts <> to HTML entities
' Replaced all Request.Form calls with calls to CleanRequestForm about 181 or so (including comments).
' (SS,19/11/18) Replaced nearly all occurrences of Request.QueryString with CleanRequestQueryString.
' Only one I didn't do was the one in Sub ProcessSagePayCallback for LCrypt = Request.QueryString("Crypt")
' (SS,20/11/18) Replaced all occurrences of Request with CleanRequest (CleanRequest first checks QueryString and then Form)
' (SS,21/11/18) Change to WAIT_TIMEOUT from 5 to 10 in Function CheckVATNumberViaWebsite to sort VAT Number check timeout issue.
' (SS,05/12/18) Removed Sub UpdateOrderCardDetails, redundant due to fields being removed.
' Following credit card fields removed from orders:
' CardType, CardNumber, CardHoldersName, CardSecurityCode, CardIssueNumber, CardValidFrom, CardExpiryDate
' Following two new fields added: RefundMethod, RefundAccountLast4Digits
' RefundMethod set to same as PaymentMethod using:
' UPDATE orders SET RefundMethod = PaymentMethod WHERE RefundAmount > 0;
' Schema version set to 5.
' SQL:
' ALTER TABLE orders
' DROP CardType,
' DROP CardNumber,
' DROP CardHoldersName,
' DROP CardSecurityCode,
' DROP CardIssueNumber,
' DROP CardValidFrom,
' DROP CardExpiryDate,
' ADD RefundMethod VARCHAR(20) DEFAULT NULL COMMENT 'Added 4/11/18, for CIRC, Schema 5' AFTER RefundAmount,
' ADD RefundAccountLast4Digits CHAR(4) DEFAULT NULL COMMENT 'Added 4/11/18, for CIRC, Schema 5' AFTER RefundMethod;
'
' Changes to Sub SendRefundEmail to include new RefundAmount and RefundAccountLast4Digits fields.
' Template RefundEmailTemplate needs to be modified to include these two fields
'
' (SS,07/12/18) Change to function HandleSpecialToken to trap error in Eval and return "?ERROR?"
' (SS,13/12/18) Added cancel order facility for orders awaiting payment paid for by cheque or bank transfer
' New functions CancelOrderAllowed, GetCancelOrderURL, sub CancelOrder
' Changes to functions GetEmailBody and GetEmailBodyMessage and Sub ProductsMain.
' Change to Function GetProductsPageTitleV2 to add cancelorder.
' (SS,13/12/18) Added new token feature to allow ProductName to be set.
' Change to Function ComposeDescription and added new Function GetActionHTML
' (SS,14/12/18) Further improvements to token table feature to add APH and RBR
' APH adds product hrefs and RBR allows blank rows to be removed
' Changes to functions ComposeDescription, IsSpecialToken, HandleSpecialToken, added new function RemoveBlankTableRows
' Change to Function GetActionHTML to limit field size to 100 to prevent data too long error
' (SS,19/12/18) Modified Function GetDiscountUsingVoucherCode to handle new MinimumQty field
' Added email address to Payzone (for email receipt to customer) changes to Sub SetUpPayzoneForm and Sub ProcessPayzoneCallback
' (SS,22/01/19) Rounded review stars to 1 dp (instead of nearest half). Google showing stars for products and rounding to 1 dp. For HF product KST-DS215MG
' was showing 4.5 instead of 4.7. Change made to Function GetReviewRatingAndCount.
' (SS,27/02/19) Change to Sub SendOrderProgressEmails to use DateTimePaid instead of DateTimeOrdered due to bank transfer payment delays
' (SS,18/03/19) Change to Sub SaveStockNotification to left name to 50 and email to 100 prevent "Data too long for column 'Name'"
' (SS,05/04/19) Changes to jpg image cache to also work for category, subcategory, option and other images. Previously it work only for product images.
' New functions GetImagesFolder, GetCategoryImagesFolder, GetSubcategoryImagesFolder, GetOptionImagesFolder, GetOtherImagesFolder, GetCategoryImageLink,
' GetSubcategoryImageLink, GetImageNameForCategory, GetImageNameForSubcategory, GetImageNameForProductOptionValueID, GetImageNameForOther
' Changes to Function GetProductImageLink, GetProductOptionValueImageLink, GetStoreLogoLink
' Changes also made to create-image-cache.asp
' (SS,06/04/19) Changes to image cache folder names, images to img, and products to p (later removed p), category to c etc.
' (SS,07/04/19) Further improvements, to automatically create image file in cache if it doesn't already exist
' New functions GetImageName, EnsureImageExists, FileExistsWithSameDateTime, new subs EnsureFolderExistsForFileName, SetFileLastModifiedDate
' Removed functions GetProductImageNameForProductCode, GetImagesFolder, GetCategoryImagesFolder, GetSubcategoryImagesFolder, GetOptionImagesFolder, GetOtherImagesFolder
' Removed functions GetImageNameForCategory, GetImageNameForSubcategory, GetImageNameForProductOptionValueID, GetImageNameForOther
' New routines SetImageCreatedInCache, SetImageCreatedInCache.
' (SS,09/04/19) Added Function GetImageCacheFolder, separated sub ShowTimer into Function GetTimer.
' (SS,09/04/19) Change to Sub DoFacebookPixel to add event tracking for product page view and add to basket. Added function IsAddToBasketPage.
' (SS,10/04/19) Change to Sub DoFacebookPixel to content_type and content_ids to ViewContent and AddToCart. Added function GetBasketProductCode.
' (SS,10/04/19) Renamed DoGoogleAnalyticsEcommerce to DoTrackPurchaseEvent to also work for Facebook.
' Added ATrackType parameter which can be ttGoogle for Google or ttFacebook for Facebook.
' Added new constants ttGoogle, ttFacebook
' Renamed GoogleAnalyticsEcommerceAddItem to TrackPurchaseEventAddItem, added ATrackType to also work for Facebook
' The above was for improved dynamic ads remarketing in Facebook.
' (SS,11/04/19) Change to DoTrackPurchaseEvent to add JavaScriptStrEscape to GetStoreName
' Replaced 2 x SingleQuotedJavascriptString with JavaScriptStrEscape in Sub TrackPurchaseEventAddItem because product name may contain a double quote
' From DoFacebookPixel sub Removed the additional (not necessary I think) <noscript><img> tracking because it was interfering with the Facebook Pixel Helper add-on
' (SS,12/04/19) Change sub DoFacebookPixel to added events Search, InitiateCheckout, InitiateCheckout, AddPaymentInfo
' New functions IsStartOfCheckout, IsCheckoutFilled, IsNewSearch
' Modified function GetTotalItemsInBasket to add GetShoppingBasketFilter(False) to ignore subproducts (missed from before)
' (SS,16/04/19) Change to Sub ShowEmailConfirmationHTML to call Function AuthenticateOrderNo (code from ShowEmailConfirmationHTML move to AuthenticateOrderNo
' Also used by new Sub SendCancelledOrderEmail.
' (SS,18/04/19) Change to Sub Initialise to set Application("WebsiteURL") which is required by global.asa when session is closed for order placed
' Also new setting FCancelledOrderEmailsEnabled. New Sub SendCancelledOrderEmail called from send-cancelled-order-email.asp.
' (SS,25/04/19) Added Function GetOrderFieldValues to return up to 5 values from orders record.
' (SS,01/05/19) Change to Function GetActionHTML to log the product rename to new log_product_renames table for debugging
' Bugfix, change to Sub DoGoogleShoppingDataFeed, to product name renaming for HF, setting the product code global before call to ComposeDescription fixed it
' (SS,03/05/19) Improvement to Add to Existing Order feature. Customer were ticking this unnecessarily. Improved to remove in same
' checkout stage showing alert message if customer doesn't have an existing order that hasn't been completed.
' New subs SetDeliveryAddToExistingOrder, AddToExistingOrderAddMessage, AddToExistingOrderRemoveMessage
' Changes to Sub CheckOut.
' (SS,03/06/19) Change to Sub SendCancelledOrderEmailModified to not send email if another subsequent order exists for same email address
' (SS,28/06/19) Change to Function GetEmailBodyMessage to add additional message to completed order email (VDK)
' (SS,29/08/19) Change to Function GetSEOFriendlyImageName so that size of "" returns the name for small thumbnail, fixes issue with basket page showing "o" original image
' ### Perhaps in future modify inc-template-basket.asp so that it specifically fetches "s" instead of "".
' (SS,26/09/19) Bugfix to Function CustomerHasExistingOrder to fix issue where add to existing order wasn't working in same session due to order no being retained before next one is issued.
' (SS,27/09/19) Added Application/RWDFramework setting, also function IsBootstrap4, change made to ShowCheckoutFormHeader
' to not use "form-horizontal" class for Bootstrap 4
' (SS,27/09/19) Change to Function GetButton For Bootstrap 4, replaced glyphicon-chevron-right with fa-chevron-right
' (SS,30/09/19) Change to Sub ShowCheckoutFormHeader for Bootstrap 4 modified to add validation in browser for required fields, by adding class "needs-validation" also novalidate to override built in validation
' (SS,03/10/19) Modified Function CheckValidPersonalDetails, to stop Title from being required. No longer in inc-templatate-checkout.asp (Bootstrap 4 version)
' (SS,24/10/19) Added Function GetReviewAggregateRating
' (SS,06/12/19) Change to Function GetHTMLDescription, MAX_LENGTH from 250 to 160. Google search now only display first 160 or so characters.
' Also adjusted to replace 3 and 2 spaces with single space.
' (SS,24/10/19) Added Function GetReviewAggregateRating
' (SS,28/10/19) Google Sitemps, change to 2nd querystring parameter to use "&" instead of "&" investigate issue in Google Search Console
' Change made to Sub AddGoogleSitemapLevel
' (SS,06/12/19) Change to Function GetHTMLDescription, MAX_LENGTH from 250 to 160. Google search now only display first 160 or so characters.
' Also adjusted to replace 3 and 2 spaces with single space.
' Change to Function GetHTMLTitle to not create a title more than 60 characters for product detail page i.e. not add category/subcategory if it results in more than 60 characters
' (SS,10/12/19) Modified Sub SendOrderProgressEmails (for CIRC) to prevent less than 1 appearing in from days. Now the minimum will be 1 - 2.
' (SS,13/01/20) Minor change to Sub SendReviewRequests (for CIRC) to debug an issue
' (SS,14/01/20) Further mod to Sub SendReviewRequests (for HF) to remove the >= 14 Dec and <= 31 Dec (Christmas delay), added different delay for non-uk orders (for HF) if set
' (SS,17/03/20) Change to Sub SendReviewReceivedEmail (for HF) to change from email from FEmailContactFrom to reviewer's email address
' (SS,19/03/20) Modifications to vouchers to add free delivery and extra range
' Removed field SingleUsage (no longer used, some database still had it)
' Ensured that VoucherCode was CHAR (not VARCHAR)
' Increased length of VoucherName from VARCHAR(40) to VARCHAR(80)
' Added new fields: FreeDelivery, MinimumSpend2, MinimumQty2, DiscountAmount2, DiscountPercentage2, FreeDelivery2
' (SS,19/03/20) Modified voucher system to allow free delivery and additional range
' Changes made to Function GetDiscountUsingVoucherCode, Function GetDiscountUsingAutoVoucherCode, Sub GetOrderTotalsForBasket
' Added new function GetDiscountForRange
' (SS,24/03/20) Added feature to temporarily suspend ordering.
' New function OrderingSuspended, new setting Application / OrderingSuspended
' Changes also to function InStock, Sub SetStockInfo
' Also to Sub ShowStockNotificationLink in inc-template-other.asp
' Custom routine Function CustomOrderingSuspended can be added to customutils.asp to fine tune which products to apply to
' (SS,26/03/20) Added mailshot feature for CIRC. New Sub SendMailshot, new functions MailshotResultOverallHeader, MailshotResultOverallFooter, MailshotResultHeader, MailshotResultFooter MailshotResultRow
' Also new function called CustomMailshotGetSQL in customutils.asp.
' (SS,31/03/20) Added form-control to class for combo box in Function GetProductOptionComboBox
' (SS,06/04/20) Change to Sub SendStockNotificationEmail to add additional text defined in sitedetails table / Other / StockNotificationEmailAdditional
' Change to Function OrderingSuspended to pass ProductID to CustomOrderingSuspended
' Added Function ProductOrderingSuspended, change to Function OrderingSuspended to call this instead
' Modified Sub RestoreBasket to fix loophole of suspended products from being ordered due to this feature
' (SS,10/05/20) Modified Sub SetUpPaymentButton to change button for Sage Pay for Bootstrap 4
' (SS,11/05/20) Correction in Sub GetSettings, [If LFieldName = "EmailOrderConfirmationFrom" Then FEmailOrderConfirmationFrom = LFieldValue] ' (SS,11/5/20) corrected EmailOrderConfirmationFrom to OrderConfirmationFrom
' (SS,12/05/20) Corrected Voucher Code not functioning in checkout for free delivery only, i.e. when discount itself is 0.
' Changes made to Sub ShowOrderDetails, Function CheckVoucherCode, Function IsVoucherCodeValid
' (SS,19/06/20) Change to Function GetDiscountForRange, replaced ADiscountableTotal with ASubtotal, i.e. overall total is checked for minimum spend
' Requested by Neil, he assumed this was how it worked before especially for voucher code ENJOYF5J
' (SS,11/08/20) Bug fix to prevent cancelled order reactivation via EPDQ payment browser refresh, by adding check for PaymentReceived in
' Function CheckPaymentReceived, also changes to Sub ProcessEPDQRedirectCallback to redirect to home page if refresh duplicate detected
' Improved logging adding new field called InternalStatus. Added new Sub EPDQUpdateInternalStatus
' Modified table epdq_redirect_callbacks to add new field called "InternalStatus" VARCHAR(20) and index added to SHASIGN field
' (SS,24/09/20) New official common version which works for both Bootstrap 3 and Bootstrap 4.
' Previous version were 5.57p for Bootstrap 3 and 5.64 for Bootstrap 4. Numbered this version 5.70.
' (SS,25/09/20) Added new setting for ShowDeliveryAddToExistingOrder used by HF for not showing this option, originally hardcode in HF's inc-template-checkout.asp in 23/4/20
' (SS,29/09/20) Added new functions GetPanelCardClass, Bootstrap3Only, Bootstrap4Only. These are used to keep some of the common templates the same across Bootstrap 3 and 4
' The common inc templates are the following:
' inc-template-account.asp
' inc-template-basket.asp
' inc-template-checkout.asp
' inc-template-email-html.asp
' inc-template-other.asp
' inc-template-site-seal.asp
' (SS,01/10/20) Added note for HF if free delivery voucher used
' New routines ClearFreeDeliveryVoucherUsed, SetFreeDeliveryVoucherUsed, FreeDeliveryVoucherUsed, NoteFreeDeliveryVoucherUsage
' Also change to Sub GetOrderTotalsForBasket to call ClearFreeDeliveryVoucherUsed and SetFreeDeliveryVoucherUsed
' (SS,01/10/20) Modified emailing of baskets i.e. Sub SaveBasket to allow a maximum of 10 saved baskets per day (no restriction in local mode)
' Table schema change for saved_baskets. New field IPAddress also index added to this field and existing DateTimeSaved field.
' (SS,02/10/20) Loophole fix for CIRC's order suspending / quota restrictions. How prevents checking out if suspended items (i.e. rads) already in basket
' Changes made to Sub CheckOut, added new function ProductsInBasketOrderingSuspended. Update to customutils.asp function CustomOrderingSuspended for CIRC
' (SS,02/10/20) Change to Sub StockNotify to redirect to product page if referrer was from outside the website.
' This is due to stocknotify pages being indexed by search engines.
' Also added Function ProductIsDiscontinued for use in customutils.asp for HF
' (SS,04/10/20) Change to SendOrderProgressEmails to also send new ready for despatch alert email
' New OrderProgressReadyForDespatchAlert, OrderProgressReadyForDespatchAlertHeader, OrderProgressReadyForDespatchAlertRow
' (SS,04/10/20) Added Function NetPaySuccessfulPayment, change to Function IsSuccessfulReturnFromPaymentProviderPage to call NetPaySuccessfulPayment
' Change Function TrackPurchaseConversion to call IsSuccessfulReturnFromPaymentProviderPage
' Change to Sub ProcessNetPayCallback to prevent duplicate and redirect to home page if duplicate
' Also bug fix to NetPay's server post method, using cmd=payment was making it think it's not in the checkout stage and was removing items from basket
' Moved the call to NetPayServerPost from ProductsMain to Sub DoCheckout (Checkout renamed to DoCheckout), also change to Function GetNetPayFormURL
' Improved payment log in Sub ProcessNetPayCallback
' Change to Sub DoCheckout, just before ProcessOrder, added check for LConfirmOrderRedirect to prevent another call to ProcessOrder
' This prevents items being added back to stock and taken out multiple times (i.e. 3 entries in stock audit instead of just one)
' not necessary in this page redirect stage or when this page is refreshed.
' Kept the xcmd=filled, still useful, even though it's done via a redirect. No other simple way of detecting this stage early on in the same.
' (SS,21/10/20) Change to Sub ProcessTransferWiseCallback to log passed on Reference value
' (SS,22/10/20) Changes for GSC, since before this date.....
' (SS,12/11/20) Change made to Sub SendStockNotificationEmails (for CIRC) to send out notification when NumInStock is Null (i.e. blank), i.e. treated as in stock.
' Also changed to exclude if the product is disabled.
' (SS,12/11/20) Changes for GSC, continued since before this date.....
' (SS,25/11/20) Change to Sub SendTrustpilotAFSEmail to also send BCC copy to the store, it was ignoring it due to matching the from address
' (SS,26/11/20) Added new InStockQty and change to GetPriceAndStockForProductID to call InStockQty instead of InStock
' Previously GetPriceAndStockForProductID was only checking for qty of 1, now it checks for provide qty.
' (SS,26/11/20) Further change to GetPriceAndStockForProductID to call SetAllowOutOfStockOrdering
' (SS,08/12/20) Added Sub SendTrustpilotReviewInvitations (called from new trustpilot-review-invitations.asp)
' (SS,22/12/20) Added new store setting EORINo (function GetStoreEORINo, variable FStoreEORINo)
' Also added call to GetStoreEORINo to inc-template-email-html.asp in Function GetOrderEmailFooter
' (SS,21/01/21) Change to sub SetUpPaymentButton, removed "preferred" text from PayZone button caption, due to showing NetPay and PayZone for HyperFlight
' (SS,22/01/21) Added optional reference field to subs NetPayServerPost and ProcessNetPayCallback. Also added the field reference to the netpay_callbacks table
' (SS,22/01/21) Change to Sub NetPayServerPost to show and log the error after doing the server post request returns an error condition
' Also size of AVSGatewayCode (field in netpay_callbacks) increased from 20 to 50
' (SS,23/01/21) Change to Sub NetPayServerPost, NetPay doesn't like a blank for bill_to_county even though it's optional, not passing it when blank fixes it
' Also concatenated address1 and address2 for bill_to_address previously it was just address1
' (SS,24/01/21) Modified NetPayServerPost to always add to payment log
' (SS,26/01/21) Change to AddToPaymentLog to add to correct order if session was lost on return from payment provider
' New global FCallbackOrderNo, new routines SetCallbackOrderNoForPaymentLog GetCallbackOrderNoForPaymentLog
' (SS,08/02/21) Added new function Function GetCountryFromDefault called from functions GetDeliveryCountry and GetInvoiceCountry
' To sort issue with Express Music not defaulting to UK Mainland in basket and if customer doesn't select UK, it doesn't show "Don't charge delivery, I will collect" tick box
' (SS,12/02/21) Added new setting Function AllowCollectionBasketPage, also added this feature to inc-templatate-checkout.asp and inc-template-account.asp
' (SS,15/02/21) EORI number features
' (SS,16/02/21) Change to Function GetEmailBodyOrderDetails added EORINumber and XIEORINumber, change also made to this routine in inc-template-email-html.asp
' (SS,17/02/21) Minor adjustment for HF to Sub SetUpPaymentButton and Sub SetUpPaymentButtons
' (SS,17/02/21) Added FedEx to Function GetTrackingURLForCourier
' (SS,22/02/21) Added new routines Sub HTMLBodyStart, HTMLBodyEnd, AddScript, ShowScripts, new global FScriptList
' This allows the jQuery/JavaScript to function in inc-template-checkout.pas and inc-template-account.asp
' With reference to jQuery library further down the page (as it was for CIRC for SEO)
' Had to add calles to HTMLBodyStart and HTMLBodyEnd in inc-template-main.asp for each site
' (SS,20/04/21) Change to Function ProcessOrder to add calender READ to LOCK TABLES for CIRC
' (SS,21/04/21) New setting Features / DespatchDatesEnabled, new sub SetTokenText, changes to functions ProcessOrder and TryProcessOrder
' (SS,22/04/21) Changes for new expedited delivery method/option. Change to SetCountryFromBasketForm, new routines SetExpeditedDeliverySelected, GetExpeditedDeliverySelected,
' SetExpeditedDeliverySelectionAllowed, GetExpeditedDeliverySelectionAllowed
' SetUntrackedDeliverySelectionAllowed, GetUntrackedDeliverySelectionAllowed
' Changes also to inc-template-basket.asp and customutils.asp for HF
' Added SetDeliveryOptionalLabel and GetDeliveryOptionLabel for HF, also to inc-template-checkout.asp and inc-template-email-html.asp
' (SS,23/04/21) New functions IsDateWorkingDay(ADate) and WorkingDaysBetween to help with selected DespatchByDate in local mode with priority 9
' WorkingDaysBetween uses new stored function called common.GetWorkingDaysBetween
' common.GetNthWorkingDay modified to also work backwards when supplied with negative ANthWorkingDay
' Changes also made to inc-template-checkout.asp
' (SS,29/04/21) Changes to Sub SetDeliveryOptionLabel, Sub SetDeliveryOption, Function GetDeliveryOption for improved DeliveryOption for HF
' (SS,30/04/21) Added new function GetWeightRangeForCategory for HF, to help with additional RC Models delivery (called from customutils.asp)
' (SS,05/05/21) Interpolation feature added to Function GetDeliveryFromTable (for HF)
' (SS,06/05/21) New settings FDeliveryInterpolationEnabled, FDeliveryInterpolationStartThreshold, FDeliveryInterpolationEndThreshold
' For HF delivery interpolation feature. New functions DeliveryInterpolationEnabled, DeliveryInterpolationStartThreshold, DeliveryInterpolationEndThreshold.
' (SS,06/05/21) Change to GetDeliveryFromTable, correction to to interpolation to use RangeStart instead of Value field
' (SS,06/05/21) Bug fix to Function GetDeliveryFromTable (low threshold for interpolation)
' (SS,07/05/21) Modified to allow adjusted total weight to be saved (for HF)
' New variable FAdjustedTotalWeight, routines: Sub SetAdjustedTotalWeight, Function IsAdjustedWeightSet, Function GetAdjustedTotalWeight
' (SS,10/05/21) Correction/bugfix to Function GetWeightRangeForCategory
' (SS,10/05/21) Correction to interpolation in Function GetDeliveryFromTable, when end reached not no high value found, it now returns the low value (i.e. highest value from last record)
' (SS,12/05/21) Modified Function GetWeightRangeForCategory to remove medium ref
' (SS,12/05/21) Added setting FTrustpilotReviewsVisible and Function TrustpilotReviewsVisible
' For CIRC to allow TrustPilot reviews to be shown when ReviewType is not Trustpilot
' (SS,13/05/21) Further changes for Trustpilot reviews. New Sub ShowRecentReviewsTrustpilot, ShowRecentReviewsNormal. Also Function GetTrustpilotSiteName.
' (SS,20/05/21) Change to Function GetEmailBodyOrderDetails to replace Mobile with AlternativePhone
' Various changes for AlternativePhone and HearAboutUs, HearAboutUsOther
' Changes made to templates: inc-templatate-checkout.asp, inc-template-checkout.asp and inc-template-email-html.asp
' (SS,24/05/21) This version released
' (SS,25/05/21) Added remarketing 'event' tags for Google Ads to Sub DoGoogleAnalytics
' (SS,25/05/21) Changes to functions GetProductsFilter and ShowSingleProduct to use IsLocalModeProduct flag to not show such products in non local mode if local mode enabled
' New field IsLocalModeProduct added to products table.
' (SS,28/05/21) Added Function GetGoogleAdsConversionID due to call from inc-templatate-main.asp for VDK Dynamic Remarketing tracking test
' (SS,15/06/21) Change to Sub ShowCheckoutLoginFormFooter added hidden name login with value "yes" to make login detection easier
' Change also to AccountOptionalLoginAttempt
' Added Sub GetHearAboutUsFromForm to fix HearAboutUs values to being saved for existing customers (to allow change of question and options)
' This is called where applicable when after calling GetPersonalDetailsFromForm
' Change also made to Sub ShowCheckoutLoginSection in inc-template-check.asp to remove redundant/incorrect Session("Password")
' (SS,15/06/21) Message change in Sub ShowCheckoutLoginForm
' (SS,16/06/21) Change to Sub SendOrderProgressEmails to add DespatchByDate (template also change to show from and to dates)
' New Function GetAttributeWithOptionNameInBasketCount for CIRC
' Correction to DoCheckout to AccountExists(Session("Email")) to AccountExists(Session("LoginEmail"))
' (SS,01/07/21) Change to Sub SetUpPaymentButtons for HyperFlight to show the two main payment types alternatively on odd/even days
' Change to Function GetEmailBodyMessage, added AddNewlinesToHTMLBreaks to reduce line length for emails, try to keep below 1000, adds NLs after BRs
' Moved Function CleanSQLStrMax from apputils.asp to dbfunctions.asp
' Change to Function ProcessOrder to add additonal tables to lock via CustomGetAdditionalLockTables
' NB. Latest dbfunction.asp required for this apputils.asp
' (SS,28/08/21) Added Sub StockCheckLog (for CIRC) called from stock-check-log.asp via scheduled task
' (SS,17/09/21) Added Function GetEnhancedConversionValues, changes to Sub DoGoogleAnalytics to add enhanced conversion, new setting FGoogleEnhancedConversionsEnabled
' Also fixed events so that add to cart id uses GetBasketProductCode instead of GetProductCode, previously it had either blank or incorrect value.
' Also changed so that view_item event doesn't appear when add_to_cart event occurs.
' (SS,29/09/21) Modified Sub GetOrderTotalsForBasket to include subproducts for weight calculation for radiators for CIRC, false in call to GetOrderItemsQuery changed to true
' (SS,07/10/21) Change to Sub SetUpPaymentButtons to revert the alternating between PayZone and NetPay for HF
' (SS,12/11/21) Changes to Sub AddContactToDatabaseAndEmail and Sub SendContactEmail to also function from customutils.asp via Ajax query string (GSC)
' (SS,18/11/21) Changes to Sub EmailOrder, Sub ShowEmailConfirmationHTML, Function GetEmailBody, Function GetEmailBody to add voucher notification email feature
' (SS,20/11/21) Added call to CustomCheckAddressDetails in CheckValidPersonalDetails and CheckValidDeliveryAddress, to not allow delivery for Northern Ireland unless collecting (GSC)
' (SS,24/11/21) Change to Function GetEmailBodyAddressDetails to allow a customer message for collection via GetMessage (added to inc-template-message.asp for EM)
' (SS,02/12/21) Change to Sub SendSMS, added 4 parameters to allow two tokens for setting despatch from and to dates in order progress SMS message (CIRC)
' (SS,15/12/21) Added mailshot simple routines including Sub SendMailshotSimple, specifically for CIRC data breach emails (call via new send-mailshot-simple.asp)
' (SS,17/12/21) Added feature to hide personal details from Bcc order emails
' Changes to subs EmailOrder, ShowEmailConfirmationHTML; functions GetEmailBody, GetEmailBodyOrderDetails, GetEmailBodyAddressDetails
' New functions HideSensitiveData and AddNewlineIfNotBlank
' (SS,25/01/22) Changes to Sub SendRefundEmail to make use of new refunds table instead of refund fields in orders table
' (SS,04/02/22) Added REFUND_REF to Sub SendRefundEmail
' (SS,25/02/22) Modified Sub RestoreBasket to not restore quotes older than a year
' (SS,25/02/22) New restore basket from order feature; modified Sub SendCancelledOrderEmail, new Sub RestoreBasketFromOrder and new Function GetRestoreBasketFromOrderURL
' (SS,03/03/22) Improvements to cancelled ordered email to added the actual products to it (changes to Sub SendCancelledOrderEmail and Sub RestoreBasketFromOrder)
' (SS,29/03/22) Added "ROYAL MAIL" to Function GetTrackingURLForCourier, added Function IsDeliveryOptionUntracked, added call to Function GetEmailBodyMessage
' (SS,31/03/22) Changes to functions GetEmailBody and GetEmailBodyMessage, to show "Order Ready for Collection" instead of despatched in subject and text of email if DeliveryWillCollect is true
' (SS,11/04/22) Added spam email address check to cut down on spam enquiry emails, one email address in particular
' Added new const SPAM_EMAIL_ADDRESSES, new function IsSpamEmailAddress, change to AddContactToDatabaseAndEmail
' (SS,12/05/22) Added const DEBUG_ENABLED for improved debugging, also Sub ShowDebug, added called to ShowDebug in various routines
' Fixed a bug which was result in DeliveryOption wrongly being set to "Collection" if user happens to first choose "Delivery Will Collect" and
' And then going to the basket page and checking out again. Was due to GetDeliveryCost exiting early.
' Possible 3 different bugs altogether including the Priorty going wrong sometimes (which is hopefully fixed now)
' 1. Collection free delivery bug was due to DeliveryOption being saved early in TryProcessOrder, fixed by adding to update order later
' 2. Also moved saving of Priority later in TryProcessOrder because GetDeliveryCost called later could affect it
' 3. Basket page showing 0 delivery cost when defaulting to Untracked or Tracked, fixed by not exiting early in GetDeliveryCost if basket page
' (SS,13/05/22) Change to Function GetDeliveryCost to allow exiting on basket page for Express Music (i.e. Click & Collect if AllowCollectionBasketPage is set)
' (SS,04/06/22) Change to Sub Finalise to call new Sub CollectStats to collect page performance and query figures
' Also change to Sub AddMultiMenuLevel to remove GetQueryRecordCount which was tripling the query
' CollectStats makes use of new app_stats memory table and stored procedure collect_stats
' (SS,08/06/22) Added Clover payment provider
' (SS,21/06/22) Changes to frmCheckoutLogin to preserve "I will collect", voucher code and message when logging in.
' (SS,23/06/22) Change to Sub ProcessEPDQRedirectCallback to log all fields to PaymentLog and also set the OrderNo from callback to allow AddToPaymentLog to detect session change
' (SS,24/06/22) Changes to Clover to optionally show multiple buttons for different payment methods, also added duplicate detection for Clover
' (SS,25/06/22) Error handling improvements in Function ProcessOrder (to help get to the bottom of "waiting for table metadata lock" hanging issue in HyperFlight)
' (SS,21/07/22) Important change to remove the LOCK and UNLOCK MySQL statements from ProcessOrder, these are proving to be a hassle because every table being accessed has to be locked.
' Meta locks have changed on later version of MySQL and have resulted in a hang on at least 3 occasions with HF.
' Discoved a bug in CIRC where locking has worked since April 2021 due the "calender" table in lock statement and error in lock statement not being trapped..
' To get around this a lot more tables need to be locked and it was getting silly, including the common database calendar table for which lock access is denied.
' I think one reason for this LOCK feature was to ensure correct getting of NextOrderNo from settings. This has now been replaced with AUTO_INCREMENT being added to the OrderNo field in orders table.
' Following SQL needs to be run: ALTER TABLE orders MODIFY COLUMN OrderNo INT(11) NOT NULL AUTO_INCREMENT;
' Changes made to Function GetNextOrderNo to get next order number by inserting a record in orders table instead of getting from settings.
' Changes made Function ProcessOrder to remove the LOCK and UNLOCK code.
' Changes to Function TryProcessOrder to replace the "REPLACE" statement with "UPDATE"
' Added Sub UpgradeSchemaTo7 to change the OrderNo in orders table in AUTO_INCREMENT.
' !!! Need to run products.asp?cmd=upgrade to force the schema upgrade
' (SS,28/07/22) Change to Sub ShowBasket to default the DeliveryCountry to Country if delivery address same as invoice (i.e. customer had already been to checkout) to fix postcode alert bug
' (SS,28/07/22) Change to Function GetDeliveryRegionFromPostcode to not send alert email if postcode not valid for UK on basket page
' (SS,01/08/22) Changes to Function GetDetailsFromPayPalExpress to remove DebugLog
' (SS,01/08/22) Changes to Sub DoGoogleAnalytics to enhanced conversion data, removed phone and added postcode, country, county and city
' (SS,03/08/22) Added PayPal Pay Later messages feature, new settings FPayPalPayLaterMessagesEnabled, FPayPalPayLaterMessagesClientID, functions GetPayPalPayLaterMessagesEnabled, GetPayPalPayLaterMessagesClientID
' Changes also to inc-template-basket.asp
' New Function RemoveCurrencyAndCommas. Also change to Sub SetUpPaymentButton to show this message for PayPal.
' (SS,05/08/22) Bug fix to update SQL statement in Sub SendReviewRequests which updates the ReviewRequestSentDate field.
' Also change to Sub AddSearchToLog to truncate the search value saved to the searchlog table to size of field (100), to prevent data too long for column error.
' (SS,10/08/22) Change to Sub DoGoogleAnalytics to enhanced conversion data to fix issue, now using gtag('set', 'user_data')
' (SS,10/08/22) Change to Sub UpdateOrderStatusForOrderPlaced to add CleanSQLStrMax(255) to PaymentInfo to prevent value too long which has occurred for TransferWise,
' also added CleanSQLStrMax(255) to PaymentReference. Changes to Sub ProcessTransferWiseCallback to replace CleanSQLStr with CleanSQLStrMax to values passed.
' (SS,05/10/22) Added new function GetAttributeInBasketMaxValue for HF for GetAttributeInBasketMaxValue("Packaged Weight") in customutils.asp for delivery cost calculation.
' (SS,28/10/22) New routine Function InvoiceCountryIsUK called by AllowCheques to only show for UK
' (SS,17/11/22) Fix to prevent values too long for column SQL error, which occur when form fields are HTML encoder by browser, making then 7 chars for every 1 char, when non-Latin characters entered
' Change to Function TryProcessOrder, added new functions CheckTruncateFormData, GetFormDataTruncationInfo
' and new subs CheckTruncateFormField, ClearFormDataTruncationInfo, SetFormDataTruncationInfo, AddFormDataTruncationInfo, Function GetFormDataTruncationInfo
' (SS,03/02/23) v6.00 (was v5.98) Added cache feature to reduce the number of unnecessarily repeated queries for looking up the ChargeVAT flag, as much as 85 on HF, 20 on CIRC home pages.
' Changes to Sub Initialise, Function GetCountryChargeVATFlag.
' (SS,14/02/23) Bugfix to Function GetEmailBodyOrderDetails to correctly remove VAT for prices shown in emails (especially despatch emails)
' (SS,22/02/23) Added Sub CheckAndSetDevMode to clear certain settings in development mode
' (SS,14/06/23) Change to Function GetTrackingURLForCourier for UPS tracking
' (SS,15/06/23) Change to Function GetEmailBodyMessage to show the tracking link even if DeliveryOption chosen is Untracked
' (SS,15/06/23) Change to Sub DoGoogleAnalytics, enhanced conversion data to follow Google support team's recommendation i.e. first_name and last_name moved outside of address, and address renamed to home_address
' (SS,20/06/23) Change to Sub DoGoogleAnalytics, modified enhanced conversion to use new FGoogleEnhancedConversionsType to allow either offical type with "address" to the Support Teams undocumented type of "home_address"
' Change to Sub DoWebAnalytics to call DoCookieConsent, new Sub DoCookieConsent, change to Sub DoFacebookPixel to revoke consent by default
' (SS,02/07/23) Reverted the change made to Sub DoFacebookPixel back to the version without consent, due to it missing conversions etc. (renamed the consent version to go back to it later)
' (SS,20/07/23) Bug fix to Function GetDiscountForRange bug where ADiscountAmount was incorrectly being applied when category/product chosen, due to a previous change to use ASubtotal instead of ADiscountableTotal for AMinimumSpend
' Change to Function GetDiscountUsingVoucherCode, modified to not apply discountable total to second discount and to sum the discount if free delivery not used for CIRC (25OFF discount that provides �25 for ads and 5% for all if �2000+)
' (SS,28/07/23) Changes to functions GetDiscountUsingVoucherCode, GetDiscountForRange and GetDiscountUsingAutoVoucherCode.
' Modified to set Discount Info via calls to new ClearDiscountInfo AddDiscountInfo
' New routines ClearDiscountInfo, AddDiscountInfo, GetDiscountInfo
' Change also made to inc-template-checkout.asp (common), and inc-template-messages.asp (custom)
' (SS,03/08/23) Added Sub DoOptinMonster and two new settings FOptinMonsterID1 and FOptinMonsterID2 in new OtherTools group. Change to DoWebAnalytics to call DoOptinMonster
' (SS,04/08/23) Renamed FOptinMonsterID1 to FOptinMonsterUserID and FOptinMonsterID2 to FOptinMonsterAccountID
' Change to Sub GetOrderTotalsForBasket to ensure Discount Info is cleared when voucher is removed or is invalid
' Correction Function GetDiscountForRange, change discount info to remove VAT where applicable and in selected currency.
' (SS,23/08/23) Change to Sub SendReviewRequests, for HF, to send not just review requests matching today but previous ones too in case the request days were adjusted like thay have been from 60 to 30 for non-UK
' (SS,15/09/23) Change to Sub SendCancelledOrderEmail, modified "SELECT * FROM orderdetails" statement to filter out subproducts using GetOrderDetailsFilter
' (SS,04/10/23) Change to Sub HTMLHeadStart, added DisableIndexingInDevMode (new sub in dbfunctions.asp) to prevent indexing in Dev mode
' (SS,19/10/23) GTM (Google Tag Manager) changes, includes new library gtm-lib.asp
' (SS,25/10/23) Modified Sub FinaliseWebAnalytics to only do GTM if oGTM is set, to fix error occurring in redirects
' (SS,30/10/23) Bugfix in Function TryProcessOrder to prevent Notes entered in localmode being lost due to truncated form data info being added previously
' (SS,30/10/23) Added changes for new "Blogs" section in sitedetails table, change to Function GetWebText and added new Function GetBlogPostContent
' (SS,10/11/23) Merged with previous latest changes from 6.16 and 6.15c into this 6.17
' (SS,21/11/23) Change to Sub DoAccount, removed LCmd = "create" to disable account create feature due to a bot randomly creating accounts and doing a forgot password for VDK and CIRC
' (SS,22/11/23) Change to Function GetWeightRangeForCategory to remove duplicate link to productcategories table causing error in HF
' (SS,22/11/23) Bugfix to Sub ProcessOrderThirdPartyPayment to fix to same order no being reused by customer bug for payment methods including Clover, EPDQ, SagePay etc.
' (SS,20/12/23) Change to Sub SendOrderProgressEmails, modified to call new sub ShowOrderProgressEmailSample and also check for cmd=do before running
' (SS,24/12/23) URL change to new one in Sub SetUpPayzoneForm(AOrderNo) (PayZone/Takepayuments had stopped working recently for HF)
' (SS,15/01/24) Changes to add Backona's version of Analytics scripts for Google and Facebook. Change also made to gtm-lib.asp
' (SS,16/01/24) Change to DoFacebookPixelEvents to added fbq('trackCustom', 'PView'), also to DoFacebookPixel to add missing end quote
' (SS,17/01/24) Added missing '-' from nocors Facebook Pixel, Backona version
' (SS,19/01/24) Change to Function GetEmailBodyMessage to not show tracking if DeliveryOption is "CRL24" even though the tracking no field has a value
' (SS,29/02/24) From 16/2/24 to 29/2/24, various improvements including shopping basket page and checkout validation, to remove old code including ShowBasketOld
' (SS,01/03/24) Change to Sub DoCheckout to prevent voucher code from being lost due to Voucher Code being removed from checkout page, now only in basket page
' (SS,01/03/24) New Function GetBasketOptionValueComparedWithAttributeCount to help fix issue with CIRC rads above min sections to result in an oversize charge
' Issue as a result of moving basket totals to show ahead of the items.
' (SS,08/03/24) Added new Sub ShowCheckoutLoginLink for HyperFlight log in option on checkout page
' (SS,30/09/24) (Also added to 6.41, Bootstrap 5 branch) Added DHL to Function GetTrackingURLForCourier
' (SS,05/11/24) 6.30c - Added span detection code for HF (Function SpamDetection)
' (SS,26/12/24) 6.30d - Removed Function IsSpamEmailAddress and Const SPAM_EMAIL_ADDRESSES, improved version in common/inc-email-utils.asp
' (SS,28/02/25) 6.30e - Change to Function GetTrackingURLForCourier for DHL (for WebShip agent including courier DHL eCommerce and DHL Express)
' (SS,24/03/25) 6.30f - Change/fix to Function GetProductOptionComboBox - LNoOptionsInStock for HyperFlight when all options get shown instead of just the ones with Null (KITE)
' (SS,02/07/25) 6.30g - New version of Function GetTrackingURLForCourier and new Function IsCourierOrAgent
' ### need to investigate the proper and standard way of encoding a URL for sitemap use, canonical link use and html link use, have a routine that
' can be called with parameter true or false to include full path or just relative
' and use it DoGoogleSitemap, Get Product with Name link and ShowCanonicalLink
' (SS,15/10/18) To do - improve formatting for enquiry email. Now HTML was plain text. E.g. add table, full HTML tags. See Sub AddContactToDatabaseAndEmail and SendContactEmail
' *** TO DO 14/2/13 get values from settings for functions GetFeefoLogon, GetFeefoFTPHost, GetFeefoFTPUser, GetFeefoFTPPassword, ReviewTypeIsFeefo
' *** 10/5/13 feefo caching
' *** IMPORTANT *** 8/5/10 need to update ahref parameter in ShowProductListJumpFooterNext & ShowProductListJumpFooterPrevious in inc-template-product-list.asp in all shopping sites
' *** IMPORTANT *** 17/4/07
' install notes for sites besides ExpressMusic
' Remove code from inc-pages.asp from If Request.QueryString("xcmd") = "delete" Then.... to End If
' Add DoBasketOperation to end of inc-main.asp
' need to test all basket operations are working
' check shopping status looks okay
' also check that currency change still works in clifton
'
' also add the latest dbfunction.asp to existing shopping apps
'
' because of various changes to pricing routines, need to check with existing apps, especially contract prices with toner2desk
' Add Finalise to end of inc-template-main.asp to close database etc
' Finalise must be called specifically from call back routines too
' Password code moved from inc-template-main.asp to apputils.asp Initialise sub
' OpenDatabaseCommon... to be test with currency/clifton
' Added "Region" field to Orders and Customers after "Country", moved DeliveryRegion after DeliveryCountry
' GetDeliveryCombo in inc-template-checkout.asp renamed to GetDeliveryRegionCombo
' Countries table, added new fields RegionCode Char(3) and SortOrder Smallint
' DeliveryRegions table, changed RegionCode from VARCHAR(2) to VARCHAR(3)
' DeliveryRegion field can be removed from orders table
' Need to modify express music to work without DeliveryRegion, make sure delivery works correct, modify countries table
' Functions such as ShowSpecialDeliveryRegion, GetDeliveryRegionCombo will need to be removed
' ShowCheckoutOrderDetailsFooter in inc-template-checkout added AInCheckout, AOrderNo parameters
' 22/6/07 Orders table: Deleted fields Region, DeliveryRegion, added TotalWeight
' ============'
' global constants and variables '
' (SS,11/5/22) to enable/disable debug features, 1st implementation is to disable page redirection in SetPageRedirection because it can interfere with debugging
' e.g. redirects to final checkout stage with xmcd=filled and prevent debug info from being seen
' modified SetPageRedirection to use this constant, also added showing current date/time to Sub Finalise
Const DEBUG_ENABLED = False
' (SS,11/2/04) added payment variables because it is now to handle worldpay and direct payments '
Const ptWorldPay = "WORLDPAY"
Const ptPayPal = "PAYPAL"
Const ptEPDQ = "EPDQ" ' (SS,7/9/06)
Const ptSagePay = "SAGE PAY" ' (SS,20/3/13)
Const ptPayzone = "PAYZONE" ' (SS,22/3/18)
Const ptNetPay = "NETPAY" ' (SS,16/9/20)
Const ptClover = "CLOVER" ' (SS,8/6/22)
Const ptCheque = "CHEQUE" ' (SS,28/5/09)
Const ptBankTransfer = "BANK TRANSFER" ' (SS,28/5/09), (SS,5/8/11) changed to "BANK TRANSFER"
Const ptPayPalExpress = "PAYPAL EXPRESS" ' (SS,20/11/14)
' (SS,4/8/17) added following special bank transfers to EUR to USD accounts selected via bank transfer modal form
Const ptBankTransferEUR = "BANK TRANSFER - EUR"
Const ptBankTransferUSD = "BANK TRANSFER - USD"
Const ptBankTransferGBP = "BANK TRANSFER - GBP" ' (SS,29/9/17)
' (SS,23/6/22) Clover payment methods
Const cpmAll = ""
Const cpmApplePay = "ApplePay"
Const cpmGooglePay = "GooglePay"
Const cpmVisa = "V"
Const cpmMastercard = "M"
' (SS,10/4/19) added following for tracking type
Const ttGoogle = 1
Const ttFacebook = 2
' following are used to determine how many to show across and down '
' and fine tuning the main product listing *** perhaps move these to app variables '
Const PRODUCTS_ACROSS = 4
Const PRODUCTS_DOWN = 2
Const SMALL_THUMBNAIL_WIDTH = 100
Const SMALL_THUMBNAIL_HEIGHT = 100
Const LARGE_THUMBNAIL_WIDTH = 240
Const LARGE_THUMBNAIL_HEIGHT = 240
Const PAGES_PER_GROUP = 10
Const HORIZONTAL_SPACE_TO_IGNORE = 310
Const VERTICAL_SPACE_TO_IGNORE = 160
Const HORIZONTAL_SPACE_PRODUCT = 107
Const VERTICAL_SPACE_PRODUCT = 200
Const MIN_PRODUCTS_ACROSS = 4
Const MIN_PRODUCTS_DOWN = 2
Const MAX_PRODUCT_QTY = 1000
Const ORDER_PLACED_STATUS = "ORDER PLACED"
Const AWAITING_PAYMENT_STATUS = "AWAITING PAYMENT" ' (SS,28/5/09)
Const PAYMENT_RECEIVED_STATUS = "PAYMENT RECEIVED"
Const ORDER_CANCELLED_STATUS = "CANCELLED"
Const PAYMENT_ON_ACCOUNT_STATUS = "PAYMENT ON ACCOUNT" ' to be added (SS,23/8/04) '
Const ORDER_COMPLETED_STATUS = "COMPLETED" ' (SS,15/8/05)
' (SS,12/8/05) following moved here from Sub CheckOut
Const GET_ACCOUNT_TYPE = "GetAccountType" ' (SS,3/8/04) '
Const GET_PERSONAL_DETAILS = "GetPersonalDetails"
Const GET_DELIVERY_ADDRESS = "GetDeliveryAddress" ' (SS,4/8/04) '
' Const CONFIRM_DETAILS = "ConfirmDetails" ' (SS,27/7/05) removed '
Const CONFIRM_ORDER = "ConfirmOrder"
Const CONFIRM_PAYMENT = "ConfirmPayment" ' (SS,29/5/09)used for cheque or bank transfers
Const RETURN_FROM_THIRD_PARTY_PAYMENT = "co" ' (SS,14/8/05)
Const COMPLETE_ORDER = "CompleteOrder" ' (SS,27/7/05) '
Const CS_PAYPAL_EXPRESS_CHECKOUT = "PayPalExpressCheckout" ' (SS,19/11/14) checkout stage for redirecting to PayPal Express
Const CS_PAYPAL_EXPRESS_RETURN = "PayPalExpressReturn" ' (SS,19/11/14) checkout stage for return from PayPal Express
Const CS_PAYPAL_EXPRESS_CANCEL = "PayPalExpressCancel" ' (SS,19/11/14) checkout stage for return from PayPal Express with cancel chosen
Const VATABLE_REGIONCODES = "UK,EU" ' (SS,13/9/06)
' (SS,18/9/06)
Const DEFAULT_CURRENCY_CODE = "GBP"
Const DEFAULT_CURRENCY_RATE = 1
Const DEFAULT_CURRENCY_SYMBOL = "£" ' (SS,28/10/09) replaced "�" with "£"
Const DEFAULT_CURRENCY_SHOW_VAT = True
Const DEFAULT_CURRENCY_COUNTRY = "United Kingdom"
Const MAIN_CURRENCIES = "GBP,USD,EUR" ' (SS,18/12/14) i.e. the major currencies for which you're likely to have bank accounts, used by exchange adjustment routine
Const DEFAULT_DELIVERY_REGION_UK = "UK" ' (SS,19/1/15) required if delivery postcodes used and post hasn't yet been entered
' (SS,12/9/06)
Const DT_ORIGINAL = "original"
Const DT_HIGHEST = "highest"
Const DT_LOWEST = "lowest"
Const DT_TOTAL = "total"
Const DT_CUSTOM = "custom" ' (SS,13/9/07)
Const GROUP_MAIN = "Main" ' (SS,14/5/07)
Const DISCONTINUED_TEXT = "*discontinued*" ' (SS,15/11/07) if this text exists product name then it means it's been discontinued
Const DISCONTINUED_TEXT2 = "*special order*" ' (SS,16/11/07) if this text exists product name then it means it's a special order (behaves like discontinued)
Const INTRA_COMMUNITY_SUPPLY_MESSAGE = "This is an intra-community supply and is exempt from VAT." ' (SS,16/11/07)
' (SS,27/5/09) Account Types
Const AT_COMPULSORY = "Compulsory"
Const AT_OPTIONAL = "Optional"
Const AT_ADMIN = "Admin"
' (SS,4/6/09)
Const MAX_RECENTLY_VIEWED = 5
Const SPECIAL_OFFERS_SEARCH_TEXT = "--special offers--" ' (SS,13/5/10), (SS,25/7/11) changed to lower case
Const NEW_PRODUCTS_SEARCH_TEXT = "--new products--" ' (SS,18/1/13)
' (SS,17/5/10) button types
Const BT_ORIGINAL = "Original"
Const BT_TYPE1 = "Type1"
' (SS,3/6/11) made this into a constant used in several places
Const NEW_LINE_FIX = "@@@"
' (SS,14/12/18) special value used in ComposeDescription to remove a table row if blank, # prefix doesn't work because it gets removed so used $ instead
Const REMOVE_BLANK_ROW = "$REMOVE_BLANK_ROW$"
' (SS,30/6/11) default value for combo prompting for something to be selected
Const COMBO_PLEASE_SELECT = "Please select..."
' (SS,30/6/11) product option input type constants
Const POIT_COMBO_BOX = "Combo Box"
Const POIT_TEXT = "Text"
Const POIT_RADIO = "Radio"
Const POIT_CHECK_BOX = "Check Box"
Const POIT_SPLIT_COMBO = "Split Combo" ' (SS,15/7/11)
Const PO_SPLIT_COMBO_SEPARATOR = "/" ' (SS,14/7/11)
Const DISCOUNT_OVERRIDE_VOUCHER_CODE = "INTERNAL" ' (SS,7/10/16)
Const ADD_TO_PREVIOUS_ORDER_TEXT = "**Add to previous order**" ' (SS,31/3/17)
' (SS,20/3/18) contants for SMS types
Const ST_ORDER_CONFIRMATION = "Order Confirmation"
Const ST_ORDER_PROGRESS = "Order Progress"
Const ST_ANTICIPATED_DESPATCH_UPDATE = "Anticipated Despatch/Update"
Const ST_ORDER_DESPATCHED = "Order Despatched"
Const ST_REVIEW_REQUEST = "Review Request"
Const GMAIL_ALERT_ADDRESS = "gmailalert@itpartnership.com" ' (SS,25/6/22) a distribution group for a more urgent alert
' (SS,23/3/05) '
Dim NL
NL = Chr(13) + Chr(10)
' main variables '
Dim FSessionID ' (SS,12/8/05) was gsSessionID
Dim strCommand, strSearch, strPage, strGroup, strCategory, strSubcategory, strProductCode, strQty
Dim strClientWidth, strClientHeight, strOptions
Dim strGroupFromMenu ' (SS,12/2/05) group assigned in ShowMainMenu, passed onto GetProductsPageTitle '
' Dim strImageNo ' (SS,6/7/06) for extra product images; (SS,8/8/18) removed
Dim strStage ' (SS,8/9/06)
' (SS,23/5/11) following used to prevent stack overflow in ReplaceTokens routine
Dim FReplaceTokensRecursionCount
FReplaceTokensRecursionCount = 0
' check out variables '
' Dim strPaymentType, strDescForWorldPay, strTotalAmountForWorldPay ' (SS,10/8/05) removed
Dim gsITP_ErrorMessage ' error message passed back to browser using javascript '
' (SS,20/2/14) used to hold message shown on popup
Dim FPopUpMessage
' (SS,23/7/05) '
' credit card variables '
Dim FErrorCardType, FErrorCardNumber, FErrorSecurityCode, FErrorCardHoldersName, FErrorExpiryDate, FCardCounter
' (SS,12/9/06) new delivery variables
Dim FDeliveryCalculationFailure
Dim FDeliveryType, FIsDeliveryByPrice, FIsDeliveryByWeight, FIsDeliveryByWeightFlagged, FIsDeliveryByWeightNonFlagged
Dim FIsDeliverySpecialRegionByPrice, FIsDeliverySpecialRegionByWeight
' (SS,25/9/20)
Dim FShowDeliveryAddToExistingOrder
' (SS,18/9/06)
Dim FCurrencyCode, FCurrencyRate, FCurrencySymbol, FCurrencyShowVAT, FCurrencyCountry
' (SS,3/2/23) to cache charge VAT flag result, it was causing lots of unnecessary repeated queries before
Dim FChargeVATFlagCountry, FChargeVATFlag
' (SS,17/5/07) new price values, used to pass values to product templates and calculate prices
' (SS,6/7/11) removed FBasketQty
' (SS,10/9/14) added FPostalWeight
Dim FStdPrice, FSalePrice, FPrice1, FPrice2, FPrice3, FPrice4, FPostalWeight
Dim FMinCurrencyPrice ' (SS,7/11/12)
Dim FDiscountPercentage, FVATBand, FVATRate, FProductCode, FTotalItemsInBasket
Dim FStockInfo ' (SS,16/11/07)
Dim FNumInStock ' (SS,16/5/11)
Dim FProductID, FOptionsPrice, FOptionsWeight ' (SS,6/7/11)
' (SS,17/5/07) new settings
Dim FVATRegistered, FVATBandsEnabled, FPricesEnteredIncludeVAT, FUseVATFlagFromCountries
Dim FFourPricingFieldsEnabled, FUseDiscountFieldForSpecialOffers, FCustomPricingEnabled
Dim FAtFirstProduct, FAtLastProduct, FProductDescription, FProductDimensions
Dim FVATBands(10, 1), FVATBandCount, FVATLabel ' (SS,26/5/07) up to 10 bands
' (SS,30/5/07)
' (SS,27/5/09) replaced FAccountsCompulsory with FAccountTypes
Dim FAccountsEnabled, FAccountTypes, FUseEmailAddressForLogin
Dim FLargeThumbnailWidth, FLargeThumbnailHeight
Dim FSmallThumbnailWidth, FSmallThumbnailHeight ' (SS,19/3/09)
Dim FUseGetPicASP ' (SS,9/8/18)
' (SS,17/5/21) added FHearAboutUsEnabled, FHearAboutUsLabel
Dim FHearAboutUsList, FHearAboutUsEnabled, FHearAboutUsLabel
Dim FDefaultCountry, FIsBasketEmpty
' (SS,11/6/07) delivery settings moved here from global.asa
Dim FDeliveryUKLimit, FDeliveryUKBelow, FDeliveryUKAbove, FDeliveryUKText
Dim FDeliveryEULimit, FDeliveryEUBelow, FDeliveryEUAbove, FDeliveryEUText
Dim FDeliveryRWLimit, FDeliveryRWBelow, FDeliveryRWAbove, FDeliveryRWText
' (SS,6/5/21) delivery interpolation settings
Dim FDeliveryInterpolationEnabled, FDeliveryInterpolationStartThreshold, FDeliveryInterpolationEndThreshold
' (SS,11/6/07) store settings moved here from global.asa
Dim FStoreName, FStoreCompany, FStoreAddress1, FStoreAddress2, FStoreAddress3, FStoreTown, FStoreCounty, FStorePostcode, FStoreCountry
' (SS,22/12/20) added FStoreEORINo
' (SS,16/2/21) added FStoreXIEORINo
Dim FStoreTelephone, FStoreFax, FStoreEmail, FStoreVATRegNo, FStoreEORINo, FStoreXIEORINo, FStoreRegards, FStoreURL
' (SS,1/5/09) added following two
Dim FStorePlaceOfRegistration, FStoreRegisteredCompanyNo
' (SS,12/6/07)
Dim FHTMLEmailsEnabled
Dim FEmailOrderConfirmationBcc1, FEmailOrderConfirmationBcc2, FEmailOrderConfirmationFrom
Dim FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom
Dim FEmailSecurityCodeEnabled ' (SS,17/4/09)
Dim FEmailConfirmationIsVATReceipt ' (SS,14/6/10)
Dim FEmailUseMessageToCustomerForDespatch ' (SS,23/10/15)
' (SS,14/6/07) payment settings
' (SS,4/6/09) added FPaymentType3
' (SS,21/5/10) added FPaymentHideCurrency
' (SS,14/11/12) added FWorldPayMD5SecretKey
' (SS,2/10/14) added FEPDQPARAMVAR
Dim FPaymentType, FPaymentType2, FPaymentType3, FWorldPayInstallID, FWorldPayTestMode, FWorldPayMD5SecretKey, FPaymentHideCurrency
Dim FPayPalBusiness, FPayPalTestMode, FPayPalShippingAddressFlag
' (SS,26/4/18) NB. FEPDQClientID is same as PSPID, decided not to add a separate FEPDQPSPID because only one of these is required
Dim FEPDQClientID, FEPDQPassphrase, FEPDQChargeType, FEPDQMerchantDisplayName, FEPDQPARAMVAR
' (SS,26/4/18)
Dim FEPDQTestMode, FEPDQStringToHash
' (SS,26/1/15) added following for PayPal Express
Dim FPayPalExpressEnabled, FPayPalAPIUserName, FPayPalAPIPassword, FPayPalAPISignature
Dim FPayPalUKOnlyCheckout ' (SS,9/4/18)
Dim FPayPalExpressShowOnBasketPage ' (SS,23/4/18)
Dim FPayPalNonUKSurchargePercentage ' (SS,8/6/18)
Dim FPayPalPayLaterMessagesEnabled, FPayPalPayLaterMessagesClientID ' (SS,3/8/22)
' (SS,20/3/13) added Sage Pay variables
Dim FSagePayVendorName, FSagePayMode, FSagePayEncryptionKey
' (SS,23/3/18) added Payzone variables
Dim FPayzoneMerchantID, FPayzoneGatewayAccountPassword, FPayzonePreSharedKey
' (SS,28/3/18)
Dim FPayzoneStringToHash
' (SS,16/9/20) NetPay variables
' (SS,16/2/21) added FNetPayTemplate
Dim FNetPayMerchantID, FNetPayUserName, FNetPayEncryptionKey, FNetPayEncryptionIV, FNetPayIntegrationPassword, FNetPayOperationMode, FNetPayCrypt, FNetPayTemplate
' (SS,16/9/20) object variables used for NetPay encryption/decryption
Dim FoUTF8, FoB64Enc, FoB64Dec, FoAES, FoJSONRequest
' (SS,17/6/22) Clover variables
Dim FCloverStoreID, FCloverSharedSecret, FCloverTestMode, FCloverExtendedHash
' (SS,18/6/09)
Dim FWorldPaySiteSeal, FPayPalSiteSeal
' (SS,29/5/09)
' (SS,20/2/12) added FBankTransferDetailsEUR, FBankTransferDetailsUSD
' (SS,29/9/17) added FBankTransferDetailsGBP
Dim FAllowCheques, FAllowBankTransfers, FChequesPayableTo, FBankTransferDetails, FBankTransferDetailsEUR, FBankTransferDetailsUSD, FBankTransferDetailsGBP
' (SS,14/6/07)
Dim FBestSellersMax, FBestSellersPastDays, FBestSellersSortOrder
' (SS,14/6/07)
' (SS,12/5/11) added FProductsPerPageFixed
Dim FProductFilesEnabled, FMaxPicturesPerProduct, FProductsAcrossMax, FProductsDownMax, FProductsPerPageFixed, FProductsMaxSpecialOffer
' (SS,1/7/11)
Dim FProductAttributesEnabled, FProductOptionsEnabled
' (SS,18/10/18)
Dim FProductSubproductsEnabled
' (SS,16/1/13)
Dim FProductSearchWithoutDescFirst
' (SS,1/6/15)
Dim FProductSearchFullText
' (SS,10/6/14)
Dim FProductsShowReviewsImmediately
' (SS,26/8/15)
Dim FProductsSortByDefault
' (SS,14/6/07)
Dim FDevelopmentPassword, FAllowDifferentDeliveryAddress
Dim FAllowOutOfStockOrdering, FOutOfStockMessage ' (SS,19/7/10) replaced FAllowProductOrderIfNoStock with FAllowOutOfStockOrdering
Dim FShowIncVAT, FShowExcVAT, FSummaryListEnabled
Dim FMinCurrencyPricesEnabled ' (SS,7/11/12)
' (SS,14/6/07)
Dim FGroupsEnabled, FExtraSearchComboCategory, FExtraSearchComboBlankEntry, FShowProductsOnFullListCat
Dim FCategoryForSubcategoryMenu, FAddSpecialOffersToSubcategoryMenu, FCategoryListEnabled, FSubcategoryListEnabled
Dim FShowCategoryHeadingFooterIfEmpty ' (SS,12/10/15)
' (SS,17/6/07)
Dim FStartTimer, FEndTimer
' (SS,22/6/07)
Dim FWeightUnits, FShowWeightInEmail
' (SS,13/9/07)
Dim FUseAlternateColorForCategories, FDefaultTitle, FMulticurrencyEnabled, FAllowedCurrencies
' (SS,5/6/14)
' (SS,18/12/14) renamed FExchangeRateAdjustmentRatio to FExchangeRateAdjustmentRatioMain, added FExchangeRateAdjustmentRatioOther
Dim FMulticurrencyMethod, FExchangeRateAdjustmentRatioMain, FExchangeRateAdjustmentRatioOther
' (SS,14/11/07)
Dim FCurrencyDefaultCode, FCurrencyDefaultRate, FCurrencyDefaultSymbol, FCurrencyDefaultShowVAT, FCurrencyDefaultCountry
' (SS,14/11/07)
Dim FShowRelatedProductsInGroup, FSchemaVersion, FAllowCollection
Dim FAllowCollectionBasketPage ' (SS,15/2/21)
Dim FRelatedProductsOutOfStock ' (SS,18/5/12)
' (SS,16/11/07)
' (SS,11/11/10) added FValidateVATNumber
' (SS,12/12/12) added FVATIntraCommunityEmailAlertEnabled
Dim FShowStockInfo, FVATZeroForIntraCommunity, FVATIntraCommunityCountries, FValidateVATNumber, FVATIntraCommunityEmailAlertEnabled
' (SS,23/6/10)
' (SS,20/7/10) added FCustomStockInfoEnabled
' (SS,21/7/10) added FShowOutOfStockMessage
Dim FShowStockAmount, FStockAvailabilityEnabled, FStockAvailability, FStockAvailableDaysFrom, FStockAvailableDaysTo, FCustomStockInfoEnabled, FShowOutOfStockMessage
Dim FBackInStockNotificationsStaggeredDelay ' (SS,14/3/12)
Dim FBackInStockNotificationsStockMultiplier ' (SS,27/3/12)
' (SS,5/12/11)
Dim FStockAmountInfoSpec
' (SS,28/1/08) a special product name token e.g. *pallet*
Dim FProductNameTokensInBasket
' (SS,22/11/13) for special product prefixes e.g. "RMP-"
Dim FProductCodePrefixesInBasket, FProductCodePrefixesPrefix
' (SS,17/9/08) see SetDefaultCategory
Dim FDefaultCategory
' (SS,7/11/08) added following for google analytics
' (SS,27/11/13) added FGoogleAnalyticsDone
' (SS,12/2/15) added FGoogleAnalyticsUseDoubleClickDotNet
' (SS,3/3/16) added FGoogleAnalyticsCrossDomainTrackingList
' (SS,6/3/18) removed FEcommerceTrackingActivated, FGoogleAnalyticsDone
Dim FGoogleAnalyticsWebPropertyID, FGoogleAnalyticsUseDoubleClickDotNet, FEcommerceTrackingEnabled, FGoogleAnalyticsCrossDomainTrackingList
' (SS,10/11/08) added following for conversion tracking
' (SS,28/11/13) added FAdwordsConversionLabelRemarketing
' (SS,6/3/18) removed FAdWordsPurchaseConversionActivated
Dim FAdWordsConversionTrackingID, FAdWordsConversionLabelPurchase, FAdWordsConversionLabelNewAccount, FAdWordsConversionLabelRemarketing, FAdWordsNewAccountConversionActivated
' (SS,17/9/21) added FGoogleEnhancedConversionsEnabled
' (SS,20/6/23) added FGoogleEnhancedConversionsType
Dim FGoogleEnhancedConversionsEnabled, FGoogleEnhancedConversionsType
' (SS,5/10/23)
Dim FGoogleTagManagerContainerID
' (SS,1/10/14)
' (SS,9/10/17) replaced FFacebookConversionTrackingID with FFacebookPixelID, and added FFacebookPurchaseConversionActivated
' (SS,6/3/18) removed FFacebookPurchaseConversionActivated
Dim FFacebookPixelID
' (SS,3/8/23) added following for OptinMonster
' (SS,4/8/23) renamed to FOptinMonsterAccountID, FOptinMonsterUserID
Dim FOptinMonsterAccountID, FOptinMonsterUserID
' (SS,15/1/24) added following for Backon Analytics
Dim FBackonaAnalyticsEnabled, FBackonaAnalyticsDomain
' (SS,17/4/09)
' (SS,18/5/21) replaced FMobileEnabled with FAlternativePhoneEnabled
Dim FChooseDeliveryDate, FMaxDeliveryDays, FAlternativePhoneEnabled
' (SS,6/5/09)
' (SS,18/5/09) added FBackInStockNotificationsEnabled
' (SS,20/9/12) added FAutoLoginEnabled
Dim FVouchersEnabled, FProductReviewsEnabled, FBackInStockNotificationsEnabled, FAutoLoginEnabled
' (SS,15/1/13)
' (SS,17/1/13) added FCustomPagesEnabled
' (SS,14/1/20) added FReviewRequestsDaysNonUK
Dim FReviewRequestsEnabled, FReviewRequestsDays, FReviewRequestsDaysNonUK, FCustomPagesEnabled
' (SS,10/6/14)
Dim FGeoIPEnabled
' (SS,25/2/15)
Dim FSaveBasketEnabled
' (SS,13/3/15)
Dim FFroogleProductType, FGoogleShoppingDataFeedHeader, FGoogleShoppingDataFeedLine, FGoogleShoppingDataFeedHeaderDone
' (SS,21/10/16) new settings for address lookup and local mode
Dim FAddressLookupEnabled, FAddressLookupType, FAddressLookupAccountCode, FAddressLookupLocalModeOnly
Dim FLocalModeEnabled, FLocalModeExchangeReasons, FLocalModePaymentMethods
' (SS,20/3/18)
Dim FSMSEnabled
' (SS,18/4/19)
Dim FCancelledOrderEmailsEnabled
' (SS,21/4/21)
Dim FDespatchDatesEnabled
' (SS,31/7/09)
Dim FCheckoutAlertMessage
' (SS,26/1/16)
Dim FCheckoutConfirmTermAndConditions
' (SS,10/11/09)
Dim FNotifyCustomerRecordUpdate, FCustomerFieldChange, FCustomerDetailsOld, FCustomerDetailsNew, FCustomerFieldsChangedList
' (SS,25/2/10)
Dim FProductImageCount
' (SS,17/3/10)
Dim FTranslationEnabled, FTranslationLanguage, FTransArrayEnglish(), FTransArrayLanguage()
' (SS,17/5/10)
Dim FButtonType
' (SS,20/2/14)
Dim FAddToBasketAlertType
' (SS,15/8/14)
Dim FResponsiveWebDesign
' (SS,27/9/19)
Dim FRWDFramework
' (SS,24/3/20)
Dim FOrderingSuspended
' (SS,5/6/22)
Dim FAppStatsEnabled
' (SS,25/5/10)
Dim FVATNumberExample
' (SS,13/5/11)
Dim FShowRelatedProductsCalled, FViewOtherProductsCalled
' (SS,16/5/11)
Dim FMaxRecentlyViewed
' (SS,17/6/11)
Dim FProductPageTabs
' (SS,28/7/11)
Dim FDefaultGroup
' (SS,1/8/11)
Dim FAlwaysDefaultGroupForMenu, FIncludeGroupInHTMLTitleTag
' (SS,6/9/12)
Dim FFeefoFileName
' (SS,17/1/13)
Dim FPageExists
' (SS,20/3/13) for SagePay
Dim FSagePayCrypt
' (SS,28/11/13)
Dim FRemarketingTagTotalValue, FRemarketingTagProductIDs
' (SS,18/2/14)
Dim FPageRedirectURL
' (SS,5/6/22)
Dim FRedirectSet
' (SS,9/10/14)
Dim FDeliveryInfo
' (SS,22/4/21)
Dim FDeliveryOptionLabel
' (SS,20/10/14)
Dim FReviewsType, FFeefoLogon, FFeefoFTPHost, FFeefoFTPUser, FFeefoFTPPassword
' (SS,18/5/17)
Dim FTrustpilotAFSEmailAddress
' (SS,12/5/21)
Dim FTrustpilotReviewsVisible, FTrustpilotSiteName
' (SS,10/4/15)
Dim FUseDeliveryPostcodes
' (SS,21/5/15)
Dim FMultiMenuType
' (SS,11/11/16)
Dim FMultiMenuTopLevelItemCount
' (SS,30/7/15)
Dim FHashCommentLineOptions
' (SS,19/10/15)
Dim FProductNavigationEnabled
' (SS,15/4/16)
Dim FBasketOutOfStockMessage
' (SS,8/4/119)
Dim FImageCreatedInCache
' (SS,26/1/21)
Dim FCallbackOrderNo
' (SS,22/2/21)
Dim FScriptList
' (SS,7/5/21)
Dim FAdjustedTotalWeight
' (SS,6/6/22)
Dim FHTMLCache
' (SS,13/10/23) new Google Tag Manager object
Dim oGTM
Initialise
' (SS,30/8/04) runs code to be run before all templates
Sub Initialise
FStartTimer = Timer
gsITP_ErrorMessage = ""
FPopUpMessage = "" ' (SS,20/2/14)
' (SS,20/6/11) dbfunctions.pas function, to clear the default class="form" used by combo boxes
' setting no class will cause it to use the browser default "select" instead of ".form"
SetSelectClass("")
'SetDebugLevel 2
'DebugOn
OpenDatabase ' (SS,26/5/07) now only one open is done, close is done in Finalise sub
' (SS,18/5/07) get settings from settings table
GetSettings
' (SS,18/4/19) set website URL in Application, used by global.asa which doesn't have access to Request.ServerVariables and is used to fetch a web page
' following must be after GetSettings
If IsEmpty(Application("WebsiteURL")) Then
Application("WebsiteURL") = Iif(LCase(Request.ServerVariables("HTTPS")) = "on", "https://", "http://") & Request.ServerVariables("SERVER_NAME")
Application("CancelledOrderEmailsEnabled") = FCancelledOrderEmailsEnabled
End If
' (SS,14/11/07) do the restructuring if required
CheckSchema
' (SS,25/11/08) check and change the VAT rate if necessary
CheckVAT
' (SS,26/5/07) moved following code here from inc-template-main.asp
' if password has been set up and not authenticated then get password otherwise continue with normal stuff '
' (SS,6/6/07) added GetScriptName = "products.asp" to allow pages other than products.asp to bypass the password dialog
' necessary to prevent worldpay and other call backs from failing
If GetScriptName = "products.asp" And GetDevelopmentPassword <> "" And Not Session("Authenticated") Then
If UCase(CleanRequestForm("password")) = GetDevelopmentPassword Then
Session("Authenticated") = True
Else
Finalise ' make sure database is closed
Response.Redirect("getpassword.asp")
End If
End If
' (SS,12/4/11) process redirections for product, category and subcategory
' if there is a redirection then this process calls Finalise and does a Response.Redirect
ProcessRedirections
' get SessionID in FSessionID, in making direct payment then original session is used
' (SS,19/5/21) commented out following redundant code, all site are now secure and we don't use this direct payment method anymore
'If CleanRequestForm("DP_SessionID") <> "" Then
' Session("MainSession") = CleanRequestForm("DP_SessionID")
' CopyMainSessionToSecureSession
'End If
'If Session("MainSession") <> "" Then
' FSessionID = Session("MainSession")
'Else
' FSessionID = Session.SessionID ' (SS,12/8/05) moved here from dbfunctions.asp
'End If
' (SS,19/5/21) just kept this line from above
FSessionID = Session.SessionID ' (SS,12/8/05) moved here from dbfunctions.asp
' add referrer to database
' (SS,11/9/15) removed, no longer used
'If Not Session("ReferrerAdded") Then
' AddReferrerToDatabase
' Session("ReferrerAdded") = True
'End If
strGroupFromMenu = "" ' (SS,12/2/05)
' (SS,9/6/14) gets/sets the currency and delivery country from/to cookies using Geo IP, saves to cookie if applicable
SetCurrencyAndDeliveryCountryCookieFromGeoIP
' (SS,20/2/12) save delivery country in cookie, if necessary, this must be done before html is sent
' only if Request("cmd") = "recalculate" and CleanRequestForm("DeliveryCountry") <> ""
SetDeliveryCountryCookie
' (SS,18/9/06) get currency settings
' GetLatestExchangeRatesIfNeeded ' (SS,9/6/14) removed no longer used, task schedule does this
SetCurrencyCode("") ' (SS,28/10/09) added "" parameter
GetCurrencyExchangeRate
' (SS,3/2/23) to cache charge VAT flag result, it was causing lots of unnecessary repeated queries before, default to no country which forces a lookup first time
FChargeVATFlagCountry = ""
FChargeVATFlag = True
' (SS,17/3/10) set up translation, may read from common database
SetUpTranslation
GetVATBands ' (SS,26/5/07) puts VAT Bands into array if required
FIsBasketEmpty = GetIsBasketEmpty ' (SS,5/6/07) sets FIsBasketEmpty for IsBasketEmpty function
FDefaultCategory = "" ' (SS,17/9/08)
' (SS,6/3/18) removed following
'FGoogleAnalyticsDone = False ' (SS,27/11/13)
'FEcommerceTrackingActivated = False ' (SS,10/11/08)
'FAdWordsPurchaseConversionActivated = False ' (SS,12/11/08)
FAdWordsNewAccountConversionActivated = False ' (SS,12/11/08)
FShowRelatedProductsCalled = False ' (SS,13/5/11)
FViewOtherProductsCalled = False ' (SS,13/5/11)
' (SS,1/8/11)
SetBreadcrumbCategory
SetBreadcrumbSubcategory
FProductCode = "" ' (SS,15/2/12) now used in new SetProductCode and GetProductCode
DoAutoLogin ' (SS,20/9/12) automatic log in using cookies
' (SS,22/3/13) used to only show a payment type for payment provider testing, where payment method is only shown if website reached via ?pptest=true (payment provider test)
CheckPaymentProviderTestMode
If FunctionExists("CustomInitialise") Then CustomInitialise ' (SS,17/9/08)
FPageExists = "" ' (SS,17/1/13) empty string effectively means not set, first call to PageExists functions will set this to True or False
FPageRedirectURL = "" ' (SS,18/2/14)
FRedirectSet = False ' (SS,5/6/22)
' (SS,6/9/14) for RWD i.e. Bootstrap - change the default class for select combos
If IsRWD Then SetSelectClass("form-control")
FDeliveryInfo = "" ' (SS,9/10/14)
' (SS,4/8/15) clear the hash comment line options, which can pass on from one token to the another, i.e. inherit from parent token or page
' this is to prevent having to add it to every token, e.g. the no convert newline feature
SetHashCommentLineOptions ""
' (SS,19/10/15) production navigation enabled by default, can be disabled by custom utils
EnableProductNavigation
' (SS,15/4/16)
ClearBasketOutOfStockMessage
' (SS,7/10/16)
CheckLocalMode
' (SS,1/12/16)
' (SS,16/8/18) changed from 5 to "5" (integer to string) because it wasn't working i.e. was default to 9 instead, changing to a string fixed it
SetPriorityDefault "5"
' (SS,26/1/21)
FCallbackOrderNo = ""
' (SS,22/2/21)
FScriptList = ""
' (SS,7/5/21)
FAdjustedTotalWeight = 0
' (SS,13/10/23) create and initialise Google Tag Manager object
Set oGTM = New GTMDef.Init(FGoogleTagManagerContainerID, GetStoreName)
' (SS,15/1/24)
If FBackonaAnalyticsEnabled Then
oGTM.BackonaAnalyticsEnabled = True
oGTM.BackonaAnalyticsDomain = FBackonaAnalyticsDomain
End If
End Sub
' (SS,2/3/18) to allow items to be added at the start of the head tag, call to HTMLHeadStart needs to in the correct place in main template
' DisableCache moved here and call to DisableCache in inc-template-main.asp replaced with HTMLHeadStart
' (SS,4/10/23) added DisableIndexingInDevMode (new sub in dbfunctions.asp) to prevent indexing in Dev mode
Sub HTMLHeadStart
DisableCache
DisableIndexingInDevMode ' (SS,4/10/23)
End Sub
' (SS,2/3/18) to allow items to be added just before the end of the head tag, call to HTMLHeadStart needs to in the correct place in main template
' good place for tracking code
Sub HTMLHeadEnd
DoWebAnalytics
End Sub
' (SS,19/2/21)
Sub HTMLBodyStart
End Sub
' (SS,19/2/21)
Sub HTMLBodyEnd
' call ShowScripts to render the scripts added using AddScript
' this allows javaScript that refers to jQuery to be placed later on the page, to allow jQuery library to be included as later as possible
' jQuery library must be included before call to HTMLBodyEnd in inc-template-main.asp
' without this the code fails with reference error $ is not defined
ShowScripts
End Sub
' (SS,22/2/21) adds to list of script to show later via HTMLBodyEnd
' this allows scripts that depend on jQuery to be placed after loading jQuery, allowing the jQuery library to be placed as later as possible
Sub AddScript(AScriptName)
' if not already added to list then add it
If InStr(1, "," + FScriptList + ",", "," + AScriptName + ",", vbTextCompare) = 0 Then
If FScriptList <> "" Then FScriptList = FScriptList + ","
FScriptList = FScriptList + AScriptName
End If
End Sub
' (SS,22/2/21) called from HTMLBodyEnd
Sub ShowScripts
' if there are scripts in the list then add them
If FScriptList <> "" Then
Dim LScripts, LScript
LScripts = Split(FScriptList, ",")
Dim LSubRef
For Each LScript In LScripts
Response.Write "<!-- START SCRIPT: " & LScript & " -->" ' header comment
' discovered GetRef, allow use of Sub instead of Eval, could have used Eval but the routines would then need to be functions that don't return a value
Set LSubRef = GetRef(LScript) ' get ref to the sub
LSubRef ' call the sub
Response.Write "<!-- END SCRIPT: " & LScript & " -->" & NL & NL ' footer comment
Next
Set LSubRef = Nothing
End If
End Sub
' (SS,26/5/07) called from end of inc-template-main.asp
Sub Finalise
' (SS,18/11/13) added "If ScriptIsProducts Then" to ensure Google Analytics stuff is only done on products.asp page
' i.e. not on order-details.asp (order confirmation), callback pages and ajax.asp etc. pages
' (SS,27/11/13) removed "If ScriptIsProducts Then" because DoGoogleAnalytics does it, added False parameter for non-async version if async not done, it also does adword conversion in sync mode
' (SS,2/3/18) moved DoGoogleAnalytics and DoFacebookPixel to new HTMLHeadEnd which is called earlier
' DoGoogleAdWordsRemarketingTag now taken care of by DoGoogleAnalytics
'DoGoogleAnalytics(False) ' (SS,10/11/08)
'If ScriptIsProducts Then DoGoogleAdWordsRemarketingTag ' (SS,28/11/13)
'DoFacebookPixel ' (SS,10/10/17) does these tracking and conversion
' (SS,6/3/18) anything to do at the end for Web Analytics e.g. update the conversion_tracking_log with payment method
FinaliseWebAnalytics
' (SS,17/4/18) removed
'DoPaymentRedirection ' (SS,20/11/08)
If FunctionExists("CustomFinalise") Then CustomFinalise ' (SS,10/10/14)
' (SS,3/6/22) must be before CloseDatabase because it's needed by CloseDatabase when saving the stats
If AppStatsEnabled Then SetPageTypeForAppStats
CloseDatabase
ShowAlertMessage
ShowPopUpMessage ' (SS,20/2/14)
FinaliseDBFunctions ' (SS,27/05/10)
If ScriptIsProducts Then ShowTimer ' (SS,20/2/13) moved to Sub ShowTimer ' (SS,18/11/13) now only shown in products.asp page
' (SS,11/5/22) if debug enable then show current date/time to help with debugged cache issues
If DEBUG_ENABLED then Response.Write "### " & Now() & " ###"
DoPageRedirection ' (SS,18/2/14) different to DoRedirect because it allows the page to finish and get this far
End Sub
' (SS,3/6/22) collects stats to measure performance of web pages, including time, queries
' passe onto SetAppStat in dbfunction.asp
Sub SetPageTypeForAppStats
Dim LPageType
' determine page type: home, basket, product, category, checkouk, search
' if not products.asp then it's set to the script name
If Not ScriptIsProducts Then
LPageType = "external"
ElseIf IsRedirect Then ' this has priority over others
LPageType = "redirect"
ElseIf IsSearchPage Then
LPageType = "search"
ElseIf IsProductDetailsPage Then
LPageType = "product"
ElseIf IsCategoryPage Then
LPageType = "category"
ElseIf IsSubcategoryPage Then
LPageType = "subcategory"
ElseIf IsBasketPage Then
LPageType = "basket"
ElseIf InCheckout Then
LPageType = "checkout"
ElseIf IsHomePage Then
LPageType = "home"
Else
LPageType = "other"
End If
' sets in dbfunction.asp to save when database is closed
SetAppStatsOn
SetAppStat "PageType", LPageType
SetAppStat "ScriptName", GetScriptName
End Sub
' (SS,9/4/19) returns time taken in seconds to 3 dp, called from ShowTimer
Function GetTimer
FEndTimer = Timer
GetTimer = FormatNumber(FEndTimer - FStartTimer, 3, True) & " secs"
End Function
' (SS,20/2/13) made into routine to allow calling from elsewhere for debugging purposes
' (SS,9/4/19) modified to call GetTimer, i.e. moved some code to GetTimer
Sub ShowTimer
' (SS,27/05/10) added following as HTML comment
Response.Write("<!-- " & GetTimer & " -->")
End Sub
' (SS,5/7/11) new simpler finalise especially for Ajax, which doesn't have analytics, redirection, alerts, and timer
Sub FinaliseAjax
CloseDatabase
FinaliseDBFunctions
End Sub
' (SS,1/7/11) all redirects go through here, also Finalise runs before the redirect takes place
Sub DoRedirect(AURL, AIsPermanent)
SetRedirect ' (SS,5/6/22)
' do the permanent redirection
Finalise ' make sure we close the database because Response.End will end the script
If AIsPermanent Then
Response.Status = "301 Moved Permanently"
Response.AddHeader "Location", AURL
Response.End
Else
Response.Redirect AURL
End If
End Sub
' (18/2/14)
Sub SetPageRedirection(ARedirectURL)
' (SS,11/5/22) in debug enabled then don't redirect
If DEBUG_ENABLED then
ShowDebug "SetPageRedirection called with " & ARedirectURL
Exit Sub
End If
FPageRedirectURL = ARedirectURL
SetRedirect ' (SS,5/6/22)
End Sub
' (SS,18/2/14) if redirection requested then do it
Sub DoPageRedirection
If FPageRedirectURL <> "" Then Response.Redirect FPageRedirectURL
End Sub
' (SS,5/6/22)
Sub SetRedirect
FRedirectSet = True
End Sub
' (SS,5/6/22) returns true if redirecting, used by collect stats for page type
Function IsRedirect
IsRedirect = FRedirectSet
End Function
' (SS,18/5/07) get settings from settings file
Sub GetSettings
Dim LGroupName, LFieldName, LFieldValue
' set defaults
FVATRegistered = True
FVATBandsEnabled = False
FVATRate = 0
FVATZeroForIntraCommunity = False ' (SS,16/11/07)
FVATIntraCommunityCountries = "" ' (SS,16/11/07)
FValidateVATNumber = False ' (SS,11/11/10) default to not validating VAT number
FVATIntraCommunityEmailAlertEnabled = False ' (SS,12/12/12)
FPricesEnteredIncludeVAT = True
FFourPricingFieldsEnabled = False
FUseDiscountFieldForSpecialOffers = False
FCustomPricingEnabled = False
FUseVATFlagFromCountries = False ' (SS,11/5/09) missed from before
FWeightUnits = "" ' (SS,22/6/07)
FShowWeightInEmail = False ' (SS,22/6/07)
' (SS,30/5/07)
FAccountsEnabled = False
' (SS,27/5/09) replaced FAccountsCompulsory with FAccountTypes, and False with AT_COMPULSORY
FAccountTypes = AT_COMPULSORY
FUseEmailAddressForLogin = True
' delivery defaults
FDeliveryType = DT_ORIGINAL
FIsDeliveryByPrice = False
FIsDeliveryByWeight = False
FIsDeliveryByWeightFlagged = False ' (SS,22/10/08)
FIsDeliveryByWeightNonFlagged = False ' (SS,22/10/08)
FIsDeliverySpecialRegionByPrice = False
FIsDeliverySpecialRegionByWeight = False
FChooseDeliveryDate = False ' (SS,17/4/09)
FMaxDeliveryDays = 10 ' (SS,17/4/09)
FUseDeliveryPostcodes = False ' (SS,10/4/15)
FShowDeliveryAddToExistingOrder = True ' (SS,25/9/20)
' (SS,6/5/21)
FDeliveryInterpolationEnabled = False
FDeliveryInterpolationStartThreshold = 0
FDeliveryInterpolationEndThreshold = 0
' picture defaults
FLargeThumbnailWidth = LARGE_THUMBNAIL_WIDTH
FLargeThumbnailHeight = LARGE_THUMBNAIL_HEIGHT
' (SS,19/3/09)
FSmallThumbnailWidth = SMALL_THUMBNAIL_WIDTH
FSmallThumbnailHeight = SMALL_THUMBNAIL_HEIGHT
' (SS,9/8/18)
FUseGetPicASP = True
' default country
FDefaultCountry = ""' (SS,11/7/07) was United Kingdom"
' default emails
FHTMLEmailsEnabled = False
FEmailOrderConfirmationBcc1 = ""
FEmailOrderConfirmationBcc2 = ""
FEmailOrderConfirmationFrom = ""
FEmailContactTo = ""
FEmailContactBcc1 = ""
FEmailContactBcc2 = ""
FEmailContactFrom = ""
FEmailSecurityCodeEnabled = False ' (SS,17/4/09)
FEmailConfirmationIsVATReceipt = False ' (SS,14/6/10)
FEmailUseMessageToCustomerForDespatch = False ' (SS,23/10/15)
' payment details
FPaymentType = "" ' (SS,17/4/18) modified from "DIRECT" to ""
FPaymentType2 = "" ' (SS,28/9/07)
FPaymentType3 = ""' (SS,4/6/09)
FPaymentHideCurrency = False ' (SS,21/5/10)
FWorldPayInstallID = ""
FWorldPayTestMode = ""
FWorldPayMD5SecretKey = "" ' (SS,14/11/12)
FPayPalBusiness = ""
FPayPalTestMode = ""
FPayPalShippingAddressFlag = ""
FPayPalUKOnlyCheckout = False ' (SS,9/4/18)
FPayPalExpressShowOnBasketPage = True ' (SS,23/4/18)
FPayPalNonUKSurchargePercentage = 0 ' (SS,23/4/18)
' (SS,26/1/15)
FPayPalExpressEnabled = False
FPayPalAPIUserName = ""
FPayPalAPIPassword = ""
FPayPalAPISignature = ""
' (SS,3/8/22)
FPayPalPayLaterMessagesEnabled = False
FPayPalPayLaterMessagesClientID = ""
FEPDQClientID = ""
FEPDQPassphrase = ""
FEPDQChargeType = ""
FEPDQMerchantDisplayName = "" ' (SS,10/5/12)
FEPDQPARAMVAR = "" ' (SS,2/10/14)
FEPDQTestMode = False ' (SS,26/4/18)
' (SS,20/3/13)
FSagePayVendorName = ""
FSagePayMode = ""
FSagePayEncryptionKey = ""
' (SS,23/3/18)
FPayzoneMerchantID = ""
FPayzoneGatewayAccountPassword = ""
FPayzonePreSharedKey = ""
' (SS,16/9/20)
FNetPayMerchantID = ""
FNetPayUserName = ""
FNetPayEncryptionKey = ""
FNetPayEncryptionIV = ""
FNetPayIntegrationPassword = ""
FNetPayOperationMode = ""
FNetPayCrypt = ""
FNetPayTemplate = "" ' (SS,16/2/21)
' (SS,17/6/22)
FCloverStoreID = ""
FCloverSharedSecret = ""
FCloverTestMode = False
' (SS,18/6/09)
FWorldPaySiteSeal = ""
FPayPalSiteSeal = ""
' (SS,29/5/09)
FAllowCheques = False
FAllowBankTransfers = False
FChequesPayableTo = ""
FBankTransferDetails = ""
' (SS,20/2/12)
FBankTransferDetailsEUR = ""
FBankTransferDetailsUSD = ""
FBankTransferDetailsGBP = "" ' (SS,29/9/17)
' best sellers
FBestSellersMax = 5
FBestSellersPastDays = 365
FBestSellersSortOrder = ""
' products
FProductFilesEnabled = False
FMaxPicturesPerProduct = 3
FProductsAcrossMax = 0
FProductsDownMax = 0
FProductsMaxSpecialOffer = 5
FShowIncVAT = False
FShowExcVAT = True
FMinCurrencyPricesEnabled = False ' (SS,7/11/12)
FSummaryListEnabled = False
FProductsPerPageFixed = False ' (SS,12/5/11)
FMaxRecentlyViewed = MAX_RECENTLY_VIEWED ' (SS,16/5/11)
FProductPageTabs = False ' (SS,17/6/11)
FProductAttributesEnabled = False ' (SS,1/7/11)
FProductOptionsEnabled = False ' (SS,1/7/11)
FProductSubproductsEnabled = False ' (SS,18/10/18)
FProductSearchWithoutDescFirst = False ' (SS,16/1/13)
FProductSearchFullText = False ' (SS,1/6/15)
FProductsShowReviewsImmediately = False ' (SS,10/6/14)
FProductsSortByDefault = "" ' (SS,26/8/15)
' categories
FGroupsEnabled = False
FExtraSearchComboCategory = ""
FExtraSearchComboBlankEntry = "--Select--"
FShowProductsOnFullListCat = True
FCategoryForSubcategoryMenu = ""
FAddSpecialOffersToSubcategoryMenu = False
FCategoryListEnabled = True
FSubcategoryListEnabled = True
FUseAlternateColorForCategories = False
FDefaultGroup = GROUP_MAIN ' (SS,28/7/11)
FAlwaysDefaultGroupForMenu = False ' (SS,1/8/11)
FIncludeGroupInHTMLTitleTag = True ' (SS,2/8/11)
FShowCategoryHeadingFooterIfEmpty = False ' (SS,12/10/15)
' other
FDevelopmentPassword = ""
FAllowDifferentDeliveryAddress = True
' FAllowProductOrderIfNoStock = False ' (SS,19/7/10) removed, replaced by FAllowOutOfStockOrdering used on a by product basis
FOutOfStockMessage = "Out of Stock"
' checkout
' (SS,18/5/21) replaced FMobileEnabled with FAlternativePhoneEnabled
FAlternativePhoneEnabled = False ' (SS,17/4/09)
' (SS,13/9/07)
FDefaultTitle = ""
FMulticurrencyEnabled = False
FMulticurrencyMethod = "Original" ' (SS,5/6/14)
FAllowedCurrencies = "GBP,USD,EUR"
FExchangeRateAdjustmentRatioMain = "1" ' (SS,5/6/14) ' (SS,18/12/14) renamed from FExchangeRateAdjustmentRatio to FExchangeRateAdjustmentRatioMain
FExchangeRateAdjustmentRatioOther = "1" ' (SS,18/12/14)
' (SS,14/11/07)
FCurrencyDefaultCode = DEFAULT_CURRENCY_CODE
FCurrencyDefaultRate = DEFAULT_CURRENCY_RATE
FCurrencyDefaultSymbol = DEFAULT_CURRENCY_SYMBOL
FCurrencyDefaultShowVAT = DEFAULT_CURRENCY_SHOW_VAT
FCurrencyDefaultCountry = DEFAULT_CURRENCY_COUNTRY
' (SS,14/11/07)
FShowRelatedProductsInGroup = False
FSchemaVersion = 1
FAllowCollection = False
FAllowCollectionBasketPage = False ' (SS,15/2/21)
' (SS,18/5/12)
FRelatedProductsOutOfStock = ""
' (SS,16/11/07)
FShowStockInfo = False
FShowStockAmount = True ' (SS,25/6/10)
FCustomStockInfoEnabled = False ' (SS,20/7/10)
FShowOutOfStockMessage = False ' (SS,21/7/10)
FStockAmountInfoSpec = "" ' (SS,5/12/11)
' (SS,23/6/10)
FStockAvailabilityEnabled = False
FStockAvailability = ""
FStockAvailableDaysFrom = ""
FStockAvailableDaysTo = ""
FBackInStockNotificationsStaggeredDelay = 0 ' (SS,14/3/12)
FBackInStockNotificationsStockMultiplier = 1 ' (SS,27/4/12)
' (SS,7/11/08)
FGoogleAnalyticsWebPropertyID = ""
FEcommerceTrackingEnabled = False
FGoogleAnalyticsUseDoubleClickDotNet = False ' (SS,12/2/15)
' (SS,3/3/16)
FGoogleAnalyticsCrossDomainTrackingList = ""
' (SS,11/11/08)
FAdWordsConversionTrackingID = ""
FAdWordsConversionLabelPurchase = ""
FAdWordsConversionLabelNewAccount = ""
FAdWordsConversionLabelRemarketing = "" ' (SS,28/11/13)
FGoogleEnhancedConversionsEnabled = False ' (SS,17/9/21)
FGoogleEnhancedConversionsType = "" ' (SS,20/6/23) i.e. default "A" for "address" (not "home_address")
FGoogleTagManagerContainerID = "" ' (SS,5/10/23)
' FFacebookConversionTrackingID = "" ' (SS,1/10/14)
' (SS,9/10/17) replaced above with FFacebookPixelID
FFacebookPixelID = ""
' (SS,6/3/18) removed following
' FFacebookPurchaseConversionActivated = False ' (SS,9/10/17)
' (SS,3/8/23) added following for OptinMonster
FOptinMonsterAccountID = ""
FOptinMonsterUserID = ""
' (SS,15/1/24) added following for Backona
FBackonaAnalyticsEnabled = False
FBackonaAnalyticsDomain = ""
' (SS,6/5/09)
FVouchersEnabled = False
FProductReviewsEnabled = False
' (SS,20/9/12)
FAutoLoginEnabled = False
' (SS,15/1/13)
FReviewRequestsEnabled = False
FReviewRequestsDays = 7
FReviewRequestsDaysNonUK = 0 ' (SS,14/1/20) 0 means use the same value as FReviewRequestsDays
FCustomPagesEnabled = False ' (SS,17/1/13)
FGeoIPEnabled = False ' (SS,10/6/14)
FSaveBasketEnabled = False ' (SS,25/2/15)
FCancelledOrderEmailsEnabled = False ' (SS,19/4/19)
' (SS,21/4/21)
FDespatchDatesEnabled = False
' (SS,18/5/09)
FBackInStockNotificationsEnabled = False
' (SS,31/7/09)
FCheckoutAlertMessage = ""
' (SS,26/1/16)
FCheckoutConfirmTermAndConditions = False
' (SS,10/11/09)
FNotifyCustomerRecordUpdate = False
' (SS,17/3/10) default to translation disabled
FTranslationEnabled = False
FTranslationLanguage = ""
' (SS,17/5/10)
FButtonType = BT_ORIGINAL
' (SS,15/8/14)
FResponsiveWebDesign = False
FRWDFramework = "" ' (SS,27/9/19)
' (SS,24/3/20)
FOrderingSuspended = False
' (SS,5/6/22)
FAppStatsEnabled = False
' (SS,20/10/14)
FReviewsType = ""
FFeefoLogon = ""
FFeefoFTPHost = ""
FFeefoFTPUser = ""
FFeefoFTPPassword = ""
' (SS,18/5/17)
FTrustpilotAFSEmailAddress = ""
' (SS,12/5/21)
FTrustpilotReviewsVisible = False
FTrustpilotSiteName = ""
' (SS,13/3/15)
FFroogleProductType = ""
' (SS,21/10/16)
FAddressLookupEnabled = False
FAddressLookupType = ""
FAddressLookupAccountCode = ""
FAddressLookupLocalModeOnly = True
FLocalModeEnabled = False
FLocalModeExchangeReasons = ""
FLocalModePaymentMethods = ""
' (SS,20/3/18)
FSMSEnabled = False
' (SS,17/5/21) added following
FHearAboutUsList = ""
FHearAboutUsEnabled = False
FHearAboutUsLabel = "Hear about us"
OpenQuery("SELECT * FROM settings")
Do While Not EndOfQuery
LGroupName = GetFieldValue("GroupName")
LFieldName = GetFieldValue("FieldName")
LFieldValue = NB(GetFieldValue("FieldValue"))
If LGroupName = "Application" Then
' price settings
If LFieldName = "VATRegistered" Then FVATRegistered = StrToBool(LFieldValue)
If LFieldName = "VATBandsEnabled" Then FVATBandsEnabled = StrToBool(LFieldValue)
If LFieldName = "VATRate" Then FVATRate = NZ(LFieldValue)
If LFieldName = "VATZeroForIntraCommunity" Then FVATZeroForIntraCommunity = StrToBool(LFieldValue) ' (SS,16/11/07)
If LFieldName = "VATIntraCommunityCountries" Then FVATIntraCommunityCountries = LFieldValue ' (SS,16/11/07)
If LFieldName = "ValidateVATNumber" Then FValidateVATNumber = LFieldValue ' (SS,11/11/10)
If LFieldName = "VATIntraCommunityEmailAlertEnabled" Then FVATIntraCommunityEmailAlertEnabled = LFieldValue ' (SS,12/12/12)
If LFieldName = "PricesEnteredIncludeVAT" Then FPricesEnteredIncludeVAT = StrToBool(LFieldValue)
If LFieldName = "FourPricingFieldsEnabled" Then FFourPricingFieldsEnabled = StrToBool(LFieldValue)
If LFieldName = "UseDiscountFieldForSpecialOffers" Then FUseDiscountFieldForSpecialOffers = StrToBool(LFieldValue)
If LFieldName = "CustomPricingEnabled" Then FCustomPricingEnabled = StrToBool(LFieldValue)
If LFieldName = "UseVATFlagFromCountries" Then FUseVATFlagFromCountries = StrToBool(LFieldValue)
If LFieldName = "WeightUnits" Then FWeightUnits = LFieldValue ' (SS,22/6/07)
If LFieldName = "ShowWeightInEmail" Then FShowWeightInEmail = StrToBool(LFieldValue) ' (SS,22/6/07)
' other settings
If LFieldName = "AccountsEnabled" Then FAccountsEnabled = StrToBool(LFieldValue)
If LFieldName = "AccountTypes" Then FAccountTypes = LFieldValue ' (SS,27/5/09) was FAccountsCompulsory
If LFieldName = "UseEmailAddressForLogin" Then FUseEmailAddressForLogin = StrToBool(LFieldValue)
If LFieldName = "HearAboutUsList" Then FHearAboutUsList = NB(GetFieldValue("MemoValue"))
If LFieldName = "DefaultCountry" Then FDefaultCountry = LFieldValue
If LFieldName = "DevelopmentPassword" Then FDevelopmentPassword = UCase(LFieldValue)
' (SS,19/7/10) following replaced, setting still used as a default in ShoppingAdmin app
' If LFieldName = "AllowProductOrderIfNoStock" Then FAllowProductOrderIfNoStock = StrToBool(LFieldValue)
If LFieldName = "OutOfStockMessage" Then FOutOfStockMessage = LFieldValue
If LFieldName = "ShowStockInfo" Then FShowStockInfo = StrToBool(LFieldValue) ' (SS,16/11/07)
If LFieldName = "ShowStockAmount" Then FShowStockAmount = StrToBool(LFieldValue) ' (SS,25/6/10)
If LFieldName = "StockAmountInfoSpec" Then FStockAmountInfoSpec = Trim(LFieldValue) ' (SS,5/12/11)
If LFieldName = "CustomStockInfoEnabled" Then FCustomStockInfoEnabled = StrToBool(LFieldValue) ' (SS,20/7/10)
If LFieldName = "ShowOutOfStockMessage" Then FShowOutOfStockMessage = StrToBool(LFieldValue) ' (SS,21/7/10)
If LFieldName = "StockAvailableDaysFrom" Then FStockAvailableDaysFrom = LFieldValue ' (SS,23/6/10)
If LFieldName = "StockAvailableDaysTo" Then FStockAvailableDaysTo = LFieldValue ' (SS,23/6/10)
If LFieldName = "BackInStockNotificationsStaggeredDelay" Then FBackInStockNotificationsStaggeredDelay = LFieldValue ' (SS,14/3/12)
If LFieldName = "BackInStockNotificationsStockMultiplier" Then FBackInStockNotificationsStockMultiplier = LFieldValue ' (SS,27/4/12)
If LFieldName = "AllowDifferentDeliveryAddress" Then FAllowDifferentDeliveryAddress = StrToBool(LFieldValue) ' (SS,17/3/09) added this setting, somehow missed it previously
' (SS,13/9/07)
If LFieldName = "DefaultTitle" Then FDefaultTitle = LFieldValue
' (SS,14/11/07)
If LFieldName = "ShowRelatedProductsInGroup" Then FShowRelatedProductsInGroup = StrToBool(LFieldValue)
If LFieldName = "SchemaVersion" Then FSchemaVersion = CDbl(LFieldValue)
' (SS,18/5/12)
If LFieldName = "RelatedProductsOutOfStock" Then FRelatedProductsOutOfStock = LFieldValue
' (SS,17/3/10)
If LFieldName = "TranslationEnabled" Then FTranslationEnabled = StrToBool(LFieldValue)
If LFieldName = "TranslationLanguage" Then FTranslationLanguage = LFieldValue
' (SS,17/5/10)
If LFieldName = "ButtonType" Then FButtonType = LFieldValue
' (SS,20/2/14)
If LFieldName = "AddToBasketAlertType" Then FAddToBasketAlertType = LFieldValue
' (SS,15/8/14)
If LFieldName = "ResponsiveWebDesign" Then FResponsiveWebDesign = LFieldValue
' (SS,27/9/19)
If LFieldName = "RWDFramework" Then FRWDFramework = LFieldValue
' (SS,24/3/20)
If LFieldName = "OrderingSuspended" Then FOrderingSuspended = StrToBool(LFieldValue) ' (SS,5/6/22) correction, noticed missing StrToBool
' (SS,5/6/22)
If LFieldName = "AppStatsEnabled" Then FAppStatsEnabled = StrToBool(LFieldValue)
' (SS,17/4/09)
ElseIf LGroupName = "Checkout" Then
If LFieldName = "AlertMessage" Then FCheckoutAlertMessage = LFieldValue ' (SS,31/7/09)
If LFieldName = "ConfirmTermAndConditions" Then FCheckoutConfirmTermAndConditions = StrToBool(LFieldValue) ' (SS,26/1/16)
ElseIf LGroupName = "Currency" Then
' (SS,14/11/07) following 3 moved here from application
If LFieldName = "MulticurrencyEnabled" Then FMulticurrencyEnabled = LFieldValue
If LFieldName = "MulticurrencyMethod" Then FMulticurrencyMethod = LFieldValue ' (SS,5/6/14)
If LFieldName = "AllowedCurrencies" Then FAllowedCurrencies = LFieldValue
If LFieldName = "ExchangeRateAdjustmentRatioMain" Then FExchangeRateAdjustmentRatioMain = LFieldValue ' (SS,5/6/14) ' (SS,18/12/14) renamed from FExchangeRateAdjustmentRatio to FExchangeRateAdjustmentRatioMain
If LFieldName = "ExchangeRateAdjustmentRatioOther" Then FExchangeRateAdjustmentRatioOther = LFieldValue ' (SS,18/12/14)
' (SS,14/11/07) added following 5 new values
If LFieldName = "DefaultCode" Then FCurrencyDefaultCode = LFieldValue
If LFieldName = "DefaultRate" Then FCurrencyDefaultRate = LFieldValue
If LFieldName = "DefaultSymbol" Then FCurrencyDefaultSymbol = CurrencyCharToHTML(LFieldValue) ' (SS,19/5/11) added CurrencyCharToHTML to ensure correct HTML display
If LFieldName = "DefaultShowVAT" Then FCurrencyDefaultShowVAT = LFieldValue
If LFieldName = "DefaultCountry" Then FCurrencyDefaultCountry = LFieldValue
ElseIf LGroupName = "Delivery" Then
' delivery settings (SS,26/5/07) moved here from GetDeliverySettings
If LFieldName = "Type" Then FDeliveryType = LCase(LFieldValue) ' can be Original, Highest, Lowest, Total (SS,10/9/07) added LCase
If LFieldName = "ByPrice" Then FIsDeliveryByPrice = StrToBool(LFieldValue)
If LFieldName = "ByWeight" Then FIsDeliveryByWeight = StrToBool(LFieldValue)
If LFieldName = "ByWeightFlagged" Then FIsDeliveryByWeightFlagged = StrToBool(LFieldValue) ' (SS,22/10/08)
If LFieldName = "ByWeightNonFlagged" Then FIsDeliveryByWeightNonFlagged = StrToBool(LFieldValue) ' (SS,22/10/08)
If LFieldName = "SpecialRegionByPrice" Then FIsDeliverySpecialRegionByPrice = StrToBool(LFieldValue)
If LFieldName = "SpecialRegionByWeight" Then FIsDeliverySpecialRegionByWeight = StrToBool(LFieldValue)
If LFieldName = "ChooseDeliveryDate" Then FChooseDeliveryDate = StrToBool(LFieldValue) ' (SS,17/4/09)
If LFieldName = "MaxDeliveryDays" Then FMaxDeliveryDays = CLng(LFieldValue) ' (SS,17/4/09)
If LFieldName = "ShowDeliveryAddToExistingOrder" Then FShowDeliveryAddToExistingOrder = StrToBool(LFieldValue) ' (SS,25/9/20)
' (SS,11/9/07) removed following
' If LFieldName = "SpecialRegionLimitCountries" Then FIsDeliverySpecialRegionLimitCountries = StrToBool(LFieldValue)
If LFieldName = "UKLimit" Then FDeliveryUKLimit = NZ(LFieldValue)
If LFieldName = "UKBelow" Then FDeliveryUKBelow = NZ(LFieldValue)
If LFieldName = "UKAbove" Then FDeliveryUKAbove = NZ(LFieldValue)
If LFieldName = "UKText" Then FDeliveryUKText = LFieldValue
If LFieldName = "EULimit" Then FDeliveryEULimit = NZ(LFieldValue)
If LFieldName = "EUBelow" Then FDeliveryEUBelow = NZ(LFieldValue)
If LFieldName = "EUAbove" Then FDeliveryEUAbove = NZ(LFieldValue)
If LFieldName = "EUText" Then FDeliveryEUText = LFieldValue
If LFieldName = "RWLimit" Then FDeliveryRWLimit = NZ(LFieldValue)
If LFieldName = "RWBelow" Then FDeliveryRWBelow = NZ(LFieldValue)
If LFieldName = "RWAbove" Then FDeliveryRWAbove = NZ(LFieldValue)
If LFieldName = "RWText" Then FDeliveryRWText = LFieldValue
' (SS,6/5/21)
If LFieldName = "InterpolationEnabled" Then FDeliveryInterpolationEnabled = LFieldValue
If LFieldName = "InterpolationStartThreshold" Then FDeliveryInterpolationStartThreshold = NZD(LFieldValue) ' NB. NZD used instead of NZ
If LFieldName = "InterpolationEndThreshold" Then FDeliveryInterpolationEndThreshold = NZD(LFieldValue) ' NB. NZD used instead of NZ
If LFieldName = "AllowCollection" Then FAllowCollection = LFieldValue ' (SS,14/11/07)
If LFieldName = "AllowCollectionBasketPage" Then FAllowCollectionBasketPage = LFieldValue ' (SS,15/2/21)
' (SS,10/4/15) added following
If LFieldName = "UseDeliveryPostcodes" Then FUseDeliveryPostcodes = LFieldValue
' (SS,6/5/09)
ElseIf LGroupName = "Features" Then
If LFieldName = "VouchersEnabled" Then FVouchersEnabled = StrToBool(LFieldValue)
If LFieldName = "ProductReviewsEnabled" Then FProductReviewsEnabled = StrToBool(LFieldValue)
' (SS,18/5/09)
If LFieldName = "BackInStockNotificationsEnabled" Then FBackInStockNotificationsEnabled = StrToBool(LFieldValue)
' (SS,10/11/09)
If LFieldName = "NotifyCustomerRecordUpdate" Then FNotifyCustomerRecordUpdate = StrToBool(LFieldValue)
' (SS,23/6/10)
If LFieldName = "StockAvailabilityEnabled" Then FStockAvailabilityEnabled = StrToBool(LFieldValue)
' (SS,20/9/12)
If LFieldName = "AutoLoginEnabled" Then FAutoLoginEnabled = StrToBool(LFieldValue)
' (SS,15/1/13)
If LFieldName = "ReviewRequestsEnabled" Then FReviewRequestsEnabled = StrToBool(LFieldValue)
If LFieldName = "ReviewRequestsDays" Then FReviewRequestsDays = NZL(LFieldValue)
If LFieldName = "ReviewRequestsDaysNonUK" Then FReviewRequestsDaysNonUK = NZL(LFieldValue) ' (SS,14/1/20)
' (SS,17/1/13)
If LFieldName = "CustomPagesEnabled" Then FCustomPagesEnabled = StrToBool(LFieldValue)
' (SS,10/6/14)
If LFieldName = "GeoIPEnabled" Then FGeoIPEnabled = StrToBool(LFieldValue)
' (SS,25/2/15)
If LFieldName = "SaveBasketEnabled" Then FSaveBasketEnabled = StrToBool(LFieldValue)
' (SS,18/4/19)
If LFieldName = "CancelledOrderEmailsEnabled" Then FCancelledOrderEmailsEnabled = StrToBool(LFieldValue)
' (SS,21/4/21)
If LFieldName = "DespatchDatesEnabled" Then FDespatchDatesEnabled = StrToBool(LFieldValue)
' (SS,17/5/21) see Application for HearAboutUsList
If LFieldName = "HearAboutUsEnabled" Then FHearAboutUsEnabled = StrToBool(LFieldValue)
If LFieldName = "HearAboutUsLabel" Then FHearAboutUsLabel = LFieldValue
' (SS,17/4/09)
' (SS,18/5/21) replaced FMobileEnabled with FAlternativePhoneEnabled and moved from Checkout to Features
If LFieldName = "AlternativePhoneEnabled" Then FAlternativePhoneEnabled = StrToBool(LFieldValue)
ElseIf LGroupName = "Pictures" Then
If LFieldName = "LargeThumbnailWidth" Then FLargeThumbnailWidth = NZL(LFieldValue)
If LFieldName = "LargeThumbnailHeight" Then FLargeThumbnailHeight = NZL(LFieldValue)
' (SS,19/3/09)
If LFieldName = "SmallThumbnailWidth" Then FSmallThumbnailWidth = NZL(LFieldValue)
If LFieldName = "SmallThumbnailHeight" Then FSmallThumbnailHeight = NZL(LFieldValue)
' (SS,9/8/18)
If LFieldName = "UseGetPicASP" Then FUseGetPicASP = StrToBool(LFieldValue)
ElseIf LGroupName = "Store" Then
If LFieldName = "Name" Then FStoreName = LFieldValue
If LFieldName = "Company" Then FStoreCompany = LFieldValue
If LFieldName = "Address1" Then FStoreAddress1 = LFieldValue
If LFieldName = "Address2" Then FStoreAddress2 = LFieldValue
If LFieldName = "Address3" Then FStoreAddress3 = LFieldValue
If LFieldName = "Town" Then FStoreTown = LFieldValue
If LFieldName = "County" Then FStoreCounty = LFieldValue
If LFieldName = "Postcode" Then FStorePostcode = LFieldValue
If LFieldName = "Country" Then FStoreCountry = LFieldValue
If LFieldName = "Telephone" Then FStoreTelephone = LFieldValue
If LFieldName = "Fax" Then FStoreFax = LFieldValue
If LFieldName = "Email" Then FStoreEmail = LFieldValue
If LFieldName = "VATRegNo" Then FStoreVATRegNo = LFieldValue
If LFieldName = "EORINo" Then FStoreEORINo = LFieldValue ' (SS,22/12/20)
If LFieldName = "XIEORINo" Then FStoreXIEORINo = LFieldValue ' (SS,16/2/21)
If LFieldName = "Regards" Then FStoreRegards = LFieldValue
If LFieldName = "URL" Then FStoreURL = LFieldValue
If LFieldName = "PlaceOfRegistration" Then FStorePlaceOfRegistration = LFieldValue
If LFieldName = "RegisteredCompanyNo" Then FStoreRegisteredCompanyNo = LFieldValue
ElseIf LGroupName = "Email" Then
If LFieldName = "HTMLEmailsEnabled" Then FHTMLEmailsEnabled = StrToBool(LFieldValue)
If LFieldName = "OrderConfirmationBcc1" Then FEmailOrderConfirmationBcc1 = LFieldValue
If LFieldName = "OrderConfirmationBcc2" Then FEmailOrderConfirmationBcc2 = LFieldValue
If LFieldName = "OrderConfirmationFrom" Then FEmailOrderConfirmationFrom = LFieldValue ' (SS,11/5/20) corrected EmailOrderConfirmationFrom to OrderConfirmationFrom
If LFieldName = "ContactTo" Then FEmailContactTo = LFieldValue
If LFieldName = "ContactBcc1" Then FEmailContactBcc1 = LFieldValue
If LFieldName = "ContactBcc2" Then FEmailContactBcc2 = LFieldValue
If LFieldName = "ContactFrom" Then FEmailContactFrom = LFieldValue
If LFieldName = "SecurityCodeEnabled" Then FEmailSecurityCodeEnabled = LFieldValue ' (SS,17/4/09)
If LFieldName = "ConfirmationIsVATReceipt" Then FEmailConfirmationIsVATReceipt = LFieldValue ' (SS,14/6/10)
If LFieldName = "UseMessageToCustomerForDespatch" Then FEmailUseMessageToCustomerForDespatch = StrToBool(LFieldValue) ' (SS,23/10/15)
ElseIf LGroupName = "Payment" Then
If LFieldName = "Type" Then FPaymentType = UCase(LFieldValue)
If LFieldName = "Type2" Then FPaymentType2 = UCase(LFieldValue) ' (SS,28/9/07)
If LFieldName = "Type3" Then FPaymentType3 = UCase(LFieldValue) ' (SS,4/6/09)
If LFieldName = "HideCurrency" Then FPaymentHideCurrency = StrToBool(LFieldValue) ' (SS,21/5/10)
If LFieldName = "WorldPayInstallID" Then FWorldPayInstallID = LFieldValue
If LFieldName = "WorldPayTestMode" Then FWorldPayTestMode = LFieldValue
If LFieldName = "WorldPayMD5SecretKey" Then FWorldPayMD5SecretKey = LFieldValue ' (SS,14/11/12)
If LFieldName = "PayPalBusiness" Then FPayPalBusiness = LFieldValue
If LFieldName = "PayPalTestMode" Then FPayPalTestMode = StrToBool(LFieldValue) ' (SS,26/1/15) added StrToBool
If LFieldName = "PayPalShippingAddressFlag" Then FPayPalShippingAddressFlag = LFieldValue
' (SS,26/1/15)
If LFieldName = "PayPalExpressEnabled" Then FPayPalExpressEnabled = StrToBool(LFieldValue)
If LFieldName = "PayPalAPIUserName" Then FPayPalAPIUserName = LFieldValue
If LFieldName = "PayPalAPIPassword" Then FPayPalAPIPassword = LFieldValue
If LFieldName = "PayPalAPISignature" Then FPayPalAPISignature = LFieldValue
If LFieldName = "PayPalUKOnlyCheckout" Then FPayPalUKOnlyCheckout = LFieldValue ' (SS,9/4/18)
If LFieldName = "PayPalExpressShowOnBasketPage" Then FPayPalExpressShowOnBasketPage = LFieldValue ' (SS,23/4/18)
If LFieldName = "PayPalNonUKSurchargePercentage" Then FPayPalNonUKSurchargePercentage = CDbl(LFieldValue) ' (SS,8/6/18)
' (SS,3/8/22)
If LFieldName = "PayPalPayLaterMessagesEnabled" Then FPayPalPayLaterMessagesEnabled = StrToBool(LFieldValue)
If LFieldName = "PayPalPayLaterMessagesClientID" Then FPayPalPayLaterMessagesClientID = LFieldValue
If LFieldName = "ePDQClientID" Then FEPDQClientID = LFieldValue
If LFieldName = "ePDQPassphrase" Then FEPDQPassphrase = LFieldValue
If LFieldName = "ePDQChargeType" Then FEPDQChargeType = LFieldValue
If LFieldName = "ePDQMerchantDisplayName" Then FEPDQMerchantDisplayName = LFieldValue ' (SS,10/5/12)
If LFieldName = "ePDQPARAMVAR" Then FEPDQPARAMVAR = LFieldValue ' (SS,10/5/12)
If LFieldName = "ePDQTestMode" Then FEPDQTestMode = StrToBool(LFieldValue) ' (SS,26/4/18)
If LFieldName = "SagePayVendorName" Then FSagePayVendorName = LFieldValue ' (SS,20/3/13)
If LFieldName = "SagePayMode" Then FSagePayMode = LFieldValue ' (SS,20/3/13)
If LFieldName = "SagePayEncryptionKey" Then FSagePayEncryptionKey = LFieldValue ' (SS,20/3/13)
' (SS,23/3/18)
If LFieldName = "PayzoneMerchantID" Then FPayzoneMerchantID = LFieldValue
If LFieldName = "PayzoneGatewayAccountPassword" Then FPayzoneGatewayAccountPassword = LFieldValue
If LFieldName = "PayzonePreSharedKey" Then FPayzonePreSharedKey = LFieldValue
' (SS,16/9/20)
If LFieldName = "NetPayMerchantID" Then FNetPayMerchantID = LFieldValue
If LFieldName = "NetPayUserName" Then FNetPayUserName = LFieldValue
If LFieldName = "NetPayEncryptionKey" Then FNetPayEncryptionKey = LFieldValue
If LFieldName = "NetPayEncryptionIV" Then FNetPayEncryptionIV = LFieldValue
If LFieldName = "NetPayIntegrationPassword" Then FNetPayIntegrationPassword = LFieldValue
If LFieldName = "NetPayOperationMode" Then FNetPayOperationMode = LFieldValue
If LFieldName = "NetPayTemplate" Then FNetPayTemplate = LFieldValue ' (SS,16/2/21)
' (SS,17/6/22)
If LFieldName = "CloverStoreID" Then FCloverStoreID = LFieldValue
If LFieldName = "CloverSharedSecret" Then FCloverSharedSecret = LFieldValue
If LFieldName = "CloverTestMode" Then FCloverTestMode = StrToBool(LFieldValue)
' (SS,28/5/09)
If LFieldName = "AllowCheques" Then FAllowCheques = StrToBool(LFieldValue)
If LFieldName = "AllowBankTransfers" Then FAllowBankTransfers = StrToBool(LFieldValue)
If LFieldName = "ChequesPayableTo" Then FChequesPayableTo = LFieldValue
If LFieldName = "BankTransferDetails" Then FBankTransferDetails = NB(GetFieldValue("MemoValue")) ' (SS,29/5/09) held in memo field
If LFieldName = "BankTransferDetailsEUR" Then FBankTransferDetailsEUR = NB(GetFieldValue("MemoValue")) ' (SS,20/2/12) for Euros
If LFieldName = "BankTransferDetailsUSD" Then FBankTransferDetailsUSD = NB(GetFieldValue("MemoValue")) ' (SS,20/2/12) for Dollars
If LFieldName = "BankTransferDetailsGBP" Then FBankTransferDetailsGBP = NB(GetFieldValue("MemoValue")) ' (SS,29/9/12) for GBP
' (SS,18/6/09)
If LFieldName = "WorldPaySiteSeal" Then FWorldPaySiteSeal = LFieldValue
If LFieldName = "PayPalSiteSeal" Then FPayPalSiteSeal = LFieldValue
ElseIf LGroupName = "BestSellers" Then
If LFieldName = "Max" Then FBestSellersMax = NZL(LFieldValue)
If LFieldName = "PastDays" Then FBestSellersPastDays = NZL(LFieldValue)
If LFieldName = "SortOrder" Then FBestSellersSortOrder = LFieldValue
ElseIf LGroupName = "Products" Then
If LFieldName = "FilesEnabled" Then FProductFilesEnabled = StrToBool(LFieldValue)
If LFieldName = "MaxPicturesPerProduct" Then FMaxPicturesPerProduct = NZL(LFieldValue)
If LFieldName = "AcrossMax" Then FProductsAcrossMax = NZL(LFieldValue)
If LFieldName = "DownMax" Then FProductsDownMax = NZL(LFieldValue)
If LFieldName = "ProductsPerPageFixed" Then FProductsPerPageFixed = StrToBool(LFieldValue) ' (SS,12/5/10)
If LFieldName = "MaxSpecialOffer" Then FProductsMaxSpecialOffer = NZL(LFieldValue)
If LFieldName = "ShowIncVAT" Then FShowIncVAT = StrToBool(LFieldValue)
If LFieldName = "ShowExcVAT" Then FShowExcVAT = StrToBool(LFieldValue)
If LFieldName = "MinCurrencyPricesEnabled" Then FMinCurrencyPricesEnabled = StrToBool(LFieldValue) ' (SS,7/11/12)
If LFieldName = "SummaryListEnabled" Then FSummaryListEnabled = StrToBool(LFieldValue)
If LFieldName = "MaxRecentlyViewed" Then FMaxRecentlyViewed = NZL(LFieldValue) ' (SS,16/5/11)
If LFieldName = "ProductPageTabs" Then FProductPageTabs = StrToBool(LFieldValue) ' (SS,17/6/11)
If LFieldName = "AttributesEnabled" Then FProductAttributesEnabled = StrToBool(LFieldValue) ' (SS,1/7/11)
If LFieldName = "OptionsEnabled" Then FProductOptionsEnabled = StrToBool(LFieldValue) ' (SS,1/7/11)
If LFieldName = "SubproductsEnabled" Then FProductSubproductsEnabled = StrToBool(LFieldValue) ' (SS,18/10/18)
If LFieldName = "ProductSearchWithoutDescFirst" Then FProductSearchWithoutDescFirst = StrToBool(LFieldValue) ' (SS,16/1/13)
If LFieldName = "ProductSearchFullText" Then FProductSearchFullText = StrToBool(LFieldValue) ' (SS,1/6/15)
If LFieldName = "ShowReviewsImmediately" Then FProductsShowReviewsImmediately = StrToBool(LFieldValue) ' (SS,10/6/14)
If LFieldName = "SortByDefault" Then FProductsSortByDefault = LFieldValue ' (SS,26/8/15)
' (SS,20/10/14)
ElseIf LGroupName = "Reviews" Then
If LFieldName = "Type" Then FReviewsType = LFieldValue
If LFieldName = "FeefoLogon" Then FFeefoLogon = LFieldValue
If LFieldName = "FeefoFTPHost" Then FFeefoFTPHost = LFieldValue
If LFieldName = "FeefoFTPUser" Then FFeefoFTPUser = LFieldValue
If LFieldName = "FeefoFTPPassword" Then FFeefoFTPPassword = LFieldValue
If LFieldName = "TrustpilotAFSEmailAddress" Then FTrustpilotAFSEmailAddress = LFieldValue ' (SS,18/5/17)
If LFieldName = "TrustpilotReviewsVisible" Then FTrustpilotReviewsVisible = LFieldValue ' (SS,12/5/21)
If LFieldName = "TrustpilotSiteName" Then FTrustpilotSiteName = LFieldValue ' (SS,13/5/21)
ElseIf LGroupName = "Categories" Then
If LFieldName = "GroupsEnabled" Then FGroupsEnabled = StrToBool(LFieldValue)
If LFieldName = "ExtraSearchComboCategory" Then FExtraSearchComboCategory = LFieldValue
If LFieldName = "ExtraSearchComboBlankEntry" Then FExtraSearchComboBlankEntry = LFieldValue
If LFieldName = "ShowProductsOnFullListCat" Then FShowProductsOnFullListCat = StrToBool(LFieldValue)
If LFieldName = "CategoryForSubcategoryMenu" Then FCategoryForSubcategoryMenu = LFieldValue
If LFieldName = "AddSpecialOffersToSubcategoryMenu" Then FAddSpecialOffersToSubcategoryMenu = StrToBool(LFieldValue)
If LFieldName = "CategoryListEnabled" Then FCategoryListEnabled = StrToBool(LFieldValue)
If LFieldName = "SubcategoryListEnabled" Then FSubcategoryListEnabled = StrToBool(LFieldValue)
If LFieldName = "UseAlternateColorForCategories" Then FUseAlternateColorForCategories = StrToBool(LFieldValue)
If LFieldName = "DefaultGroup" Then FDefaultGroup = LFieldValue ' (SS,28/7/11)
If LFieldName = "AlwaysDefaultGroupForMenu" Then FAlwaysDefaultGroupForMenu = StrToBool(LFieldValue) ' (SS,1/8/11)
If LFieldName = "IncludeGroupInHTMLTitleTag" Then FIncludeGroupInHTMLTitleTag = StrToBool(LFieldValue) ' (SS,2/8/11)
If LFieldName = "ShowCategoryHeadingFooterIfEmpty" Then FShowCategoryHeadingFooterIfEmpty = StrToBool(LFieldValue) ' (SS,12/10/15)
' (SS,7/11/08)
ElseIf LGroupName = "Google" Then
If LFieldName = "GoogleAnalyticsWebPropertyID" Then FGoogleAnalyticsWebPropertyID = LFieldValue
If LFieldName = "GoogleAnalyticsUseDoubleClickDotNet" Then FGoogleAnalyticsUseDoubleClickDotNet = LFieldValue ' (SS,12/2/15)
If LFieldName = "GoogleAnalyticsCrossDomainTrackingList" Then FGoogleAnalyticsCrossDomainTrackingList = LFieldValue ' (SS,3/3/16)
If LFieldName = "EcommerceTrackingEnabled" Then FEcommerceTrackingEnabled = StrToBool(LFieldValue)
If LFieldName = "AdwordsConversionTrackingID" Then FAdWordsConversionTrackingID = LFieldValue
If LFieldName = "AdwordsConversionLabelPurchase" Then FAdWordsConversionLabelPurchase = LFieldValue
If LFieldName = "AdwordsConversionLabelNewAccount" Then FAdWordsConversionLabelNewAccount = LFieldValue
If LFieldName = "AdwordsConversionLabelRemarketing" Then FAdWordsConversionLabelRemarketing = LFieldValue ' (SS,28/11/13)
If LFieldName = "EnhancedConversionsEnabled" Then FGoogleEnhancedConversionsEnabled = LFieldValue ' (SS,17/9/21)
If LFieldName = "EnhancedConversionsType" Then FGoogleEnhancedConversionsType = LFieldValue ' (SS,20/6/23)
If LFieldName = "GoogleTagManagerContainerID" Then FGoogleTagManagerContainerID = LFieldValue ' (SS,5/10/23)
' (SS,1/10/14)
ElseIf LGroupName = "Facebook" Then
'If LFieldName = "ConversionTrackingID" Then FFacebookConversionTrackingID = LFieldValue
' (SS,9/10/17) replaced above with following, i.e. ConversionTrackingID with PixelID
If LFieldName = "PixelID" Then FFacebookPixelID = LFieldValue
' (SS,3/8/23) added following for OptinMonster
' (SS,4/8/23) renamed to FOptinMonsterAccountID, FOptinMonsterUserID
ElseIf LGroupName = "OtherTools" Then
If LFieldName = "OptinMonsterAccountID" Then FOptinMonsterAccountID = LFieldValue
If LFieldName = "OptinMonsterUserID" Then FOptinMonsterUserID = LFieldValue
' (SS,15/1/24) added following for Backona Analytics
If LFieldName = "BackonaAnalyticsEnabled" Then FBackonaAnalyticsEnabled = StrToBool(LFieldValue)
If LFieldName = "BackonaAnalyticsDomain" Then FBackonaAnalyticsDomain = LFieldValue
' (SS,13/3/15)
ElseIf LGroupName = "Froogle" Then
If LFieldName = "ProductType" Then FFroogleProductType = LFieldValue
' (SS,21/10/16)
ElseIf LGroupName = "AddressLookup" Then
If LFieldName = "Enabled" Then FAddressLookupEnabled = StrToBool(LFieldValue)
If LFieldName = "Type" Then FAddressLookupType = LFieldValue
If LFieldName = "AccountCode" Then FAddressLookupAccountCode = LFieldValue
If LFieldName = "LocalModeOnly" Then FAddressLookupLocalModeOnly = LFieldValue
' (SS,21/10/16)
ElseIf LGroupName = "LocalMode" Then
If LFieldName = "Enabled" Then FLocalModeEnabled = StrToBool(LFieldValue)
If LFieldName = "ExchangeReasons" Then FLocalModeExchangeReasons = LFieldValue
If LFieldName = "PaymentMethods" Then FLocalModePaymentMethods = LFieldValue
' (SS,20/3/18)
ElseIf LGroupName = "SMS" Then
If LFieldName = "Enabled" Then FSMSEnabled = StrToBool(LFieldValue)
End If
NextQueryRecord
Loop
CloseQuery
' if certain email addresses are blank then default to storeemail address
If FEmailOrderConfirmationBcc1 = "" Then FEmailOrderConfirmationBcc1 = FStoreEmail
If FEmailOrderConfirmationFrom = "" Then FEmailOrderConfirmationFrom = FStoreEmail
If FEmailContactTo = "" Then FEmailContactTo = FStoreEmail
If FEmailContactFrom = "" Then FEmailContactFrom = FStoreEmail
' (SS,14/1/20) if FReviewRequestsDaysNonUK not set i.e. 0 then default to FReviewRequestsDays
If FReviewRequestsDaysNonUK = 0 Then FReviewRequestsDaysNonUK = FReviewRequestsDays
CheckAndSetDevMode ' (SS,22/2/23)
End Sub
' (SS,22/2/23) checks for dev mode, i.e. website with "dev." prefix instead of the usual "www."
' if dev mode detected then override the appropriate settings with suitable ones for development purposes
' useful feature that allows a database to be restored and tested without needing to set some important variables like email address, Google & Facebook analytic and ads settings
Sub CheckAndSetDevMode
If Not IsDevMode Then Exit Sub ' no change if not in dev mode
'Response.Write "*** StoreURL before: " & FStoreURL & "***" & BR
FStoreURL = IIf(Request.ServerVariables("HTTPS") = "on", "https", "http") & "://" & Request.ServerVariables("SERVER_NAME") ' URL of this host e.g. https://dev.hyperflight.co.uk
' Email, set test default or clear
FStoreEmail = "shoppingtest@itpartnership.com"
FEmailOrderConfirmationBcc1 = FStoreEmail
FEmailOrderConfirmationBcc1 = ""
FEmailOrderConfirmationFrom = FStoreEmail
FEmailContactTo = FStoreEmail
FEmailContactBcc1 = ""
FEmailContactBcc2 = ""
FEmailContactFrom = FStoreEmail
' Google, clear analytics and ads variables
FGoogleAnalyticsWebPropertyID = ""
FGoogleAnalyticsUseDoubleClickDotNet = False
FGoogleAnalyticsCrossDomainTrackingList = ""
' (SS,16/1/24) was False, enabled for Backona testing
' (SS,16/2/24) changed back to False (from True)
FEcommerceTrackingEnabled = False
FAdWordsConversionTrackingID = ""
FAdWordsConversionLabelPurchase = ""
FAdWordsConversionLabelNewAccount = ""
FAdWordsConversionLabelRemarketing = False
' FGoogleEnhancedConversionsEnabled = False ' (SS,10/11/23) removed because it be called anyway due to FGoogleAnalyticsWebPropertyID being blank, needed to be true for GTM testing
' Facebook, clear pixel ID
' FFacebookPixelID = ""
' (SS,15/1/24) temporary added a special test version of "12345567890"
'FFacebookPixelID = "12345567890"
' (SS,16/2/24) set back to blank
'FFacebookPixelID = ""
' (SS,2/3/24) put back in for testing again, also added FEcommerceTrackingEnabled = True, to track conversions
FFacebookPixelID = "12345567890"
FEcommerceTrackingEnabled = True
' (SS,3/8/23) clear the OptinMonster IDs
FOptinMonsterAccountID = ""
FOptinMonsterUserID = ""
' (SS,15/1/24) clear the Backona
'FBackonaAnalyticsEnabled = False
'FBackonaAnalyticsDomain = ""
' Response.Write "*** SERVER_NAME: " & Request.ServerVariables("SERVER_NAME") & "***" & BR
'Response.Write "*** URL: " & Request.ServerVariables("URL") & "***" & BR
'Response.Write "*** HTTPS: " & Request.ServerVariables("HTTPS") & "***" & BR
'Response.Write "*** SERVER_PORT_SECURE: " & Request.ServerVariables("SERVER_PORT_SECURE") & "***" & BR
'Response.Write "*** SERVER_PORT: " & Request.ServerVariables("SERVER_PORT") & "***" & BR
' Response.Write "*** StoreURL after: " & FStoreURL & "***" & BR
End Sub
' (SS,14/11/07) check schema version and upgrade if necessary
Sub CheckSchema
' (SS,11/11/13) added following to only upgrade if cmd = "upgrade", to prevent page access from other than myself causing upgrade
' and from being called multiple times
If CleanRequestQueryString("cmd") <> "upgrade" Then Exit Sub
' if schema version doesn't exist, i.e. version is 1.00 or less then add it, otherwise SetSchemaVersion will fail
If GetSchemaVersion <= 1 Then AddSetting "Application", "SchemaVersion", 1
' upgrade to version 1.42 if required
'If GetSchemaVersion < 1.42 Then UpgradeSchemaTo142
'If GetSchemaVersion < 1.43 Then UpgradeSchemaTo143
'If GetSchemaVersion < 1.44 Then UpgradeSchemaTo144 ' (SS,21/10/08)
'If GetSchemaVersion < 1.45 Then UpgradeSchemaTo145 ' (SS,17/4/09)
'If GetSchemaVersion < 1.46 Then UpgradeSchemaTo146 ' (SS,23/11/09)
'If GetSchemaVersion < 1.47 Then UpgradeSchemaTo147 ' (SS,27/01/10)
'If GetSchemaVersion < 1.48 Then UpgradeSchemaTo148 ' (SS,28/04/10)
'If GetSchemaVersion < 1.49 Then UpgradeSchemaTo149 ' (SS,23/06/10)
'If GetSchemaVersion < 1.50 Then UpgradeSchemaTo150 ' (SS,29/06/10)
'If GetSchemaVersion < 1.51 Then UpgradeSchemaTo151 ' (SS,22/07/10)
'If GetSchemaVersion < 1.52 Then UpgradeSchemaTo152 ' (SS,21/03/11)
If GetSchemaVersion < 1.59 Then ' (SS,6/3/13) added extra "if" to group the changes prior to 1.59
If GetSchemaVersion < 1.53 Then UpgradeSchemaTo153 ' (SS,14/07/11)
If GetSchemaVersion < 1.54 Then UpgradeSchemaTo154 ' (SS,14/02/12)
If GetSchemaVersion < 1.55 Then UpgradeSchemaTo155 ' (SS,14/03/12)
If GetSchemaVersion < 1.56 Then UpgradeSchemaTo156 ' (SS,16/03/12)
If GetSchemaVersion < 1.57 Then UpgradeSchemaTo157 ' (SS,27/04/12)
If GetSchemaVersion < 1.58 Then UpgradeSchemaTo158 ' (SS,30/05/12)
If GetSchemaVersion < 1.59 Then UpgradeSchemaTo159 ' (SS,19/06/12)
End If
If GetSchemaVersion < 1.60 Then UpgradeSchemaTo160 ' (SS,28/09/12)
If GetSchemaVersion < 1.61 Then UpgradeSchemaTo161 ' (SS,08/11/12)
If GetSchemaVersion < 1.62 Then UpgradeSchemaTo162 ' (SS,06/12/12)
If GetSchemaVersion < 1.63 Then UpgradeSchemaTo163 ' (SS,10/01/13)
If GetSchemaVersion < 1.64 Then UpgradeSchemaTo164 ' (SS,13/02/13)
If GetSchemaVersion < 1.65 Then UpgradeSchemaTo165 ' (SS,28/02/13)
If GetSchemaVersion < 1.66 Then UpgradeSchemaTo166 ' (SS,06/03/13)
If GetSchemaVersion < 1.67 Then UpgradeSchemaTo167 ' (SS,13/12/13)
' (SS,21/7/22) schema updates from 1.67 onwards have been done either manually or via Shopping Admin, current schema should be 6, here we're updating to 7 from 6
If GetSchemaVersion = 6 Then UpgradeSchemaTo7
End Sub
' (SS,14/11/07) upgrade to version 1.42 - add 3 new fields to orders and one to customers
Sub UpgradeSchemaTo142
ExecuteQuery "ALTER TABLE orders ADD VATNumber varchar(20) default '' AFTER ExchangeRate," +_
"ADD IntraCommunitySupply tinyint(1) NOT NULL default '0' AFTER VATNumber," +_
"ADD DeliveryWillCollect tinyint(1) NOT NULL default '0' AFTER GrandTotal"
ExecuteQuery "ALTER TABLE customers ADD VATNumber varchar(20) default '' AFTER Telephone"
SetSchemaVersion(1.42)
End Sub
' (SS,16/11/07) date DateStockDue to products table
Sub UpgradeSchemaTo143
ExecuteQuery "ALTER TABLE products ADD DateStockDue date default NULL AFTER NumInStock"
SetSchemaVersion(1.43)
End Sub
' (SS,21/10/08) added CustomFlag (tinyint) to products table and IntraCommunitySupply to countries
Sub UpgradeSchemaTo144
ExecuteQuery "ALTER TABLE products ADD CustomFlag tinyint(1) NOT NULL default 0 AFTER ProductDisabled"
ExecuteQuery "ALTER TABLE countries ADD IntraCommunitySupply tinyint(1) NOT NULL DEFAULT 0 AFTER ChargeVAT"
SetSchemaVersion(1.44)
End Sub
' (SS,17/4/09) changes to orders table and added new vouchers table
Sub UpgradeSchemaTo145
Dim LSQL
' changed CustomerID from VARCHAR(20) to INT(11) was mistakenly set to VARCHAR(20)
' later removed this changed becauses Toner2Desk uses VARCHAR(20) for CustomerID
' added new fields Mobile, DeliveryDate, VoucherID and Discount, added index idxVoucherID
' (SS,22/5/09) added Courier, TrackingNo & MessageToCustomer
LSQL = "ALTER TABLE orders " +_
"ADD Mobile VARCHAR(100) DEFAULT NULL AFTER Telephone, " +_
"ADD DeliveryDate DATE DEFAULT NULL AFTER DeliveryWillCollect, " +_
"ADD VoucherID INT(11) DEFAULT NULL AFTER TotalWeight, " +_
"ADD Discount DOUBLE NOT NULL DEFAULT '0' AFTER Subtotal, " +_
"ADD Courier VARCHAR(50) DEFAULT NULL AFTER IntraCommunitySupply, " +_
"ADD TrackingNo VARCHAR(255) DEFAULT NULL AFTER Courier, " +_
"ADD MessageToCustomer MEDIUMTEXT AFTER TrackingNo, " +_
"ADD INDEX idxVoucherID (VoucherID)"
ExecuteQuery LSQL
' added Mobile to customers
LSQL = "ALTER TABLE customers ADD Mobile VARCHAR(100) DEFAULT NULL AFTER Telephone"
ExecuteQuery LSQL
' new vouchers table
LSQL = "CREATE TABLE vouchers (" +_
"VoucherID INTEGER(11) NOT NULL AUTO_INCREMENT, " +_
"VoucherCode CHAR(20) DEFAULT NULL, " +_
"VoucherType CHAR(2) DEFAULT NULL, " +_
"VoucherName VARCHAR(40) DEFAULT NULL, " +_
"ValidFromDate DATE DEFAULT NULL, " +_
"ExpiryDate DATE DEFAULT NULL, " +_
"MinimumSpend DECIMAL(10,2) DEFAULT NULL, " +_
"DiscountAmount DECIMAL(10,2) DEFAULT NULL, " +_
"DiscountPercentage DECIMAL(5,2) DEFAULT NULL, " +_
"SingleUsage TINYINT(1) DEFAULT '0', " +_
"Category VARCHAR(50) DEFAULT NULL, " +_
"Subcategory VARCHAR(50) DEFAULT NULL, " +_
"PRIMARY KEY (VoucherID), " +_
"UNIQUE KEY idxVoucherCode (VoucherCode), " +_
"KEY idxCategory (Category), " +_
"KEY idxSubcategory (Subcategory) " +_
")ENGINE=MyISAM " +_
"AUTO_INCREMENT=1;"
ExecuteQuery LSQL
' new MenuShortName to categories table
ExecuteQuery "ALTER TABLE categories ADD MenuShortName VARCHAR(30) DEFAULT NULL AFTER Priority"
' new product reviews table
LSQL = "CREATE TABLE productreviews (" +_
"ReviewID INTEGER(11) NOT NULL AUTO_INCREMENT, " +_
"ReviewType CHAR(1) NOT NULL DEFAULT 'R' COMMENT 'R for Review, C for Comment', " +_
"ReviewDateTime DATETIME NOT NULL, " +_
"ProductCode VARCHAR(20) NOT NULL DEFAULT '', " +_
"ReviewTitle VARCHAR(50) DEFAULT NULL, " +_
"ProductRating TINYINT(1) DEFAULT NULL, " +_
"ReviewText MEDIUMTEXT, " +_
"ReviewerName VARCHAR(50) DEFAULT NULL, " +_
"ReviewerEmail VARCHAR(100) DEFAULT NULL, " +_
"ShowOnSite TINYINT(1) DEFAULT '1', " +_
"PRIMARY KEY (ReviewID), " +_
"KEY idxProductCode (ProductCode) " +_
")ENGINE=MyISAM " +_
"AUTO_INCREMENT=1;"
ExecuteQuery LSQL
' new sitedetails table
LSQL = "CREATE TABLE sitedetails (" +_
"ID INTEGER(11) NOT NULL AUTO_INCREMENT, " +_
"Type VARCHAR(20) NOT NULL DEFAULT '', " +_
"SortOrder INTEGER(11) NOT NULL DEFAULT '0', " +_
"Name VARCHAR(100) DEFAULT NULL, " +_
"Text MEDIUMTEXT, " +_
"File LONGBLOB, " +_
"ExtraField1 VARCHAR(200) DEFAULT NULL, " +_
"ExtraField2 VARCHAR(200) DEFAULT NULL, " +_
"ExtraField3 VARCHAR(200) DEFAULT NULL, " +_
"CheckBoxField TINYINT(1) NOT NULL DEFAULT '1', " +_
"LastUpdated TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, " +_
"PRIMARY KEY (ID), " +_
"UNIQUE KEY idxTypeName (Type, Name), " +_
"KEY idxType (Type) " +_
")ENGINE=MyISAM " +_
"AUTO_INCREMENT=1;"
ExecuteQuery LSQL
' new voucherproducts table
LSQL = "CREATE TABLE voucherproducts (" +_
"VoucherID INTEGER(11) NOT NULL," +_
"ProductCode VARCHAR(20) NOT NULL DEFAULT ''," +_
"PRIMARY KEY (VoucherID, ProductCode)" +_
")ENGINE=MyISAM;"
ExecuteQuery LSQL
' (SS,11/5/09) countries table, change ChargeVAT from CHAR(1) to TINYINT(1)
ExecuteQuery "UPDATE countries SET ChargeVAT = '1' WHERE ChargeVAT = 'Y';"
ExecuteQuery "UPDATE countries SET ChargeVAT = '0' WHERE ChargeVAT = 'N';"
ExecuteQuery "ALTER TABLE countries MODIFY ChargeVAT TINYINT(1) DEFAULT '0';"
ExecuteQuery "UPDATE countries SET ChargeVAT = 1 WHERE PostalArea <> 'RW';"
' (SS,22/5/09) new stocknotifications table
LSQL = "CREATE TABLE stocknotifications (" +_
"ID INTEGER(11) NOT NULL AUTO_INCREMENT, " +_
"ProductCode VARCHAR(20) NOT NULL DEFAULT '', " +_
"Name VARCHAR(50) NOT NULL DEFAULT '', " +_
"Email VARCHAR(100) NOT NULL DEFAULT '', " +_
"DateTimeAdded DATETIME NOT NULL, " +_
"DateTimeNotified DATETIME DEFAULT NULL, " +_
"PRIMARY KEY (ID), " +_
"KEY idxProductCode (ProductCode), " +_
"KEY idxDateTimeNotified (DateTimeNotified) " +_
")ENGINE=MyISAM " +_
"AUTO_INCREMENT=1;"
ExecuteQuery LSQL
SetSchemaVersion(1.45)
End Sub
' (SS,23/11/09) added NewCustomer flag to orders table
Sub UpgradeSchemaTo146
ExecuteQuery "ALTER TABLE orders ADD NewCustomer tinyint(1) NOT NULL default 0 AFTER MessageToCustomer;"
SetSchemaVersion(1.46)
End Sub
' (SS,27/1/10) added new loginlog table to help diagnose login issue, originally added just for Petfood site
Sub UpgradeSchemaTo147
Dim LSQL
LSQL = "CREATE TABLE loginlog (" +_
"ID INTEGER(11) NOT NULL AUTO_INCREMENT, " +_
"DateTimeAttempted DATETIME DEFAULT NULL, " +_
"SessionID VARCHAR(20) DEFAULT NULL, " +_
"IPAddress VARCHAR(20) DEFAULT NULL, " +_
"AlreadyLoggedIn TINYINT(1) NOT NULL DEFAULT '0', " +_
"LoginResult VARCHAR(20) DEFAULT NULL, " +_
"CustomerID VARCHAR(12) DEFAULT NULL, " +_
"Email VARCHAR(255) DEFAULT NULL, " +_
"Password VARCHAR(255) DEFAULT NULL, " +_
"Referrer VARCHAR(255) DEFAULT NULL, " +_
"URL VARCHAR(255) DEFAULT NULL, " +_
"QueryString VARCHAR(255) DEFAULT NULL, " +_
"UserAgent VARCHAR(255) DEFAULT NULL, " +_
"PRIMARY KEY (ID) " +_
")ENGINE=MyISAM " +_
"AUTO_INCREMENT=1;"
ExecuteQuery LSQL
SetSchemaVersion(1.47)
End Sub
' (SS,28/4/10) modify the Category and Subcategory fields from 50 to 75 characters (for galleon french/german longer names)
Sub UpgradeSchemaTo148
ExecuteQuery "ALTER TABLE categories MODIFY Category VARCHAR(75) NOT NULL DEFAULT '';"
ExecuteQuery "ALTER TABLE subcategories MODIFY Category VARCHAR(75) NOT NULL DEFAULT '', MODIFY Subcategory VARCHAR(75) NOT NULL DEFAULT '';"
ExecuteQuery "ALTER TABLE productcategories MODIFY Category VARCHAR(75) NOT NULL DEFAULT '', MODIFY Subcategory VARCHAR(75) NOT NULL DEFAULT '';"
ExecuteQuery "ALTER TABLE vouchers MODIFY Category VARCHAR(75) DEFAULT NULL, MODIFY Subcategory VARCHAR(75) DEFAULT NULL;"
SetSchemaVersion(1.48)
End Sub
' (SS,23/6/10) added new suppliers table and three new fields to products table
Sub UpgradeSchemaTo149
Dim LSQL
LSQL = "CREATE TABLE suppliers (" +_
"SupplierID INTEGER(11) NOT NULL AUTO_INCREMENT, " +_
"SupplierName VARCHAR(100) NOT NULL DEFAULT '', " +_
"AddressLine1 VARCHAR(100) DEFAULT NULL, " +_
"AddressLine2 VARCHAR(100) DEFAULT NULL, " +_
"Town VARCHAR(100) DEFAULT NULL, " +_
"County VARCHAR(50) DEFAULT NULL, " +_
"Postcode VARCHAR(20) DEFAULT NULL, " +_
"Country VARCHAR(50) DEFAULT NULL, " +_
"ContactName VARCHAR(100) DEFAULT NULL, " +_
"Telephone VARCHAR(100) DEFAULT NULL, " +_
"EmailAddress VARCHAR(100) DEFAULT NULL, " +_
"Website VARCHAR(120) DEFAULT NULL, " +_
"Notes MEDIUMTEXT, " +_
"AvailabilityDaysFrom SMALLINT(6) DEFAULT NULL, " +_
"AvailabilityDaysTo SMALLINT(6) DEFAULT NULL, " +_
"LastUpdated TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP, " +_
"PRIMARY KEY (SupplierID), " +_
"UNIQUE KEY idxSupplierName (SupplierName) " +_
")ENGINE=MyISAM " +_
"AUTO_INCREMENT=1;"
ExecuteQuery LSQL
LSQL = "ALTER TABLE products " +_
"ADD SupplierID INTEGER(11) DEFAULT NULL AFTER CustomFlag, " +_
"ADD AvailabilityDaysFrom SMALLINT(6) DEFAULT NULL AFTER SupplierID, " +_
"ADD AvailabilityDaysTo SMALLINT(6) DEFAULT NULL AFTER AvailabilityDaysFrom, " +_
"ADD INDEX idxSupplierID (SupplierID);"
ExecuteQuery LSQL
SetSchemaVersion(1.49)
End Sub
' (SS,29/6/10) update pictures table to add PictureID autoinc field and resize Code and Code2 from 50 to 75 due to category resize done in schema 1.48
Sub UpgradeSchemaTo150
Dim LSQL
LSQL = "ALTER TABLE pictures " +_
"MODIFY Code VARCHAR(75) NOT NULL DEFAULT '', " +_
"MODIFY Code2 VARCHAR(75) NOT NULL DEFAULT '', " +_
"ADD PictureID INTEGER(11) NOT NULL AUTO_INCREMENT FIRST, " +_
"DROP PRIMARY KEY, " +_
"ADD PRIMARY KEY (PictureID), " +_
"ADD UNIQUE INDEX idxTypeAndCode (Type, Code, Code2);"
ExecuteQuery LSQL
SetSchemaVersion(1.50)
End Sub
' (SS,22/7/10) update products to add new AllowOutOfStockOrdering field, orders to add PackedBy field
' also added fields DeliveryAgentName, DeliveryAgentDate, DeliveryAgentCost which only hyperflight had
Sub UpgradeSchemaTo151
ExecuteQuery "ALTER TABLE products ADD AllowOutOfStockOrdering TINYINT(1) DEFAULT '1' AFTER AvailabilityDaysTo;"
' set the default in each product record for AllowOutOfStockOrdering to the global default setting
ExecuteQuery "UPDATE products SET AllowOutOfStockOrdering = " & BoolToInt(StrToBool(GetSettingFromField("Application", "AllowProductOrderIfNoStock", "FieldValue"))) & ";"
Dim LSQL
LSQL = "ALTER TABLE orders " +_
"ADD DeliveryAgentName VARCHAR(50) DEFAULT NULL COMMENT 'Added 23/3/2010 for Hyperflight' AFTER NewCustomer, " +_
"ADD DeliveryAgentDate DATE DEFAULT NULL COMMENT 'Added 23/3/2010 for Hyperflight' AFTER DeliveryAgentName, " +_
"ADD DeliveryAgentCost DECIMAL(11,2) DEFAULT NULL COMMENT 'Added 23/3/2010 for Hyperflight' AFTER DeliveryAgentDate, " +_
"ADD PackedBy VARCHAR(20) DEFAULT NULL COMMENT 'Added 22/7/2010 for Hyperflight' AFTER DeliveryAgentCost;"
ExecuteQuery LSQL
SetSchemaVersion(1.51)
End Sub
' (SS,21/3/11) added Extra text field after FileName, used to hold URL for Banners, but could be used for other things in future
Sub UpgradeSchemaTo152
ExecuteQuery "ALTER TABLE files ADD Extra VARCHAR(255) DEFAULT NULL AFTER FileName;"
SetSchemaVersion(1.52)
End Sub
' (SS,14/7/11) adding of attributes and options, also ShortMenuName to subcategories
Sub UpgradeSchemaTo153
Dim LSQL
' subcategories table, new MenuShortName field
' decided to add manually to each shopping database, due to integration with shopping admin app categories forms
' ExecuteQuery "ALTER TABLE subcategories ADD COLUMN MenuShortName VARCHAR(30) DEFAULT NULL AFTER Priority"
' products table, new ProductID field, which is now the primary key, unique key added for ProductCode field which was the primary key before
ExecuteQuery "ALTER TABLE products DROP PRIMARY KEY"
ExecuteQuery "ALTER TABLE products ADD COLUMN ProductID INTEGER(11) NOT NULL AUTO_INCREMENT PRIMARY KEY FIRST"
ExecuteQuery "ALTER TABLE products ADD UNIQUE idxProductCode (ProductCode)"
' shoppingbaskets table, new ProductID field which also has an index, index idxSessionIDProductCode replaced with idxSessionID
' shoppingbaskets table is also truncated, because existing records will not have the correct product id
ExecuteQuery "ALTER TABLE shoppingbaskets ADD INDEX idxSessionID (SessionID)"
ExecuteQuery "ALTER TABLE shoppingbaskets DROP INDEX idxSessionIDProductCode"
ExecuteQuery "ALTER TABLE shoppingbaskets ADD COLUMN ProductID INTEGER(11) NOT NULL AFTER SessionID"
ExecuteQuery "ALTER TABLE shoppingbaskets ADD INDEX idxProductID (ProductID)"
ExecuteQuery "TRUNCATE TABLE shoppingbaskets"
' orderdetails table, new ProductID field and index, new OptionsList field, index idxOrderNoProductCode replaced with two separate idxOrderNo and idxProductCode indexes
ExecuteQuery "ALTER TABLE orderdetails DROP INDEX idxOrderNoProductCode"
ExecuteQuery "ALTER TABLE orderdetails ADD COLUMN ProductID INTEGER(11) NOT NULL AFTER OrderNo"
ExecuteQuery "ALTER TABLE orderdetails ADD COLUMN OptionsList VARCHAR(255) DEFAULT NULL AFTER ProductName"
ExecuteQuery "ALTER TABLE orderdetails ADD INDEX idxProductID (ProductID)"
ExecuteQuery "ALTER TABLE orderdetails ADD INDEX idxProductCode (ProductCode)"
ExecuteQuery "ALTER TABLE orderdetails ADD INDEX idxOrderNo (OrderNo)"
' new log_cancelled_sessions table, used for debugging global.asa
LSQL = "CREATE TABLE log_cancelled_sessions (" &_
"ID int(11) NOT NULL AUTO_INCREMENT," &_
"DateTimeLogged timestamp NULL DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP," &_
"SessionID varchar(20) DEFAULT NULL," &_
"OrderNo varchar(10) DEFAULT NULL," &_
"Message varchar(100) DEFAULT NULL," &_
"PRIMARY KEY (ID)" &_
") ENGINE=MyISAM AUTO_INCREMENT=1"
ExecuteQuery LSQL
' new attributes table
LSQL = "CREATE TABLE attributes (" &_
"AttributeID int(11) NOT NULL AUTO_INCREMENT," &_
"AttributeName varchar(50) DEFAULT NULL," &_
"InputType enum('Text','Combo Box','Memo') DEFAULT 'Text'," &_
"Required tinyint(1) NOT NULL DEFAULT '0'," &_
"ValueList varchar(255) DEFAULT NULL COMMENT 'Comma separated list for combo box input type'," &_
"SortOrder int(11) NOT NULL DEFAULT '0'," &_
"PRIMARY KEY (AttributeID)," &_
"UNIQUE KEY idxAttributeName (AttributeName)" &_
") ENGINE=MyISAM AUTO_INCREMENT=1"
ExecuteQuery LSQL
' new product_attributes table
LSQL = "CREATE TABLE product_attributes (" &_
"ProductID int(11) NOT NULL," &_
"AttributeID int(11) NOT NULL," &_
"AttributeValue varchar(100) DEFAULT NULL," &_
"PRIMARY KEY (ProductID,AttributeID)" &_
") ENGINE=MyISAM"
ExecuteQuery LSQL
' new product_options table
LSQL = "CREATE TABLE product_options (" &_
"ProductOptionID int(11) NOT NULL AUTO_INCREMENT," &_
"ProductID int(11) NOT NULL," &_
"OptionName varchar(50) NOT NULL," &_
"InputType enum('Combo Box','Text','Check Box','Radio','Split Combo') NOT NULL DEFAULT 'Combo Box'," &_
"Required tinyint(1) NOT NULL DEFAULT '0'," &_
"SortOrder int(11) NOT NULL DEFAULT '0'," &_
"PRIMARY KEY (ProductOptionID)," &_
"UNIQUE KEY idxProductIDOptionName (ProductID,OptionName)," &_
"KEY idxProductID (ProductID)" &_
") ENGINE=MyISAM AUTO_INCREMENT=1"
ExecuteQuery LSQL
' new product_option_values table
' (SS,1/8/12) changed OptionValue varchar(100) to OptionValue varchar(150)
LSQL = "CREATE TABLE product_option_values (" &_
"ProductOptionValueID int(11) NOT NULL AUTO_INCREMENT," &_
"ProductOptionID int(11) NOT NULL," &_
"ProductID int(11) NOT NULL," &_
"OptionValue varchar(150) NOT NULL DEFAULT ''," &_
"NumInStock int(11) DEFAULT NULL," &_
"PriceAdjust decimal(10,2) NOT NULL DEFAULT '0.00'," &_
"WeightAdjust decimal(10,3) NOT NULL DEFAULT '0.000'," &_
"SortOrder int(11) NOT NULL DEFAULT '0'," &_
"PRIMARY KEY (ProductOptionValueID)," &_
"UNIQUE KEY idxProductOptionIDOptionValue (ProductOptionID,OptionValue)," &_
"KEY idxProductOptionID (ProductOptionID)," &_
"KEY idxProductID (ProductID)" &_
") ENGINE=MyISAM AUTO_INCREMENT=1"
ExecuteQuery LSQL
' new shopping_basket_options table
' (SS,1/8/12) changed OptionValue varchar(100) to OptionValue varchar(150), and OptionName varchar(100) to OptionName varchar(50)
LSQL = "CREATE TABLE shopping_basket_options (" &_
"ShoppingBasketOptionID int(11) NOT NULL AUTO_INCREMENT," &_
"ItemID int(11) NOT NULL," &_
"ProductOptionID int(11) NOT NULL," &_
"ProductOptionValueID int(11) NOT NULL," &_
"OptionName varchar(150) DEFAULT ''," &_
"OptionValue varchar(50) DEFAULT ''," &_
"PRIMARY KEY (ShoppingBasketOptionID)," &_
"KEY idxItemID (ItemID)" &_
") ENGINE=MyISAM AUTO_INCREMENT=1"
ExecuteQuery LSQL
' new order_detail_options table
' (SS,1/8/12) changed OptionValue varchar(100) to OptionValue varchar(150), and OptionName varchar(100) to OptionName varchar(50)
LSQL = "CREATE TABLE order_detail_options (" &_
"OrderDetailOptionID int(11) NOT NULL AUTO_INCREMENT," &_
"OrderNo int(11) NOT NULL," &_
"OrderDetailID int(11) NOT NULL," &_
"ProductOptionID int(11) NOT NULL," &_
"ProductOptionValueID int(11) NOT NULL," &_
"OptionName varchar(50) DEFAULT NULL," &_
"OptionValue varchar(150) DEFAULT NULL," &_
"PRIMARY KEY (OrderDetailOptionID)," &_
"KEY idxOrderDetailID (OrderDetailID)" &_
") ENGINE=MyISAM AUTO_INCREMENT=1"
ExecuteQuery LSQL
' update exist orderdetails records to hold the correct product id instead of 0 for existing records
LSQL = "UPDATE orderdetails, products" &_
" SET orderdetails.ProductID = products.ProductID" &_
" WHERE orderdetails.ProductCode = products.ProductCode AND orderdetails.ProductID = 0"
ExecuteQuery LSQL
SetSchemaVersion(1.53)
End Sub
' (SS,14/2/12) Modify product_options table to add ExtraSettings field after Required
Sub UpgradeSchemaTo154
ExecuteQuery "ALTER TABLE product_options ADD ExtraSettings VARCHAR(50) DEFAULT NULL AFTER Required"
ExecuteQuery "ALTER TABLE stocknotifications ADD ProductOption VARCHAR(100) DEFAULT '' AFTER ProductCode" ' ProductOption used instead of Option due to Option being an internal SQL word
SetSchemaVersion(1.54)
End Sub
' (SS,14/3/12) added DelayUntil field to stocknotifications
Sub UpgradeSchemaTo155
ExecuteQuery "ALTER TABLE stocknotifications ADD DelayUntil DATETIME DEFAULT NULL AFTER DateTimeAdded"
SetSchemaVersion(1.55)
End Sub
' (SS,15/3/12)
Sub UpgradeSchemaTo156
Dim LSQL
' drop loginlog table, no longer used, may add back in future if required for debugging
ExecuteQuery "DROP TABLE loginlog"
' categories table, drop IconFile and LastUpdated fields, add new TitleTag, DescriptionMetaTag and KeywordsMetaTag fields
LSQL = "ALTER TABLE categories " &_
"DROP IconFile, " &_
"DROP LastUpdated, " &_
"ADD TitleTag VARCHAR(66) DEFAULT NULL AFTER GroupName, " &_
"ADD DescriptionMetaTag VARCHAR(165) DEFAULT NULL AFTER TitleTag, " &_
"ADD KeywordsMetaTag VARCHAR(255) DEFAULT NULL AFTER DescriptionMetaTag"
ExecuteQuery LSQL
' subcategories table, add new TitleTag, DescriptionMetaTag and KeywordsMetaTag fields
LSQL = "ALTER TABLE subcategories " &_
"ADD TitleTag VARCHAR(66) DEFAULT NULL AFTER Picture, " &_
"ADD DescriptionMetaTag VARCHAR(165) DEFAULT NULL AFTER TitleTag, " &_
"ADD KeywordsMetaTag VARCHAR(255) DEFAULT NULL AFTER DescriptionMetaTag"
ExecuteQuery LSQL
' groups table, drop ProductListCategorySuffix and FroogleNameSuffix fields, add new TitleTag, DescriptionMetaTag and KeywordsMetaTag fields
LSQL = "ALTER TABLE groups " &_
"DROP ProductListCategorySuffix, " &_
"DROP FroogleNameSuffix, " &_
"ADD TitleTag VARCHAR(66) DEFAULT NULL AFTER SortOrder, " &_
"ADD DescriptionMetaTag VARCHAR(165) DEFAULT NULL AFTER TitleTag, " &_
"ADD KeywordsMetaTag VARCHAR(255) DEFAULT NULL AFTER DescriptionMetaTag"
ExecuteQuery LSQL
' sitedetails table, resize Type from 20 to 25 to allow for "Description Meta Tags"
ExecuteQuery "ALTER TABLE sitedetails MODIFY Type VARCHAR(25) NOT NULL DEFAULT ''"
' attributes table, add new MaxLength field to allow limit to be set for the attribue value field
ExecuteQuery "ALTER TABLE attributes ADD MaxLength INT(11) NOT NULL DEFAULT 0 AFTER ValueList"
' product_attributes table, resize AttributeValue from 100 to 255 to allow Keywords Meta Tag to be held which can be up to 255 chars
ExecuteQuery "ALTER TABLE product_attributes MODIFY AttributeValue VARCHAR(255) DEFAULT NULL"
' attributes table, add new Title Tag, Description Meta Tag and Keywords Meta Tag attributes
LSQL = "INSERT INTO attributes (AttributeName, InputType, Required, ValueList, MaxLength, SortOrder) VALUES " &_
"('Title Tag', 'Text', 0, NULL, 66, 1010), " &_
"('Description Meta Tag', 'Text', 0, NULL, 165, 1020), " &_
"('Keywords Meta Tag', 'Text', 0, NULL, 255, 1030)"
ExecuteQuery LSQL
SetSchemaVersion(1.56)
End Sub
' (SS,27/4/12)
Sub UpgradeSchemaTo157
' product_option_values table, resize OptionValue column from 100 to 150
ExecuteQuery "ALTER TABLE product_option_values MODIFY COLUMN OptionValue varchar(150) NOT NULL DEFAULT ''"
' order_detail_options table, resize OptionValue column from 100 to 150
ExecuteQuery "ALTER TABLE order_detail_options MODIFY COLUMN OptionValue varchar(150) NOT NULL DEFAULT ''"
SetSchemaVersion(1.57)
End Sub
' (SS,30/5/12)
Sub UpgradeSchemaTo158
' added NumInStock to orderdetails to hold a historical number in stock value
' (SS,1/6/12) field renamed from NumInStock to PrevStock
ExecuteQuery "ALTER TABLE orderdetails ADD PrevStock int(11) DEFAULT NULL AFTER PriceEach;"
SetSchemaVersion(1.58)
End Sub
' (SS,19/6/12)
Sub UpgradeSchemaTo159
Dim LSQL
' encrypt the password, add new fields used to reset password: PasswordResetKey, PasswordResetDateTime
' (SS,1/6/12) field renamed from NumInStock to PrevStock
LSQL = "ALTER TABLE customers " &_
"ADD NewPassword varbinary(50) DEFAULT NULL AFTER Password, " &_
"ADD PasswordResetKey varchar(10) DEFAULT NULL AFTER DateTimeLastLogin, " &_
"ADD PasswordResetDateTime datetime DEFAULT NULL AFTER PasswordResetKey"
ExecuteQuery LSQL
' encrypt the Password into NewPassword
ExecuteQuery "UPDATE customers SET NewPassword = " & GetSQLForPasswordEncryption("Password", True)
' drop the original Password field
ExecuteQuery "ALTER TABLE customers DROP Password"
' rename NewPassword to Password
ExecuteQuery "ALTER TABLE customers CHANGE NewPassword Password varbinary(50) DEFAULT NULL"
SetSchemaVersion(1.59)
End Sub
' (SS,28/9/12)
Sub UpgradeSchemaTo160
' review request feature added, new ReviewRequestSentDate field and some extra indexes
ExecuteQuery "ALTER TABLE orders ADD COLUMN ReviewRequestSentDate DATE DEFAULT NULL AFTER PackedBy"
ExecuteQuery "ALTER TABLE orders ADD INDEX idxReviewRequestSentDate (ReviewRequestSentDate)"
ExecuteQuery "ALTER TABLE orders ADD INDEX idxDateTimeOrdered (DateTimeOrdered)"
ExecuteQuery "ALTER TABLE orders ADD INDEX idxDateTimeCompleted (DateTimeCompleted)"
ExecuteQuery "ALTER TABLE orders ADD INDEX idxStatus (Status)"
SetSchemaVersion(1.60)
End Sub
' (SS,08/11/12)
Sub UpgradeSchemaTo161
Dim LSQL
' added 3 new fields to products table
LSQL = "ALTER TABLE products " &_
"ADD MinUSDPrice DECIMAL(10,2) DEFAULT NULL AFTER Price4, " &_
"ADD MinEURPrice DECIMAL(10,2) DEFAULT NULL AFTER MinUSDPrice, " &_
"ADD DateAdded DATE DEFAULT NULL AFTER MPN"
ExecuteQuery LSQL
SetSchemaVersion(1.61)
End Sub
' (SS,06/12/12)
Sub UpgradeSchemaTo162
Dim LSQL
LSQL = "ALTER TABLE customers " &_
"ADD OrderReminderSentDate DATE DEFAULT NULL AFTER PasswordResetDateTime, " &_
"ADD OrderReminderOptOut TINYINT(1) DEFAULT 0 AFTER OrderReminderSentDate"
ExecuteQuery LSQL
SetSchemaVersion(1.62)
End Sub
' (SS,10/01/13)
Sub UpgradeSchemaTo163
Dim LSQL
LSQL = "ALTER TABLE categories " &_
"ADD Heading VARCHAR(100) DEFAULT NULL AFTER MenuShortName, " &_
"ADD Footer MEDIUMTEXT AFTER Description"
ExecuteQuery LSQL
LSQL = "ALTER TABLE subcategories " &_
"ADD Heading VARCHAR(100) DEFAULT NULL AFTER GoogleProductCategory, " &_
"ADD Footer MEDIUMTEXT AFTER Description"
ExecuteQuery LSQL
SetSchemaVersion(1.63)
End Sub
' (SS,13/2/13)
Sub UpgradeSchemaTo164
Dim LSQL
LSQL = "ALTER TABLE orders " &_
"ADD CancelledOrderChasedDate date DEFAULT NULL AFTER ReviewRequestSentDate"
ExecuteQuery LSQL
SetSchemaVersion(1.64)
End Sub
' (SS,28/2/13)
' (SS,5/3/13) modified to only add customer records if customer has a successful order
Sub UpgradeSchemaTo165
Dim LSQL
LSQL = "ALTER TABLE customers " &_
"ADD MarketingEmailSentDate date DEFAULT NULL AFTER OrderReminderOptOut"
ExecuteQuery LSQL
' (SS,28/2/13) for sites with optional accounts, i.e. not Galleon
If AccountsOptional Then
' !!! for shopping sites that don't force customer record creation (i.e. non galleon)
DebugLog -1, "UpgradeSchemaTo165" ' (SS,11/11/13)
' find customer ID for matching email address
LSQL = "UPDATE orders, customers SET orders.CustomerID = customers.CustomerID" &_
" WHERE customers.EmailAddress = orders.EmailAddress" &_
" AND (orders.CustomerID = '' OR orders.CustomerID IS NULL)"
DebugLog -1, LSQL ' (SS,11/11/13)
ExecuteQuery LSQL
' find customer ID for matching address
LSQL = "UPDATE orders, customers SET orders.CustomerID = customers.CustomerID" &_
" WHERE customers.FirstName = orders.FirstName" &_
" AND customers.Surname = orders.Surname" &_
" AND customers.CompanyName = orders.CompanyName" &_
" AND customers.AddressLine1 = orders.AddressLine1" &_
" AND customers.AddressLine2 = orders.AddressLine2" &_
" AND customers.Town = orders.Town" &_
" AND customers.County = orders.County" &_
" AND customers.Postcode = orders.Postcode" &_
" AND customers.Country = orders.Country" &_
" AND (orders.CustomerID = '' OR orders.CustomerID IS NULL)"
DebugLog -1, LSQL ' (SS,11/11/13)
ExecuteQuery LSQL
' select the latest order for those that don't have a customer record, if more then one for the email address then it select the latest order no
' insert the new record into customers
' (SS,5/3/13) modified to only had records for successful orders, i.e. not CANCELLED or ORDER PLACED
LSQL = "INSERT INTO customers" &_
" (EmailAddress, Title, FirstName, Surname, CompanyName, AddressLine1, AddressLine2, Town, County, Postcode, Country," &_
" Telephone, Mobile, VATNumber," &_
" DeliveryAddressSameAsInvoice, DeliveryName, DeliveryCompanyName, DeliveryAddressLine1, DeliveryAddressLine2, DeliveryTown, DeliveryCounty, DeliveryPostcode, DeliveryCountry, Subscribe, HearAboutUs)" &_
" SELECT " &_
" o1.EmailAddress, Title, FirstName, Surname, CompanyName, AddressLine1, AddressLine2, Town, County, Postcode, Country," &_
" Telephone, Mobile, VATNumber," &_
" DeliveryAddressSameAsInvoice, DeliveryName, DeliveryCompanyName, DeliveryAddressLine1, DeliveryAddressLine2, DeliveryTown, DeliveryCounty, DeliveryPostcode, DeliveryCountry, Subscribe, HearAboutUs" &_
" FROM orders o1" &_
" INNER JOIN (SELECT o2.EmailAddress, MAX(o2.OrderNo) AS LatestOrderNo FROM orders o2 WHERE (o2.CustomerID = '' OR o2.CustomerID IS NULL)" &_
" AND o2.Status <> 'CANCELLED' AND o2.Status <> 'ORDER PLACED'" &_
" GROUP BY o2.EmailAddress) latest" &_
" ON latest.LatestOrderNo = o1.OrderNo" &_
" WHERE (CustomerID = '' OR CustomerID IS NULL) AND o1.Status <> 'CANCELLED' AND o1.Status <> 'ORDER PLACED'" &_
" ORDER BY OrderNo"
ExecuteQuery LSQL
DebugLog -1, LSQL ' (SS,11/11/13)
' update the orders with CustomerID from new inserted customer record by running first query again
LSQL = "UPDATE orders, customers SET orders.CustomerID = customers.CustomerID" &_
" WHERE customers.EmailAddress = orders.EmailAddress" &_
" AND (orders.CustomerID = '' OR orders.CustomerID IS NULL)"
ExecuteQuery LSQL
DebugLog -1, LSQL ' (SS,11/11/13)
' (SS,11/11/13) the DateTimeCreated field was null, so set this to the current date
LSQL = "UPDATE customers SET DateTimeCreated = CURDATE() WHERE DateTimeCreated IS NULL"
ExecuteQuery LSQL
DebugLog -1, LSQL ' (SS,11/11/13)
End If
SetSchemaVersion(1.65)
End Sub
' (SS,6/3/13) change CustomerID in orders table from VARCHAR(20) to INT(11), as it is in customers, was VARCHAR for toner2desk
Sub UpgradeSchemaTo166
' convert all the blank strings to null to prevent ALTER TABLE query below from failing with error
ExecuteQuery "UPDATE orders SET CustomerID = NULL WHERE CustomerID = ''"
' change CustomerID to integer
ExecuteQuery "ALTER TABLE orders MODIFY CustomerID int(11) DEFAULT NULL"
SetSchemaVersion(1.66)
End Sub
' (SS,13/12/13) added new Picture flag field to product_option_values table
Sub UpgradeSchemaTo167
ExecuteQuery "ALTER TABLE product_option_values ADD Picture TINYINT(1) DEFAULT 0 NOT NULL"
SetSchemaVersion(1.67)
End Sub
' (SS,21/7/22) make OrderNo in orders an AUTO_INCREMENT field
Sub UpgradeSchemaTo7
ExecuteQuery "ALTER TABLE orders MODIFY COLUMN OrderNo INT(11) NOT NULL AUTO_INCREMENT"
SetSchemaVersion(7)
End Sub
' (SS,14/11/07)
Function GetSchemaVersion
GetSchemaVersion = FSchemaVersion
End Function
' (SS,14/11/07)
Sub SetSchemaVersion(AVersion)
SetSetting "Application", "SchemaVersion", AVersion
End Sub
' (SS,25/11/08) added to change the VAT from 17.5% to 15% on 1/12/2008
' (SS,22/12/09) added VAT change from 15% to 17.5% on 1/1/2010
' (SS,21/12/10) renamed from CheckVAT, can be deleted
Sub CheckVATOld
' if date is >= 1/12/2008 and VAT Rate is 17.5% then change to 15% in settings table and vatbands table
' (SS,22/12/09) added And DateDiff("d", "1/1/2010", Date) < 0 so this isn't called for dates >= 1/12/2008
If DateDiff("d", "1/12/2008", Date) >= 0 And DateDiff("d", "1/1/2010", Date) < 0 And FVATRate = 0.175 Then
FVATRate = 0.15
SetSetting "Application", "VATRate", FVATRate
ExecuteQuery("UPDATE vatbands SET VATRate = 0.15 WHERE VATRate = 0.175")
' (SS,22/12/09) added following for VAT change
' if date is >= 1/1/2010 and VAT Rate is 15% then change to 17.5% in settings table and vatbands table
ElseIf DateDiff("d", "1/1/2010", Date) >= 0 And FVATRate = 0.15 Then
FVATRate = 0.175
SetSetting "Application", "VATRate", FVATRate
ExecuteQuery("UPDATE vatbands SET VATRate = 0.175 WHERE VATRate = 0.15")
End If
End Sub
' (SS,25/11/08) added to change the VAT from 17.5% to 15% on 1/12/2008
' (SS,22/12/09) added VAT change from 15% to 17.5% on 1/1/2010
' (SS,21/12/10) added VAT change from 17.5% to 20% on 4/1/2011, previous code renamed to CheckVATOld see above
Sub CheckVAT
' if date is >= 4/1/2011 and VAT Rate is 17.5% then change to 20% in settings table and vatbands table
If DateDiff("d", "4/1/2011", Date) >= 0 And FVATRate = 0.175 Then
FVATRate = 0.20
SetSetting "Application", "VATRate", FVATRate
ExecuteQuery("UPDATE vatbands SET VATRate = 0.20 WHERE VATRate = 0.175")
End If
End Sub
' (SS,12/4/11) for redirecting pages, useful when product codes, categories or subcategories have been renamed
' and Google is still showing the old values, this will redirect to the required place
' the redirect list is held in the sitedetails table, "Other / RedirectionList" section
' (SS,1/3/13) change to allow semicolon to also be used to separate as well as comma, to allow names to contain a comma
' (SS,12/5/16) modified to redirect to category/subcategory page if product detail page and product is disabled
' (SS,13/6/17) modified to fix redirection issue for subcategories, new GetSubcategoryLinkForRedirect now called instead of GetSubcategoryLink
Sub ProcessRedirections
Dim LPageType, LCode1, LCode2
' determine page type, return immediately if not the appropriate page
If IsProductDetailsPage Then
LPageType = "P"
LCode1 = GetProductCode
LCode2 = ""
ElseIf IsCategoryPage Then
LPageType = "C"
LCode1 = GetCategory
LCode2 = ""
ElseIf IsSubcategoryPage Then
LPageType = "S"
LCode1 = GetCategory
LCode2 = GetSubcategory
Else
Exit Sub
End If
' return if redirection list is empty
Dim LRedirectionList
LRedirectionList = TrimAll(GetSiteDetail("Other", "RedirectionList"))
If LRedirectionList = "" Then Exit Sub
Dim LLines, i, LCols, LFound, LRedirectionType, LRedirectionCode1, LRedirectionCode2, LRedirectionCode3, LRedirectionCode4, LSeparator
LLines = Split(LRedirectionList, NL, -1, 0)
LFound = False
For i = LBound(LLines) to UBound(LLines)
' Response.Write "###" & i & ", " & LLines(i) & "###<br>"
' (SS,1/3/13) added following to allow semicolon to be used as separator as well, useful when date contains a comma, it takes priority over comma
If InStr(LLines(i), ";") > 0 Then
LSeparator = ";"
Else
LSeparator = ","
End If
LCols = Split(LLines(i), LSeparator, -1, 0) ' (SS,1/3/13) replaced "," with LSeparator
If UBound(LCols) > 0 Then ' ignore lines with no content and just one column, e.g. comments allowed with # prefix
LRedirectionType = UCase(Trim(LCols(0)))
If LRedirectionType = LPageType Then
If UBound(LCols) >= 1 Then LRedirectionCode1 = Trim(LCols(1)) Else LRedirectionCode1 = ""
If UBound(LCols) >= 2 Then LRedirectionCode2 = Trim(LCols(2)) Else LRedirectionCode2 = ""
If UBound(LCols) >= 3 Then LRedirectionCode3 = Trim(LCols(3)) Else LRedirectionCode3 = ""
If UBound(LCols) >= 4 Then LRedirectionCode4 = Trim(LCols(4)) Else LRedirectionCode4 = ""
If LPageType = "S" Then
If LCode1 = LRedirectionCode1 And LCode2 = LRedirectionCode2 And LRedirectionCode3 <> "" And LRedirectionCode4 <> "" Then
LFound = True
Exit For
End If
Else
If LCode1 = LRedirectionCode1 And LRedirectionCode2 <> "" Then
LFound = True
Exit For
End If
End If
End If
End If
Next
Dim LURL
LURL = "" ' (SS,12/5/16)
' if match found then do the redirection
If LFound Then
If LPageType = "P" Then
LURL = GetProductLink(LRedirectionCode2)
ElseIf LPageType = "C" Then
LURL = GetCategoryLink(LRedirectionCode2)
Else ' "S"
' (SS,13/6/17) replaced GetSubcategoryLink with GetSubcategoryLinkForRedirect because & doesn't work correctly
LURL = GetSubcategoryLinkForRedirect(LRedirectionCode3, LRedirectionCode4)
End If
' (SS,12/5/16) if product page and product exists and is disabled then redirect to category / subcategory page
ElseIf LPageType = "P" And LCode1 <> "" Then
'Response.Write "### 0.1 REACHED HERE ###" & BR
If Not CheckEnabledProductExists(LCode1) Then
'Response.Write "### 0.2 REACHED HERE ###" & BR
Dim LGroup, LCategory, LSubcategory
GetFirstCatSubcatForProduct LCode1, LGroup, LCategory, LSubcategory
If LCategory <> "" Then
' (SS,27/10/20) added check for special category (i.e. case studies for GSC)
If Not IsSpecialCategory(LCategory) Then
' (SS,13/6/17) replaced GetSubcategoryLink with GetSubcategoryLinkForRedirect because & doesn't work correctly
LURL = GetSubcategoryLinkForRedirect(LCategory, LSubcategory)
End If
End If
End If
End If
If LURL <> "" Then
' prefix with store URL which includes http:// if it hasn't already been added by GetCategoryLink etc.
If Left(LURL, 7) <> "http://" Then LURL = GetStoreURL + "/" + LURL
' do the permanent redirection
' (SS,1/7/11) redirection code moved to new routine DoRedirect
DoRedirect LURL, True
End If
End Sub
' (SS,16/5/11) makes use of the redirection list to lookup replacement product code for given product
Function GetReplacementProductCode(AProductCode)
Dim LResult, LRedirectionList
LResult = AProductCode ' assume no match, i.e. return same code
' return straightaway if redirection list is empty, else find a match
LRedirectionList = TrimAll(GetSiteDetail("Other", "RedirectionList"))
If LRedirectionList <> "" Then
Dim LLines, i, LCols, LFound
LLines = Split(LRedirectionList, NL, -1, 0)
LFound = False
For i = LBound(LLines) to UBound(LLines)
LCols = Split(LLines(i), ",", -1, 0)
If UBound(LCols) = 2 Then ' ignore lines with no content and just one column, e.g. comments allowed with # prefix, i.e. only look at lines with 3 values
If UCase(Trim(LCols(0))) = "P" And Trim(LCols(1)) = AProductCode Then
If Trim(LCols(2)) <> "" Then LResult = Trim(LCols(2))
LFound = True
Exit For
End If
End If
Next
End If
GetReplacementProductCode = LResult
End Function
' (SS,10/6/07) *** followings settings to be held in a common database
Function GetMailServer(AServerNo)
If AServerNo = 1 Then
GetMailServer = "mail.itpartnership.com"
ElseIf AServerNo = 2 Then
GetMailServer = "mail.ontheworldweb.com"
Else
GetMailServer = ""
End If
End Function
' (SS,6/6/07) returns name of current script file, in most cases this will be products.asp
' but could also be worldpay-callback.asp etc
Function GetScriptName
Dim LScriptName
LScriptName = LCase(Request.ServerVariables("SCRIPT_NAME"))
If Left(LScriptName, 1) = "/" Then LScriptName = Mid(LScriptName, 2, Len(LScriptName) - 1)
GetScriptName = LScriptName
End Function
' (SS,18/11/13) returns true if script name is products.asp
Function ScriptIsProducts
ScriptIsProducts = GetScriptName = "products.asp"
End Function
' (SS,19/2/13)
Function GetURLForPage(APageName)
GetURLForPage = "products.asp?page=" & APageName
End Function
' (SS,14/6/07)
Function GetDevelopmentPassword
GetDevelopmentPassword = FDevelopmentPassword
End Function
' (SS,21/5/07)
Function FourPricingFieldsEnabled
FourPricingFieldsEnabled = FFourPricingFieldsEnabled
End Function
' (SS,21/5/07)
Function PricesEnteredIncludeVAT
PricesEnteredIncludeVAT = FPricesEnteredIncludeVAT
End Function
' (SS,21/5/07)
Function UseDiscountFieldForSpecialOffers
UseDiscountFieldForSpecialOffers = FUseDiscountFieldForSpecialOffers
End Function
' (SS,21/5/07)
Function VATBandsEnabled
VATBandsEnabled = FVATBandsEnabled
End Function
' (SS,26/5/07)
Function CustomPricingEnabled
CustomPricingEnabled = FCustomPricingEnabled
End Function
' (SS,13/9/07)
Function GetDeliveryType
If IsNull(FDeliveryType) Or FDeliveryType = "" Then
GetDeliveryType = DT_ORIGINAL
Else
GetDeliveryType = FDeliveryType
End If
End Function
' (SS,26/5/07)
' (SS,13/9/07) replaced FCustomDeliveryEnabled with FDeliveryType = DT_CUSTOM
Function CustomDeliveryEnabled
CustomDeliveryEnabled = FDeliveryType = DT_CUSTOM
End Function
' (SS,27/5/07)
Function UseVATFlagFromCountries
UseVATFlagFromCountries = FUseVATFlagFromCountries
End Function
' (SS,22/6/07)
Function GetWeightUnits
GetWeightUnits = FWeightUnits
End Function
' (SS,22/6/07)
Function GetShowWeightInEmail
GetShowWeightInEmail = FShowWeightInEmail
End Function
' (SS,30/5/07)
Function LargeThumbnailWidth
LargeThumbnailWidth = FLargeThumbnailWidth
End Function
' (SS,30/5/07)
Function LargeThumbnailHeight
LargeThumbnailHeight = FLargeThumbnailHeight
End Function
' (SS,19/3/09)
Function SmallThumbnailWidth
SmallThumbnailWidth = FSmallThumbnailWidth
End Function
' (SS,19/3/09)
Function SmallThumbnailHeight
SmallThumbnailHeight = FSmallThumbnailHeight
End Function
' (SS,5/6/07)
Function GetDefaultCountry
GetDefaultCountry = FDefaultCountry
End Function
' (SS,14/6/07)
Function GetAccountID
GetAccountID = Session("AccountID")
End Function
' (SS,20/9/12) alias for GetAccountID
Function GetCustomerID
GetCustomerID = GetAccountID
End Function
' (SS,5/6/07)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Function PaymentOnAccountEnabled
PaymentOnAccountEnabled = False
If AccountLoggedIn And FieldExistsInTable("customers", "PaymentOnAccount") Then
PaymentOnAccountEnabled = IntToBool(GetValueFromQuery("PaymentOnAccount", "SELECT PaymentOnAccount FROM customers WHERE CustomerID = '" & CleanSQLStr(Session("AccountID")) & "'"))
End If
End Function
' (SS,14/6/07)
Function GetPaymentType
GetPaymentType = FPaymentType
End Function
' (SS,16/6/09) same as GetPaymentType
Function GetPaymentType1
GetPaymentType1 = FPaymentType
End Function
' (SS,28/9/07)
Function GetPaymentType2
GetPaymentType2 = FPaymentType2
End Function
' (SS,4/6/09)
Function GetPaymentType3
GetPaymentType3 = FPaymentType3
End Function
' (SS,21/5/10)
Function GetPaymentHideCurrency
GetPaymentHideCurrency = FPaymentHideCurrency
End Function
' (SS,16/6/09) returns number of different payment type including cheque and bank transfer
Function PaymentTypeCount
Dim LCount
LCount = 0
If GetPaymentType1 <> "" Then LCount = LCount + 1
If GetPaymentType2 <> "" Then LCount = LCount + 1
If GetPaymentType3 <> "" Then LCount = LCount + 1
If AllowCheques Then LCount = LCount + 1
If AllowBankTransfers Then LCount = LCount + 1
PaymentTypeCount = LCount
End Function
' (SS,20/11/08) returns chosen payment type from hidden frmCheckout field
Function GetChosenPaymentType
GetChosenPaymentType = CleanRequestForm("paymenttype")
End Function
' (SS,29/5/09)
Function IsChosenPaymentCheque
IsChosenPaymentCheque = GetChosenPaymentType = ptCheque
End Function
' (SS,29/5/09)
' (SS,4/8/17) modified to return true if starts if "BANK TRANSFER" i.e. can be "BANK TRANSFER - EUR", "BANK TRANSFER - USD" etc.
Function IsChosenPaymentBankTransfer
' IsChosenPaymentBankTransfer = GetChosenPaymentType = ptBankTransfer
' (SS,4/8/17) replaced above with following
IsChosenPaymentBankTransfer = IsPaymentBankTransfer(GetChosenPaymentType)
End Function
' (SS,4/8/17) added following due to new ptBankTransferEUR and ptBankTransferUSD
Function IsPaymentBankTransfer(APaymentMethod)
IsPaymentBankTransfer = APaymentMethod = ptBankTransfer Or APaymentMethod = ptBankTransferEUR Or APaymentMethod = ptBankTransferUSD Or APaymentMethod = ptBankTransferGBP ' (SS,29/9/17) added ptBankTransferGBP
End Function
' (SS,10/12/14)
Function IsChosenPaymentPayPalExpress
IsChosenPaymentPayPalExpress = GetChosenPaymentType = ptPayPalExpress
End Function
' (SS,16/12/14)
Function ReturnFromPayPalExpressLaterStage
ReturnFromPayPalExpressLaterStage = CleanRequestQueryString("xcmd") = "paypallaterstage"
End Function
' (SS,21/3/13)
Function ReturnFromPaymentProvider(APaymentType)
ReturnFromPaymentProvider = (CleanRequest("stage") = RETURN_FROM_THIRD_PARTY_PAYMENT) And (CleanRequest("pt") = APaymentType)
End Function
' (SS,14/6/07)
Function GetWorldPayInstallID
GetWorldPayInstallID = FWorldPayInstallID
End Function
' (SS,14/6/07)
Function GetWorldPayTestMode
GetWorldPayTestMode = FWorldPayTestMode
End Function
' (SS,14/11/12)
Function GetWorldPayMD5SecretKey
GetWorldPayMD5SecretKey = FWorldPayMD5SecretKey
End Function
' (SS,14/6/07)
Function GetPayPalBusiness
GetPayPalBusiness = FPayPalBusiness
End Function
' (SS,14/6/07)
Function GetPayPalTestMode
GetPayPalTestMode = FPayPalTestMode
End Function
' (SS,22/6/07)
Function GetPayPalShippingAddressFlag
GetPayPalShippingAddressFlag = FPayPalShippingAddressFlag
End Function
' (SS,15/12/14)
' (SS,26/1/15) now alias to GetPayPalExpressEnabled
Function UsePayPalExpress
UsePayPalExpress = GetPayPalExpressEnabled
End Function
' (SS,26/1/15)
Function GetPayPalExpressEnabled
GetPayPalExpressEnabled = FPayPalExpressEnabled
End Function
' (SS,26/1/15)
Function GetPayPalAPIUserName
GetPayPalAPIUserName = FPayPalAPIUserName
End Function
' (SS,26/1/15)
Function GetPayPalAPIPassword
GetPayPalAPIPassword = FPayPalAPIPassword
End Function
' (SS,26/1/15)
Function GetPayPalAPISignature
GetPayPalAPISignature = FPayPalAPISignature
End Function
' (SS,9/4/18)
Function GetPayPalUKOnlyCheckout
GetPayPalUKOnlyCheckout = FPayPalUKOnlyCheckout
End Function
' (SS,23/4/18)
Function GetPayPalExpressShowOnBasketPage
GetPayPalExpressShowOnBasketPage = FPayPalExpressShowOnBasketPage
End Function
' (SS,8/6/18)
Function GetPayPalSurchargePercentage
If IsPayPalSurcharge Then
GetPayPalSurchargePercentage = FPayPalNonUKSurchargePercentage
Else
GetPayPalSurchargePercentage = 0
End If
End Function
' (SS,8/6/18)
Function IsPayPalSurcharge
IsPayPalSurcharge = FPayPalNonUKSurchargePercentage > 0 And Not IsUK(GetInvoiceCountry)
End Function
' (SS,8/6/18) apply surcharge if applicable
Function PayPalAmountWithSurcharge(AAmount)
Dim LNewAmount
'SendWebLogEmail "Original Amount: " & AAmount
If IsPayPalSurcharge Then
LNewAmount = Round2dp(AAmount * (1 + (GetPayPalSurchargePercentage / 100)))
Else
LNewAmount = AAmount
End If
'SendWebLogEmail "Amount with Surcharge: " & LNewAmount
PayPalAmountWithSurcharge = LNewAmount
End Function
' (SS,3/8/22)
Function GetPayPalPayLaterMessagesEnabled
GetPayPalPayLaterMessagesEnabled = FPayPalPayLaterMessagesEnabled And GetPayPalPayLaterMessagesClientID <> ""
End Function
' (SS,3/8/22)
Function GetPayPalPayLaterMessagesClientID
GetPayPalPayLaterMessagesClientID = FPayPalPayLaterMessagesClientID
End Function
' (SS,14/6/07)
Function GetEPDQClientID
GetEPDQClientID = FEPDQClientID
End Function
' (SS,14/6/07)
Function GetEPDQPassphrase
GetEPDQPassphrase = FEPDQPassphrase
End Function
' (SS,14/6/07)
Function GetEPDQChargeType
GetEPDQChargeType = FEPDQChargeType
End Function
' (SS,10/5/12)
Function GetEPDQMerchantDisplayName
If FEPDQMerchantDisplayName = "" Then
GetEPDQMerchantDisplayName = GetStoreName
Else
GetEPDQMerchantDisplayName = FEPDQMerchantDisplayName
End If
End Function
' (SS,2/10/14)
Function GetEPDQPARAMVAR
GetEPDQPARAMVAR = FEPDQPARAMVAR
End Function
' (SS,26/4/18)
Function GetEPDQTestMode
GetEPDQTestMode = FEPDQTestMode
End Function
' (SS,20/3/13)
Function GetSagePayVendorName
GetSagePayVendorName = FSagePayVendorName
End Function
' (SS,20/3/13)
Function GetSagePayMode
GetSagePayMode = FSagePayMode
End Function
' (SS,20/3/13)
Function GetSagePayEncryptionKey
GetSagePayEncryptionKey = FSagePayEncryptionKey
End Function
' (SS,22/3/13) activate payment provider test mode if pptest = true in URL
Sub CheckPaymentProviderTestMode
If LCase(CleanRequest("pptest")) = "true" Then
Session("PaymentProviderTestModeActivated") = True
End If
End Sub
' (SS,22/3/13)
Function IsPaymentProviderTestModeActivated
IsPaymentProviderTestModeActivated = Session("PaymentProviderTestModeActivated")
End Function
' (SS,22/3/13)
Function IsSagePayTestMode
IsSagePayTestMode = GetSagePayMode <> "LIVE"
End Function
' (SS,28/5/09)
' (SS,17/2/12) added And IsCurrencyGBP
' (SS,28/10/22) added And InvoiceCountryIsUK to not show for non-UK countries
Function AllowCheques
AllowCheques = FAllowCheques And IsCurrencyGBP And InvoiceCountryIsUK
End Function
' (SS,29/5/09)
Function AllowBankTransfers
AllowBankTransfers = FAllowBankTransfers
End Function
' (SS,29/5/09)
Function GetChequesPayableTo
GetChequesPayableTo = FChequesPayableTo
End Function
' (SS,29/5/09)
' (SS,20/2/12) now handles details for different countries if set i.e. EUR and USD
' (SS,19/12/14) modified to make use of the new DefaultPaymentCurrencyCode field in the orders table, now assumes orders database accessible with GetFieldValue
' (SS,9/8/17) new version which calls new GetBankTransferDetailsForCurrency below (allows call for testing via bank-details.asp (in local mode)
Function GetBankTransferDetails
Dim LCurrencyCode
' (SS,19/12/14) added following to make use of DefaultPaymentCurrencyCode
LCurrencyCode = GetCurrencyCode
If IsMulticurrency And IsMulticurrencyMethodLocalTable And GetCurrencyCode <> GetFieldValue("DefaultPaymentCurrencyCode") Then
LCurrencyCode = GetFieldValue("DefaultPaymentCurrencyCode")
End If
GetBankTransferDetails = GetBankTransferDetailsForCurrency(LCurrencyCode, GetFieldValue("Country")) ' (SS,29/9/17) added GetFieldValue("Country")
End Function
' (SS,9/8/17) new separated version which allows call for testing via bank-details.asp (in local mode)
' (SS,29/9/17) added ABillingCountry because we have two different GBP accounts
Function GetBankTransferDetailsForCurrency(ACurrencyCode, ABillingCountry)
Dim LResult
LResult = ""
If ACurrencyCode = "EUR" Then
LResult = FBankTransferDetailsEUR
ElseIf ACurrencyCode = "USD" Then
LResult = FBankTransferDetailsUSD
End If
' (SS,29/9/17) if GBP and UK
If ACurrencyCode = "GBP" And IsUK(ABillingCountry) Then
LResult = FBankTransferDetailsGBP
End If
If LResult = "" Then ' i.e. not set above e.g. currency other than EUR, USD or GBP, or GBP and not UK
LResult = FBankTransferDetails
End If
GetBankTransferDetailsForCurrency = LResult
End Function
' (SS,29/5/09)
' (SS,20/2/12) replaced FBankTransferDetails with LBankTransferDetails which calls GetBankTransferDetails
' (SS,9/8/17) modified to call GetTextAsHTMLTable to convert to HTML table
Function GetBankTransferDetailsAsHTML
Dim LBankTransferDetails
LBankTransferDetails = GetBankTransferDetails
' if it already contains a <br> or <td> then assume it's already in HTML format and don't a convert newlines to BRs
If InStr(1, LBankTransferDetails, "<br>", vbTextCompare) > 0 Or InStr(1, LBankTransferDetails, "<td>", vbTextCompare) > 0 Then
GetBankTransferDetailsAsHTML = LBankTransferDetails
Else
'GetBankTransferDetailsAsHTML = ReplaceNewLinesWithBR(LBankTransferDetails)
' (SS,9/8/17) replaced above with following to convert text to HTML table
GetBankTransferDetailsAsHTML = BankTransferDetailsToHTML(LBankTransferDetails)
End If
End Function
' (SS,10/8/17) returns given bank transfer details converted to HTML (i.e. table added)
Function BankTransferDetailsToHTML(ABankTransferDetails)
BankTransferDetailsToHTML = GetTextAsHTMLTable(ABankTransferDetails, ":", True, True, "right")
End Function
' (SS,9/8/17) adds HTML to given text, NL is used to separate lines, AColumnSeparator to separate columns, if AKeepSeparator is True then the separate is kept at the end of the column
' e.g. GetTextAsHTMLTable(ABankTransferText, ":", True, True) for
' Account name: HyperFlight Ltd
' Sort Code: 40-27-06
' Account number: 52202921
' AFirstColAlign can be "" for no change in align, "right" or "left" or "center" i.e. anything applicable to text-align in css
' NL deliberately not added to the HTML due to possibility of conversion of them to BRs in subsequent code (e.g. order emails) and result in unnecessary spacing
Function GetTextAsHTMLTable(AText, AColumnSeparator, AKeepSeparator, AFirstColIsHeading, AFirstColAlign)
' split text into lines
' split line into columns
' add the table HTML
Dim LResult, LText
LText = Trim(AText)
LResult = ""
If LText <> "" Then
LResult = LResult & "<table>"
Dim i, LLines, LLine, c, LColumns, LColumn, LFirstCol, LLastCol, LColTag
LLines = Split(AText, NL, -1, 0)
For i = LBound(LLines) to UBound(LLines)
LResult = LResult & "<tr>"
LLine = Trim(LLines(i))
LColumns = Split(LLine, AColumnSeparator, -1, 0)
LFirstCol = LBound(LColumns)
LLastCol = UBound(LColumns)
For c = LFirstCol to LLastCol
If c = LFirstCol And AFirstColIsHeading Then
LColTag = "th"
Else
LColTag = "td"
End If
LColumn = Trim(LColumns(c))
LResult = LResult & "<" & LColTag
If c = LFirstCol And AFirstColIsHeading And AFirstColAlign <> "" Then LResult = LResult & " style=""text-align:" & AFirstColAlign & """"
LResult = LResult & ">" & LColumn
If c <> LLastCol And AKeepSeparator Then LResult = LResult & AColumnSeparator & " " ' add non breaking space to ensure gap
LResult = LResult & "</" & LColTag & ">"
Next
LResult = LResult & "</tr>"
Next
LResult = LResult & "</table>"
End If
GetTextAsHTMLTable = LResult
End Function
' (SS,18/6/09)
Function GetWorldPaySiteSeal
GetWorldPaySiteSeal = FWorldPaySiteSeal
End Function
' (SS,18/6/09)
Function GetPayPalSiteSeal
GetPayPalSiteSeal = FPayPalSiteSeal
End Function
' (SS,8/6/07)
Function HTMLEmailsEnabled
HTMLEmailsEnabled = FHTMLEmailsEnabled
End Function
' (SS,17/4/09)
Function EmailSecurityCodeEnabled
EmailSecurityCodeEnabled = FEmailSecurityCodeEnabled
End Function
' (SS,14/6/10)
Function EmailConfirmationIsVATReceipt
EmailConfirmationIsVATReceipt = FEmailConfirmationIsVATReceipt
End Function
' (SS,23/10/15)
Function EmailUseMessageToCustomerForDespatch
EmailUseMessageToCustomerForDespatch = FEmailUseMessageToCustomerForDespatch
End Function
' (SS,17/4/09)
Function ChooseDeliveryDate
ChooseDeliveryDate = FChooseDeliveryDate
End Function
' (SS,17/4/09)
Function MaxDeliveryDays
MaxDeliveryDays = FMaxDeliveryDays
End Function
' (SS,25/9/20)
Function ShowDeliveryAddToExistingOrder
ShowDeliveryAddToExistingOrder = FShowDeliveryAddToExistingOrder
End Function
' (SS,17/4/09)
' (SS,18/5/21) replaced FMobileEnabled with FAlternativePhoneEnabled
Function AlternativePhoneEnabled
AlternativePhoneEnabled = FAlternativePhoneEnabled
End Function
' (SS,26/1/16)
Function CheckoutConfirmTermAndConditions
CheckoutConfirmTermAndConditions = FCheckoutConfirmTermAndConditions
End Function
' (SS,11/6/07)
Function DeliveryUKLimit
DeliveryUKLimit = FDeliveryUKLimit
End Function
Function DeliveryUKBelow
DeliveryUKBelow = FDeliveryUKBelow
End Function
Function DeliveryUKAbove
DeliveryUKAbove = FDeliveryUKAbove
End Function
Function DeliveryUKText
DeliveryUKText = FDeliveryUKText
End Function
Function DeliveryEULimit
DeliveryEULimit = FDeliveryEULimit
End Function
Function DeliveryEUBelow
DeliveryEUBelow = FDeliveryEUBelow
End Function
Function DeliveryEUAbove
DeliveryEUAbove = FDeliveryEUAbove
End Function
Function DeliveryEUText
DeliveryEUText = FDeliveryEUText
End Function
Function DeliveryRWLimit
DeliveryRWLimit = FDeliveryRWLimit
End Function
Function DeliveryRWBelow
DeliveryRWBelow = FDeliveryRWBelow
End Function
Function DeliveryRWAbove
DeliveryRWAbove = FDeliveryRWAbove
End Function
Function DeliveryRWText
DeliveryRWText = FDeliveryRWText
End Function
' (SS,8/9/06)
Function GetStoreName
GetStoreName = FStoreName
End Function
' (SS,20/4/18) returns True for HyperFlight only, to allow HF specific options
Function IsHyperFlight
IsHyperFlight = GetStoreName = "HyperFlight"
End Function
' (SS,13/6/07)
Function GetStoreCompany
GetStoreCompany = FStoreCompany
End Function
Function GetStoreAddress1
GetStoreAddress1 = FStoreAddress1
End Function
Function GetStoreAddress2
GetStoreAddress2 = FStoreAddress2
End Function
Function GetStoreAddress3
GetStoreAddress3 = FStoreAddress3
End Function
Function GetStoreTown
GetStoreTown = FStoreTown
End Function
Function GetStoreCounty
GetStoreCounty = FStoreCounty
End Function
Function GetStorePostcode
GetStorePostcode = FStorePostcode
End Function
Function GetStoreCountry
GetStoreCountry = FStoreCountry
End Function
Function GetStoreTelephone
GetStoreTelephone = FStoreTelephone
End Function
Function GetStoreFax
GetStoreFax = FStoreFax
End Function
Function GetStoreEmail
GetStoreEmail = FStoreEmail
End Function
Function GetStoreVATRegNo
GetStoreVATRegNo = FStoreVATRegNo
End Function
' (SS,22/12/20)
Function GetStoreEORINo
GetStoreEORINo = FStoreEORINo
End Function
' (SS,16/2/21)
Function GetStoreXIEORINo
GetStoreXIEORINo = FStoreXIEORINo
End Function
Function GetStoreRegards
GetStoreRegards = FStoreRegards
End Function
Function GetStoreURL
GetStoreURL = FStoreURL
End Function
' (SS,1/5/09)
Function GetStorePlaceOfRegistration
GetStorePlaceOfRegistration = FStorePlaceOfRegistration
End Function
' (SS,1/5/09)
Function GetStoreRegisteredCompanyNo
GetStoreRegisteredCompanyNo = FStoreRegisteredCompanyNo
End Function
Function GetStoreURLNoHttp
Dim LURL
LURL = Trim(FStoreURL)
If Left(LCase(LURL), 7) = "http://" Then LURL = Mid(LURL, 8)
GetStoreURLNoHttp = LURL
End Function
' (SS,8/3/13) added SpacesToNBS to convert spaces to non-breaking spaces, if on one line
Function GetStoreAddress(AOneLine, ACompanyNameInBold)
Dim LResult, LSeparator
If AOneLine Then
LSeparator = ", "
Else
LSeparator = NL
End If
LResult = IIf(ACompanyNameInBold, "<b>", "") + GetStoreCompany + IIf(ACompanyNameInBold, "</b>", "")
LResult = LResult + IIf(GetStoreAddress1 = "", "", LSeparator + IIf(AOneLine, SpacesToNBS(GetStoreAddress1), GetStoreAddress1))
LResult = LResult + IIf(GetStoreAddress2 = "", "", LSeparator + IIf(AOneLine, SpacesToNBS(GetStoreAddress2), GetStoreAddress2))
LResult = LResult + IIf(GetStoreAddress3 = "", "", LSeparator + IIf(AOneLine, SpacesToNBS(GetStoreAddress3), GetStoreAddress3))
LResult = LResult + IIf(GetStoreTown = "", "", LSeparator + IIf(AOneLine, SpacesToNBS(GetStoreTown), GetStoreTown))
LResult = LResult + IIf(GetStoreCounty = "", "", LSeparator + IIf(AOneLine, SpacesToNBS(GetStoreCounty), GetStoreCounty))
LResult = LResult + IIf(GetStorePostcode = "", "", LSeparator + IIf(AOneLine, SpacesToNBS(GetStorePostcode), GetStorePostcode))
LResult = LResult + IIf(GetStoreCountry = "", "", LSeparator + IIf(AOneLine, SpacesToNBS(GetStoreCountry), GetStoreCountry))
If Not AOneLine Then LResult = LResult + LSeparator
GetStoreAddress = LResult
End Function
Function GetStoreAddressAsHTML()
GetStoreAddressAsHTML = ReplaceNewLinesWithBR(GetStoreAddress(False, False))
End Function
Function GetBestSellersMax
GetBestSellersMax = FBestSellersMax
End Function
Function GetBestSellersPastDays
GetBestSellersPastDays = FBestSellersPastDays
End Function
Function GetBestSellersSortOrder
GetBestSellersSortOrder = FBestSellersSortOrder
End Function
Function GetProductFilesEnabled
GetProductFilesEnabled = FProductFilesEnabled
End Function
Function GetProductMoreImagesEnabled
GetProductMoreImagesEnabled = FMaxPicturesPerProduct > 1
End Function
' (SS,22/11/12)
Function GetMaxPicturesPerProduct
GetMaxPicturesPerProduct = FMaxPicturesPerProduct
End Function
Function GetProductsAcrossMax
GetProductsAcrossMax = FProductsAcrossMax
End Function
Function GetProductsDownMax
GetProductsDownMax = FProductsDownMax
End Function
' (SS,12/5/11)
Function GetProductsPerPageFixed
GetProductsPerPageFixed = FProductsPerPageFixed
End Function
Function GetProductsMaxSpecialOffer
GetProductsMaxSpecialOffer = FProductsMaxSpecialOffer
End Function
' (SS,16/5/11)
Function GetMaxRecentlyViewed
GetMaxRecentlyViewed = FMaxRecentlyViewed
End Function
' (SS,17/6/11) returns true if using tabs on product page
Function ProductPageTabs
ProductPageTabs = FProductPageTabs
End Function
' (SS,1/7/11)
Function ProductAttributesEnabled
ProductAttributesEnabled = FProductAttributesEnabled
End Function
' (SS,1/7/11)
Function ProductOptionsEnabled
ProductOptionsEnabled = FProductOptionsEnabled
End Function
' (SS,18/10/18)
Function ProductSubproductsEnabled
ProductSubproductsEnabled = FProductSubproductsEnabled
End Function
' (SS,16/1/13)
Function ProductSearchWithoutDescFirst
ProductSearchWithoutDescFirst = FProductSearchWithoutDescFirst
End Function
' (SS,1/6/15)
Function ProductSearchFullText
ProductSearchFullText = FProductSearchFullText
End Function
' (SS,10/6/14)
Function ProductsShowReviewsImmediately
ProductsShowReviewsImmediately = FProductsShowReviewsImmediately
End Function
' (SS,26/8/15)
Function ProductsSortByDefault
ProductsSortByDefault = FProductsSortByDefault
End Function
' (SS,19/7/10) removed
'Function AllowProductOrderIfNoStock
' AllowProductOrderIfNoStock = FAllowProductOrderIfNoStock
'End Function
Function GetOutOfStockMessage
GetOutOfStockMessage = FOutOfStockMessage
End Function
Function ShowIncVAT
ShowIncVAT = FShowIncVAT
End Function
Function ShowExcVAT
ShowExcVAT = FShowExcVAT
End Function
' (SS,7/11/12)
Function MinCurrencyPricesEnabled
MinCurrencyPricesEnabled = FMinCurrencyPricesEnabled
End Function
' (SS,27/3/07) originally added on this date, moved to settings table on 14/6/07
Function SummaryListEnabled
SummaryListEnabled = FSummaryListEnabled
End Function
Function GroupsEnabled
GroupsEnabled = FGroupsEnabled
End Function
Function GetExtraSearchComboCategory
GetExtraSearchComboCategory = FExtraSearchComboCategory
End Function
Function GetExtraSearchComboBlankEntry
GetExtraSearchComboBlankEntry = FExtraSearchComboBlankEntry
End Function
Function ShowProductsOnFullListCat
ShowProductsOnFullListCat = FShowProductsOnFullListCat
End Function
Function GetCategoryForSubcategoryMenu
GetCategoryForSubcategoryMenu = FCategoryForSubcategoryMenu
End Function
Function AddSpecialOffersToSubcategoryMenu
AddSpecialOffersToSubcategoryMenu = FAddSpecialOffersToSubcategoryMenu
End Function
' (SS,27/3/07) originally added on this date, moved to settings table on 14/6/07
Function CategoryListEnabled
CategoryListEnabled = FCategoryListEnabled
End Function
' (SS,27/3/07) originally added on this date, moved to settings table on 14/6/07
Function SubcategoryListEnabled
SubcategoryListEnabled = FSubcategoryListEnabled ' (SS,13/9/07) corrected from FCategoryListEnabled
End Function
' (SS,13/9/07)
Function UseAlternateColorForCategories
UseAlternateColorForCategories = FUseAlternateColorForCategories
End Function
' (SS,28/7/11)
Function GetDefaultGroup
GetDefaultGroup = FDefaultGroup
End Function
' (SS,1/8/11)
Function AlwaysDefaultGroupForMenu
AlwaysDefaultGroupForMenu = FAlwaysDefaultGroupForMenu
End Function
' (SS,2/8/11)
Function IncludeGroupInHTMLTitleTag
IncludeGroupInHTMLTitleTag = FIncludeGroupInHTMLTitleTag
End Function
' (SS,12/10/15)
Function ShowCategoryHeadingFooterIfEmpty
ShowCategoryHeadingFooterIfEmpty = FShowCategoryHeadingFooterIfEmpty
End Function
' (SS,13/9/07)
Function GetDefaultTitle
GetDefaultTitle = FDefaultTitle
End Function
' (SS,14/11/07)
Function ShowRelatedProductsInGroup
ShowRelatedProductsInGroup = FShowRelatedProductsInGroup
End Function
' (SS,18/5/12)
Function RelatedProductsOutOfStockEnd
RelatedProductsOutOfStockEnd = FRelatedProductsOutOfStock = "End"
End Function
' (SS,18/5/12)
Function RelatedProductsOutOfStockHide
RelatedProductsOutOfStockHide = FRelatedProductsOutOfStock = "Hide"
End Function
' (SS,6/5/09)
Function VouchersEnabled
VouchersEnabled = FVouchersEnabled
End Function
' (SS,6/5/09)
Function ReviewsEnabled
ReviewsEnabled = FProductReviewsEnabled
End Function
' (SS,18/5/09)
Function BackInStockNotificationsEnabled
BackInStockNotificationsEnabled = FBackInStockNotificationsEnabled
End Function
' (SS,20/9/12)
Function AutoLoginEnabled
AutoLoginEnabled = FAutoLoginEnabled
End Function
' (SS,15/1/13)
Function ReviewRequestsEnabled
ReviewRequestsEnabled = FReviewRequestsEnabled
End Function
' (SS,15/1/13)
Function ReviewRequestsDays
ReviewRequestsDays = FReviewRequestsDays
End Function
' (SS,14/1/20)
Function ReviewRequestsDaysNonUK
ReviewRequestsDaysNonUK = FReviewRequestsDaysNonUK
End Function
' (SS,17/1/13)
Function CustomPagesEnabled
CustomPagesEnabled = FCustomPagesEnabled
End Function
' (SS,10/6/14)
Function GeoIPEnabled
GeoIPEnabled = FGeoIPEnabled
End Function
' (SS,25/2/15)
Function SaveBasketEnabled
SaveBasketEnabled = FSaveBasketEnabled
End Function
' (SS,21/4/21)
Function DespatchDatesEnabled
DespatchDatesEnabled = FDespatchDatesEnabled
End Function
' (SS,14/11/07)
' (SS,18/12/14) modified to only return true if delivery country is the default country i.e. UK
Function AllowCollection
AllowCollection = FAllowCollection And GetDeliveryCountry = FDefaultCountry ' (SS,18/12/14) added And GetDeliveryCountry = FDefaultCountry
End Function
' (SS,12/2/21)
Function AllowCollectionBasketPage
AllowCollectionBasketPage = AllowCollection And FAllowCollectionBasketPage
End Function
' (SS,16/11/07)
Function ShowStockInfo
ShowStockInfo = FShowStockInfo
End Function
' (SS,25/6/10)
Function ShowStockAmount
ShowStockAmount = FShowStockAmount
End Function
' (SS,5/12/11)
Function StockAmountInfoSpec
StockAmountInfoSpec = FStockAmountInfoSpec
End Function
' (SS,20/7/10)
Function CustomStockInfoEnabled
CustomStockInfoEnabled = FCustomStockInfoEnabled
End Function
' (SS,21/7/10)
Function ShowOutOfStockMessage
ShowOutOfStockMessage = FShowOutOfStockMessage
End Function
' (SS,21/8/12) max length of customer message in checkout, now restricted to 600
Function GetMaxMessageLength
GetMaxMessageLength = 600
End Function
' (SS,30/4/10)
Function GetTranslationLanguage
GetTranslationLanguage = FTranslationLanguage
End Function
' (SS,21/5/10)
Function IsEnglish
IsEnglish = GetTranslationLanguage = "" Or GetTranslationLanguage = "English"
End Function
' (SS,30/4/10)
Function GetWorldPayLanguageCode
' (SS,30/4/10) added language, for more help see http://www.rbsworldpay.com/support/kb/bg/customisingadvanced/custa7605.html
If GetTranslationLanguage = "German" Then
GetWorldPayLanguageCode = "de"
ElseIf GetTranslationLanguage = "French" Then
GetWorldPayLanguageCode = "fr"
Else
GetWorldPayLanguageCode = "en"
End If
End Function
' (SS,22/5/18) returns True for HyperFlight, False for others, whether to tick terms and conditions by default or not
Function GetCheckoutTermsAndConditionsDefault
GetCheckoutTermsAndConditionsDefault = IsHyperFlight
End Function
' (SS,15/8/14) returns True if using Responsive Web Design (e.g. Bootstrap), used to allow different HTML to be sent where applicable and held in apputils.asp
Function IsRWD
IsRWD = FResponsiveWebDesign
End Function
' (SS,27/9/19) returns true if Bootstrap 4 used
Function IsBootstrap4
IsBootstrap4 = FRWDFramework = "Bootstrap 4"
End Function
' (SS,28/9/20) returns the correct class for panel/card depending on whether Bootstrap 3 or 4 is used
' AType can be "" or "M" for main, "H" for heading/header, "B" for body
Function GetPanelCardClass(AType)
Dim LType, LResult
LType = UCase(AType)
If IsBootstrap4 Then
If LType = "H" Then
LResult = "card-header"
ElseIf AType = "B" Then
LResult = "card-body"
Else ' i.e. "" or "M"
LResult = "card"
End If
Else ' Bootstrap 3
If AType = "H" Then
LResult = "panel-heading"
ElseIf AType = "B" Then
LResult = "panel-body"
Else ' i.e. "" or "M"
LResult = "panel panel-default"
End If
End If
GetPanelCardClass = LResult
End Function
' (SS,28/9/20) returns given value if Bootstrap 3, else a blank is returned
Function Bootstrap3Only(AOption)
If IsBootstrap4 Then
Bootstrap3Only = ""
Else ' i.e. Bootstrap 3
Bootstrap3Only = AOption
End IF
End Function
' (SS,28/9/20) returns given value if Bootstrap 4, else a blank is returned
Function Bootstrap4Only(AOption)
If IsBootstrap4 Then
Bootstrap4Only = AOption
Else
Bootstrap4Only = ""
End IF
End Function
' (SS,30/9/04)
' (SS,22/3/06) added Left(.., MAX_SIZE) to ensure max field size of 255 isn't exceeded
' add this after noticing following in iislog files for toner2desk:
' [MySQL][ODBC_3.51_Driver][mysqld-5.0.16-nt-log]Data_too_long_for_column_'Referrer'_at_row_1
' (SS,16/2/12) modified to only add if referrer isn't blank, most records were blank many due to search engine bots
' (SS,11/9/15) now redundant, can be removed. referrers table no longer exists.
Sub AddReferrerToDatabase
Const MAX_SIZE = 255
Dim LReferrer, LURL, LQueryString, LUserAgent
LReferrer = Left(Request.ServerVariables("HTTP_REFERER"), MAX_SIZE)
If Trim(LReferrer) <> "" Then ' (SS,16/2/12)
LURL = Left(Request.ServerVariables("URL"), MAX_SIZE)
LQueryString = Left(Request.ServerVariables("QUERY_STRING"), MAX_SIZE)
LUserAgent = Left(Request.ServerVariables("HTTP_USER_AGENT"), MAX_SIZE)
' (SS,12/6/12) added CleanSQLStr before FSessionID to prevent SQL injection
ExecuteQuery("INSERT INTO referrers SET DateTime=NOW(), Date=Now(), SessionID='" & CleanSQLStr(FSessionID) & "', Referrer='" & CleanSQLStr(LReferrer) & "', URL='" & CleanSQLStr(LURL) & "', QueryString='" & CleanSQLStr(LQueryString) & "', UserAgent='" & CleanSQLStr(LUserAgent) & "', IPAddress='" & CleanSQLStr(Request.ServerVariables("REMOTE_ADDR")) & "'")
End If
End Sub
' (SS,16/9/04) called from inc-template-main.asp to get title for web page'
' (SS,11/2/05) added group '
' (SS,15/3/05) added group that was missed from non IsProductDetailsPage '
' (SS,20/9/06) removed repetitives
' (SS,01/7/08) moved ProductName in front of group / category, don't use space in separator in more than so many characters long
' (SS,27/7/11) added HTMLEncode
' (SS,02/2/12) fixed double encoding product name issue
' (SS,16/3/12) modified to get the title tag if available from categories, subcategories, groups, product_attributes and sitedetails tables
' (SS,6/12/19) Google only shows about 60, Bing complains when more than 100 with error in Webmaster, modified for product detail page
' to not add the category & subcategory if the total would result in more than 100 characters
Function GetHTMLTitle(ADefaultTitle)
Const vbTextCompare = 1
Const SEPARATOR = "#-#"
Const SEPARATOR_NORMAL = " - "
Const SEPARATOR_COMPACT = "-"
Const MAX_BEFORE_COMPACT = 999 ' was 66 but make titles look untidy, 999 means don't use the compact separator
Const MAX_RECOMMENDED = 60 ' (SS,6/12/19) used to keep product detail title short
Dim LProductCode, LGroup, LCategory, LSubcategory, LProductName, LResult
LResult = ""
If IsProductDetailsPage Then
LProductCode = GetProductCodeQS
' (SS,16/3/12) try to get title tag from product attribute, if not found then do as before
Dim LProductID
LProductID = GetProductIDForProductCode(LProductCode)
LResult = GetTitleTagForProduct("T", LProductID)
' (SS,16/3/12) following code is as before, i.e. builds the tag from product name, category etc.
If LResult = "" Then
GetFirstCatSubcatForProduct LProductCode, LGroup, LCategory, LSubcategory
' (SS,15/3/05) added Iif(Application("EnableGroups") '
' (SS,26/7/11) replaced GetFieldForProduct with GetProductName which also does a HTMLEncode
' (SS,2/2/12) replaced GetProductName with GetProductNameNoHTMLEncode, & was being encode as "&amp;", i.e. encoded twice, we only want to encode right at the end
LProductName = GetProductNameNoHTMLEncode(LProductCode)
' (SS,20/9/06) if group, category or subcategory exists in product name then don't include it
If Not GroupsEnabled Or InStr(LProductName, LGroup) > 0 Then LGroup = ""
' (SS,2/8/11) added following to exclude group when IncludeGroupInHTMLTitleTag is False, also lookup short names
If GroupsEnabled Then
If Not IncludeGroupInHTMLTitleTag Then LGroup = ""
LSubcategory = GetShortNameForSubcategory(LCategory, LSubcategory) ' (SS,11/1/13) added missing LCategory
LCategory = GetShortNameForCategory(LCategory)
End If
If InStr(1, LProductName, LCategory, vbTextCompare) > 0 Then LCategory = ""
If InStr(1, LProductName, LSubcategory, vbTextCompare) > 0 Then LSubcategory = ""
' (SS,1/7/08) if group matches category, or category matches subcategory then don't repeat it
If LGroup = LCategory Then LCategory = ""
If LCategory = LSubcategory Then LSubcategory = ""
' LResult = Iif(LGroup <> "", LGroup + SEPARATOR, "") + Iif(LCategory <> "", LCategory + SEPARATOR, "") + Iif(LSubcategory <> "", LSubcategory + SEPARATOR, "") + LProductName
' (SS,1/7/08) product name moved to the front, above replaced with following
LResult = LProductName + Iif(LGroup <> "", SEPARATOR + LGroup, "") + Iif(LCategory <> "", SEPARATOR + LCategory, "") + Iif(LSubcategory <> "", SEPARATOR + LSubcategory, "")
' (SS,6/12/19) added following to use only the product name if length more than max (60)
If Len(LResult) >= MAX_RECOMMENDED Then
LResult = LProductName
End If
End If
Else
' (SS,15/3/05) get group name for category '
LCategory = CleanRequestQueryString("cat")
LSubcategory = CleanRequestQueryString("subcat")
' (SS,16/3/12) added following because LCategory, LSubcategory get set to short names in "If GroupsEnabled" code below
Dim LFullCategory, LFullSubcategory
LFullCategory = LCategory
LFullSubcategory = LSubcategory
If GroupsEnabled And LCategory <> "" Then
LGroup = GetGroupForCat(LCategory)
Else
LGroup = CleanRequestQueryString("grp") ' (SS,1/7/08) was ""
End If
' (SS,2/8/11) added following to exclude group when IncludeGroupInHTMLTitleTag is False, also lookup short names
If GroupsEnabled Then
If Not IncludeGroupInHTMLTitleTag Then LGroup = ""
LSubcategory = GetShortNameForSubcategory(LCategory, LSubcategory) ' (SS,11/1/13) added LCategory
LCategory = GetShortNameForCategory(LCategory)
End If
If LCategory <> "" And LSubcategory <> "" Then
' (SS,16/3/12) try to get title tag from subcategories table, if blank then do as before
LResult = GetTitleTagForSubcategory("T", LFullCategory, LFullSubcategory)
' (SS,16/3/12) following code is as before, i.e. builds the tag from product name, category etc.
If LResult = "" Then
' (SS,15/3/05) added Iif(LGroup <> "".. '
' (SS,20/9/06) if group, category exists in subcategory then don't include it
If Not GroupsEnabled Or InStr(LSubcategory, LGroup) > 0 Then LGroup = ""
If InStr(1, LSubcategory, LCategory, vbTextCompare) > 0 Then LCategory = ""
If LGroup = LCategory Then LGroup = "" ' (SS,1/7/08) don't repeat if group same as category
LResult = Iif(LGroup <> "", LGroup + SEPARATOR, "") + Iif(LCategory <> "", LCategory + SEPARATOR, "") & LSubcategory
End If
ElseIf LCategory <> "" Then
' (SS,16/3/12) try to get title tag from categories table, if blank then do as before
LResult = GetTitleTagForCategory("T", LFullCategory)
' (SS,16/3/12) following code is as before, i.e. builds the tag from product name, category etc.
If LResult = "" Then
' (SS,15/3/05) added Iif(LGroup <> "".. '
If LGroup = LCategory Then LGroup = "" ' (SS,1/7/08) don't repeat if group same as category
LResult = LResult & Iif(LGroup <> "", LGroup + SEPARATOR, "") & LCategory
If ADefaultTitle <> "" Then
LResult = LResult + SEPARATOR + ADefaultTitle
End If
End If
' (SS,1/7/08)
ElseIf LGroup <> "" Then
' (SS,16/3/12) try to get title tag from groups table, if blank then do as before
LResult = GetTitleTagForGroup("T", LGroup)
' (SS,16/3/12) following code is as before, i.e. builds the tag from product name, category etc.
If LResult = "" Then
LResult = LGroup
If ADefaultTitle <> "" Then
LResult = LResult + SEPARATOR + ADefaultTitle
End If
End If
Else
' (SS,16/3/12) try to get title tag from site details table, if blank then try the default
LResult = GetTitleTagForPage("T", GetPageName)
If LResult = "" Then LResult = GetTitleTagForPage("T", "Default")
' (SS,16/3/12) following is as before, if still blank then use the one passed to this routine as a parameter
If LResult = "" Then LResult = ADefaultTitle
End If
End If
' (SS,1/7/08) if length is > 66 then don't use spaces around the '-' to make it fit into 66 or less
If Len(LResult) > MAX_BEFORE_COMPACT Then
LResult = ReplaceStr(LResult, SEPARATOR, SEPARATOR_COMPACT)
Else
LResult = ReplaceStr(LResult, SEPARATOR, SEPARATOR_NORMAL)
End If
GetHTMLTitle = HTMLEncode(LResult) ' (SS,27/7/11) added HTMLEncode
End Function
' (SS,16/9/04) called from inc-template-main.asp to get meta tag description for web page '
' (SS,19/9/06) improved
' (SS,27/7/11) added HTMLEncode
' (SS,16/3/12) modified to get the description meta tag if available from categories, subcategories, groups, product_attributes and sitedetails tables
' (SS,21/3/12) slight improvement for product page, to not prefix with product name if description is longer than name
' (SS,16/7/13) change to use ComposeDescription for to convert tokens and suffix with "..." if longer than max length
' (SS,6/12/19) changed MAX_LENGTH from 250 to 160, Also adjusted to replace 3 and 2 spaces with single space.
Function GetHTMLDescription(ADefaultDescription)
Const MAX_LENGTH = 160
Dim LResult
If IsProductDetailsPage Or IsCategoryPage Or IsSubcategoryPage Then
Dim LCategory, LSubcategory
LCategory = CleanRequestQueryString("cat")
LSubcategory = CleanRequestQueryString("subcat")
If IsCategoryPage Then
' (SS,16/3/12) try to get description meta tag from categories table, if blank then do as before
LDescription = GetTitleTagForCategory("D", LCategory)
' (SS,16/3/12) following code after the "if" is as before, i.e. builds the tag from category, subcategory etc.
If LDescription = "" Then LDescription = LCategory & " - " & GetSubcategoryListForCategory(LCategory)
ElseIf IsSubcategoryPage Then
' (SS,16/3/12) try to get description meta tag from subcategories table, if blank then do as before
LDescription = GetTitleTagForSubcategory("D", LCategory, LSubcategory)
' (SS,16/3/12) following code after the "if" is as before, i.e. builds the tag from category and subcategory
If LDescription = "" Then LDescription = LCategory & " - " & LSubcategory
Else ' i.e. IsProductDetailsPage
Dim LProductCode, LDescription, LProductName
LProductCode = GetProductCodeQS
' (SS,16/3/12) try to get description meta tag from product attribute, if not found then do as before
Dim LProductID
LProductID = GetProductIDForProductCode(LProductCode)
LDescription = GetTitleTagForProduct("D", LProductID)
' (SS,16/3/12) following code is as before, i.e. builds the tag from product name and description
If LDescription = "" Then
' (SS,26/7/11) was GetFieldForProduct(LProductCode, "ProductName")
' (SS,21/3/12) replaced GetProductName with GetProductNameNoHTMLEncode to avoid encoding twice
LProductName = GetProductNameNoHTMLEncode(LProductCode)
LDescription = GetFieldForProduct(LProductCode, "ProductDescription")
LDescription = ComposeDescription(LDescription, True, False) ' (SS,16/7/13) added to process tokens to prevent curly brackets appearing in Google search
If LDescription = "" Then
LDescription = ADefaultDescription
' (SS,21/3/12) only prefix with name if length of ProductDescription is less than length of ProductName, it used to always prefix with name before
ElseIf Len(LDescription) < Len(LProductName) Then
LDescription = LProductName & " - " & LDescription
End If
End If
' remove HTML Tags
LDescription = RemoveHTMLTags(LDescription)
' replace quote with single quote
LDescription = ReplaceStr(LDescription, """", "'")
' replace new lines with space '
LDescription = ReplaceStr(LDescription, Chr(13) + Chr(10) , " ")
' (SS,6/12/19) replaced 3 spaces with single space, also 2 spaces with single space
LDescription = ReplaceStr(LDescription, " ", " ")
LDescription = ReplaceStr(LDescription, " ", " ")
End If
' LResult = Left(LDescription, MAX_LENGTH)
' (SS,16/7/13) replaced above with following to reduce size and suffix with "..." if more than max
If Len(LDescription) > MAX_LENGTH Then
LResult = Mid(LDescription, 1, MAX_LENGTH) + "..."
Else
LResult = LDescription
End If
Else
' (SS,16/3/12) added following for group page
If IsGroupPage Then
' try to get description meta tag from groups table, if blank then do as before
LResult = GetTitleTagForGroup("D", GetGroup)
Else ' page
' try to get title tag from site details table
LResult = GetTitleTagForPage("D", GetPageName)
End If
' if blank then try the default
If LResult = "" Then LResult = GetTitleTagForPage("D", "Default")
' (SS,27/7/11) added HTMLEncode
' (SS,16/3/12) removed HTMLEncode because we're doing it below
' (SS,16/3/12) following after the "if", is as before, if still blank then use the one passed to this routine as a parameter
If LResult = "" Then LResult = ADefaultDescription
End If
' (SS,27/7/11) added HTMLEncode
GetHTMLDescription = HTMLEncode(LResult)
End Function
' (SS,19/9/06)
' (SS,27/7/11) added HTMLEncode
' (SS,16/3/12) modified to get the keywords meta tag if available from categories, subcategories, groups, product_attributes and sitedetails tables
Function GetHTMLKeyWords(ADefaultKeyWords)
Const MAX_LENGTH = 255 ' (SS,16/3/12) increased from 250 to 255
Dim LResult
If IsProductDetailsPage Or IsCategoryPage Or IsSubcategoryPage Then
Dim LCategory, LSubcategory, LKeyWords
LCategory = CleanRequestQueryString("cat")
LSubcategory = CleanRequestQueryString("subcat")
' (SS,16/3/12) removed following
' LKeyWords = ADefaultKeyWords
If IsCategoryPage Then
' (SS,16/3/12) try to get keywords meta tag from categories table, if blank then do as before
LKeyWords = GetTitleTagForCategory("K", LCategory)
' (SS,16/3/12) following code after the "if" is as before, i.e. builds the tag from category, subcategory etc.
If LKeyWords = "" Then LKeyWords = LCategory & ", " & GetSubcategoryListForCategory(LCategory) & ", " & ADefaultKeyWords
ElseIf IsSubcategoryPage Then
' (SS,16/3/12) try to get keywords meta tag from subcategories table, if blank then do as before
LKeyWords = GetTitleTagForSubcategory("K", LCategory, LSubcategory)
' (SS,16/3/12) following code after the "if" is as before, i.e. builds the tag from category and subcategory
If LKeyWords = "" Then LKeyWords = LCategory & ", " & LSubcategory & ", " & ADefaultKeyWords
Else ' ie. Product Details page
Dim LProductCode, LProductName
LProductCode = GetProductCodeQS
' (SS,16/3/12) try to get keyword meta tag from product attribute, if not found then do as before
Dim LProductID
LProductID = GetProductIDForProductCode(LProductCode)
LKeyWords = GetTitleTagForProduct("K", LProductID)
' (SS,16/3/12) following code is as before, i.e. builds the tag from product name and description
If LKeyWords = "" Then
' (SS,26/7/11) replaced GetFieldForProduct(LProductCode, "ProductName") with GetProductName(LProductCode)
' which also does a HTMLEncode so RemoveHTMLTags and Replace quote below not required
LProductName = GetProductName(LProductCode)
' remove HTML Tags
'LProductName = RemoveHTMLTags(LProductName)
' replace quote with single quote '
'LProductName = ReplaceStr(LProductName,"""", "'")
Dim LGroup
GetFirstCatSubcatForProduct LProductCode, LGroup, LCategory, LSubcategory
' remove repeated words
If LCategory <> "" Then
LProductName = Replace(LProductName, LCategory, "")
' LKeyWords = Replace(LKeyWords, LSubcategory, "")
End if
If LSubcategory <> "" Then
LProductName = Replace(LProductName, LSubcategory, "")
' LKeyWords = Replace(LKeyWords, LSubcategory, "")
End If
'LKeyWords = Replace(LKeyWords, " ", " ")
LProductName = RemoveCommonWords(LProductName)
LProductName = Replace(LProductName, " ", " ")
LProductName = Replace(LProductName, " ", ", ")
LKeyWords = LCategory + ", " + LSubcategory + ", " + LProductName + ", " & ADefaultKeyWords
End If
End If
LResult = Left(LKeyWords, MAX_LENGTH)
Else
' (SS,16/3/12) added following for group page
If IsGroupPage Then
' try to get description meta tag from groups table, if blank then do as before
LResult = GetTitleTagForGroup("K", GetGroup)
Else ' page
' try to get title tag from site details table
LResult = GetTitleTagForPage("K", GetPageName)
End If
' if blank then try the default
If LResult = "" Then LResult = GetTitleTagForPage("K", "Default")
' (SS,16/3/12) following after the "if" is as before, if still blank then use the one passed to this routine as a parameter
If LResult = "" Then LResult = ADefaultKeyWords
End If
GetHTMLKeyWords = HTMLEncode(LResult)
End Function
' (SS,16/3/12) returns title, description or keyword meta tag, Type can be T, D, or K
' (SS,17/1/13) modified so that if page doesn't exist in site details and CustomPagesEnabled it tries to get the values from CustomGetTitleTagForPage instead which is in CustomUtils.asp
' (SS,5/2/13) was returning wrong values for home page, this was due to PageExists returning False for home page i.e. where APage is "", now corrected
Function GetTitleTagForPage(AType, APage)
' if page is "" then get the Home page, + "s" because it's plural in the site details table
If PageExists(APage) Then
GetTitleTagForPage = Trim(GetSiteDetail(GetTagNameForType(AType, False) + "s", IIf(APage = "", "Home", APage)))
ElseIf CustomPagesEnabled Then
GetTitleTagForPage = CustomGetTitleTagForPage(AType, APage)
Else
GetTitleTagForPage = ""
End If
End Function
' (SS,16/3/12) returns title, description or keyword meta tag, Type can be T, D, or K
Function GetTitleTagForProduct(AType, AProductID)
GetTitleTagForProduct = Trim(GetProductAttributeByName(AProductID, GetTagNameForType(AType, False)))
End Function
' (SS,16/3/12) returns title, description or keyword meta tag, Type can be T, D, or K
Function GetTitleTagForCategory(AType, ACategory)
GetTitleTagForCategory = Trim(NB(GetSQLValue("SELECT " & GetTagNameForType(AType, True) & " FROM categories WHERE Category = '" & CleanSQLStr(ACategory) & "'")))
End Function
' (SS,16/3/12) returns title, description or keyword meta tag, Type can be T, D, or K
Function GetTitleTagForSubcategory(AType, ACategory, ASubcategory)
GetTitleTagForSubcategory = Trim(NB(GetSQLValue("SELECT " & GetTagNameForType(AType, True) & " FROM subcategories WHERE Category = '" & CleanSQLStr(ACategory) & "' AND Subcategory = '" & CleanSQLStr(ASubcategory) & "'")))
End Function
' (SS,16/3/12) returns title, description or keyword meta tag, Type can be T, D, or K
Function GetTitleTagForGroup(AType, AGroup)
GetTitleTagForGroup = Trim(NB(GetSQLValue("SELECT " & GetTagNameForType(AType, True) & " FROM groups WHERE GroupName = '" & CleanSQLStr(AGroup) & "'")))
End Function
' (SS,16/3/12) returns the full name for type, AType can be T, D, or K, if AForField true then it returns name without spaces
Function GetTagNameForType(AType, AForField)
Dim LResult
If AType = "T" Then
LResult = "Title Tag"
ElseIf AType = "D" Then
LResult = "Description Meta Tag"
Else ' AType = "K"
LResult = "Keywords Meta Tag"
End If
If AForField Then LResult = ReplaceStr(LResult, " ", "") ' remove spaces
GetTagNameForType = LResult
End Function
' (SS,10/8/11) used to tell Facebook which image to use for the like button, it was taking image from related items
' (SS,10/5/13) added NL
Sub ShowFacebookLikeImageMeta
If IsProductDetailsPage Then
Response.Write "<meta property=""og:image"" content=""" & GetFullProductImageLink(GetProductCode, "s") & """ />" & NL
End If
End Sub
' (SS,10/5/13) canonical link to tell search engines that products.asp without a query string is the same as the home page without any page name
' i.e. for http://www.coventry-demolition.com/products.asp the canonical link is http://www.coventry-demolition.com
' it will also be shown for the root page i.e. http://www.coventry-demolition.com, in ASP there's no way of checking if URL was without the default page name
' (SS,2/3/15) added canonical link for product details page containing code and name
' ### need to investigate the proper and standard way of encoding a URL for sitemap use, canonical link use and html link use, have a routine that
' can be called with parameter true or false to include full path or just relative
' (SS,16/12/15) added missing "name=" from URL, and URLEncode()
' (SS,24/8/17) changed to not show canonical when product code not found
Sub ShowCanonicalLink
If Request.ServerVariables("QUERY_STRING") = "" And GetScriptName = "products.asp" Then
Response.Write "<link rel=""canonical"" href=""" & Iif(LCase(Request.ServerVariables("HTTPS")) = "on", "https://", "http://") & Request.ServerVariables("SERVER_NAME") & """ />" & NL
' (SS,1/3/15) added following canonical link for product page when product page URL contains no name, page containing the name is to be the main product page
ElseIf IsProductDetailsPage And CleanRequestQueryString("name") = "" Then
Dim LURL, LProductCode, LProductName
LProductCode = GetProductCodeQS
LProductName = GetProductName(LProductCode)
' (SS,24/8/17) added If check for product name, i.e. product code found, don't show show canonical if product doesn't exist
If LProductName <> "" Then
' (SS,16/12/15) added missing "name=", removed URLEncode() from LProductCode and SEOFriendlyStr, not necessary, just causing duplicates to be detected
LURL = GetStoreURL + "/products.asp?code=" + LProductCode + "&name=" & SEOFriendlyStr(LProductName)
Response.Write "<link rel=""canonical"" href=""" & LURL & """ />" & NL
End If
End If
End Sub
' (SS,20/9/06)
' (SS,5/10/11) modified to replace break tags with a space
' (SS,21/3/13) HTML comment tags caused an issue if they had other tags inside, fixed by checking for <!-- and --> to ignore everything in comment tags
' (SS,19/10/15) bug fix to prevent error when first or second characters are ">" (added And i > 2)
Function RemoveHTMLTags(AValue)
Dim i, c, LLen, LNewValue, LInTag, LValue, LInCommentTag
' (SS,5/10/11) replace the breaks with a space
LValue = ReplaceStr(AValue, BR, " ") ' i.e. <br />
LValue = Replace(LValue, "<br>", " ", 1, -1, 1) ' case insensitive version
LLen = Len(LValue)
LNewValue = ""
LInTag = False
LInCommentTag = False
For i = 1 to LLen
c = Mid(LValue, i, 1)
If c = "<" Then
If Mid(LValue, i, 4) = "<!--" Then
LInCommentTag = True
Else
LInTag = True
End If
ElseIf c = ">" And i > 2 Then ' (SS,19/10/15) added And i > 2
' (SS,19/10/15) Mid function was failing when i was 1, i.e. first char a ">"
' fixed by first checking that i > 2 in above ElseIf
If Mid(LValue, i - 2, 3) = "-->" Then
LInCommentTag = False
Else
LInTag = False
End If
ElseIf Not LInTag And Not LInCommentTag Then
LNewValue = LNewValue + c
End If
Next
RemoveHTMLTags = LNewValue
End Function
' (SS,20/9/06)
Function RemoveCommonWords(AValue)
Const COMMON_WORDS = "the, a, and, in, a, of, that, to, this, as, or"
Dim LValue, LWords, LPos, LWord
LValue = " " & AValue & " "
LWords = COMMON_WORDS
Do While LWords <> ""
LPos = InStr(LWords, ",")
If LPos = 0 Then LPos = Len(LWords) + 1
LWord = Trim(Mid(LWords, 1, LPos - 1))
LWords = Trim(Mid(LWords, LPos + 1, Len(LWords)))
' following gets repeated for each word in COMMON_WORDS
LValue = Replace(LValue, " " & LWord & " ", " ")
LValue = Replace(LValue, " " & UCase(LWord) & " ", " ")
LValue = Replace(LValue, " " & UCase(Left(LWord,1)) + Mid(LWord,2,Len(LWord)) & " ", " ")
Loop
RemoveCommonWords = Trim(LValue)
End Function
' (SS,28/11/13) returns true if on home page
Function IsHomePage
Dim LPageName
LPageName = LCase(CleanRequestQueryString("page"))
IsHomePage = LPageName = "home" Or (LPageName = "" And CleanRequestQueryString("cmd") = "" And GetProductCodeQS = "" And CleanRequestQueryString("cat") = "" And CleanRequestQueryString("grp") = "")
End Function
' (SS,28/11/13) returns true if on basket page
Function IsBasketPage
Dim LCmd
LCmd = CleanRequestQueryString("cmd") ' (20/11/18) replaced multiple Request.QueryString with this
IsBasketPage = LCmd = "basket" Or LCmd = "buy" Or LCmd = "remove" Or LCmd = "recalculate"
End Function
' (SS,18/2/14)
Function GetBasketPageURL
GetBasketPageURL = "products.asp?cmd=basket"
End Function
' (SS,18/2/14) requested by Clifton's AdWord person, for unique URL for different steps, redirection done to this URL
Function GetCheckoutConfirmOrderURL
GetCheckoutConfirmOrderURL = "products.asp?cmd=checkout&xcmd=filled"
End Function
' (SS,20/2/15) for new save basket feature
Function GetSaveBasketURL
GetSaveBasketURL = "products.asp?cmd=savebasket"
End Function
' (SS,20/2/15) for new save basket feature
Function GetRestoreBasketURL(ASavedBasketID, AEmailAddress)
GetRestoreBasketURL = GetStoreURL & "/products.asp?cmd=restorebasket&id=" & ASavedBasketID & "&email=" & URLEncode(AEmailAddress)
End Function
' (SS,25/2/22)
Function GetRestoreBasketFromOrderURL(AOrderNo)
' get session ID and IP address for security
Dim LResult, LSessionID, LIPAddress
If GetSQL2Values("SELECT SessionID, IPAddress FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'", LSessionID, LIPAddress) Then
LResult = GetStoreURL & "/products.asp?cmd=restorebasketorder&orderno=" & AOrderNo & "&sid=" & LSessionID & "&ip=" & LIPAddress
Else
LResult = ""
End If
GetRestoreBasketFromOrderURL = LResult
End Function
' (SS,16/9/04) called to check whether page requested is a product details page
Function IsProductDetailsPage
Dim LCommand, LProductCode
LCommand = CleanRequestQueryString("cmd")
If LCommand = "" Then strCommand = CleanRequestForm("cmd")
LProductCode = GetProductCodeQS
If LCommand = "remove" Or strCommand = "recalculate" Or strCommand = "basket" Or strCommand = "checkout" Or strCommand = "payment" Then
IsProductDetailsPage = False
ElseIf LProductCode <> "" Then
IsProductDetailsPage = True
Else
IsProductDetailsPage = False
End If
End Function
' (SS,9/4/19) added following for Facebook Pixel AddToCart event tracking
Function IsAddToBasketPage
Dim Lcmd, Lcode
' xcmd takes priority over cmd
Lcmd = CleanRequest("xcmd")
Lcode = CleanRequest("xcode")
If Lcmd = "" Then
Lcmd = CleanRequest("cmd")
Lcode = CleanRequest("code")
End if
IsAddToBasketPage = (Lcmd = "buy" Or Lcmd = "buyl") and Lcode <> ""
End Function
' (SS,9/4/19) added following for Facebook Pixel AddToCart event tracking, returns the product code for product added to basket
Function GetBasketProductCode
Dim Lcode
Lcode = CleanRequest("xcode")
If Lcode = "" Then Lcode = CleanRequest("code")
GetBasketProductCode = Lcode
End Function
' (SS,12/2/05) called to check whether page requested is a search page '
Function IsSearchPage
' (SS,25/7/11) added Or GetSearch <> ""
If CleanRequestQueryString("cmd") = "search" Or GetSearch <> "" Or (CleanRequestQueryString("cmd") = "page" And CleanRequestQueryString("cat") = "" And CleanRequestQueryString("subcat") = "") Then
IsSearchPage = True
Else
IsSearchPage = False
End If
End Function
' (SS,19/9/06)
Function IsCategoryPage
If CleanRequestQueryString("cat") <> "" And CleanRequestQueryString("subcat") = "" Then
IsCategoryPage = True
Else
IsCategoryPage = False
End If
End Function
' (SS,19/9/06)
Function IsSubcategoryPage
If CleanRequestQueryString("cat") <> "" And CleanRequestQueryString("subcat") <> "" Then
IsSubcategoryPage = True
Else
IsSubcategoryPage = False
End If
End Function
' (SS,16/3/12)
Function IsGroupPage
If GroupsEnabled And CleanRequestQueryString("grp") <> "" Then
IsGroupPage = True
Else
IsGroupPage = False
End If
End Function
' (SS,27/11/13) returns true if payment page (i.e. the payment redirection page), used by google analytics for ecommerce tracking
Function IsPaymentPage
IsPaymentPage = CleanRequestQueryString("cmd") = "checkout" And CleanRequestQueryString("xcmd") = "pay"
End Function
' (SS,3/3/14) is return from Payment Provider page, after payment has been made
Function IsReturnFromPaymentProviderPage
IsReturnFromPaymentProviderPage = CleanRequestQueryString("cmd") = "checkout" And CleanRequestQueryString("stage") = "co"
End Function
' (SS,30/4/18) added to return true if browser return from EPDQ or Payzone are successful payments
' (SS,4/10/20) added NetPay
Function IsSuccessfulReturnFromPaymentProviderPage
Dim LResult, LPaymentType
If IsReturnFromPaymentProviderPage Then
LPaymentType = CleanRequestQueryString("pt")
If LPaymentType = ptEPDQ Then
LResult = EPDQSuccessfulPayment
ElseIf LPaymentType = ptPayzone Then
LResult = PayzoneSuccessfulPayment
' (SS,4/10/20)
ElseIf LPaymentType = ptNetPay Then
LResult = NetPaySuccessfulPayment
' (SS,17/6/22)
ElseIf LPaymentType = ptClover Then
LResult = CloverSuccessfulPayment
Else
LResult = True ' assume successful for others without any additional check
End If
Else
LResult = False ' i.e. not a return from payment provider
End If
IsSuccessfulReturnFromPaymentProviderPage = LResult
End Function
' (SS,31/5/07)
Function InCheckout
' If CleanRequestQueryString("cmd") = "checkout" Or CleanRequestForm("cmd") = "checkout" Then
' (SS,14/6/11) replaced above with following
If CleanRequest("cmd") = "checkout" Then
InCheckout = True
Else
InCheckout = False
End If
End Function
' (SS,12/4/19) start of checkout (used by Facebook Pixel 'InitiateCheckout' event)
' !!! NB will to track if PayPal checkout used from basket page
Function IsStartOfCheckout
Dim LResult, LCurrentStage
LResult = InCheckout And CleanRequestQueryString("xcmd") <> "filled"
If LResult Then
LCurrentStage = CleanRequestForm("stage")
If LCurrentStage = "" Then LCurrentStage = CleanRequestQueryString("stage")
LResult = LCurrentStage = ""
End If
IsStartOfCheckout = LResult
End Function
' (SS,12/4/19) returns true when checkout filled (used by Facebook Pixel 'AddPaymentInfo' event)
Function IsCheckoutFilled
IsCheckoutFilled = InCheckout And CleanRequestQueryString("xcmd") = "filled" And GetOrderNo <> ""
End Function
' (SS,20/5/04) called from inc-products.asp '
' (SS,12/2/05) improved to show better info '
' (SS,18/3/10) add tr() for translation
Function GetProductsPageTitle
Dim LCmd
Lcmd = CleanRequestQueryString("cmd") ' (SS,20/11/18) replaced multiple Request.QueryString with variable and CleanRequestQueryString
If Lcmd = "basket" Or Lcmd = "buy" Or Lcmd = "remove" Or Lcmd = "recalculate" Then
GetProductsPageTitle = tr("Your Basket")
ElseIf LCmd = "checkout" Or CleanRequestForm("cmd") = "checkout" Then
GetProductsPageTitle = tr("Checkout")
Else
If IsSearchPage Then
GetProductsPageTitle = tr("Product Search")
ElseIf LCmd = "cat" Then
If CleanRequestQueryString("grp") <> "" Then
GetProductsPageTitle = tr("Categories for") & " " & CleanRequestQueryString("grp")
Else
GetProductsPageTitle = tr("Categories")
End If
ElseIf LCmd = "subcat" Then
If CleanRequestQueryString("subcat") = "" Then
If strGroupFromMenu = "" Then
GetProductsPageTitle = tr("Subcategories for") & " " & CleanRequestQueryString("cat")
Else
GetProductsPageTitle = strGroupFromMenu & " - " & CleanRequestQueryString("cat")
End If
Else
GetProductsPageTitle = tr("Products")
End If
' (SS,15/5/07) changed And to Or to fix bug where "Product" was showing instead of "Products" when category chosen
ElseIf (LCmd = "list") Or (CleanRequestQueryString("cat") <> "") Or (CleanRequestQueryString("subcat") <> "") Then
GetProductsPageTitle = tr("Products")
Else
GetProductsPageTitle = tr("Product")
End If
End If
End Function
' (SS,17/5/11) new version 2, AOptions parameter not currently used
Function GetProductsPageTitleV2(AOptions)
Dim LResult, LCmd
LCmd = CleanRequestQueryString("cmd")
If LCmd = "basket" Or LCmd = "remove" Or LCmd = "recalculate" Then ' (SS,12/9/12) removed LCmd = "buy" because "Your Basket " was incorrectly showing when adding item to basket for new Galleon with combo add
LResult = tr("Your Basket")
ElseIf LCmd = "checkout" Then
LResult = tr("Checkout")
' (SS,13/12/18) for new cancel order facility
ElseIf LCmd = "cancelorder" Then
LResult = tr("Cancel Order")
Else
Dim LGrp, LCat, LSubcat
LGrp = GetGroup
LCat = GetCategory
LSubcat = GetSubcategory
If IsSearchPage Then
LResult = tr("Product Search")
ElseIf LCmd = "cat" Then
If LGrp <> "" Then
LResult = tr("Categories for") & " " & LGrp
Else
LResult = tr("Categories")
End If
ElseIf LCmd = "subcat" Then
If LSubcat = "" Then
If strGroupFromMenu = "" Then
LResult = tr("Subcategories for") & " " & LCat
Else
LResult = strGroupFromMenu & " - " & LCat
End If
Else
LResult = tr("Products")
End If
' (SS,15/5/07) changed And to Or to fix bug where "Product" was showing instead of "Products" when category chosen
ElseIf LCmd = "list" Then
LResult = tr("Products")
' (SS,11/1/13) replaced GetProductCode in following with GetProductCodeQS because in some cases it stopped showing the breadcrumb when in category or subcategory
ElseIf GetProductCodeQS = "" Then ' only if it's not a product code, product detail has it's own heading for breadcrumb
' (SS,17/5/11) instead of the word "product", show a breadcrumb
LResult = GetBreadcrumb(LGrp, LCat, LSubcat, AOptions) ' return a breadcrumb to show in title/heading
End If
End If
GetProductsPageTitleV2 = LResult
End Function
' (SS,17/5/11) new routine which returns a breadcrumb to show near the top of the product section
' called from GetProductsPageTitleV2 and from Sub ShowProductDetailYouAreHere in inc-template-product-detail.asp
' AOptions parameter is for future expansion, not currently used
' (SS,26/7/11) added GetShortNameForCategory and GetShortNameForSubcategory to make use of short names
Function GetBreadcrumb(AGroup, ACategory, ASubcategory, AOptions)
Dim LResult
LResult = ""
' (SS,15/8/14)
LResult = LResult & GetBreadcrumbHeader
If GroupsEnabled Then
Dim LGroup
If AGroup = "" Then
If ACategory <> "" Then LGroup = GetGroupForCategory(ACategory)
Else
LGroup = AGroup
End If
If LGroup <> "" Then LResult = LResult & GetBreadcrumbLink(LGroup, GetGroupLink(LGroup))
End If
If ACategory <> "" Then
If LResult <> "" Then LResult = LResult & GetBreadcrumbSeparator
LResult = LResult & GetBreadcrumbLink(GetShortNameForCategory(ACategory), GetCategoryLink(ACategory))
End If
If ASubcategory <> "" Then
If LResult <> "" Then LResult = LResult & GetBreadcrumbSeparator
LResult = LResult & GetBreadcrumbLink(GetShortNameForSubcategory(ACategory, ASubcategory), GetSubcategoryLink(ACategory, ASubcategory)) ' (SS,11/1/13) added missing ACategory to GetShortNameForSubcategory
End If
' (SS,15/8/14)
LResult = LResult & GetBreadcrumbFooter
GetBreadcrumb = LResult
End Function
' (SS,15/8/14) added for compatibility, function with same name to override this may exist in inc-template-products.asp
Function GetBreadcrumbHeader
GetBreadcrumbHeader = ""
End Function
' (SS,17/5/11)
' (SS,26/7/11) added HTMLEncode to ensure people don't try to add html tags to the names
' (SS,15/8/14) overriding version of this may exist in inc-template-products.asp
Function GetBreadcrumbLink(AName, AHRef)
GetBreadcrumbLink = "<span class=""breadcrumb""><a href=""" & AHRef & """>" & HTMLEncode(AName) & "</a></span>"
End Function
' (SS,17/5/11)
' (SS,15/8/14) overriding version of this may exist in inc-template-products.asp
Function GetBreadcrumbSeparator
GetBreadcrumbSeparator = "<span class=""breadcrumb-separator""> » </span>"
End Function
' (SS,15/8/14) added for compatibility, function with same name to override this may exist in inc-template-products.asp
Function GetBreadcrumbFooter
GetBreadcrumbFooter = ""
End Function
' (SS,3/2/04) looks at list of form fields specified (comma separated) '
' returns list of the ones that have a blank value '
' i.e. have not been entered '
Function GetListOfMissingFields(ARequiredList)
Dim i, c, LLength, LFieldName, LMissingFields
LMissingFields = ""
LLength = Len(ARequiredList)
LFieldName = ""
For i = 1 To LLength
c = Mid(ARequiredList, i, 1)
' if comma or last char, i.e. we have a field '
If c <> "," Then LFieldName = LFieldName + c
If c = "," Or i = LLength Then
LFieldName = Trim(LFieldName)
If LFieldName <> "" Then
If CleanRequestForm(LFieldName) = "" Then
LMissingFields = LMissingFields + Iif(LMissingFields = "", "", ", ") + LFieldName
End If
End If
LFieldName = ""
End If
Next
GetListOfMissingFields = LMissingFields
End Function
' (SS,24/5/04) now uses template instead of separate contact.asp amd contact-email.asp pages '
' (SS,18/3/10) added tr() to translation the two error message
Sub DoContactForm
Dim LErrorMessage, LShowContactForm
LErrorMessage = ""
LShowContactForm = True
ShowContactHeader
' if previously tried to post form then check telephone and email address entered'
If CleanRequestForm("postform") = "yes" Then
' (SS,6/3/13) removed (CleanRequestForm("Name") = "") because name is no longer compulsory
If (CleanRequestForm("Email") = "" And CleanRequestForm("Telephone") = "") Then
LErrorMessage = tr("Please enter either your email address or telephone") + "." ' (SS,6/3/13) removed "your Name and "
' (SS,5/3/13) added check for enquiry
ElseIf TrimAll(CleanRequestForm("Enquiry")) = "" Then
LErrorMessage = tr("Please enter your enquiry") + "."
' (SS,17/4/09) added following security code check
ElseIf EmailSecurityCodeEnabled Then
If Not SecurityOK(False) Then
LErrorMessage = tr("Please enter the correct Security Code") + "."
End If
End If
If LErrorMessage = "" Then
ShowContactThankYou
LShowContactForm = False
' add enquiry to contact database
' (SS,5/3/13) removed Address and Postcode, added Country
' (SS,13/11/13) added Addrews and Postcode back in, required by some sites for samples etc.
AddContactToDatabaseAndEmail "Contact", "Name, Address, Postcode, Country, Telephone, Email", "Enquiry", True
End If
End If
If LShowContactForm Then ShowContactForm(LErrorMessage)
ShowContactFooter
End Sub
' (SS,15/2/12)
' (SS,17/8/15) modified for Trustpilot
Sub DoReviewsPage
Dim LSQL, LReviewCount, LDoneCount, LProductCode, LProductName, LReviewerName, LReviewText, LReviewRating, LProductIsDisabled
If ReviewTypeIsTrustpilot Then
LSQL = "SELECT *, DATE_FORMAT(ReviewDateTime, '%e %b %Y') AS ReviewDate FROM trustpilot_reviews WHERE ReviewID > 1" ' Review ID 1 is a special one holding average
Else
' decided not to use time ( %l:%i %p), decided to show disabled by removing NOT p.ProductDisabled, but marked as (discontinued) with links removed
' (SS,14/9/17) added GROUP BY ReviewText, DATE(ReviewDateTime), ReviewerName, to prevent duplicate ReviewTexts appearing and harming SEO
LSQL = "SELECT pr.*, p.ProductDisabled, DATE_FORMAT(ReviewDateTime, '%e %b %Y') AS ReviewDate" &_
" FROM productreviews pr" &_
" INNER JOIN products p ON p.ProductCode = pr.ProductCode" &_
" WHERE ShowOnSite AND ReviewType = 'R'" &_
" GROUP BY ReviewText, DATE(ReviewDateTime), ReviewerName"
End If
LSQL = LSQL & " ORDER BY ReviewDateTime DESC"
' (SS,26/5/17) set limit of 100 due to too many appearing for HyperFlight causing "response buffer limit exceeded" error
LSQL = LSQL & " LIMIT 100"
OpenQuery(LSQL)
LReviewCount = GetQueryRecordCount
ShowReviewsPageHeader
If LReviewCount = 0 Then
ShowReviewsPageEmpty
Else
LDoneCount = 0
Do While Not EndOfQuery
LDoneCount = LDoneCount + 1
' (SS,17/8/15) added Trustpilot
If ReviewTypeIsTrustpilot Then
LProductCode = ""
LProductName = ""
LReviewText = GetQueryValue("ReviewBody")
LReviewRating = GetQueryValue("ReviewRating")
LProductIsDisabled = False
Else
LProductCode = GetQueryField("ProductCode")
LProductName = GetProductName(LProductCode)
LReviewText = ParagraphiseText(GetQueryValue("ReviewText"))
LReviewRating = GetQueryValue("ProductRating")
LProductIsDisabled = IntToBool(GetQueryField("ProductDisabled"))
End If
LReviewerName = GetQueryValue("ReviewerName")
If LReviewerName = "" Then LReviewerName = "Anonymous" ' (SS,15/5/09)
ShowReviewsPageItem LDoneCount, GetQueryField("ReviewID"), LProductCode, LProductName, LProductIsDisabled, GetQueryField("ReviewDate"), GetQueryValue("ReviewTitle"), LReviewRating, LReviewText, LReviewerName
NextQueryRecord
Loop
End If
CloseQuery
ShowReviewsPageFooter
End Sub
' (SS,27/7/04)'
' (SS,1/6/07) major mods for new account method
Sub DoCreateAccountForm
Dim LErrorMessage, LShowCreateAccountForm, LCreateNew
LErrorMessage = ""
LShowCreateAccountForm = True
LCreateNew = Not AccountLoggedIn
ShowCreateAccountHeader(LCreateNew) ' (SS,14/6/11) added LCreateNew
' if previously tried to post form then check telephone and email address entered'
If CleanRequestForm("postform") = "yes" Then
' (SS,5/3/13) removed old code which was only applicable for old account method (from the Else section), removed the "If NewAccountMethod" condition which was no longer applicable
GetPersonalDetailsFromForm
GetHearAboutUsFromForm ' (SS,15/6/21) separated from GetPersonalDetailsFromForm
GetDeliveryDetailsFromForm
CheckValidPersonalDetails
LErrorMessage = gsErrorMessage
If Not AllowDifferentDeliveryAddress Then Session("DeliveryAddressSameAsInvoice") = True ' (SS,19/6/09) because we don't want to validate delivery details because they won't have been entered
If LErrorMessage = "" And Not Session("DeliveryAddressSameAsInvoice") Then
CheckValidDeliveryAddress
LErrorMessage = gsErrorMessage
End If
' (SS,18/6/12) moved code to new function CheckNewPassword, for use elsewhere
' (SS,19/6/12) check now only done when creating new account, password fields not shown when editing account details
If LCreateNew Then
Dim LPasswordMsg
LPasswordMsg = CheckNewPassword
If LPasswordMsg <> "" Then LErrorMessage = LErrorMessage + Iif(LErrorMessage = "", "", "<br>") + LPasswordMsg
End If
If LErrorMessage = "" Then
LShowCreateAccountForm = False
' (SS,5/3/13) removed old code which was only applicable for old account method (from the Else section), removed the "If NewAccountMethod" condition which was no longer applicable
If LCreateNew Then
If CreateAccount(True, 0) Then
' ensure we're logged in with all details in Session, this will always return True
' (SS,19/6/12) removed first parameter 0, no longer applicable
If GetAccountDetails(CleanRequestForm("Email"), CleanRequestForm("Password"), "") Then
SaveAutoLoginToCookie ' (SS,20/9/12) save login to cookie if feature enabled
ShowCreateAccountThankYou
End If
Else
LShowCreateAccountForm = True
LErrorMessage = gsErrorMessage
End If
Else
If CreateAccount(False, Session("AccountID")) Then
ShowUpdateAccountThankYou
Else
LShowCreateAccountForm = True
LErrorMessage = gsErrorMessage
End If
End If
End If
Else
SetCheckoutAccountDefaults
End If
If LErrorMessage <> "" Then SetAlertMessage(LErrorMessage)
If LShowCreateAccountForm Then
ShowCreateAccountForm LCreateNew, LErrorMessage
Else
If NewAccountMethod Then ShowPreviousOrders ' (SS,7/11/07) added If NewAccountMethod Then
End If
ShowCreateAccountFooter
End Sub
' (SS,18/6/12) moved here from DoCreateAccountForm above because it's also called from reset password
Function CheckNewPassword
Dim LResult
' (SS,19/3/10) added tr for translation
If CleanRequestForm("Password") = "" Then
LResult = tr("Password must be entered") & "."
Else
If CleanRequestForm("Password") <> "" And Len(CleanRequestForm("Password")) < 5 Then
LResult = tr("Password must be at least 5 characters long") & "."
ElseIf CleanRequestForm("Password") <> CleanRequestForm("Password2") Then
LResult = tr("Password and Retype Password must match") & "."
Else
LResult = ""
End If
End If
CheckNewPassword = LResult
End Function
' (SS,30/5/07) new sub to call various account routines
' (SS,21/11/23) removed LCmd = "create" to disable account create feature due to a bot randomly creating accounts and doing a forgot password for VDK and CIRC
Sub DoAccount
Dim LCmd
LCmd = CleanRequestQueryString("cmd")
If LCmd = "logout" Then
DoAccountLogout
ElseIf LCmd = "forgotpassword" Then
DoForgotPassword
' (SS,18/6/12) added reset password
ElseIf LCmd = "rp" Then
DoResetPassword
' (SS,23/5/18) added subscribe (newsletter/offers optin)
ElseIF LCmd = "subscribe" Then
DoSubscribe
' ElseIf LCmd = "create" Or LCmd = "update" Then
' (SS,21/11/23) removed LCmd = "create" due to a bot randomly creating accounts and doing a forgot password for VDK and CIRC
ElseIf LCmd = "update" Then
DoCreateAccountForm
Else
DoAccountLogin
End If
End Sub
' (SS,5/8/04) '
' (SS,14/8/05) modified to show account details
' (SS,19/6/12) removed LAccountID and UseEmailAddressForLogin, no longer used
Sub DoAccountLogin
Dim LNewValidLogIn, LAlreadyLoggedIn, LOrderNo, LErrorMessage
LNewValidLogIn = False
LErrorMessage = "" ' (SS,14/6/11)
LAlreadyLoggedIn = AccountLoggedIn
DoLoginLog("Initial") ' (SS,6/1/10)
' (SS,14/6/11) moved checking log in here from below, so that we can display correct name in heading
If Not LAlreadyLoggedIn Then ' if not already logged in
' validate the account ID and password and get address details '
' (SS,30/5/07) added CleanRequestForm("Email") to following
Dim LEmail, LPassword
LEmail = Trim(CleanRequestForm("Email"))
LPassword = Trim(CleanRequestForm("Password"))
' (SS,14/6/07) GetAccountDetails also sets AccountID returned using GetAccountID
' (SS,19/6/12) removed LAccountID parameter, no longer used
If GetAccountDetails(LEmail, LPassword, "") Then
SetDateTimeOfLastLogin ' (SS,20/9/12) code moved to new routine
LNewValidLogIn = True
SaveAutoLoginToCookie ' (SS,20/9/12) save login to cookie if feature enabled
Else
If LEmail <> "" Or LPassword <> "" Then LErrorMessage = tr("Email and/or Password is incorrect")
' ShowAccountLoginMain(LErrorMessage)
End If
DoLoginLog(iif(LNewValidLogIn, "Success", "Failure")) ' (SS,6/1/10)
End If
If Not InCheckout Then
' (SS,31/5/07) added If Not InCheckout because title will already have been shown if in checkout
' (SS,14/6/11) added Or LNewValidLogIn
ShowAccountLoginHeader(LAlreadyLoggedIn Or LNewValidLogIn)
End If
If LAlreadyLoggedIn Or LNewValidLogIn Then
' if order no specified then show the details
LOrderNo = CleanRequestQueryString("orderno")
If LOrderNo <> "" And IsOrderForThisAccount(LOrderNo) Then
ShowOrderDetailsMaster False, LOrderNo
ShowOrderDetails False, LOrderNo
Else
ShowAccountDetails(LAlreadyLoggedIn) ' (SS,14/6/11) replaced LAlreadyLoggedIn with True
ShowPreviousOrders ' (SS,12/3/13) moved here from below, to only not show on same page as order details master
End If
Else
ShowAccountLoginMain(LErrorMessage) ' (SS,14/6/11) moved here
End If
' (SS,13/6/11) moved ShowAccountLoginFooter here and added check for InCheckout (which might not be necessary, not certain if routine called InCheckOut)
If Not InCheckout Then ShowAccountLoginFooter
End Sub
' (SS,20/9/12) moved from DoAccountLogin to here, now also called from DoAutoLogin
Sub SetDateTimeOfLastLogin
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
ExecuteQuery("UPDATE customers SET DateTimeLastLogin = NOW() WHERE CustomerID = '" & CleanSQLStr(GetAccountID) & "'") ' (SS,14/6/07) store date/time of login
End Sub
' (SS,6/1/10) added following to help diagnose log in problem with some users
' (SS,15/3/12) no longer used, code commented out, table loginlog has been dropped for security reasons in Sub UpgradeSchemaTo156, can be added back in future if required, see UpgradeSchemaTo147
Sub DoLoginLog(AResult)
' (SS,15/3/12) following removed until further notice, table loginlog also dropped
'Const MAX_SIZE = 255
'Dim LReferrer, LURL, LQueryString, LUserAgent
'LReferrer = Left(Request.ServerVariables("HTTP_REFERER"), MAX_SIZE)
'LURL = Left(Request.ServerVariables("URL"), MAX_SIZE)
'LQueryString = Left(Request.ServerVariables("QUERY_STRING"), MAX_SIZE)
'LUserAgent = Left(Request.ServerVariables("HTTP_USER_AGENT"), MAX_SIZE)
'ExecuteQuery("INSERT INTO loginlog SET LoginResult = '" & AResult & "', Email = '" & CleanSQLStr(Trim(CleanRequestForm("Email"))) & "', Password = '" & CleanSQLStr(Trim(CleanRequestForm("Password"))) & "', CustomerID = '" & GetAccountID & "', AlreadyLoggedIn=" & AccountLoggedIn &_
' ", DateTimeAttempted=NOW(), SessionID='" & Session.SessionID & "', IPAddress='" & CleanSQLStr(Request.ServerVariables("REMOTE_ADDR")) & "'" & ", Referrer='" & CleanSQLStr(LReferrer) & "', URL='" & CleanSQLStr(LURL) & "', QueryString='" & CleanSQLStr(LQueryString) & "', UserAgent='" & CleanSQLStr(LUserAgent) & "'")
End Sub
' (SS,13/9/12) returns customer using customer id in session or cookie, used in welcome message
' (SS,20/9/12) renamed from GetCustomerNameUsingCookie to GetCustomerNameForWelcome, now returns from session variables, rather than table
Function GetCustomerNameForWelcome
Dim LResult, LCustomerID
LCustomerID = GetCustomerID ' replaced GetSetCookieCustomerID with GetCustomerID
If LCustomerID <> "" Then
LResult = Trim(Session("Title") & " " & Session("FirstName") & " " & Session("Surname"))
Else
LResult = ""
End If
GetCustomerNameForWelcome = LResult
End Function
' (SS,20/9/12) if not already logged in and auto login is enabled then validate cookie and log in if valid
Sub DoAutoLogin
If AccountLoggedIn Or Not AutoLoginEnabled Then Exit Sub
Dim LCustomerIDCookie, LAuthCookie, LDecryptedAuthCookie
LCustomerIDCookie = GetCookie("CustomerID")
LAuthCookie = GetCookie("CustomerAuth")
' only login if both cookies exist
If LCustomerIDCookie <> "" And LAuthCookie <> "" Then
' decrypt using store name, special suffix and customer id from cookie
LDecryptedAuthCookie = AES_DecryptHex(LAuthCookie, GetStoreName & "~itp743#" & LCustomerIDCookie)
' compare, i.e customerid = customerid, if match then login
If LDecryptedAuthCookie = LCustomerIDCookie Then
If GetAccountDetails("", "", LCustomerIDCookie) Then
SetDateTimeOfLastLogin
End If
End If
End If
End Sub
' (SS,20/9/12) called when customer logs in successfully, if cookie login enabled, save customer id to cookie and encrypted version
Sub SaveAutoLoginToCookie
If Not AutoLoginEnabled Then Exit Sub
Dim LCustomerID
LCustomerID = CStr(GetAccountID) ' CStr ensures string, probably not necessary
SetCookie "CustomerID", LCustomerID
SetCookie "CustomerAuth", AES_EncryptHex(LCustomerID, GetStoreName & "~itp743#" & LCustomerID)
End Sub
' (SS,20/9/120 clears login cookies to disable auto log in
Sub ClearAutoLoginFromCookie
If Not AutoLoginEnabled Then Exit Sub
SetCookie "CustomerID", ""
SetCookie "CustomerAuth", ""
End Sub
' (SS,1/6/07) can be called to create new or update existing
' ACustomerID is valid when updating existing
' (SS,6/10/11) added NoteVATValidation
' (SS,12/6/12) added CleanSQLStr before LCustomerID to prevent SQL injection
Function CreateAccount(ACreateNew, ACustomerID)
Dim LCustomerID
CreateAccount = False
' if creating new then check to use if account already exists with same email address, abort with error if it does
If ACreateNew Then
Dim LAutoAccountExists ' (SS,22/2/13)
LAutoAccountExists = False
' If GetValueFromQuery("RecordCount", "SELECT COUNT(*) As RecordCount FROM customers WHERE EmailAddress = '" & CleanSQLStr(Session("Email") ) & "'") > 0 Then
' (SS,22/2/13) replaced above SQL with following which also check that account exist with blank password
' Null is returned if account/customer record doesn't exist, True i.e. Integer 1 is returned account exist but password is null/empty, i.e. an auto created account, CustomerID is also returned if it exists
Dim LPasswordIsEmpty
If GetSQL2Values("SELECT CustomerID, Password IS NULL AS PasswordIsEmpty FROM customers WHERE EmailAddress = '" & CleanSQLStr(Session("Email") ) & "'", LCustomerID, LPasswordIsEmpty) Then
LAutoAccountExists = IntToBool(LPasswordIsEmpty)
' (SS,22/2/13) if the automatically created account exists then we continue because we want to allow user to save the password
If Not LAutoAccountExists Then
' gsErrorMessage = tr("An account with this email address already exists.<br>Please choose 'Forgot password' to have your password emailed to you.")
' (SS,19/6/12) replaced above with following, because password can't be sent, it can only be reset, this message will also be displayed in a dialog Window (in create an account)
' (SS,4/10/17) modified to show different message in checkout e.g. link to allow bypass
gsErrorMessage = tr("An account with this email address already exists") & "."
If InCheckOut Then
gsErrorMessage = gsErrorMessage & BR & tr("Please log in by entering email/password above and pressing the 'Log in' button") & "." & BR & GetCheckoutAccountBypassTextAndLink
Else
gsErrorMessage = gsErrorMessage & BR & tr("Please log in") & "."
End If
Exit Function
End If
End If
' (SS,22/2/13) added "If Not LAutoAccountExists Then" because we can't create another customer record with same email address, we use the existing one and save the password etc
If Not LAutoAccountExists Then
' insert new customer record and get the CustomerID, fields are placed later
ExecuteQuery("INSERT INTO customers SET FirstName = '', Surname = '', AddressLine1 = '', DateTimeCreated = NOW()") ' these 3 fields are essential else query fails
LCustomerID = CLng(GetValueFromQuery("LastInsertID", "SELECT LAST_INSERT_ID() AS LastInsertID"))
End If
' (SS,12/11/08) Google AdWords conversion tracking for new account
ActivateGoogleAdWordsNewAccountConversion
DoLoginLog("CreateAccount") ' (SS,7/1/10)
Else
LCustomerID = ACustomerID
DoLoginLog("UpdateAccount") ' (SS,7/1/10)
' check that another account with same email address doesn't exist
If GetValueFromQuery("RecordCount", "SELECT COUNT(*) As RecordCount FROM customers WHERE EmailAddress = '" & CleanSQLStr(Session("Email") ) & "' AND CustomerID <> '" & CleanSQLStr(LCustomerID) & "'") > 0 Then
gsErrorMessage = tr("Another account with this email address already exists. Please choose another.")
Exit Function
End If
End If
ClearDeliveryDetailsIfSameAsInvoice ' (SS,15/6/07)
' (SS,10/11/09) sends an email of customer details change and this option is enabled
If Not ACreateNew AND FNotifyCustomerRecordUpdate Then
CheckCustomerRecordChange ACustomerID
End If
' update the customer record
Dim LMySQL
' (SS,16/11/07) added VATNumber
' (SS,12/6/12) added CleanSQLStr before LCustomerID to prevent SQL injection
LMySQL = "UPDATE customers SET" &_
" EmailAddress = '" & CleanSQLStr(Session("Email")) & "'"
' (SS,18/6/12) added GetSQLForPasswordEncryption to Password to hash and encrypt it
' (SS,19/6/12) password now only saved then creating new account, no longer when editing account details
If ACreateNew Then
LMySQL = LMySQL &_
", Password = " & GetSQLForPasswordEncryption(Session("Password"), False)
End If
' (SS,12/2/21) removed VATNumber, added EORINumber and XIEORINumber
' (SS,19/5/21) modified to optionally include AlternativePhone and HearAboutUs, HearAboutUsOther
LMySQL = LMySQL &_
", Title = '" & CleanSQLStr(Session("Title")) & "'" &_
", FirstName = '" & CleanSQLStr(Session("FirstName")) & "'" &_
", Surname = '" & CleanSQLStr(Session("Surname")) & "'" &_
", CompanyName = '" & CleanSQLStr(Session("CompanyName")) & "'" &_
", AddressLine1 = '" & CleanSQLStr(Session("Address1")) & "'" &_
", AddressLine2 = '" & CleanSQLStr(Session("Address2")) & "'" &_
", Town = '" & CleanSQLStr(Session("Town")) & "'" &_
", County = '" & CleanSQLStr(Session("County")) & "'" &_
", Postcode = '" & CleanSQLStr(Session("Postcode")) & "'" &_
", Country = '" & CleanSQLStr(Session("Country")) & "'" &_
", Telephone = '" & CleanSQLStr(Session("Telephone")) & "'" &_
", DeliveryAddressSameAsInvoice = " & BoolToInt(Session("DeliveryAddressSameAsInvoice")) &_
", DeliveryName = '" & CleanSQLStr(Session("DeliveryName")) & "'" &_
", DeliveryCompanyName = '" & CleanSQLStr(Session("DeliveryCompanyName")) & "'" &_
", DeliveryAddressLine1 = '" & CleanSQLStr(Session("DeliveryAddress1")) & "'" &_
", DeliveryAddressLine2 = '" & CleanSQLStr(Session("DeliveryAddress2")) & "'" &_
", DeliveryTown = '" & CleanSQLStr(Session("DeliveryTown")) & "'" &_
", DeliveryCounty = '" & CleanSQLStr(Session("DeliveryCounty")) & "'" &_
", DeliveryPostcode = '" & CleanSQLStr(Session("DeliveryPostcode")) & "'" &_
", DeliveryCountry = '" & CleanSQLStr(Session("DeliveryCountry")) & "'" &_
", Subscribe = " & BoolToInt(Session("Subscribe")) &_
", EORINumber='" & CleanSQLStrMax(Session("EORINumber"), 20) & "'" &_
", XIEORINumber='" & CleanSQLStrMax(Session("XIEORINumber"), 20) & "'"
' (SS,15/6/21) removed HearAboutUs, got left behind when previous mod was made
' ", HearAboutUs = '" & CleanSQLStr(Session("HearAboutUs")) & "'" &_
' (SS,12/2/21) following removed from above
' ", VATNumber='" & CleanSQLStr(Session("VATNumber")) & "'" &_
' (SS,19/5/21) optionally include AlternativePhone
If AlternativePhoneEnabled Then
LMySQL = LMySQL & ", AlternativePhone = '" & CleanSQLStrMax(Session("AlternativePhone"), 100) & "'"
End If
' (SS,19/5/21) optionally include HearAboutUs and HearAboutUsOther
If HearAboutUsEnabled Then
LMySQL = LMySQL &_
", HearAboutUs = '" & CleanSQLStrMax(Session("HearAboutUs"), 100) & "'" &_
", HearAboutUsOther = '" & CleanSQLStrMax(Session("HearAboutUsOther"), 100) & "'"
End If
' (SS,19/5/21) moved following here from above i.e. end of LMySQL
LMySQL = LMySQL & " WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "'"
' (SS,19/6/12) added error handling to prevent exposure of SQL if following fails, we don't want to show the hash/encryption functions
On Error Resume Next
ExecuteQuery(LMySQL)
' (SS,19/6/12) check for error, unlikely to ever occur, prevent exposure of SQL if it ever does
If Err.Number <> 0 Then
LogErrorToFile("Following error occurred while in CreateAccount: " & Err.Description)
Response.Write("Updating account details failed. Sorry for any inconvenience caused. Please contact us.")
Exit Function
End If
On Error GoTo 0 ' cancel the error handling
' (SS,6/10/11) to check and note VAT Number validation
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
NoteVATValidation "customers", "CustomerID = '" & CleanSQLStr(LCustomerID) & "'"
CreateAccount = True
End Function
' (SS,10/11/09)
Sub CheckCustomerFieldChange(AName, AName2)
Dim LName2, LFieldNameFormatted, LFieldValueOld, LFieldValueNew
LFieldNameFormatted = AName & ": " & Space(12 - Len(AName))
LName2 = AName2
If LName2 = "" Then LName2 = AName
LFieldValueOld = Trim(NB(GetQueryValue(AName)))
LFieldValueNew = Trim(Session(LName2))
FCustomerDetailsOld = FCustomerDetailsOld & LFieldNameFormatted & LFieldValueOld & NL
FCustomerDetailsNew = FCustomerDetailsNew & LFieldNameFormatted & LFieldValueNew & NL
If LFieldValueOld <> LFieldValueNew Then
FCustomerFieldChange = True
FCustomerFieldsChangedList = FCustomerFieldsChangedList + iif(FCustomerFieldsChangedList = "", "", ", ") + AName
End If
End Sub
' (SS,10/11/09)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Sub CheckCustomerRecordChange(ACustomerID)
Dim LTitle, LFirstName, LSurname, LCompanyName, LAddressLine1, LAddressLine2, LTown, LCounty, LPostcode, LCountry, LTelephone, LEmailAddress, LVATNumber
OpenQuery("SELECT * FROM customers WHERE CustomerID = '" & CleanSQLStr(ACustomerID) & "'")
FCustomerFieldChange = False
FCustomerDetailsOld = ""
FCustomerDetailsNew = ""
FCustomerFieldsChangedList = ""
CheckCustomerFieldChange "Title", ""
CheckCustomerFieldChange "FirstName", ""
CheckCustomerFieldChange "Surname", ""
CheckCustomerFieldChange "CompanyName", ""
CheckCustomerFieldChange "AddressLine1", "Address1"
CheckCustomerFieldChange "AddressLine2", "Address2"
CheckCustomerFieldChange "Town", ""
CheckCustomerFieldChange "County", ""
CheckCustomerFieldChange "Postcode", ""
CheckCustomerFieldChange "Country", ""
CheckCustomerFieldChange "EmailAddress", "Email"
CheckCustomerFieldChange "VATNumber", ""
CloseQuery
' if field changed then send the email showing what fields were changed
If FCustomerFieldChange Then
Dim LBody
LBody = "Details for customer " & ACustomerID & " have been changed from:" & NL & NL & FCustomerDetailsOld & NL & "to: " & NL & NL & FCustomerDetailsNew
LBody = LBody & NL & "Fields changed: " & FCustomerFieldsChangedList
SendEmail FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, GetStoreName & " customer record change notification", LBody, False
End If
End Sub
' (SS,15/8/05) returns true if order is for current account, to prevent users from view orders of other customers
Function IsOrderForThisAccount(AOrderNo)
IsOrderForThisAccount = GetValueFromQuery("RecordCount", "SELECT COUNT(*) As RecordCount FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo ) & "' AND CustomerID = '" + CleanSQLStr(Session("AccountID")) + "'") = 1
End Function
' (SS,8/3/13) modifies the status suitable for showing to customer, i.e. COMPLETED is converted to "DESPATCHED"
Function StatusForCustomer(AStatus)
If AStatus = ORDER_COMPLETED_STATUS Then
StatusForCustomer = "DESPATCHED"
Else
StatusForCustomer = AStatus
End If
End Function
' (SS,14/8/05) list of orders to go here
' (SS,5/6/07) added LOrdersExist parameter, removed ShowAccountPreviousOrdersNone routine
' (SS,13/11/13) added code to only show despatch details columns if there are such details
Sub ShowPreviousOrders
Dim LOrderNo, LDateOfOrder, LTotal, LStatus, LHRef, LOrdersExist, LQueryOpened, LCourier, LTrackingNo, LTrackingURL, LTrackingPostcode
Dim LShowDespatchDetails ' (SS,13/11/13)
If Session("AccountID") = "" Then
LOrdersExist = False ' make sure orders with no customer id aren't shown
LQueryOpened = False
Else
' (SS,13/11/13) added following to detect whether there are despatch details, i.e. DeliveryAgent, Courier, TrackingNo and Packed By etc. have been entered for customer, and only then show them, show sites don't fill in these fields
LShowDespatchDetails = GetSQLValue("SELECT COUNT(*) FROM orders WHERE CustomerID = '" + CleanSQLStr(Session("AccountID")) + "' AND NOT (DeliveryAgentDate IS NULL AND TRIM(COALESCE(DeliveryAgentName, '')) = '' AND TRIM(COALESCE(Courier, '')) = '' AND TRIM(COALESCE(TrackingNo, '')) = '' AND TRIM(COALESCE(PackedBy, '')) = '')") > 0
LQueryOpened = True
Dim LWhere
' (SS,28/5/09) added AWAITING_PAYMENT_STATUS
LWhere = "(Status = '" + AWAITING_PAYMENT_STATUS + "' OR Status = '" + PAYMENT_RECEIVED_STATUS + "' OR Status = '" + PAYMENT_ON_ACCOUNT_STATUS + "' OR Status = '" + ORDER_COMPLETED_STATUS + "')"
' (SS,12/5/10) replaced '%d %M %Y' with GetLanguageDateFormat(True)
' (SS,8/3/13) added DateDespatchedFormatted
OpenQuery("SELECT *, DATE_FORMAT(DateTimeOrdered, '" & GetLanguageDateFormat(True) & "') AS DateOfOrderLong, DATE_FORMAT(DeliveryAgentDate, '" & GetLanguageDateFormat(False) & "') AS DateDespatchedFormatted FROM orders WHERE CustomerID = '" + CleanSQLStr(Session("AccountID")) + "' AND " + LWhere + " ORDER BY DateTimeOrdered DESC")
LOrdersExist = Not EndOfQuery ' (SS,5/6/07)
End If
' (SS,5/6/07) added parameters
' (SS,13/11/13) added LShowDespatchDetails
ShowAccountPreviousOrdersHeader LOrdersExist, Session("AccountID"), GetFullName(Session("Title"), Session("FirstName"), Session("Surname")), Session("Email"), LShowDespatchDetails
If LQueryOpened Then
Do While Not EndOfQuery
LOrderNo = GetQueryValue("OrderNo")
LDateOfOrder = GetQueryValue("DateOfOrderLong")
' (SS,1/8/17) set the currency code, rate, symbols for calls to CorrectCurrencyNV etc to work correctly to show the values using the actual historical currency and exchange rate
SetCurrencyForOrder GetFieldValue("CurrencyCode"), GetFieldValue("ExchangeRate")
LTotal = CorrectCurrency(GetQueryValue("GrandTotal")) ' (SS,12/5/10) replaced FormatNumber with CorrectCurrency
LStatus = GetQueryValue("Status")
LHRef = "products.asp?page=account&orderno=" & LOrderNo
LCourier = GetQueryValue("Courier")
LTrackingNo = Trim(GetQueryValue("TrackingNo"))
' if tracking no is a URL then use that and take the number after the last query (after last "=")
If IsURL(LTrackingNo) Then
LTrackingURL = LTrackingNo
LTrackingNo = GetLastQueryStringValue(LTrackingURL)
Else
' (SS,16/5/13) added Postcode because some courier sites require it
LTrackingPostcode = NB(GetQueryValue("DeliveryPostcode"))
If LTrackingPostcode = "" Then LTrackingPostcode = NB(GetQueryValue("Postcode"))
LTrackingURL = GetTrackingURLForCourier(GetQueryValue("DeliveryAgentName"), LCourier, LTrackingNo, LTrackingPostcode)
End If
' (SS,8/3/13) added StatusForCustomer to convert COMPLETED to DESPATCHED, added PackedBy, DeliveryAgentDate, Courier, TrackingNo, TrackingURL
' (SS,13/11/13) added LShowDespatchDetails
ShowAccountPreviousOrdersDetail LOrderNo, LDateOfOrder, LTotal, StatusForCustomer(LStatus), LHRef, LShowDespatchDetails, GetQueryValue("PackedBy"), GetQueryValue("DateDespatchedFormatted"), LCourier, LTrackingNo, LTrackingURL
NextQueryRecord
Loop
End If
If LQueryOpened Then CloseQuery
ShowAccountPreviousOrdersFooter(LOrdersExist)
End Sub
' (SS,8/3/13) in future add a common table for holding courier tracking details, or maybe a local lookup table called couriers
' (SS,16/5/13) added APostcode for APC Streetwise
' (SS,14/4/14) added UKMail and UPS
' (SS,12/9/14) added ParcelForce
' (SS,19/4/16) added direct tracking URLs for ParcelForce, RoyalMail and APC
' (SS,3/7/18) tracking not working for air mail due to new delivery agents "Tracked Airmail" and "Untracked Royal Mail"
' (SS,17/2/21) added FedEx
' (SS,29/3/22) added "Royal Mail" with a space
' (SS,14/6/23) change to UPS tracking
' (SS,30/9/24) added DHL
' (SS,28/2/25) change for DHL (for WebShip agent including courier DHL eCommerce and DHL Express)
' (SS,20/6/25) replaced with new version, this can be removed
Function GetTrackingURLForCourier_old(ADeliveryAgentName, ACourier, ATrackingNo, APostcode)
Dim LDeliveryAgentName, LCourier, LResult, LTrackingNo, LPos
LDeliveryAgentName = UCase(Trim(ADeliveryAgentName))
LCourier = UCase(Trim(ACourier))
LTrackingNo = Trim(ATrackingNo) ' (SS,16/5/13)
If LTrackingNo = "" Or LCourier = "" Then
LResult = ""
' (SS,16/5/13) added LDeliveryAgentName = "TNT" previously it was just LCourier = "TNT"
' (SS,17/2/21) added [Or LDeliveryAgentName = "FEDEX"] due to FedEx buying TNT
ElseIf LDeliveryAgentName = "TNT" Or LCourier = "TNT" Or LDeliveryAgentName = "FEDEX" Then
' LResult = "http://www.tnt.com/webtracker/tracking.do?respCountry=us&respLang=en&navigation=1&page=1&sourceID=1&sourceCountry=ww&plazaKey=&refs=&requesttype=GEN&searchType=CON&ref=" & ATrackingNo
' (SS,12/3/13) replaced above with following
LResult = "http://www.tnt.com/webtracker/tracking.do?navigation=1&searchType=CON&respLang=en&respCountry=GENERIC&genericSiteIdent=.&cons=" & LTrackingNo
' (SS,19/4/16) added Or LDeliveryAgentName = "AIRMAIL"
' (SS,3/7/18) added "TRACKED AIRMAIL" and "TRACKED ROYAL MAIL"
' (SS,29/3/22) added LDeliveryAgentName = "ROYAL MAIL"
ElseIf LDeliveryAgentName = "ROYAL MAIL" OR LDeliveryAgentName = "ROYALMAIL" Or LDeliveryAgentName = "AIRMAIL" Or LDeliveryAgentName = "TRACKED AIRMAIL" Or LDeliveryAgentName = "TRACKED ROYAL MAIL" Then
LResult = "http://www.royalmail.com/track-trace?trackNumber=" & LTrackingNo ' (SS,19/4/16) added ?trackNumber=" & LTrackingNo
' (SS,12/9/14) added ParcelForce
ElseIf LDeliveryAgentName = "PARCELFORCE" Then
LResult = "http://www.parcelforce.com/track-trace?trackNumber=" & LTrackingNo ' (SS,19/4/16) added ?trackNumber=" & LTrackingNo
' (SS,16/5/13) added APC and streetwise
ElseIf LDeliveryAgentName = "APC-OVERNIGHT.COM" Or LDeliveryAgentName = "APC" Then
' ignore the "Consignment Number: " prefix if there is one
'If LCase(Left(LTrackingNo, 19)) = "consignment number:" Then LTrackingNo = Trim(Mid(LTrackingNo, 20))
' if there's a space then get the number after the last space
'LPos = InStrRev(LTrackingNo, " ")
'If LPos > 0 Then LTrackingNo = Trim(Mid(LTrackingNo, LPos + 1))
' LResult = "http://www.apc-overnight.com/apc/quickpod.php?txtpostcode=" & URLEncode(APostcode) & "&txtconno=" & URLEncode(LTrackingNo) & "&Track=Track&type=1"
' (SS,13/1/16) replaced above with following which is no longer working, i.e. tracking no can't be passed to tracking site
'LResult = "'https://apc-overnight.com/receiving-a-parcel/tracking"
' (SS,19/4/16) replaced above with following
LResult = "https://emea.netdespatch.com/mba/23906x0/track/?type=3&ref=" & LTrackingNo
' (SS,14/4/14) added UKMail and UPS
ElseIf LDeliveryAgentName = "UKMAIL" Then
LResult = "https://www.ukmail.com/manage-my-delivery/manage-my-delivery" ' we can add the tracking number here, customers will have to copy and paste
ElseIf LDeliveryAgentName = "UPS" Then
' (SS,21/8/14) corrected "1Z57606X6899460764" to URLEncode(LTrackingNo)
' LResult = "http://wwwapps.ups.com/WebTracking/track?track.x=Track&trackNums=" & URLEncode(LTrackingNo)
' (SS,14/6/23) replaced above with following, even though above was still working via their redirection
LResult = "https://www.ups.com/track?tracknum=" & URLEncode(LTrackingNo)
' (SS,30/9/24) added DHL
'ElseIf LDeliveryAgentName = "DHL" Then
' LResult = "https://www.dhl.com/gb-en/home/tracking.html?tracking-id=" & URLEncode(LTrackingNo)
' (SS,28/2/25) replaced above with following to also handle Courier with DHL eCommerce and DHL Express, also change to URL including adding of "submit=1" to submit without requiring an additional click
ElseIf LDeliveryAgentName = "DHL" Or Left(LCourier, 3) = "DHL" Then
LResult = "https://www.dhl.com/gb-en/home/tracking/tracking-parcel.html?submit=1&tracking-id=" & URLEncode(LTrackingNo)
Else
LResult = ""
End If
GetTrackingURLForCourier = ReplaceStr(LResult, "&", "&")
End Function
' (SS,20/6/25) new version, makes use of IsCourierOrAgent, need to remove GetTrackingURLForCourier_old
Function GetTrackingURLForCourier(ADeliveryAgentName, ACourier, ATrackingNo, APostcode)
Dim LTrackingURL
If IsCourierOrAgent("Royal Mail", "RoyalMail", "", ACourier, ADeliveryAgentName, ATrackingNo, "http://www.royalmail.com/track-trace?trackNumber=", LTrackingURL) Then
ElseIf IsCourierOrAgent("Parcelforce", "", "", ACourier, ADeliveryAgentName, ATrackingNo, "http://www.parcelforce.com/track-trace?trackNumber=", LTrackingURL) Then
ElseIf IsCourierOrAgent("TNT", "", "", ACourier, ADeliveryAgentName, ATrackingNo, "http://www.tnt.com/webtracker/tracking.do?navigation=1&searchType=CON&respLang=en&respCountry=GENERIC&genericSiteIdent=.&cons=" , LTrackingURL) Then
ElseIf IsCourierOrAgent("FedEx", "", "", ACourier, ADeliveryAgentName, ATrackingNo, "https://www.fedex.com/wtrk/track/?trknbr=", LTrackingURL) Then
ElseIf IsCourierOrAgent("UPS", "", "", ACourier, ADeliveryAgentName, ATrackingNo, "https://www.ups.com/track?tracknum=", LTrackingURL) Then
ElseIf IsCourierOrAgent("DHL", "DHL eCommerce", "DHL Express", ACourier, ADeliveryAgentName, ATrackingNo, "https://www.dhl.com/gb-en/home/tracking/tracking-parcel.html?submit=1&tracking-id=", LTrackingURL) Then
Else
LTrackingURL = ""
End If
GetTrackingURLForCourier = LTrackingURL
End Function
' (SS,20/6/25) called from GetTrackingURLForCourier
Function IsCourierOrAgent(ACheckFor1, ACheckFor2, ACheckFor3, ACourier, ADeliveryAgentName, ATrackingNo, AURL, ByRef ATrackingURL)
Dim LCheckFor1, LCheckFor2, LCheckFor3, LDeliveryAgentName, LCourier, LResult, LTrackingNo
LCheckFor1 = UCase(ACheckFor1)
LCheckFor2 = UCase(ACheckFor2)
LCheckFor3 = UCase(ACheckFor3)
' following ensures it doesn't match for blank, "--No Match--" can be anything just something unlikely to be in courier or agent name
If LCheckFor2 = "" Then LCheckFor2 = "--No Match--"
If LCheckFor3 = "" Then LCheckFor3 = "--No Match--"
LDeliveryAgentName = UCase(Trim(ADeliveryAgentName))
LCourier = UCase(Trim(ACourier))
LTrackingNo = Trim(ATrackingNo)
If LCourier = LCheckFor1 Or LDeliveryAgentName = LCheckFor1 Or LCourier = LCheckFor2 Or LDeliveryAgentName = LCheckFor2 Or LCourier = LCheckFor3 Or LDeliveryAgentName = LCheckFor3 Then
ATrackingURL = AURL & LTrackingNo
ATrackingURL = ReplaceStr(ATrackingURL, "&", "&")
LResult = True
Else
LResult = False
End If
IsCourierOrAgent = LResult
End Function
' (SS,6/8/04) '
Sub DoAccountLogout()
Session("AccountID") = ""
ClearAutoLoginFromCookie ' (SS,20/9/12) to prevent cookies from auto loggin in, if feature enabled
ShowAccountLogoutHeader ' (SS,15/6/11) was ShowAccountLoginHeader(False)
ShowAccountLogoutSuccess
ShowAccountLogoutFooter ' (SS,15/6/11)
End Sub
' (SS,6/8/04)
Sub DoForgotPassword()
Dim LErrorMessage, LShowForgotPasswordForm, LEmail
LErrorMessage = ""
LShowForgotPasswordForm = True
ShowForgotPasswordHeader
' if previously tried to post form then check email address entered'
If CleanRequestForm("postform") = "yes" Then
LEmail = Trim(CleanRequestForm("Email"))
If LEmail = "" Then
LErrorMessage = tr("Email address must be entered") & "."
ElseIf Not IsValidEmailAddress(LEmail) Then ' (SS,19/5/09) replaced InStr..etc with Not IsValidEmailAddress
LErrorMessage = tr("Valid Email address must be entered") & "."
End If
If LErrorMessage = "" Then
If SendForgottenPassword(LEmail) Then
ShowForgotPasswordThankYou
LShowForgotPasswordForm = False
' add enquiry to contact database '
AddContactToDatabaseAndEmail "Forgot Password", "Email", "", False
Else
LErrorMessage = tr("Email address not found. Please enter your correct Email address.")
End If
End If
End If
If LShowForgotPasswordForm Then ShowForgotPasswordForm(LErrorMessage)
ShowForgotPasswordFooter
End Sub
' (SS,6/8/04) searches customer database for given email address and sends the password '
' (SS,18/6/12) modified to make more secure, reset password rather than sending the password
Function SendForgottenPassword(AEmailAddress)
Dim NL
NL = Chr(13) + Chr(10)
' (SS,18/6/12) renamed LAccountID to LCustomerID, and LPassword to LResetKey
Dim LCustomerID, LResetKey, LFound
OpenQuery("SELECT * FROM customers WHERE EmailAddress = '" & CleanSQLStr(AEmailAddress) & "'")
If EndOfQuery Then
LFound = False
Else
LCustomerID = GetQueryValue("CustomerID")
' LPassword = GetQueryValue("Password")
' (SS,18/6/12) above replaced with following to generate a random key for resetting password
LResetKey = GetRandomPassword(10)
' (SS,18/6/12) save the key and date/time of request in customer record
ExecuteQuery("UPDATE customers SET PasswordResetKey = '" & CleanSQLStr(LResetKey) & "', PasswordResetDateTime = NOW() WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "'")
LFound = True
End If
CloseQuery
If LFound Then
Dim LBody
' (SS,18/6/12) changed "Your Account ID and password are displayed below" to Please click the link below to reset your password
LBody = trx("This email has been sent to you because you informed us that you forgot your password for <x>", GetStoreName) & "." & NL & NL &_
tr("Please click the link below to reset your password") & ":" & NL & NL
' (SS,28/6/10) added tr to following two lines
'LBody = LBody + tr("Account ID") & ": " & LAccountID & NL
'LBody = LBody + tr("Password") & ": " & LPassword
' (SS,18/6/12) replaced above with following, i.e. a link to reset the password
LBody = LBody + GetStoreURL & "?page=account&cmd=rp&id=" & LCustomerID & "&key=" & LResetKey
' (SS,19/6/12) added following to warn about expiry
LBody = LBody & NL & NL & tr("This link will expire in 4 hours.")
SendEmail AEmailAddress, "", "", FEmailContactFrom, GetStoreName & " " & tr("Password Reset"), LBody, False
End If
SendForgottenPassword = LFound
End Function
' (SS,18/6/12)
Sub DoResetPassword
' check that id, reset key are valid and date/time is less than 4 hours
' make sure password is the minimum length and that both password are the same
Dim LCustomerID, LKey, LErrorMessage, LMessage, LShowResetPasswordForm
LCustomerID = CleanSQLStr(CleanRequestQueryString("id"))
LKey = CleanSQLStr(CleanRequestQueryString("key"))
LErrorMessage = ""
LMessage = ""
LShowResetPasswordForm = True
ShowResetPasswordHeader
' checks of customer id match, key match, and key not blank, and date time hasn't expired, currently 4 hours allowed
If GetSQLValueAsString("SELECT CustomerID FROM customers WHERE CustomerID = '" & LCustomerID & "' AND PasswordResetKey = '" & LKey & "' AND COALESCE(PasswordResetKey, '') <> '' AND DATE_ADD(PasswordResetDateTime, INTERVAL 4 HOUR) > NOW()") = "" Then
LErrorMessage = tr("Invalid or expired Password Reset URL")
LShowResetPasswordForm = False
' if previously tried to post form then check password entered
ElseIf CleanRequestForm("postform") = "yes" Then
LErrorMessage = CheckNewPassword
' if password okay then save the password
If LErrorMessage = "" Then
LShowResetPasswordForm = False
On Error Resume Next ' to prevent exposure of SQL command if error does occur, highly unlikely to happen
ExecuteQuery("UPDATE customers SET Password = " + GetSQLForPasswordEncryption(CleanRequestForm("Password"), False) + " WHERE CustomerID = '" & LCustomerID & "'")
' check for error, unlikely to ever occur, prevent exposure of SQL if it ever does
If Err.Number <> 0 Then
LogErrorToFile("Following error occurred while in DoResetPassword: " & Err.Description)
Response.Write("Resetting password failed. Sorry for any inconvenience caused. Please contact us.")
Exit Sub
End If
On Error GoTo 0 ' cancel the error handling
LMessage = tr("Your password has been reset.")
End If
End If
ShowResetPasswordForm LErrorMessage, LMessage, LShowResetPasswordForm
ShowResetPasswordFooter
End Sub
Sub DoCreateAccount
ShowCreateAccountHeader
ShowCreateAccountForm("")
ShowCreateAccountFooter
End Sub
' use for adding web form contact enquiry to database
' called from email asps
' (SS,3/2/04) changed to allow any number of form values to be added, as listed in AFieldList
' also up to 3 special values
' (SS,4/2/04) wanted to used optional parameters but they don't work in vbscript
' (SS,6/8/04) added ASendMail parameter, so things can be added to database without email being sent
' (SS,5/3/13) removed the NL Dim, which was for two lines, doubled up the NLs
' contacts table also restructured to removed the fields Company, Position, AddToMailingList
' fields Address, Postcode will become redundant in new template, moved these to the end, retain for backward compatibility for old template sites
' new fields Country and DateTimeFollowedUp added
' (SS,15/10/18) added "<br>"'s because email has changed from plain text to HTML
' (SS,12/11/21) replaced 2 x CleanRequestForm with CleanRequest to also work with query string i.e. ajax call in GSC for Extension Enquiry
' this will check query string first and then the form, form first is better in this situation
Sub AddContactToDatabaseAndEmail(AType, AFieldList, AEnquiryFieldList, ASendEmail)
Dim LEmailBody
Dim i, c, LLength, LFieldName, LFieldValue, LEnquiryFieldValue
LEmailBody = ""
' (SS,11/4/22) added following to stop recent regular spammer, it's just ignored when such an address used
If IsSpamEmailAddress(Trim(CleanRequest("Email"))) Then
' Response.Write "Spam Detected" & "<br>"
Exit Sub
End If
OpenTable "contacts"
AddRecord
PutFieldValue "Type", AType
PutFieldValue "DateTimeContacted", Now
' go through list of fields placing the values
LLength = Len(AFieldList)
LFieldName = ""
For i = 1 To LLength
c = Mid(AFieldList, i, 1)
' if comma or last char, i.e. we have a field '
If c <> "," Then LFieldName = LFieldName + c
If c = "," Or i = LLength Then
LFieldName = Trim(LFieldName)
If LFieldName <> "" Then
LFieldValue = CleanRequest(LFieldName)
If LFieldValue <> "" Then
PutFieldValue LFieldName, LFieldValue
LEmailBody = LEmailBody + LFieldName + ": " & LFieldValue & NL & NL
End If
LFieldName = ""
End If
End If
Next
' go through list of fields in Enquiry Fields placing the values
LLength = Len(AEnquiryFieldList)
LFieldName = ""
LEnquiryFieldValue = ""
For i = 1 To LLength
c = Mid(AEnquiryFieldList, i, 1)
' if comma or last char, i.e. we have a field '
If c <> "," Then LFieldName = LFieldName + c
If c = "," Or i = LLength Then
LFieldName = Trim(LFieldName)
If LFieldName <> "" Then
LFieldValue = CleanRequest(LFieldName)
If LFieldValue <> "" Then
' (SS,6/3/13) added If... to only added fieldname, colon and newlines if AEnquiryFieldList has more than one value, this never actually occurs in this app
If InStr(AEnquiryFieldList, ",") = 0 Then
LEnquiryFieldValue = LFieldValue
Else
LEnquiryFieldValue = LEnquiryFieldValue + LFieldName + ": " & LFieldValue & NL & NL
End If
LEmailBody = LEmailBody + LFieldName + ": " & LFieldValue & NL & NL
End If
LFieldName = ""
End If
End If
Next
If LEnquiryFieldValue <> "" Then
PutFieldValue "Enquiry", LEnquiryFieldValue
End If
PostRecord
CloseTable
' (SS,28/6/10) added GetStoreName & " " & for email subject to be more obvious e.g. Galleon Supplies Contact Form (instead of just Contact Form)
' (SS,30/6/10) as requested by Neil, changed "Contact" to "Enquiry" instead of "Contact Form", to allow reply without renaming of subject
Dim LSubject
If AType = "Contact" Then
LSubject = "Enquiry"
Else
LSubject = AType + " Form" ' (SS,30/6/10) how it was
End If
' (SS,25/11/11) added GetSQLLastInsertID to keep enquiry threads separate in Outlook, requested by Neil, I have the same issue in my Outlook
If ASendEmail Then
' (SS,15/10/18) added following line to replace all linefeed and carriage returns with HTML BRs, because email is now HTML
' perhaps added full HTML tags in future, i.e. HTML, BODY etc. and set the font. Perhaps put in a table.
LEmailBody = ReplaceNewLinesWithBR(LEmailBody)
SendContactEmail GetStoreName & " " & LSubject & " - " & GetSQLLastInsertID, LEmailBody
End If
End Sub
' (SS,3/2/04) new routine which just sends the email '
' given subject and body, uses mail server and email addresses from table '
' (SS,27/7/05) modified to call SendMail '
' (SS,5/9/18) modified to send as HTML instead of Plain Text
' (SS,12/11/21) replaced CleanRequestForm with CleanRequest to also work with query string i.e. ajax call in GSC for Extension Enquiry
Sub SendContactEmail(ASubject, ABody)
' try to use the original email address as the from address, if blank use the default one '
Dim LFromEmailAddress
LFromEmailAddress = Trim(CleanRequest("Email"))
If LFromEmailAddress = "" Then LFromEmailAddress = FEmailContactFrom
SendEmail FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, LFromEmailAddress, ASubject, ABody, True ' (SS,5/9/18) changed False to True to send as HTML
End Sub
' (SS,27/11/12) used to send email to site administration to alert them about something
' (SS,24/8/17) added AIsHTML parameter, changed False to AIsHTML in call to SendEmail
Sub SendAlertEmail(ASubject, ABody, AIsHTML)
Dim LSubject
LSubject = "ALERT!!! " + ASubject
' (SS,25/6/22) replaced "" (3rd parameter) with GMAIL_ALERT_ADDRESS
SendEmail FEmailOrderConfirmationBcc1, FEmailOrderConfirmationBcc2, GMAIL_ALERT_ADDRESS, FEmailOrderConfirmationFrom, LSubject, ABody, AIsHTML
End Sub
' (SS,18/4/18) special debug web log email sent only to contactforms@itpartnership.com
Sub SendWebLogEmail(AMessage)
Dim LSubject, LBody
LSubject = "Web Log for " & GetStoreName
LBody = GetWebLog
If AMessage <> "" Then
LBody = AMessage & NL & LBody
End If
SendEmail "contactforms@itpartnership.com", "", "", FEmailOrderConfirmationFrom, LSubject, LBody, False
End Sub
' (SS,24/8/17) same as SendAlertEmail but without adding "ALERT!!! " unless AIsAlert is True
Sub SendNotificationEmail(ASubject, ABody, AIsAlert, AIsHTML)
Dim LSubject
If AIsAlert Then
LSubject = "ALERT!!! " + ASubject
Else
LSubject = ASubject
End If
SendEmail FEmailOrderConfirmationBcc1, FEmailOrderConfirmationBcc2, "", FEmailOrderConfirmationFrom, LSubject, ABody, AIsHTML
End Sub
' (SS,23/8/17) new version which now calls SendEmailByCDO instead of SendEmailByDundas, previous SendMail renamed to SendEmailByDundas
Function SendEmail(AEmailAddress, ABCCEmailAddress, ABCCEmailAddress2, AFromEmailAddress, ASubject, ABody, AIsHTML)
SendEmail = SendEmailByCDO(AEmailAddress, ABCCEmailAddress, ABCCEmailAddress2, AFromEmailAddress, ASubject, ABody, "", AIsHTML, "", "")
End Function
' (SS,6/8/04) sends email to given address '
' (SS,27/7/05) added two new parameters ABCCEmailAddress, AFromEmailAddress '
' also added secondary mailserver '
' (SS,4/8/05) added ABCC2EmailAddress parameter
' (SS,24/3/06) modified to ensure script does not end with runtime error if email fails
' also an attempt is now made to send the emails again individually
' if main email address fails, then the BCCs are sent with error message added to the start of body
' hopefully this will stop some Worldpay callback failures that occurred with
' following in response - "The RCPT command failed. The specified account does not exsist."
' (SS,8/6/07) added AIsHTML parameter, changed from Sub to Function, returns True if email successful
' (SS,23/8/17) renamed from SendEmail to SendEmailByDundas, now deprecated
Function SendEmailByDundas(AEmailAddress, ABCCEmailAddress, ABCCEmailAddress2, AFromEmailAddress, ASubject, ABody, AIsHTML)
' send the email using Dundas Mailer Control
Dim objEmail 'Mailer control
Set objEmail = Server.CreateObject("Dundas.Mailer")
' (SS,10/6/07) replaced Application("MailServer") with GetMailServer(1) and Application("MailServer2") with GetMailServer(1)
objEmail.SMTPRelayServers.Add GetMailServer(1)
If GetMailServer(2) <> "" Then objEmail.SMTPRelayServers.Add GetMailServer(2)
'set Mailer control properties and collection items
objEmail.TOs.Add AEmailAddress
If ABCCEmailAddress <> "" Then objEmail.BCCs.Add ABCCEmailAddress
If ABCCEmailAddress2 <> "" Then objEmail.BCCs.Add ABCCEmailAddress2
objEmail.FromAddress = AFromEmailAddress
objEmail.Subject = ASubject
If AIsHTML Then
objEmail.HTMLBody = ABody
Else
objEmail.Body = ABody
End If
'send email
On Error Resume Next ' (SS,24/3/06) to trap error
objEmail.SendMail
' (SS,24/3/06) added following to check for error and show message
' also resend the emails individually
If Err.Number <> 0 Then
' try sending email again
objEmail.BCCs.Clear
On Error Resume Next
objEmail.SendMail
If Err.Number <> 0 Then
' add error message to start of body of the BCCs '
objEmail.Body = "*** Sending Email to " + AEmailAddress + " failed: " & Err.Description + "***" & NL & NL & objEmail.Body
Response.Write "Sending Email to " + AEmailAddress + " failed: " & Err.Description
End If
' send the BCC emails if assigned
If ABCCEmailAddress <> "" Then
objEmail.TOs.Clear
objEmail.TOs.Add ABCCEmailAddress
On Error Resume Next
objEmail.SendMail
End If
If ABCCEmailAddress2 <> "" Then
objEmail.TOs.Clear
objEmail.TOs.Add ABCCEmailAddress2
On Error Resume Next
objEmail.SendMail
End If
End If
SendEmailByDundas = Err.Number <> 0 ' (SS,10/6/07) return true if successful
'you can test for the success/failure of the operation by examining VBScript's Err object here
Set objEmail = Nothing
End Function
' (SS,10/6/06) send email using CDO, returns False if there was a failure
' (SS,28/9/12) added AEmbeddedImage to allow image to be embedded inside the email
Function SendEmailByCDO(ATo, ABcc, ABcc2, AFrom, ASubject, ABody, AFiles, AIsHTML, AUrl, AEmbeddedImage)
' Create CDO message object
Dim objMessage
Set objMessage = CreateObject("CDO.Message")
' Set configuration fields.
With objMessage.Configuration.Fields
Const SCHEMA_PREFIX = "http://schemas.microsoft.com/cdo/configuration/"
' Original sender email address
.Item(SCHEMA_PREFIX & "sendemailaddress") = AFrom
' SMTP settings - without authentication, using standard port 25 on host smtp
.Item(SCHEMA_PREFIX & "sendusing") = 2 ' cdoSendUsingPort
.Item(SCHEMA_PREFIX & "smtpserverport") = 25
.Item(SCHEMA_PREFIX & "smtpserver") = GetMailServer(1)
' SMTP Authentication
.Item(SCHEMA_PREFIX & "smtpauthenticate") = 0 ' cdoAnonymous
' Timeout
.Item(SCHEMA_PREFIX & "smtpconnectiontimeout") = 10
.Update
End With
' Set other message fields.
With objMessage
' From, To, Subject And Body are required.
.From = AFrom
.To = ATo
.Subject = ASubject
' if AUrl is provided then build the email from given web page
If AUrl <> "" Then
.CreateMHTMLBody AUrl
ElseIf AIsHTML Then
' if HTML then set the HTML body
.HTMLBody = ABody
' (SS,28/9/12) embed image if supplied, image must be in the images folder
If AEmbeddedImage <> "" Then
' (SS,28/9/12) embed the image, the HTML must contain something like <img src="cid:myimage.gif">
' with help from http://support.jodohost.com/threads/tut-how-to-add-embedded-images-in-cdo-mail.7692/
Dim objBP
' Const CdoReferenceTypeName = 1
Set objBP = objMessage.AddRelatedBodyPart(Server.MapPath("/images/" & AEmbeddedImage), AEmbeddedImage, 1)
objBP.Fields.Item("urn:schemas:mailheader:Content-ID") = "<" & AEmbeddedImage & ">"
objBP.Fields.Update
End If
Else
' else normal plain text
.TextBody = ABody
End If
' Blind copy and attachments are optional.
If ABcc <> "" Then .BCC = ABcc
If ABcc2 <> "" Then .BCC = .BCC + ";" + ABcc2
If AFiles <> "" Then .AddAttachment AFiles
' Send the email and check for failure
On Error Resume Next
.Send
' if failed then try other mail servers
Dim LMailServer, LMailServerNo
LMailServerNo = 2
Do While Err.Number <> 0
LMailServer = GetMailServer(LMailServerNo)
If LMailServer = "" Then Exit Do
LMailServerNo = LMailServerNo + 1
With objMessage.Configuration.Fields
.Item(SCHEMA_PREFIX & "smtpserver") = LMailServer
.Update
End With
On Error Resume Next ' cancels the previous error message, i.e. Err.Number starts again at zero
.Send
Loop
End With
' Returns zero If succesfull. Error code otherwise
SendEmailByCDO = Err.Number = 0
' clean up
Set objMessage = Nothing
End Function
' (SS,30/1/08) send email using itpMailer, returns False if there was a failure
' (SS,10/12/15) itpEmailer can't handle SSL (https://) URLs, fixed by fetching the body of AURL using new GetWebPage routine in dbfunctions.asp
Function SendEmailByITPEmailer(ATo, ABcc1, ABcc2, AFrom, ASubject, ABody, AIsHTML, AURL)
Dim objEmail
Set objEmail = Server.CreateObject("itpEmailer.itpEmailer")
objEmail.SMTPServer1 = GetMailServer(1)
objEmail.SMTPServer2 = GetMailServer(2)
objEmail.ToAddress = ATo
objEmail.FromAddress = AFrom
objEmail.Bcc1 = ABcc1
objEmail.Bcc2 = ABcc2
objEmail.Subject = ASubject
If AURL <> "" Then
' objEmail.URL = AURL
' (SS,10/12/15) replaced above with following because itpEmailer can't handle SSL
objEmail.HTMLBody = GetWebPage(AURL)
ElseIf AIsHTML Then
objEmail.HTMLBody = ABody
Else
objEmail.Body = ABody
End If
On Error Resume Next ' to trap error
objEmail.Send
If objEmail.ErrorMessage <> "" Then
SendEmailByITPEmailer = False
Response.Write("*** Failed to send email: " + objEmail.ErrorMessage)
ElseIf Err.Number <> 0 Then
SendEmailByITPEmailer = False
Response.Write("*** Failed to send email: Error " & Err.Number & " - " & Err.Description)
Else
SendEmailByITPEmailer = True
End If
Set objEmail = Nothing
End Function
' (SS,17/4/07) all the modify basket commands now go through here
' this is do be done before inc-template-shopping-status.asp and inc-pages.asp
' is actually called from end of inc-main.asp
' also removed dedundant code from inc-pages.asp
Sub DoBasketOperation
Dim Lcmd, Lcode, Litemid
' xcmd takes priority over cmd
Lcmd = CleanRequest("xcmd")
Lcode = CleanRequest("xcode")
If Lcmd = "" Then
Lcmd = CleanRequest("cmd")
Lcode = CleanRequest("code")
Litemid = CleanRequest("itemid") ' (SS,5/7/11)
End if
' abort if no basket operation
If Lcmd = "" Then Exit Sub
If Lcmd = "buy" Or Lcmd = "buyl" Then ' (SS,28/5/07) added "buyl" for buy from product list (ensures it stays in list)
AddToBasket Lcode, CleanRequest("qty")
' (SS,25/10/18) following removed it's now redundant (was used by old detailed shopping status)
'ElseIf Lcmd = "delete" Then
' If Litemid <> "" Then
' DeductFromBasket Litemid ' (SS,5/7/11) replaced Lcode with Litemid
' Else ' (SS,12/9/12) if itemid is blank then use Lcode i.e. xcode (shopping status delete) which now actually holds the itemid
' DeductFromBasket Lcode
' End If
ElseIf Lcmd = "remove" Then
' (SS,2/11/20) changed to call RemoveGroupFromBasket if optionslist set, else as before just call RemoveFromBasket
Dim Loptionslist
Loptionslist = CleanRequest("optionslist")
If Loptionslist <> "" Then
RemoveGroupFromBasket Litemid, Loptionslist
Else ' (SS,2/11/20) as before
RemoveFromBasket Litemid ' (SS,5/7/11) replaced Lcode with Litemid
End If
ElseIf Lcmd = "recalculate" Then
RecalculateBasket
End If
End Sub
' (SS,20/5/04) main products routine (was in inc-products-view.asp) '
' called from inc-products.asp
Sub ProductsMain
strCommand = CleanRequestQueryString("cmd")
If strCommand = "" Then strCommand = CleanRequestForm("cmd")
strSearch = CleanRequestQueryString("search")
strPage = CleanRequestQueryString("pageno")
strGroup = CleanRequestQueryString("grp") ' (SS,11/2/05)
strCategory = GetCategory ' (SS,17/9/08) replaced CleanRequestQueryString("cat") with GetCategory
strSubcategory = GetSubcategory ' (SS,26/7/11) replaced CleanRequestQueryString("subcat") with GetSubcategory
strProductCode = GetProductCodeQS ' (SS,7/11/18) replaced CleanRequestQueryString("code") with GetProductCodeQS
strQty = CleanRequestQueryString("qty")
strClientWidth = CleanRequestQueryString("cw") ' was clientwidth '
strClientHeight = CleanRequestQueryString("cl") ' was clientheight '
' (SS,13/8/15) set the sort by if
if CleanRequestQueryString("sortby") <> "" Then SetSortBy CleanRequestQueryString("sortby")
Dim Lxcmd
Lxcmd = CleanRequestQueryString("xcmd")
' (SS,20/5/04) changed to add to basket and stay in small page '
' (SS,19/8/06) added Lxcmd = "currency"
If Lxcmd = "delete" Or Lxcmd = "buy" Or Lxcmd = "currency" Then
' do nothing this would have been done in inc-pages.asp '
' (SS,17/4/07) now done in DoBasketOperations above, called before ProductsMain
ElseIf strCommand = "buy" Then
' AddToBasket strProductCode, strQty
' (SS,17/4/07) removed above, this operation is now done in DoBasketOperations, called before ProductsMain
' (SS,28/5/07) added following to ensure it doesn't go to product details page when buy
' was done on a product list (i.e. category/subcategory or search)
ElseIf strCommand = "buyl" Then ' (SS,28/5/07) buy from list
strProductCode = "" ' ensure we stay in the same list (i.e. don't go to product details page)
End If
' (SS,22/9/09) added following to do a seach when disabled product referred to from search engine
Dim LDoSearch
LDoSearch = False
' (SS,19/4/16) if order was created and user is actively viewing product, category, basket etc. page then make sure stock reserved (order placed) is added back into stock
If Not InCheckout Then
ClearExistingOrderPlaced False
End If
If strCommand = "remove" Then
' RemoveFromBasket strProductCode
' (SS,17/4/07) removed above, this operation is now done in DoBasketOperations, called before ProductsMain
ShowBasket
ElseIf strCommand = "recalculate" Then
' RecalculateBasket
' (SS,17/4/07) removed above, this operation is now done in DoBasketOperations, called before ProductsMain
ShowBasket
ElseIf strCommand = "basket" Then
ShowBasket
ElseIf strCommand = "checkout" Then
DoCheckout ' (SS,4/10/20) renamed from CheckOut to DoCheckout
' (SS,17/9/20) removed following, not used and no such rountine as TakePayment
'ElseIf strCommand = "payment" Then ' called if payment details are taken directly
' TakePayment
ElseIf strProductCode <> "" Then
' (SS,22/9/09) added following to check if product code exist, and do a search if it doesn't
' allows disabled products referred to from google to do a search rather than show product not found
If CheckEnabledProductExists(strProductCode) Then
ShowSingleProduct strProductCode
Else
strSearch = GetSearchForPhraseFromReferrer
If strSearch = "" Then ' if no search phrase then do the normal routine
ShowSingleProduct strProductCode
Else ' else do the search for the phrase from referrer
LDoSearch = True
End If
End If
'ElseIf strCommand = "sitemap" Then ' special product list to help with search engines, (SS,15/2/13) renamed from "list" to "sitemap"
' ShowHTMLSiteMap ' (SS,15/2/13) renamed from ShowFullList to ShowHTMLSiteMap, also removed strCategory, strSubcategory parameters
' (SS,19/2/13) remove, now called via PageContent sitemap with {SITEMAP} token
' (SS,19/2/15) new save basket feature
ElseIf strCommand = "savebasket" Then
SaveBasket
' (SS,19/2/15) new restore basket feature
ElseIf strCommand = "restorebasket" Then
RestoreBasket
' (SS,25/2/22) restore basket from given order
ElseIf strCommand = "restorebasketorder" Then
RestoreBasketFromOrder
' (SS,12/12/18) added cancel order feature
ElseIf strCommand = "cancelorder" Then
CancelOrder
' (SS,27/3/07) added SubcategoryListEnabled, to allow all products to be listed instead for the category
ElseIf SubcategoryListEnabled And (strSearch = "") And (strCategory <> "") And (strSubcategory = "") Then
ShowSubcategories(strCategory)
' (SS,27/3/07) added CategoryListEnabled, to allow all products to be listed instead for the group
ElseIf CategoryListEnabled And (strSearch = "") And (strCategory = "") And (strPage = "") Then
ShowCategories(strGroup) ' (SS,11/2/05) added strGroup
Else
LDoSearch = True ' (SS,22/9/09) code from here moved below, because it's now called from two conditions
End If
If LDoSearch Then
' if search has a value then empty category and subcategory
If strSearch <> "" Then
strGroup = "" ' (SS,27/3/07)
strCategory = ""
strSubcategory = ""
End If
' (SS,1/7/11) added following for attribute search between min and max
' (SS,14/3/12) added LVal, to search for exact value instead min max
Dim LAttributeID, LMin, LMax, LVal
LAttributeID = CleanRequestQueryString("attributeid")
LMin = CleanRequestQueryString("min")
LMax = CleanRequestQueryString("max")
LVal = CleanRequestQueryString("val")
' (SS,27/3/07) added strGroup to following
' (SS,1/7/11) added LAttributeID, LMin, LMax
' (SS,14/3/12) added LVal parameter
ShowProducts strGroup, strCategory, strSubcategory, strSearch, strPage, LAttributeID, LMin, LMax, LVal
End If
End Sub
' (SS,5/8/04)
' (SS,26/5/07) removed parameters AProductCode, AStdPrice, ASalePrice
' (SS,6/7/11) added FOptionsPrice, GetPricingFromProductRecord must be called before calling this routine
' (SS,28/8/14) also gets called from GetPricingFromProductRecord with FOptionsPrice set to zero to get the price without options to pass to a custom routine
' (SS,28/3/17) now calls function CustomGetPriceWithoutOptions if it exists to allow price to be overridden
Function GetProductPrice
Dim LSalePrice, LPrice
LSalePrice = GetSalePrice ' (SS,22/5/07) removed AProductCode, ASalePrice from GetSalePrice parameters
If Not IsNull(LSalePrice) Then
LPrice = LSalePrice
Else
LPrice = GetStdPrice ' (SS,22/5/07) removed AProductCode, ASalePrice from GetStdPrice parameters
End If
' (SS,7/11/12) if MinCurrencyPricesEnabled and minimum current price (in GBP) is greater than price above then set to minimum price
If MinCurrencyPricesEnabled Then
' (SS,9/11/12) added LPrice > 0 to allow negative prices (credit) to work as before
If LPrice > 0 And FMinCurrencyPrice > LPrice Then LPrice = FMinCurrencyPrice
End If
' (SS,28/3/17) added following to override main price if custom routine defined, used in local mode to override normal prices
If FunctionExists("CustomGetPriceWithoutOptions") Then
LPrice = CustomGetPriceWithoutOptions(LPrice)
End If
' (SS,6/7/11) added FOptionsPrice
GetProductPrice = LPrice + FOptionsPrice
End Function
' (SS,10/9/14)
Function GetProductWeight
GetProductWeight = FPostalWeight
End Function
' (SS,5/8/04) added this to cope with Contract Prices '
' if Account Holder then prices are obtained from ContractPrices
' if they exist otherwise normal price is return '
' (SS,21/5/07) removed parameters AProductCode, AStdPrice replaced with FProductCode, FStdPrice
' Added CustomPricingEnabled to get from CustomGetStdPrice
' (SS,8/11/12) modified to return min currency price is minimum price facility enabled and set to this product
' (SS,7/3/13) removed references to removed table contractprices
Function GetStdPrice
Dim LResult
If CustomPricingEnabled Then
LResult = CustomGetStdPrice
Else
LResult = FStdPrice
End If
' (SS,8/11/12) if MinCurrencyPricesEnabled and minimum current price (in GBP) is greater than price above then set to minimum price
If MinCurrencyPricesEnabled Then
' (SS,9/11/12) added LResult > 0 to allow negative prices (credit) to work as before
If LResult > 0 And FMinCurrencyPrice > LResult Then LResult = FMinCurrencyPrice
End If
GetStdPrice = LResult
End Function
' (SS,5/8/04) if on contract then sale price is only return '
' if it's lower than the contract price '
' (SS,21/5/07) removed parameters AProductCode, ASalePrice replaced with FProductCode, FSalePrice
' Added CustomPricingEnabled to get from CustomGetSalePrice
' (SS,8/11/12) modified to return min currency price is minimum price facility enabled and set to this product
' (SS,7/3/13) removed references to contract prices
Function GetSalePrice
Dim LResult
If CustomPricingEnabled Then
LResult = CustomGetSalePrice
ElseIf FUseDiscountFieldForSpecialOffers Then
If IsDiscounted Then
LResult = GetDiscountedPrice(FStdPrice)
Else
LResult = Null
End If
Else
LResult = FSalePrice
End If
' (SS,8/11/12) if MinCurrencyPricesEnabled and minimum current price (in GBP) is greater than sale price then clear the sale price
If MinCurrencyPricesEnabled And Not IsNull(LResult) Then
' (SS,9/11/12) added LResult > 0 to allow negative prices (credit) to work as before
If LResult > 0 And FMinCurrencyPrice > LResult Then LResult = Null
End If
GetSalePrice = LResult
End Function
' (SS,18/5/07)
Function GetDiscountedPrice(APrice)
If IsDiscounted Then
GetDiscountedPrice = Round(APrice * (1 - FDiscountPercentage / 100), 2)
Else
GetDiscountedPrice = APrice
End If
End Function
' (SS,18/5/07)
Function IsDiscounted
If FUseDiscountFieldForSpecialOffers Then
IsDiscounted = FDiscountPercentage > 0
Else
IsDiscounted = False
End If
End Function
' (SS,29/8/12) because all Galleon products are discounted by 2 percentage
Function IsDiscountedOver2PC
If FUseDiscountFieldForSpecialOffers Then
IsDiscountedOver2PC = FDiscountPercentage > 2
Else
IsDiscountedOver2PC = False
End If
End Function
' (SS,26/5/07) moved here from ShowSpecialOffers and improved
Function GetDiscountPercentage
Dim LDiscountPercentage
' (SS,18/5/07) added If FUseDiscountFieldForSpecialOffers etc for new discount field
If FUseDiscountFieldForSpecialOffers Then
LDiscountPercentage = FDiscountPercentage
Else
Dim LStdPrice, LSalePrice
LStdPrice = GetStdPrice
LSalePrice = GetSalePrice
If IsNull(LSalePrice) Then
LDiscountPercentage = 0
' (SS,23/10/14) added following ElseIf to prevent overflow error if LStdPrice is 0
ElseIf LStdPrice = 0 Then
LDiscountPercentage = 0
Else
LDiscountPercentage = (LStdPrice - LSalePrice) / LStdPrice * 100
End If
End If
GetDiscountPercentage = LDiscountPercentage
End Function
' (SS,21/5/07)
' returns list of fields for use in SQL, takes into account various flags
' ATableName is used to prefix each field following by a dot, ATableName can be ""
' in following format "StdPrice, SalePrice, Price2, Price3, Price4" without leading and trailing commas
Function GetPricingFieldsForSQL(ATableName)
Dim LSQL
' (SS,28/8/14) added PostalWeight to allow it to be passed to CustomGetOptionsPriceAndWeight
LSQL = ", StdPrice, SalePrice, PostalWeight"
If FourPricingFieldsEnabled Then LSQL = LSQL + ", Price2, Price3, Price4"
If MinCurrencyPricesEnabled Then LSQL = LSQL + ", MinUSDPrice, MinEURPrice" ' (SS,7/11/12)
If UseDiscountFieldForSpecialOffers Then LSQL = LSQL + ", Discount"
If VATBandsEnabled Then LSQL = LSQL + ", VATBand"
LSQL = Replace(LSQL, ", ", ", " + Iif(ATableName = "", "", ATableName + "."))
GetPricingFieldsForSQL = Mid(LSQL, 3, Len(LSQL)) ' also removes leading comma
End Function
' (SS,18/5/07) gets the pricing values from product record and places in globals
' value in ABasketQty is only applicable when looking at the basket, this should be Qty value from basket, 0 otherwise
' (SS,6/7/11) removed ABasketQty, doesn't seem to be used for anything, added ACalculateOptionsPrice
' when ACalculateOptionsPrice is True FOptionsPrice is calculated from options in basket, else set to 0, and place in FOptionsPrice
' query GetOrderItemsQuery is based on a link between shoppingbaskets and products, this is open before calling this routine
' (SS,7/11/12) added code for Min Currency Prices
' (SS,23/4/13) added rounding to 2dp to FMinCurrencyPrice
' (SS,28/8/14) added calling of CustomGetOptionsPriceAndWeight routine if CUSTOM extra setting in settings, Options Price and Weight are adjusted by this routine
Sub GetPricingFromProductRecord(ACalculateOptionsPrice)
' FBasketQty = ABasketQty ' (SS,6/7/11) removed
FProductCode = GetFieldValue("ProductCode") ' because product code can be used to look up contract prices
FProductID = GetFieldValue("ProductID") ' (SS,6/7/11) because we need to calculate the options price
FPostalWeight = NZ(GetFieldValue("PostalWeight")) ' (SS,10/9/14)
' NZ necessary because values are DECIMAL MYSQL which ODBC is fetching as VarType 14 (not IsNumeric) TypeMismatch error otherwise, NZ converts this to double
If FourPricingFieldsEnabled Then
FPrice1 = NZ(GetFieldValue("StdPrice"))
FPrice2 = NZ(GetFieldValue("Price2"))
FPrice3 = NZ(GetFieldValue("Price3"))
FPrice4 = NZ(GetFieldValue("Price4"))
Else
FStdPrice = ENKN(GetFieldValue("StdPrice")) ' ENKN ensures number keeping null
FSalePrice = ENKN(GetFieldValue("SalePrice")) ' (SS,14/9/07) missed from previous version
' (SS,7/11/12) added following to get min currency price if MinCurrencyPricesEnabled from either MinUSDPrice of MinEURPrice
If MinCurrencyPricesEnabled Then
If IsCurrencyUSD Then
FMinCurrencyPrice = NZ(GetFieldValue("MinUSDPrice"))
ElseIf IsCurrencyEUR Then
FMinCurrencyPrice = NZ(GetFieldValue("MinEURPrice"))
Else
FMinCurrencyPrice = 0
End If
' if not zero then convert to GBP by dividing by currency rate
' (SS,23/4/13) added Round(.., 2) to ensure subtotal is the same as line total when single item
If FMinCurrencyPrice <> 0 Then FMinCurrencyPrice = Round(FMinCurrencyPrice / GetCurrencyRate, 2)
End If
End If
If UseDiscountFieldForSpecialOffers Then FDiscountPercentage = NZ(GetFieldValue("Discount"))
If VATBandsEnabled Then FVATBand = GetFieldValue("VATBand")
' (SS,6/7/11) total up chosen options in basket for this item
FOptionsPrice = 0
FOptionsWeight = 0
If ProductOptionsEnabled And ACalculateOptionsPrice Then
' (SS,28/8/14) calculate price without options which is passed onto custom routine later, must be called while FOptionsPrice is 0 setting
Dim LPriceWithoutOptions
LPriceWithoutOptions = GetProductPrice
' FOptionsPrice, FOptionsWeight globals used
Dim LSQL
' short alias names not used, i.e. so, po, because LOCK TABLES requires the tablename, and it'll be confusing if it used so, po
LSQL = "SELECT SUM(PriceAdjust), SUM(WeightAdjust) FROM shopping_basket_options " &_
"INNER JOIN product_option_values ON product_option_values.ProductOptionValueID = shopping_basket_options.ProductOptionValueID " &_
"WHERE ItemID = " & GetFieldValue("ItemID") & " AND shopping_basket_options.ProductOptionValueID <> 0"
If GetSQL2Values(LSQL, FOptionsPrice, FOptionsWeight) Then
' nulls converted to 0, also ensures field type is numeric
FOptionsPrice = NZ(FOptionsPrice)
FOptionsWeight = NZ(FOptionsWeight)
End If
' (SS,28/8/14) added following to call a custom routine to calculate the options price and weight
' routine is called with an dictionary list of each of the options that has "custom" in the extra settings
LSQL = "SELECT * FROM shopping_basket_options " &_
"INNER JOIN product_options ON product_options.ProductOptionID = shopping_basket_options.ProductOptionID " &_
"WHERE ItemID = " & GetFieldValue("ItemID") & " AND product_options.ExtraSettings LIKE '%CUSTOM%'"
OpenQuery2(LSQL)
' if custom option exists and function exists then pass on the values via dictionary, routine will add what i needs to to FOptionsPrice and FOptionsWeight
If Not EndOfQuery2 Then
If FunctionExists("CustomGetOptionsPriceAndWeight") Then
Dim objOptionsDictionary
Set objOptionsDictionary = CreateObject("Scripting.Dictionary")
objOptionsDictionary.CompareMode = vbTextCompare 'makes the keys case insensitive'
Do While Not EndOfQuery2
objOptionsDictionary.Add GetQueryValue2("OptionName"), GetQueryValue2("OptionValue")
NextQueryRecord2
Loop
' routine will use the options to add to FOptionsPrice and FOptionsWeight
CustomGetOptionsPriceAndWeight objOptionsDictionary, LPriceWithoutOptions, NZ(GetFieldValue("PostalWeight")), FOptionsPrice, FOptionsWeight
Set objOptionsDictionary = Nothing
End If
Else ' (SS,5/4/17) following is for normal options, i.e. without product_options.ExtraSettings LIKE '%CUSTOM%'
If FunctionExists("CustomGetNormalOptionsPrice") Then
FOptionsPrice = CustomGetNormalOptionsPrice(FOptionsPrice)
End If
End If
CloseQuery2
End If
End Sub
' (SS,21/5/07) returns product description up to maximum length
' if AMaxLengh is 0 then the full description is returned
' if AClean is True then the table and HTML tags are removed
' (SS,19/9/11) added ComposeDescription to also process the tokens, and removed Trim(RemoveComposes(LDesc)) which isn't applicable now due to ComposeDescription, tables and bullets will remain
Function GetProductDescription(AClean, AMaxLength)
Dim LDesc
LDesc = FProductDescription
If IsNull(LDesc) Then
LDesc = ""
Else
If AClean Then LDesc = Trim(RemoveComposes(LDesc)) ' (SS,13/9/12) remove the special tables and bullets for clean description
LDesc = ComposeDescription(LDesc, True, False) ' (SS,19/9/11)
If AClean Then LDesc = Trim(RemoveHTMLTags(LDesc))
If AMaxLength > 0 And AMaxLength < Len(LDesc) Then
LDesc = Mid(LDesc, 1, AMaxLength) + "..."
End If
End If
GetProductDescription = LDesc
End Function
' (SS,21/5/07)
Sub SetProductDescription(AValue)
FProductDescription = AValue
End Sub
' (SS,24/7/11) for use by shopping admin via getdesc.asp to show just description, ProductCode is used if ProductID is 0 or ""
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Function GetProductDescriptionForID(AProductID, AProductCode)
Dim LSQL
LSQL = "SELECT ProductDescription FROM products WHERE "
If AProductID <> 0 And AProductID <> "" Then
LSQL = LSQL & "ProductID = '" & CleanSQLStr(AProductID) & "'"
Else
LSQL = LSQL & "ProductCode = '" & CleanSQLStr(AProductCode) & "'"
End If
GetProductDescriptionForID = ComposeDescription(GetSQLValueAsString(LSQL), True, False)
End Function
' (SS,4/8/11) used by getdesc.asp and shopping admin, as a temporary store for previewing product description, replaces GetProductDescriptionForID
' (SS,5/8/11) added pc for PC name, better for multiuser
Function GetProductDescriptionScratch
GetProductDescriptionScratch = ComposeDescription(GetSettingMemo("Scratch", "ProductDescription-" & CleanRequestQueryString("pc")), True, False)
End Function
' (SS,26/5/07)
Function GetProductDimensions
GetProductDimensions = FProductDimensions
End Function
' (SS,26/5/07)
Sub SetProductDimensions(AValue)
FProductDimensions = NB(AValue)
End Sub
' (SS,16/2/12) returns page link given page e.g. reviews, uses script page name e.g. products.asp
Function GetPageLink(APageName)
GetPageLink = GetScriptName + "?page=" & APageName
End Function
' (SS,13/3/13)
Function GetAccountLink
GetAccountLink = GetPageLink("account")
End Function
' (SS,11/2/05)
' (SS,16/2/12) removed following because another one exists by the same name
'Function GetGroupLink(AGroup)
' GetGroupLink = AddStoreURL("products.asp?cmd=cat&grp=" & Server.URLEncode(AGroup))
'End Function
' (SS,23/3/05) changed from javascript to normal link to help with search engines '
Function GetCategoryLink(ACategory)
' quote in category or subcategory is prefixed by backslash else javascript will fail '
'GetCategoryLink = "javascript:itp_subcat('" + ReplaceStr(ACategory,"'", "\'") + "','')"
GetCategoryLink = AddStoreURL("products.asp?cat=" & Server.URLEncode(ACategory)) ' (SS,17/9/08) added AddStoreURL
End Function
' (SS,26/3/07)
Function GetGroupLink(AGroup)
GetGroupLink = AddStoreURL("products.asp?grp=" & Server.URLEncode(AGroup))
End Function
' (SS,23/3/05) special one for javascript link '
Function GetCategoryJavaLink(ACategory)
' quote in category or subcategory is prefixed by backslash else javascript will fail '
' GetCategoryJavaLink = "javascript:itp_subcat('" + ReplaceStr(ACategory,"'", "\'") + "','')"
' (SS,18/5/07) replaced above with following
GetCategoryJavaLink = "javascript:itp_subcat('" + FixLinkForJavascript(ACategory) + "','')"
End Function
' (SS,20/7/07) new non javascript version, previous one renamed to GetSubcategoryJavaLink
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
Function GetSubcategoryLink(ACategory, ASubCategory)
GetSubcategoryLink = AddStoreURL("products.asp?cat=" & Server.URLEncode(ACategory) & "&subcat=" & Server.URLEncode(ASubcategory)) ' (SS,17/9/08) added AddStoreURL
End Function
' (SS,13/6/17) special redirect version that doesn't encode & as &, because & doesn't work for redirects
Function GetSubcategoryLinkForRedirect(ACategory, ASubCategory)
GetSubcategoryLinkForRedirect = AddStoreURL("products.asp?cat=" & Server.URLEncode(ACategory) & "&subcat=" & Server.URLEncode(ASubcategory)) ' (SS,17/9/08) added AddStoreURL
End Function
' (SS,20/7/07) renamed from GetSubcategoryLink to GetSubcategoryJavaLink
Function GetSubcategoryJavaLink(ACategory, ASubCategory)
' quote in category or subcategory is prefixed by backslash else javascript will fail '
' GetSubcategoryLink = "javascript:itp_subcat('" + ReplaceStr(ACategory, "'", "\'") + "','" + ReplaceStr(ASubCategory, "'", "\'") + "')"
' (SS,18/5/07) was failing for double quote, replaced with FixLinkForJavascript (previous line above)
GetSubcategoryJavaLink = "javascript:itp_subcat('" + FixLinkForJavascript(ACategory) + "','" + FixLinkForJavascript(ASubCategory) + "')"
'GetSubcategoryLink = "javascript:itp_subcat('" + Server.HTMLEncode(ACategory) + "','" + Server.HTMLEncode(ASubCategory) + "')"
End Function
' (SS,18/5/07)
Function FixLinkForJavascript(ALink)
Dim LLink ' LLink used otherwise we'll end up changing original ALink value
LLink = ALink
LLink = Replace(LLink, "'", "\'")
' "\""" doesn't work URL encode %22 does, URLEncode can't be used because it result it '+' be returned for space
' may be a better way?
LLink = Replace(LLink, """", "%22")
FixLinkForJavascript = LLink
End Function
' (SS,6/7/06) added strImageNo
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
' (SS,8/8/18) removed strImageNo
Function GetProductLink(AProductCode)
Dim LLink
' (SS,16/12/15) removed Server.URLEncode from AProductCode, helps prevent duplicates being detected in Screaming Frog SEO
LLink = "products.asp?code=" & AProductCode
GetProductLink = AddStoreURL(LLink) ' (SS,17/9/08) added AddStoreURL
End Function
' (SS,6/7/10) for SEO
' (SS,19/7/10) replaced Server.URLEncode(AProductName) with SEOFriendlyStr(AProductName)
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
Function GetProductLinkWithName(AProductCode, AProductName)
Dim LLink
' LLink = "products.asp?name=" & SEOFriendlyStr(AProductName) & "&code=" & Server.URLEncode(AProductCode)
' (SS,7/2/11) replaced above with following to reverse the code and name, requested by Neil for easier emailing
' (SS,26/7/11) added HTMLDecode because AProductName will be passed here after being HTMLEncoded, we don't want a quote to appear as the word quote
' (SS,16/12/15) removed Server.URLEncode from AProductCode and SEOFriendlyStr, helps prevent duplicates being detected in Screaming Frog SEO
LLink = "products.asp?code=" & AProductCode & "&name=" & SEOFriendlyStr(HTMLDecode(AProductName))
GetProductLinkWithName = AddStoreURL(LLink) ' (SS,17/9/08) added AddStoreURL
End Function
' (SS,18/5/09) used in emails
Function GetFullProductLink(AProductCode)
GetFullProductLink = GetStoreURL + "/" + GetProductLink(AProductCode)
End Function
' (SS,16/3/15) full version of GetProductLinkWithName
Function GetFullProductLinkWithName(AProductCode, AProductName)
GetFullProductLinkWithName = GetStoreURL + "/" + GetProductLinkWithName(AProductCode, AProductName)
End Function
' (SS,8/8/18) moved image URL fetching code from here to new section at the end
' (SS,6/7/06) new
' (SS,12/9/12) GetProductFileLinkCached below calls this and adds cache=y to it
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
Function GetProductFileLink(AProductCode, AFileNo)
Dim LLink
LLink = "getfile.asp?code=" & Server.URLEncode(AProductCode) + "&code2=" & Server.URLEncode(AFileNo)
GetProductFileLink = LLink
End Function
' (SS,12/9/12) special version which caches the file (used by banner download which is cached for 60 minutes)
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
Function GetProductFileLinkCached(AProductCode, AFileNo)
GetProductFileLinkCached = GetProductFileLink(AProductCode, AFileNo) & "&cache=y"
End Function
Function GetBuyLink(AProductCode)
GetBuyLink = "javascript:itp_buy('" & AProductCode & "')"
End Function
' (SS,13/9/12) calls itp_buyq to add given quantity to basket
Function GetBuyQLink(AProductCode, AQty)
GetBuyQLink = "javascript:itp_buyq('" & AProductCode & "'," & AQty & ")"
End Function
Function GetBuyBLink(AProductCode)
GetBuyBLink = "javascript:itp_buyb('" & AProductCode & "')"
End Function
' (SS,6/5/10) used when there are a list of products on same page
Function GetBuyLLink(AProductCode)
Dim LProductDashAsUnderscore
LProductDashAsUnderscore = Replace(AProductCode, "-", "_")
GetBuyLLink = "javascript:itp_buyl('" & AProductCode & "','QTY_" + LProductDashAsUnderscore + "')"
End Function
' (SS,1/7/11) new buy with options link, which posts using post method the frmBasket form section
' AProductID parameter is currently ignored
Function GetBuyOLink(AProductID)
'GetBuyOLink = "javascript:frmBasket.submit()"
GetBuyOLink = "javascript:itp_buyo()"
End Function
' (SS,16/5/11) version called from previous order view (inc-template-checkout.asp) uses replacement product code if it exists
Function GetBuyLinkPreviousOrders(AProductCode)
GetBuyLinkPreviousOrders = GetBuyLink(GetReplacementProductCode(AProductCode))
End Function
' (SS,4/12/12) href version used in order reminder emails, also with qty
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
Function GetBuyLinkHRef(AProductCode, AQty)
GetBuyLinkHRef = GetFullProductLink(AProductCode) & "&cmd=buy&qty=" & AQty
End Function
' (SS,29/9/04) allows us to optimise the full product list for search engines '
Function ForProductList()
' (SS,14/6/06) changed Request("name") to CleanRequestQueryString("name")
' because name was clashing with name in contacts page and causing category menu not to show
' (SS,6/7/10) added GetScriptName = "products2.asp" because "name" is now being used in products.asp for SEO
ForProductList = (CleanRequest("cmd") = "list" Or (GetScriptName = "products2.asp" And CleanRequestQueryString("name") <> ""))
End Function
' (SS,18/5/09)
Function GetProductName(AProductCode)
' (SS,26/7/11) added HTMLEncode
GetProductName = HTMLEncode(GetFieldForProduct(AProductCode, "ProductName"))
End Function
' (SS,13/1/11) added to return without encoding for plain text emails because & gets encoded as &
Function GetProductNameNoHTMLEncode(AProductCode)
GetProductNameNoHTMLEncode = GetFieldForProduct(AProductCode, "ProductName")
End Function
' (SS,4/11/20) ProductName is returned without HTMLEncode unlike GetProductName which applies HTMLEncode
Function GetProductNameForProductID(AProductID)
Dim Result
Result = GetFieldForProductID(AProductID, "ProductName")
'If IsNull(LResult) Then LResult = ""
GetProductNameForProductID = Result
End Function
' (SS,1/12/16)
Function GetDeliveryWillCollect
GetDeliveryWillCollect = AllowCollection And Session("DeliveryWillCollect")
End Function
' (SS,31/3/17)
Function GetDeliveryAddToExistingOrder
GetDeliveryAddToExistingOrder = Session("DeliveryAddToExistingOrder")
End Function
' (SS,3/5/19) allow setting of DeliveryAddToExistingOrder to True or False
Sub SetDeliveryAddToExistingOrder(AValue)
Session("DeliveryAddToExistingOrder") = AValue
End Sub
' (SS,3/5/19) code moved here from Sub CheckOut
' To add special message when customer ticks "Don't charge delivery, add to existing order"
' Separated into two routines, one to add another to remove
' This routine adds the message if it doesn't already exist
Sub AddToExistingOrderAddMessage
Dim LMessage
LMessage = Session("Message")
If InStr(LMessage, ADD_TO_PREVIOUS_ORDER_TEXT) = 0 Then
LMessage = ADD_TO_PREVIOUS_ORDER_TEXT & " " & LMessage
End if
Session("Message") = Trim(LMessage)
End Sub
' (SS,3/5/19) removes the ADD_TO_PREVIOUS_ORDER_TEXT which might be added by AddToExistingOrderAddMessage above
' this is called when user unticks the "Don't charge delivery, add to existing order" box or doesn't have a valid outstanding order
Sub AddToExistingOrderRemoveMessage
Session("Message") = Trim(ReplaceStr(Session("Message"), ADD_TO_PREVIOUS_ORDER_TEXT, ""))
End Sub
' (SS,2/10/17) returns true if customer has an existing non-completed order (awaiting payment, payment received or payment on account, excluding current order about to be placed)
Function CustomerHasExistingOrder(AEmail)
Dim LSQL, LOrderNo
LSQL = "SELECT OrderNo FROM orders WHERE EmailAddress = '" & CleanSQLStr(AEmail) & "' AND (Status = '" & AWAITING_PAYMENT_STATUS & "' OR Status = '" & PAYMENT_RECEIVED_STATUS & "' OR Status = '" & PAYMENT_ON_ACCOUNT_STATUS & "')"
LOrderNo = GetOrderNo
' (SS,26/9/19) fixed bug which was preventing customer from adding to existing order in same session due to previous order no being retained until next one is created
' i.e. replaced LOrderNo <> "" with OrderNoCanBeReused(LOrderNo)
If OrderNoCanBeReused(LOrderNo) Then LSQL = LSQL & " AND OrderNo <> '" & CleanSQLStr(LOrderNo) & "'"
CustomerHasExistingOrder = GetSQLRecordExists(LSQL)
End Function
' (SS,11/2/05) added AGroup, modified to include GroupName field '
Sub OpenCategoriesQuery(AGroup)
Dim LSQl
LSQL = "SELECT categories.GroupName, productcategories.Category, categories.Description" &_
" FROM productcategories" &_
" INNER JOIN categories ON categories.Category = productcategories.Category" &_
" INNER JOIN groups ON groups.GroupName = categories.GroupName"
If AGroup <> "" Then
LSQL = LSQL & " WHERE categories.GroupName = '" & CleanSQLStr(AGroup) & "'"
End If
LSQL = LSQL &_
" GROUP BY Category" &_
" ORDER BY groups.SortOrder, categories.GroupName, categories.SortOrder, productcategories.Category"
OpenQuery(LSQL)
End Sub
Sub OpenSubcategoriesQuery(ACategory)
OpenQuery("SELECT productcategories.Subcategory" &_
" FROM productcategories" &_
" INNER JOIN subcategories ON subcategories.Category = productcategories.Category AND subcategories.Subcategory = productcategories.Subcategory" &_
" WHERE productcategories.Category = '" & CleanSQLStr(ACategory) & "'" &_
" GROUP BY Subcategory" &_
" ORDER BY subcategories.SortOrder, productcategories.Subcategory")
End Sub
' (SS,11/2/05) added GroupName feature
' (SS,16/3/12) removed references to ProductListCategorySuffix, field has now been dropped from groups table, routine probably isn't used anymore
' (SS,15/2/13) complete rewrite, now used as sitemap, renamed from ShowFullList to ShowHTMLSiteMap, parameters ACategory, ASubcategory also removed
' (SS,19/2/13) improvements and made into function to return the HTML as a string, renamed to GetHTMLSiteMap
' (SS,20/2/13) speed improvement by using just the one query
' (SS,21/2/13) added group
Function GetHTMLSiteMap
'OpenQuery(GetCategoryMenuSQL(""))
' (SS,20/2/13) replaced above with following, to use one query for extra speed
' (SS,21/2/13) added Group
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
Dim LSQL
LSQL = "SELECT categories.GroupName, productcategories.Category, productcategories.Subcategory, categories.MenuShortName AS CategoryMenuShortName, subcategories.MenuShortName AS SubcategoryMenuShortName," &_
" products.ProductCode, products.ProductName" &_
" FROM productcategories" &_
" INNER JOIN categories ON categories.Category = productcategories.Category" &_
" INNER JOIN groups ON groups.GroupName = categories.GroupName" &_
" INNER JOIN subcategories ON subcategories.Category = productcategories.Category AND subcategories.Subcategory = productcategories.Subcategory" &_
" INNER JOIN products ON products.ProductCode = productcategories.ProductCode" &_
" WHERE products.ProductDisabled = FALSE" & GetProductsFilter &_
" GROUP BY GroupName, Category, Subcategory, ProductCode" &_
" ORDER BY groups.SortOrder, groups.GroupName, categories.SortOrder, productcategories.Category, subcategories.SortOrder, productcategories.Subcategory, products.SortOrder, products.ProductName, products.ProductCode"
OpenQuery(LSQL)
Dim LHTML
LHTML = ShowSitemapHeader
Dim LGroup, LPrevGroup, LCat, LPrevCat, LSubcat, LPrevSubcat, LCategoryMenuShortName, LSubcategoryMenuShortName
LPrevGroup = ""
LPrevCat = ""
LPrevSubcat = ""
Dim LCount
LCount = 0
LGroup = GetQueryValue("GroupName")
LCat = GetQueryValue("Category")
LSubcat = GetQueryValue("Subcategory")
LCategoryMenuShortName = NB(GetQueryValue("CategoryMenuShortName"))
LSubcategoryMenuShortName = NB(GetQueryValue("SubcategoryMenuShortName"))
Do While Not EndOfQuery
If GroupsEnabled And LGroup <> LPrevGroup Then
LHTML = LHTML & ShowSitemapGroupHeader
LHTML = LHTML & ShowSitemapGroup(LGroup, GetGroupLink(LGroup))
End If
If LCat <> LPrevCat Then
LHTML = LHTML & ShowSitemapCategoryHeader
LHTML = LHTML & ShowSitemapCategory(Iif(LCategoryMenuShortName = "", LCat, LCategoryMenuShortName), GetCategoryLink(LCat))
End If
If (LSubcat <> LPrevSubcat) Or (LCat <> LPrevCat) Then
LHTML = LHTML & ShowSitemapSubcategoryHeader
LHTML = LHTML & ShowSitemapSubcategory(Iif(LSubcategoryMenuShortName = "", LSubcat, LSubcategoryMenuShortName), GetSubCategoryLink(LCat, LSubcat))
LHTML = LHTML & ShowSitemapProductHeader ' (SS,20/2/13)
End If
LHTML = LHTML & ShowSitemapProduct(GetQueryValue("ProductCode"), HTMLEncode(GetQueryValue("ProductName")), GetProductLinkWithName(GetQueryValue("ProductCode"), GetQueryValue("ProductName")))
LPrevGroup = LGroup
LPrevCat = LCat
LPrevSubcat = LSubcat
LCount = LCount + 1
NextQueryRecord
If EndOfQuery Then
LHTML = LHTML & ShowSitemapProductFooter ' (SS,20/2/13)
LHTML = LHTML & ShowSitemapSubcategoryFooter
LHTML = LHTML & ShowSitemapCategoryFooter
If GroupsEnabled Then LHTML = LHTML & ShowSitemapGroupFooter ' (SS,21/2/13)
Else
LGroup = GetQueryValue("GroupName")
LCat = GetQueryValue("Category")
LSubcat = GetQueryValue("Subcategory")
LCategoryMenuShortName = NB(GetQueryValue("CategoryMenuShortName"))
LSubcategoryMenuShortName = NB(GetQueryValue("SubcategoryMenuShortName"))
If (LSubcat <> LPrevSubcat) Or (LCat <> LPrevCat) Then
LHTML = LHTML & ShowSitemapProductFooter ' (SS,20/2/13)
LHTML = LHTML & ShowSitemapSubcategoryFooter
End If
If LCat <> LPrevCat Then LHTML = LHTML & ShowSitemapCategoryFooter
If GroupsEnabled And LGroup <> LPrevGroup Then LHTML = LHTML & ShowSitemapGroupFooter ' (SS,21/2/13)
End If
Loop
CloseQuery
LHTML = LHTML & ShowSitemapFooter
GetHTMLSiteMap = LHTML
End Function
' (SS,11/2/05) added AGroup '
Sub ShowCategories(AGroup)
Dim LCount, LColumn, LCategory, LCategoryDescription, LIsColStartItem, LIsColEndItem
ShowCategoryListHeader
OpenCategoriesQuery AGroup ' (SS,11/2/05) added AGroup
LCount = 0
LColumn = 0
' (SS,17/2/05) added Sorry message if no categories '
If EndOfQuery Then
ShowMessage(tr("Sorry, no products currently available") & ".")
Else
Do While Not EndOfQuery
LCount = LCount + 1
LIsColStartItem = (LColumn = 0)
LIsColEndItem = (LColumn = (MAX_CATEGORY_LIST_COLUMNS - 1))
If LIsColStartItem Then
ShowCategoryListStartRow ' start new table row '
If LCount > 1 Then ShowCategoryLineSeparator
End If
LCategory = GetQueryValue("Category")
LCategoryDescription = GetQueryValue("Description")
If PictureExists("C", LCategory, "") Then
ShowCategoryListItemWithPicture LCategory, LCategoryDescription, LIsColStartItem, LIsColEndItem
Else
ShowCategoryListItem LCategory, LCategoryDescription, LIsColStartItem, LIsColEndItem
End If
NextQueryRecord
If LIsColEndItem Then
LColumn = 0
ShowCategoryListEndRow ' end the table row '
Else
LColumn = LColumn + 1
End If
Loop
End If
CloseQuery
If LColumn > 0 Then
' complete the missing columns across '
ShowCategoryListMissingColumns MAX_CATEGORY_LIST_COLUMNS - LColumn
ShowCategoryListEndRow ' end the table row '
End If
ShowCategoryListFooter
End Sub
Sub ShowSubcategories(ACategory)
Dim LCategoryDescription, LShowCategoryPicture
OpenQuery("SELECT * FROM categories WHERE Category = '" & CleanSQLStr(ACategory) & "'")
' (SS,16/8/05) added "If Not EndOfQuery" to following to prevent BOF/EOF no current record error
If Not EndOfQuery Then
' (SS,17/5/11) changed from ConvertNewlinesToHTML to ConvertNewlinesEtcToHTML for quotes and pounds to show correctly
' (SS,25/5/11) changed from ConvertNewlinesEtcToHTML to ComposeDescription, to also handle tokens
LCategoryDescription = ComposeDescription(GetQueryValue("Description"), True, False)
Else
LCategoryDescription = ""
End If
CloseQuery
LShowCategoryPicture = PictureExists("C", ACategory, "")
ShowSubcategoryListHeader ACategory, LCategoryDescription, LShowCategoryPicture
Dim LCount, LColumn, LSubcategory, LIsColStartItem, LIsColEndItem
OpenSubcategoriesQuery ACategory
LCount = 0
LColumn = 0
' (SS,17/2/05) added Sorry message if no subcategories '
If EndOfQuery Then
ShowMessage(tr("Sorry, no products currently available") & ".")
Else
Do While Not EndOfQuery
LCount = LCount + 1
LIsColStartItem = (LColumn = 0)
LIsColEndItem = (LColumn = (MAX_SUBCATEGORY_LIST_COLUMNS - 1))
If LIsColStartItem Then
ShowSubcategoryListStartRow ' start new table row '
If LCount > 1 Then ShowSubcategoryLineSeparator
End If
LSubcategory = GetQueryValue("Subcategory")
If PictureExists("S", ACategory, LSubcategory) Then
ShowSubcategoryListItemWithPicture ACategory, LSubcategory, LIsColStartItem, LIsColEndItem
Else
ShowSubcategoryListItem ACategory, LSubcategory, LIsColStartItem, LIsColEndItem
End If
NextQueryRecord
If LIsColEndItem Then
LColumn = 0
ShowSubcategoryListEndRow ' end the table row '
Else
LColumn = LColumn + 1
End If
Loop
End If
CloseQuery
If LColumn > 0 Then
' complete the missing columns across '
ShowSubcategoryListMissingColumns MAX_SUBCATEGORY_LIST_COLUMNS - LColumn
ShowSubcategoryListEndRow ' end the table row '
End If
ShowSubcategoryListFooter
End Sub
' (SS,11/2/05) added GroupName '
' (SS,27/3/07) added AGroup parameter
' (SS,1/7/11) added AAttributeID, AMin, AMax parameters to search for given attribute between min and max values
' (SS,27/7/11) renamed ShowProductListJumpFooter.. routines to ShowProductListNav.., also changed to use divs etc.
' (SS,14/3/12) added AVal parameter to use with attribute search for single value rather than min max
' (SS,3/11/15) minor change to navigation to sort issue
Sub ShowProducts(AGroup, ACategory, ASubcategory, ASearchFor, APage, AAttributeID, AMin, AMax, AVal)
' determine how many products to show across and per page using client width and height '
Dim LProductsAcross, LProductsDown, LProductsPage, LTableCellWidthPercentage
LProductsAcross = PRODUCTS_ACROSS
LProductsDown = PRODUCTS_DOWN
'Response.Write "### 1. REACHED HERE ###" & BR
' (SS,12/5/11) added If GetProductsPerPageFixed to force fixed products per page, old code in Else section
If GetProductsPerPageFixed Then
LProductsAcross = Max(1, GetProductsAcrossMax)
LProductsDown = Max(1, GetProductsDownMax)
Else
If strClientWidth <> "" And strClientHeight <> "" Then
LProductsAcross = (CInt(strClientWidth) - HORIZONTAL_SPACE_TO_IGNORE) \ HORIZONTAL_SPACE_PRODUCT
LProductsDown = (CInt(strClientHeight) - VERTICAL_SPACE_TO_IGNORE) \ VERTICAL_SPACE_PRODUCT
If LProductsAcross < MIN_PRODUCTS_ACROSS Then LProductsAcross = MIN_PRODUCTS_ACROSS
If LProductsDown < MIN_PRODUCTS_DOWN Then LProductsDown = MIN_PRODUCTS_DOWN
' (SS,7/7/06) set maximum no of products across '
If GetProductsAcrossMax > 0 Then LProductsAcross = GetProductsAcrossMax
' (SS,27/3/07) set maximum no of producsts down '
If GetProductsDownMax > 0 Then LProductsDown = GetProductsDownMax
End If
End If
LProductsPage = LProductsAcross * LProductsDown
LTableCellWidthPercentage = 100 \ LProductsAcross
' (SS,19/7/17) added following to prevent navigation being shown on home page where new products are listed (for HF)
Dim LNewProductList
LNewProductList = ASearchFor = NEW_PRODUCTS_SEARCH_TEXT
If LNewProductList And AMax <> "" Then LProductsPage = AMax
Dim LSQL, LIsSearch, LIsSpecialOffer, LSummaryList, LProductsFound
' (SS,16/1/13) SQL building code moved to GetProductSearchSQL, parameters LIsSearch, LIsSpecialOffer, LSummaryList are modified by this routine, if first parameter is False then don't search description
' the reason for doing this was because Galleon now have links to products in their description and searching for a specific product code is finding two many products
' resolved this by not doing an initial search on the description, if this returns nothing then another search is done which includes the description
If ProductSearchWithoutDescFirst And AAttributeID = "" And IsNormalSearch(ASearchFor, AGroup, ACategory, ASubcategory) Then
' (SS,27/10/20) added False for new last parameter ADisabledProductsOnly
LSQL = GetProductSearchSQL(False, AGroup, ACategory, ASubcategory, ASearchFor, APage, AAttributeID, AMin, AMax, AVal, LIsSearch, LIsSpecialOffer, LSummaryList, LProductsFound, False)
Else
LProductsFound = 0
End If
If LProductsFound = 0 Then
' (SS,27/10/20) added False for new last parameter ADisabledProductsOnly
LSQL = GetProductSearchSQL(True, AGroup, ACategory, ASubcategory, ASearchFor, APage, AAttributeID, AMin, AMax, AVal, LIsSearch, LIsSpecialOffer, LSummaryList, LProductsFound, False)
If LProductsFound = 0 And ACategory <> "" Then
If IsSpecialCategory(ACategory) Then
' Response.Write "### 2. REACHED HERE ###" & BR & LSQL & BR
' (SS,27/10/20) call again to get special disabled products
LSQL = GetProductSearchSQL(True, AGroup, ACategory, ASubcategory, ASearchFor, APage, AAttributeID, AMin, AMax, AVal, LIsSearch, LIsSpecialOffer, LSummaryList, LProductsFound, True)
End If
End If
End If
Dim LProductCode, LFoundText, LColumn, LStartRecordNo, LCurrentPage
' if only one product found then show it straightaway only if category not selected '
' (SS,27/3/07) added AGroup = ""
If LProductsFound = 1 And AGroup = "" And ACategory = "" And ASubcategory = "" Then
OpenQuery("SELECT DISTINCT products.* " + LSQL)
LProductCode = GetFieldValue("ProductCode")
CloseQuery
SingleProductRedirect LProductCode ' (SS,12/9/12) replaced ShowSingleProduct with SingleProductRedirect
Exit Sub
End If
If APage = "" Or APage = "0" Then
LCurrentPage = 1
Else
LCurrentPage = ParseInt(APage) ' (SS,13/6/12) replaced CInt with ParseInt, to better handle SQL injection
If LCurrentPage = 0 Then LCurrentPage = 1 ' (SS,13/6/12) because ParseInt will return 0 if APage isn't a valid integer
End If
LStartRecordNo = (LCurrentPage - 1) * LProductsPage ' assumes first record is 0 '
' if page no is greater than the range then recalculate the current page and record no '
If LStartRecordNo >= LProductsFound Then
LCurrentPage = ((LProductsFound - 1) \ LProductsPage) + 1
LStartRecordNo = (LCurrentPage - 1) * LProductsPage ' assumes first record is 0 '
End If
' (SS,18/3/10) added trl, translation table may contain leading uppercase for Product(s) so trl used instead of tr
LFoundText = PluralString(LProductsFound, trl("product"), trl("products"))
' actual query which selects the records
' (SS,11/2/05) added GroupName
' (SS,27/3/07) added productcategories.Category, productcategories.Subcategory (for new summary list)
' (SS,27/3/07) discovered than these affect DISTINCT and can cause same product to appear more than once
' if in more than one category, changed so that category, subcategory and group and only fetched for summary list
' Limit not applied for summary list
Dim LSQL2
' (SS,15/5/07) added ProductDescription, Price2, Price3, Price4, Discount, VATBand
' (SS,21/5/07) replaced StdPrice, SalePrice, Price2, Price3, Price4, Discount, VATBand with GetPricingFieldsForSQL("")
' (SS,26/5/07) added Dimensions
' (SS,26/5/10) added DateStockDue
' (SS,23/6/10) added the 4 availability from/to fields
' (SS,6/7/11) added products.ProductID
LSQL2 = "SELECT DISTINCT products.ProductID, products.ProductCode, ProductName, ProductDescription, Dimensions, " + GetPricingFieldsForSQL("") + ", NumInStock, DateStockDue, New " &_
", " & GetStockAvailabilityFieldList & " " &_
IIf(LSummaryList, ", GroupName, productcategories.Category, productcategories.Subcategory ", "") &_
LSQL &_
IIf(LSummaryList, "", " LIMIT " & LStartRecordNo & ", " & LProductsPage)
OpenQuery(LSQL2)
' (SS,12/10/15) because we're looking up whether cat subcat desc/footer exist before showing products don't exist message
Dim LCatSubcatDesc, LCatSubcatFooter
LCatSubcatDesc = ""
LCatSubcatFooter = ""
' (SS,27/3/07) added AGroup, ASubcategory
If AGroup = "" And ACategory = "" And ASubcategory = "" Then
' (SS,24/1/12) if AAttributeID = "" so that products found count not shown if searching for attribute
' (SS,19/7/17) added And Not LNewProductList
If AAttributeID = "" And Not LNewProductList Then
ShowProductListHeaderForSearch LFoundText, HTMLEncode(ASearchFor), LProductsFound = 0 ' (SS,24/8/17) added HTMLEncode to prevent XSS injection
End If
Else
' (SS,12/10/15) moved here from below, also LCategoryDescription renamed to LCatSubcatDesc, also merged with footer code
If Not LSummaryList Then
' (SS,10/1/13) Added LCategoryDescription to show description from category record, only at category level, for subcategory level we fetch as before
If ACategory <> "" And ASubcategory = "" Then
LCatSubcatDesc = ComposeDescription(GetFieldForCategory(ACategory, "Description"), False, False)
LCatSubcatFooter = ComposeDescription(GetFieldForCategory(ACategory, "Footer"), False, False) ' (SS,12/10/15) moved here from footer
Else
' (SS,25/5/11) replaced old code with call to ComposeDescription, which also handles tokens
' (SS,10/1/13) modified to call GetFieldForSubcategory instead of GetSubcategoryDescription
' added "Description" for fieldname parameter and and changed first True to False so that newlines stay as they are
LCatSubcatDesc = ComposeDescription(GetFieldForSubcategory(ACategory, ASubcategory, "Description"), False, False)
LCatSubcatFooter = ComposeDescription(GetFieldForSubcategory(ACategory, ASubcategory, "Footer"), False, False) ' (SS,12/10/15) moved here from footer
End If
End If
' (SS,17/2/05) added following to fix bug where GetQueryValue("GroupName") was causing BOF error when all products disabled for category '
If EndOfQuery Then
' (SS,12/10/15) added if, to only show this message and exit if not ShowCategoryHeadingFooterIfEmpty or cat/subcat desc is blank
If Not ShowCategoryHeadingFooterIfEmpty Or (LCatSubcatDesc + LCatSubcatFooter = "") Then
ShowMessage(tr("Sorry, no products currently available in this category") & ".")
CloseQuery
Exit Sub
End If
End If
' (SS,11/2/05) added GroupName '
' (SS,27/3/07) added If Not LSummaryList
If Not LSummaryList Then
' (SS,11/1/13) added following to lookup category and subcategory heading, or create it from AGroup, ACategory and ASubcategory
Dim LHeading
If ASubcategory <> "" Then
LHeading = HTMLEncode(GetFieldForSubcategory(ACategory, ASubcategory, "Heading"))
If LHeading = "" Then LHeading = HTMLEncode(GetShortNameForCategory(ACategory)) + " ‐ " + HTMLEncode(GetShortNameForSubcategory(ACategory, ASubcategory))
ElseIf ACategory <> "" Then
LHeading = HTMLEncode(GetFieldForCategory(ACategory, "Heading"))
If LHeading = "" Then LHeading = HTMLEncode(GetShortNameForCategory(ACategory))
Else
LHeading = HTMLEncode(AGroup)
End If
' (SS,27/3/07) replaced GetQueryValue("GroupName") in following with AGroup
' (SS,10/1/13) replaced ACategory with LCategoryHeading and ASubcategory with LSubcategoryHeading
' (SS,11/1/13) replaced AGroup, LCategoryHeading, LSubcategoryHeading with LHeading
ShowProductListHeaderForCategory LHeading
' (SS,12/10/15) setting code moved above, renamed LCatSubcatDesc, also renamed LCategoryDescription to LCatSubcatDesc
ShowProductListHeaderForSubcategory(LCatSubcatDesc) ' (SS,25/5/11) moved setting code above so that either category or subcategory description can be shown
End If
End If
' also added If LProductsFound > 0 to only do the following if products found
If LProductsFound > 0 Then
' (SS,11/8/15) added following to show navigation at top of page for RWD
'If IsRWD And (Not LSummaryList And LProductsFound > LProductsPage) Then
' (SS,19/7/17) added And Not LNewProductList to also not show navigation for new product list (shown on home page)
If IsRWD And Not LSummaryList And Not LNewProductList Then
ShowProductListNavigation LCurrentPage, LProductsFound, LProductsPage, LStartRecordNo
End If
' (SS,27/3/07) added If LSummaryList Then ShowProductSummaryListHeader
If LSummaryList Then
ShowProductSummaryListHeader
Dim LShowLarge, LWidth, LHeight
Else
' (SS,19/7/17) different header for new product list
If LNewProductList Then
ShowProductListHeaderNewProducts
Else
ShowProductListHeader
End If
End If
LColumn = 0
Dim LClassSuffix
Dim LStdPrice, LSalePrice
' (SS,16/1/13) moved here from above
Dim LGroup, LCategory, LSubcategory, LProductName, LProductCount
' (SS,27/3/07) added following for summary list
Dim LPrevCategory, LPrevSubcategory
LPrevCategory = ""
LPrevSubcategory = ""
LProductCount = 0
' (SS,27/3/07) added (LSummaryList Or) to list all if summary list
Do While Not EndOfQuery And (LSummaryList Or LProductCount < LProductsPage)
LProductCount = LProductCount + 1
' (SS,18/5/07) added following to allow templates to determine whether at first or last records
SetAtFirstOrLastProduct LProductCount, LProductsFound
' (SS,27/3/07) added If Not LSummaryList
If Not LSummaryList Then
If LColumn = 0 then ShowProductListStartRow ' start new table row '
End If
' (SS,18/5/07)
' (SS,6/7/11) removed 0 parameter, added False, no need to look up options price
GetPricingFromProductRecord(False)
LProductCode = GetFieldValue("ProductCode")
LStdPrice = GetStdPrice
LSalePrice = GetSalePrice
' (SS,19/9/06)
LStdPrice = CorrectCurrencyNV(LStdPrice)
LSalePrice = CorrectCurrencyNV(LSalePrice)
' (SS,21/5/07) added following to pass description and dimensions to inc-template-product-list
SetProductDescription(GetFieldValue("ProductDescription"))
SetProductDimensions(GetFieldValue("Dimensions"))
' (SS,23/6/10) must be before SetStockInfo because SetStockInfo might use the result of SetStockAvailability
SetStockAvailabilityFromFields
' (SS,26/5/10)
SetStockInfo GetFieldValue("NumInStock"), GetFieldValue("DateStockDue")
' (SS,19/2/05) added LIsSearch, LIsSpecialOffer, LGroup, LCategory, LSubcategory '
' (SS,27/3/07) added If LSummaryList Then code for new summary list
LProductName = HTMLEncode(GetFieldValue("ProductName")) ' (SS,26/7/11)
If LSummaryList Then
LCategory = GetFieldValue("Category")
LSubcategory = GetFieldValue("Subcategory")
If LCategory <> LPrevCategory Then ShowProductSummaryListCategory(LCategory)
If LSubcategory <> LPrevSubcategory Then ShowProductSummaryListSubcategory LCategory, LSubcategory
' (SS,8/8/18) commented out following, now redundant, not used since RWD framework, LWidth, LHeight will have undefined values when passed to ShowProductSummaryListItem
' GetProductPictureSize LProductCode, LWidth, LHeight ' (SS,17/4/07)
' (SS,15/5/07) added GetFieldValue("ProductDescription")
' (SS,21/5/07) removed GetFieldValue("ProductDescription") added SetProductDescription above to pass the parameter instead
' (SS,26/7/11) replaced GetFieldValue("ProductName") with LProductName, which has now been HTMLEncoded above
ShowProductSummaryListItem LProductCode, LProductName, LSalePrice, LStdPrice, GetFieldValue("NumInStock"), GetFieldValue("New") <> 0, LIsSearch, LIsSpecialOffer, LGroup, LCategory, LSubcategory, LWidth, LHeight
LPrevCategory = LCategory
LPrevSubcategory = LSubcategory
Else
' (SS,19/2/05) added following to get Group and Category for product '
GetFirstCatSubcatForProduct LProductCode, LGroup, LCategory, LSubcategory
' (SS,15/5/07) added GetFieldValue("ProductDescription")
' (SS,21/5/07) removed GetFieldValue("ProductDescription") added SetProductDescription above to pass the parameter instead
' (SS,26/7/11) replaced GetFieldValue("ProductName") with LProductName, which has now been HTMLEncoded above
ShowProductListItem LTableCellWidthPercentage, LProductCode, LProductName, LSalePrice, LStdPrice, GetFieldValue("NumInStock"), GetFieldValue("New") <> 0, LIsSearch, LIsSpecialOffer, LGroup, LCategory, LSubcategory
End If
NextQueryRecord
' (SS,27/3/07) added If Not LSummaryList
If Not LSummaryList Then
LColumn = LColumn + 1
If LColumn = LProductsAcross Then
LColumn = 0
ShowProductListEndRow ' end the table row '
End If
End If
Loop
If Not LSummaryList And LColumn > 0 Then ' (SS,27/3/07) added Not LSummaryList And
' complete the missing columns across
ShowProductListMissingColumns LProductsAcross - LColumn
ShowProductListEndRow ' end the table row '
End If
' (SS,12/10/15) footer code moved from here to below
' if there are more products than allowed per page then show the jump to footer '
' (SS,27/3/07) added Not LSummaryList And
' (SS,27/7/11) major change to use divs, routines were also renamed
' (SS,3/11/15) moved code below
End If ' If LProductsFound > 0 Then
' (SS,27/3/07) added If LSummaryList Then ShowProductSummaryListFooter
' (SS,12/10/15) moved following code here from inside "if" above to allow category/subcategory footer to be shown if not products
If LSummaryList Then
ShowProductSummaryListFooter
Else
' (SS,19/7/17) separate footer for new product list
If LNewProductList Then
ShowProductListFooterNewProducts
Else
' (SS,12/10/15) moved setting of LCategoryFooter above, renamed LCategoryFooter to LCatSubcatFooter
ShowProductListFooter LCatSubcatFooter ' (SS,10/1/13) added LCategoryFooter
End If
End If
' (SS,3/11/15) moved following here from end of "If LProductsFound > 0 Then" above. Was causing bottom nav to appear below first one due to isotope grid tidy,
' also breaking HTML. Moving here solved the problem.
' (SS,19/7/17) added And Not LNewProductList to also not show navigation for new product list (shown on home page)
If Not LSummaryList And LProductsFound > LProductsPage And Not LNewProductList Then
ShowProductListNavigation LCurrentPage, LProductsFound, LProductsPage, LStartRecordNo
End If
CloseQuery
SaveSettingsForContinue
AddSearchToLog
End Sub
' (SS,16/1/13) separated the SQL building code from ShowProducts above, it can now be called twice from ShowProducts
' it has the same parameters as ShowProducts, plus addition 3 used to passback values AIsSearch, AIsSpecialOffer, ASummaryList, AProductsFound
' new parameter ASearchDesc can be false to prevent searching in description
' (SS,13/8/15) modified to override order if sort by specified
' (SS,15/10/15) modified to allow a specific list of product IDs to be shown when AAttributeID is -1, and comma separated product ID list is in AVal
' (SS,24/1/16) added filter for max and min price i.e. maxprice=30&minprice=10
' (SS,30/6/17) change to full text search to order by relevance if no sort field set
' (SS,19/7/17) change for NEW_PRODUCTS_SEARCH_TEXT to filter out products that don't have images and are out of stock
' (SS,27/10/20) added new parameter ADisabledProductsOnly", normally false, when True it will only special disabled products e.g. case studies for GSC
Function GetProductSearchSQL(ASearchDesc, AGroup, ACategory, ASubcategory, ASearchFor, APage, AAttributeID, AMin, AMax, AVal, ByRef AIsSearch, ByRef AIsSpecialOffer, ByRef ASummaryList, ByRef AProductsFound, ADisabledProductsOnly)
Dim LSQL, LWhere, LOrderBy ' (SS,1/7/11) added LWhere
LSQL = "FROM products "
LSQL = LSQL + "LEFT JOIN productcategories ON products.ProductCode = productcategories.ProductCode "
LSQL = LSQL + "LEFT JOIN categories ON categories.Category = productcategories.Category "
' (SS,27/3/07) added following to get subcategory sort order
' LSQL = LSQL + "LEFT JOIN subcategories ON subcategories.Subcategory = productcategories.Subcategory "
' (SS,3/6/10) replaced above with following because it wasn't matching using category name,
' and causing it to match wrong subcategory sometimes if another subcategory with same name but different category exists
' Tim of Galleon, mentioned that subcategories on the left were in a different order to products shown
LSQL = LSQL + "LEFT JOIN subcategories ON subcategories.Category = productcategories.Category AND subcategories.Subcategory = productcategories.Subcategory "
' (SS,22/6/10) added following to lookup stock availability from suppliers table
LSQL = LSQL + "LEFT JOIN suppliers ON suppliers.SupplierID = products.SupplierID " ' (SS,21/6/10) to lookup for stock availability from new suppliers table
' (SS,1/7/11) modified to store in LWhere instead of adding to LSQL, allow attribute join to be added later
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
' LWhere = "ProductDisabled = 0" + GetProductsFilter
' (SS,27/10/20) replaced above with following for new ADisabledProductsOnly parameter
If ADisabledProductsOnly Then
LWhere = "ProductDisabled = TRUE"
Else ' as before but FALSE used instead of 0, works exactly the same
LWhere = "ProductDisabled = FALSE"
End If
LWhere = LWhere + GetProductsFilter
' if category and subcategory chosen then order by SortOrder First (SS,4/6/04) '
' (SS,27/3/07) added productcategories.Category and Subcategory sort order, changed the If to LSummaryList
' (SS,27/3/07) also added productcategories.Category and subcategories.Subcategory in case SortOrder is the same for all
' (SS,4/6/07) sort order is now the same for both, removed " ORDER BY ProductName" when not LSummaryList
' (SS,7/6/11) moved here from below, now the default orderby which can be overriden
LOrderBy = "categories.SortOrder, productcategories.Category, subcategories.SortOrder, subcategories.Subcategory, products.SortOrder, ProductName"
' (SS,13/3/15) added following to override normal sort order if sort order specified
Dim LSortByField
LSortByField = GetSortByField
If LSortByField <> "" Then LOrderBy = LSortByField + ", " + LOrderBy
' (SS,19/2/04) '
AIsSearch = False
AIsSpecialOffer = False
ASummaryList = False ' (SS,27/3/07)
' (SS,19/5/04) added special offers search '
' (SS,1/7/11) changed LSQL to LWhere
If LCase(ASearchFor) = SPECIAL_OFFERS_SEARCH_TEXT Then
' (SS,18/5/07) added FUseDiscountFieldForSpecialOffers etc to use new Discount field for special offers
If FUseDiscountFieldForSpecialOffers Then
LWhere = LWhere + " AND IFNULL(Discount, 0) > 0"
Else
LWhere = LWhere + " AND NOT ISNULL(SalePrice)"
End If
AIsSpecialOffer = True ' (SS,19/2/04) '
' (SS,18/1/13) added new products search
ElseIf LCase(ASearchFor) = NEW_PRODUCTS_SEARCH_TEXT Then
' LWhere = LWhere + " AND products.DateAdded IS NOT NULL"
' (SS,18/7/17) replaced above with following to include only those in stock or out of stock ordering allowed
LWhere = LWhere + " AND products.DateAdded IS NOT NULL AND (ISNULL(NumInStock) OR NumInStock > 0 OR AllowOutOfStockOrdering)"
' (SS,18/7/17) added following to include only those that have pictures
LWhere = LWhere + " AND EXISTS(SELECT PictureID FROM pictures WHERE Type = 'P' AND Code = products.ProductCode AND Enabled)"
LOrderBy = "products.DateAdded DESC, products.SortOrder"
ElseIf IsNormalSearch(ASearchFor, AGroup, ACategory, ASubcategory) Then ' (SS,27/3/07) replaced ACategory = "" with ASearchFor <> "" also added Or AGroup, ACat.. & ASubcat.., (SS,16/1/13) now uses IsNormalSearch
AIsSearch = True ' (SS,19/2/04) '
' (SS,2/11/06) added following to trim the leading and trailing spaces
Dim LSearchFor
LSearchFor = Trim(ASearchFor)
' (SS,1/7/11) added "if" to search for attribute range
' (SS,14/3/12) added Or AVal <> ""
If LSearchFor = "" And AAttributeID <> "" And ((AMin <> "" And AMax <> "") Or AVal <> "") Then
' (SS,15/10/15) added special case where AAttributeID = "-1" to only show specified products
If AAttributeID = "-1" Then
LWhere = LWhere + " AND INSTR('," & CleanSQLStr(AVal) & ",', CONCAT(',', products.ProductID, ',')) > 0"
LOrderBy = "categories.SortOrder, subcategories.SortOrder, products.SortOrder"
Else
LSQL = LSQL + "INNER JOIN product_attributes ON product_attributes.ProductID = products.ProductID "
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LWhere = LWhere + " AND product_attributes.AttributeID = '" & CleanSQLStr(AAttributeID) & "'"
' (SS,14/3/12) added "if" to do search for exact value
If AVal <> "" Then
LWhere = LWhere + " AND AttributeValue = '" & CleanSQLStr(AVal) & "'"
Else ' (SS,14/3/12) as before
' convert to decimal and find all between min and max values
LWhere = LWhere + " AND CONVERT(AttributeValue, DECIMAL(10, 2)) BETWEEN '" & CleanSQLStr(AMin) & "' AND '" & CleanSQLStr(AMax) & "'"
LOrderBy = "CONVERT(AttributeValue, DECIMAL(10, 2))" ' sort in attribute value order converted to decimal
End If
End If
Else
' (SS,1/6/15) added following for full text search (when not searching description)
If ProductSearchFullText And Not ASearchDesc Then
' assumes full text index exists, created using following
' ALTER TABLE products ADD FULLTEXT KEY idxFTProductCodeAndName (ProductCode, ProductName)
' (SS,30/6/17) added LFullTextClause, used in two places
Dim LFullTextClause
LFullTextClause = "MATCH(products.ProductCode, products.ProductName) AGAINST ('" + CleanSQLStr(AdjustForFullTextSearch(LSearchFor)) + "'" ' NB. without ending bracket
LWhere = LWhere + " AND " + LFullTextClause + " IN BOOLEAN MODE)"
' (SS,13/8/15) improved by selecting IN BOOLEAN MODE if search for contains + or - or * or "
' (SS,26/8/15) natural language mode finds two many matches, so removed
' found that prefixing every word with + worked best in boolean mode, now using just boolean mode, AdjustForFullTextSearch above adjusts the LSearchFor, prefixing each word with "+"
' following code removed
' If InStr(LSearchFor, "+") Or InStr(LSearchFor, "-") Or InStr(LSearchFor, "*") Or InStr(LSearchFor, """") Then
' LWhere = LWhere + "' IN BOOLEAN MODE)"
' Else
' LWhere = LWhere + "' IN NATURAL LANGUAGE MODE)"
' End If
' (SS,13/8/15) replaced "" with LSortByField
LOrderBy = LSortByField
' (SS,30/6/17) if sort by field is blank, i.e. sort by relevance then add order by relevance
If LOrderBy = "" Then
LOrderBy = LFullTextClause + ") DESC"
End If
Else ' (SS,1/6/15) as before
LWhere = LWhere + " AND (ProductName LIKE ""%" & CleanSQLStr(LSearchFor) & "%"" OR productcategories.Category LIKE ""%" & CleanSQLStr(LSearchFor) & "%"" OR subcategories.Subcategory LIKE ""%" & CleanSQLStr(LSearchFor) & "%"""
LWhere = LWhere + " OR products.ProductCode LIKE ""%" & CleanSQLStr(LSearchFor) & "%"""
' (SS,2/11/06) added following two lines to allow searching for product code ignoring the
' dashes and treating dashes as a space, as requested by pneuride
LWhere = LWhere + " OR REPLACE(products.ProductCode, ""-"", """") LIKE ""%" & CleanSQLStr(LSearchFor) & "%"""
LWhere = LWhere + " OR REPLACE(products.ProductCode, ""-"", "" "") LIKE ""%" & CleanSQLStr(LSearchFor) & "%"""
' (SS,16/1/13) added ASearchDesc
If ASearchDesc Then LWhere = LWhere + " OR ProductDescription LIKE ""%" & CleanSQLStr(LSearchFor) & "%"""
LWhere = LWhere + ")"
End If
End If
' (SS,27/3/07) changes to following for individual where for Group, Category and Subcategory
Else
If AGroup <> "" Then
LWhere = LWhere + " AND categories.GroupName = """ + CleanSQLStr(AGroup) + """"
End If
If ACategory <> "" Then
LWhere = LWhere + " AND productcategories.Category = """ + CleanSQLStr(ACategory) + """"
End If
If ASubcategory <> "" Then
LWhere = LWhere + " AND subcategories.Subcategory = """ + CleanSQLStr(ASubcategory) + """"
End If
' (SS,27/3/07) if subcategory is blank and summary list enabled then enable summary list (instead of normal detailed list)
If ASubcategory = "" And SummaryListEnabled Then ASummaryList = True
End If
' (SS,24/11/16) add filter for max price and min price, takes the lowest from StdPrice and SalePrice (Discount field isn't used here, maybe add in future if any site is using it)
Dim LMaxPrice
LMaxPrice = CleanRequestQueryString("maxprice")
If LMaxPrice <> "" Then
If IsNumeric(LMaxPrice) Then
LWhere = LWhere + " AND IF(SalePrice IS NULL, StdPrice, LEAST(StdPrice, SalePrice)) <= " & CleanSQLStr(LMaxPrice)
End If
End If
Dim LMinPrice
LMinPrice = CleanRequestQueryString("minprice")
If LMinPrice <> "" Then
If IsNumeric(LMinPrice) Then
LWhere = LWhere + " AND IF(SalePrice IS NULL, StdPrice, LEAST(StdPrice, SalePrice)) >= " & CleanSQLStr(LMinPrice)
End If
End If
' (SS,1/7/11) add LWhere which was separated, also LOrderBy
LSQL = LSQL + "WHERE " + LWhere
' (SS,1/6/15) added [If LOrderBy <> "" Then] because LOrderBy can now be blank due to full text search
If LOrderBy <> "" Then LSQL = LSQL + " ORDER BY " + LOrderBy
' get count of the amount of products
' (SS,16/1/13) modified to use GetSQLValue, 3 lines (OpenQuery, GetFieldValue, CloseQuery) replaced with just one
AProductsFound = GetSQLValue("SELECT Count(DISTINCT products.ProductCode) As Count " + LSQL)
'Response.Write "#" & LSQL & "#" & BR ' !***
GetProductSearchSQL = LSQL ' (SS,16/1/13)
End Function
' (SS,26/8/15) adjusts for MySQL full text search in boolean mode
' by prefixing each word not already prefixed with "+" or "-" with a "+"
' (SS,17/9/15) if prefixed with "||" then don't prefix each with +, i.e. it'll work as an "or"
Function AdjustForFullTextSearch(ASearchStr)
Dim LWords, LWord, LLeftChr, LResult, LNewWord
LResult = ""
If Left(ASearchStr, 2) = "||" Then
LResult = Mid(ASearchStr, 3) ' remove the leading ||
Else
LWords = Split(ASearchStr, " ")
For Each LWord In LWords
If LWord <> "" Then
LLeftChr = Left(LWord, 1)
If LLeftChr <> "+" And LLeftChr <> "-" Then
LNewWord = "+" + LWord
Else
LNewWord = LWord
End If
LResult = LResult + iif(LResult = "", "", " ") + LNewWord
End If
Next
End If
AdjustForFullTextSearch = LResult
End Function
' (SS,13/8/15)
Function SetSortBy(ASortBy)
If ASortBy <> "" Then
Session("SortBy") = ASortBy
End If
End Function
' (SS,13/8/15)
Function GetSortBy
Dim LResult
LResult = Session("SortBy")
If LResult = "" Then LResult = ProductsSortByDefault
GetSortBy = LResult
End Function
' (SS,13/8/15)
' 1 = Sort by Relevance, existing default search
' 2 = Price High to Low
' 3 = Price Low to High
' 4 = Product Name
Function GetSortByField
Dim LResult
Select Case GetSortBy
Case "2"
LResult = "StdPrice DESC"
Case "3"
LResult = "StdPrice"
Case "4"
LResult = "ProductName"
Case Else
LResult = ""
End Select
GetSortByField = LResult
End Function
' (SS,16/1/13) returns true if doing a normal search, used by GetProductSearchSQL and ShowProducts above
Function IsNormalSearch(ASearchFor, AGroup, ACategory, ASubcategory)
IsNormalSearch = ASearchFor <> "" Or (AGroup = "" And ACategory = "" And ASubcategory = "")
End Function
' (SS,19/10/15)
Sub EnableProductNavigation
FProductNavigationEnabled = True
End Sub
' (SS,19/10/15)
Sub DisableProductNavigation
FProductNavigationEnabled = False
End Sub
' (SS,19/10/15)
Function ProductNavigationEnabled
ProductNavigationEnabled = FProductNavigationEnabled
End Function
' (SS,27/7/11) moved here from ShowProducts
' (SS,11/8/15) calls ShowProductListNavNonRWD
Sub ShowProductListNavigation(ACurrentPageNo, AProductCount, AProductsPerPage, AStartRecordNo)
' (SS,19/10/15) added If ProductNavigationEnabled Then
If ProductNavigationEnabled Then
If IsRWD Then
ShowProductListNavRWD ACurrentPageNo, AProductCount, AProductsPerPage, AStartRecordNo
Else
ShowProductListNavNonRWD ACurrentPageNo, AProductCount, AProductsPerPage, AStartRecordNo
End If
End If
End Sub
' (SS,27/7/11) moved here from ShowProducts
' (SS,11/8/15) renamed from ShowProductListNavigation to ShowProductListNavNonRWD
' original version for backward compatibility called from ShowProductListNavigation above for non-RWD sites
Sub ShowProductListNavNonRWD(ACurrentPageNo, AProductCount, AProductsPerPage, AStartRecordNo)
Dim LPages, i, LRecordNo
LPages = ((AProductCount - 1) \ AProductsPerPage) + 1 ' \ is Div '
ShowProductListNavHeader
If ACurrentPageNo > 1 Then
ShowProductListNavLeft "javascript:itp_page(" & ACurrentPageNo - 1 & ")"
Else
ShowProductListNavLeft ""
End If
' pages are shown in groups of 10 '
Dim LStartPageNo
LStartPageNo = (((ACurrentPageNo - 1) \ PAGES_PER_GROUP) * PAGES_PER_GROUP) + 1 ' \ is Div '
ShowProductListNavMiddleHeader
ShowProductListNavItemsHeader
' if there are pages before this one then show the [...] to allow jump to previous pages
If LStartPageNo > 1 then
ShowProductListNavItem GetProductListNavItem("previous", LStartPageNo - 1, ACurrentPageNo)
End If
For i = LStartPageNo To LStartPageNo + (PAGES_PER_GROUP - 1)
If i > LPages Then Exit For ' if limit of pages reach then exit for loop
ShowProductListNavItem GetProductListNavItem("page", i, ACurrentPageNo)
Next
' if there are more pages then show the [...]
If i < LPages then
ShowProductListNavItem GetProductListNavItem("next", i, ACurrentPageNo)
End If
ShowProductListNavItemsFooter
' (SS,8/5/10) removed "Viewing ", added tr to "of"
' (SS,27/7/11) added tr("Showing")
ShowProductListNavInfo tr("Showing") & " " & (AStartRecordNo + 1) & " - " & (AStartRecordNo + AProductsPerPage) & " " & tr("of") & " " & AProductCount
ShowProductListNavMiddleFooter
If ACurrentPageNo < LPages Then
ShowProductListNavRight "javascript:itp_page(" & ACurrentPageNo + 1 & ")"
Else
ShowProductListNavRight ""
End If
ShowProductListNavFooter
End Sub
' returns product list navigation item, called from ShowProducts above
' (SS,27/7/11) AType can be "page", "previous", "next"
Function GetProductListNavItem(AType, APageNo, ACurrentPageNo)
Dim LClass, LAltTag, LText
LClass = "product-list-nav-item"
LText = "..."
If AType = "previous" Then
LAltTag = "Previous pages"
ElseIf AType = "next" Then
LAltTag = "More pages"
Else ' i.e. page
LText = CStr(APageNo)
LAltTag = "Page " & APageNo
If APageNo = ACurrentPageNo Then LClass = "product-list-nav-item-active"
End If
GetProductListNavItem = "<a class=""" & LClass & """ href=""javascript:itp_page(" & APageNo & ")"" alt=""" & LAltTag & """>" & LText & "</a>"
End Function
' (SS,27/7/11) moved here from ShowProducts
' (SS,11/8/15) renamed from ShowProductListNavigation to ShowProductListNavRWD
' new verison, modified for RWD sites
Sub ShowProductListNavRWD(ACurrentPageNo, AProductCount, AProductsPerPage, AStartRecordNo)
Const PAGES_PER_GROUP = 5
Dim LPages, i, LRecordNo
LPages = ((AProductCount - 1) \ AProductsPerPage) + 1 ' \ is Div '
ShowProductListNavHeader
' pages are shown in groups of 10 '
Dim LStartPageNo
LStartPageNo = (((ACurrentPageNo - 1) \ PAGES_PER_GROUP) * PAGES_PER_GROUP) + 1 ' \ is Div '
' (SS,8/5/10) removed "Viewing ", added tr to "of"
' (SS,27/7/11) added tr("Showing")
' (SS,12/8/15) added Min()
ShowProductListNavInfo tr("Showing") & " " & (AStartRecordNo + 1) & " - " & Min(AStartRecordNo + AProductsPerPage, AProductCount) & " " & tr("of") & " " & AProductCount
' (SS,12/8/15) added If, to only do if there is more than one page because above is routine is now always called
If AProductCount > AProductsPerPage Then
ShowProductListNavItemsHeader
' if there are previous pages
If ACurrentPageNo > 1 Then
ShowProductListNavItem GetProductListNavItemRWD("previous page", ACurrentPageNo - 1, ACurrentPageNo)
End If
' if there are pages before this one then show the [...] to allow jump to previous pages
If LStartPageNo > 1 then
ShowProductListNavItem GetProductListNavItemRWD("previous", LStartPageNo - 1, ACurrentPageNo)
End If
For i = LStartPageNo To LStartPageNo + (PAGES_PER_GROUP - 1)
If i > LPages Then Exit For ' if limit of pages reach then exit for loop
ShowProductListNavItem GetProductListNavItemRWD("page", i, ACurrentPageNo)
Next
' if there are more pages then show the [...]
If i < LPages then
ShowProductListNavItem GetProductListNavItemRWD("next", i, ACurrentPageNo)
End If
' if there are next pages
If ACurrentPageNo < LPages Then
ShowProductListNavItem GetProductListNavItemRWD("next page", ACurrentPageNo + 1, ACurrentPageNo)
End If
ShowProductListNavItemsFooter
End If
ShowProductListNavFooter
End Sub
' returns product list navigation item, called from ShowProducts above
' (SS,27/7/11) AType can be "page", "previous", "next"
' (SS,11/8/15) new version for RWD, added "previous page" and "next page" types
Function GetProductListNavItemRWD(AType, APageNo, ACurrentPageNo)
Dim LClass, LText
LClass = ""
If AType = "page" Then
LText = CStr(APageNo)
If APageNo = ACurrentPageNo Then LClass = " class=""active"""
ElseIf AType = "previous page" Then
LText = "<"
ElseIf AType = "next page" Then
LText = ">"
Else ' i.e. "previous" or "next" (group of pages)
LText = "..."
End If
GetProductListNavItemRWD = "<li" + LClass + "><a href=""javascript:itp_page(" & APageNo & ")"">" & LText & "</a></li>"
End Function
' (SS,26/5/07) added following for routines to allow templates to determine whether at first or last records
Sub SetAtFirstOrLastProduct(ACount, ARecordCount)
FAtFirstProduct = ACount = 1
FAtLastProduct = ACount = ARecordCount
End Sub
Function AtFirstProduct
AtFirstProduct = FAtFirstProduct
End Function
Function AtLastProduct
AtLastProduct = FAtLastProduct
End Function
' added If CleanRequestQueryString("grp")...
' (SS,6/6/07) added Server.HTMLEncode to cat and subcat because cat or subcat name may contain " or other odd characters
' (SS,17/9/08) replaced CleanRequestQueryString("cat") with GetCategory, also added AddStoreURL
' (SS,11/7/11) added "/" just before ending ">" for xml compatibility, also added id="frmSearch" to allow getElementById function to find the form, removed cw, cl
' (SS,20/2/12) replaced "products.asp" with GetScriptName, mainly for development use, but it's better anyway
' (SS,17/1/13) removed the ending "/" tag from form because it means the end of the form it shouldn't be here
' (SS,12/8/15) added sortby, removed extra combo search code including If IsSearchVisible Then
' (SS,12/8/15) changed qty from "1" to "" to stop it being returned in search URL
' (SS,13/8/15) moved qty to end (from after code to after sortby) for a tidier URL, also moved pageno from after cmd to after page
' (SS,24/8/17) added Server.HTMLEncode to all variables to prevent xss, including cmd, code, grp, page, pageno, orderno, previously only cat and subcat had it
Sub ShowSearch
%>
<form name="frmSearch" id="frmSearch" method="get" action="<%=AddStoreURL(GetScriptName)%>" onsubmit="return itp_onsubmitsearch()" class="nospace">
<%
' (SS,6/7/07) added HTMLEncode to following to allow quotes etc when previous search value is displayed
Dim LSearchDefault
LSearchDefault = HTMLEncode(CleanRequestQueryString("search"))
ShowSearchMain LSearchDefault, ""
%>
<input type="hidden" name="cmd" value="<%=Server.HTMLEncode(CleanRequestQueryString("cmd"))%>" />
<%If CleanRequestQueryString("grp") <> "" Then Response.Write("<input type=""hidden"" name=""grp"" value=""" & Server.HTMLEncode(CleanRequestQueryString("grp")) & """>") End If%>
<input type="hidden" name="cat" value="<%=Server.HTMLEncode(GetCategory)%>" />
<input type="hidden" name="subcat" value="<%=Server.HTMLEncode(CleanRequestQueryString("subcat"))%>" />
<input type="hidden" name="code" value="<%=Server.HTMLEncode(GetProductCodeQS)%>" />
<input type="hidden" name="page" value="<%=Server.HTMLEncode(CleanRequestQueryString("page"))%>" />
<input type="hidden" name="pageno" value="<%=Server.HTMLEncode(CleanRequestQueryString("pageno"))%>" />
<input type="hidden" name="xcmd" value="" />
<input type="hidden" name="xcode" value="" />
<input type="hidden" name="orderno" value="<%=Server.HTMLEncode(CleanRequestQueryString("orderno"))%>" />
<input type="hidden" name="sortby" value="" />
<input type="hidden" name="qty" value="" />
</form>
<%
End Sub
' (SS,9/12/04) invisible form required to allow javascript to work on these pages '
' (SS,17/1/13) added ending / to input tag
' (SS,12/8/15) removed cbsubcat, no longer used
' (SS,24/8/17) added HTMLEncode to page to prevent xss
Sub ShowSearchForStreamline
%>
<form name="frmSearch" method="get" action="products.asp" onsubmit="return itp_onsubmitsearch()" class="nospace">
<input type="hidden" name="search" value="" />
<input type="hidden" name="cmd" value="" />
<input type="hidden" name="pageno" value="" />
<input type="hidden" name="cat" value="" />
<input type="hidden" name="subcat" value="" />
<input type="hidden" name="code" value="" />
<input type="hidden" name="qty" value="1" />
<input type="hidden" name="cw" value="" />
<input type="hidden" name="cl" value="" />
<input type="hidden" name="page" value="<%=Server.HTMLEncode(CleanRequestQueryString("page"))%>" />
<input type="hidden" name="xcmd" value="" />
<input type="hidden" name="xcode" value="" />
</form>
<%
End Sub
' (SS,25/7/11) following four routines moved here from ShowCategoryMenu
Sub SetMenuCategory(AMenuCategory)
Session("MenuCategory") = AMenuCategory
End Sub
Sub SetMenuSubcategory(AMenuSubcategory)
Session("MenuSubcategory") = AMenuSubcategory
End Sub
Function GetMenuCategory
GetMenuCategory = Session("MenuCategory")
End Function
Function GetMenuSubcategory
GetMenuSubcategory = Session("MenuSubcategory")
End Function
' (SS,7/6/11) mod to only show category if category contains at least one enabled product
' (SS,26/7/11) added MenuShortName and HTMLEncoded of Category and Subcategory names
' (SS,18/4/11) added Special Offers
Sub ShowCategoryMenu
ShowMenuHeader
Dim LMenuCategory, LMenuSubcategory, LCategory, LSubcategory, LPrevCategory, LEndSubcategoryTable, LDoEndTable
Dim LHRefCat, LHRefCatJava, LHRefSubcat, LSubcatCount, LCatCount
' get menu category from query string, if not assigned then get from session '
LMenuCategory = CleanRequestQueryString("cat")
If LMenuCategory = "" Then
LMenuCategory = GetMenuCategory
End If
LMenuSubcategory = CleanRequestQueryString("subcat")
If LMenuSubcategory = "" Then
LMenuSubcategory = GetMenuSubcategory
End If
' if a search was done or cat command then clear the menu selection '
If (CleanRequestQueryString("search") <> "") or (CleanRequestQueryString("cmd") = "cat") Then
LMenuCategory = ""
LMenuSubcategory = ""
End If
' (SS,17/5/11) added following to allow category menu to be shown for selected group
Dim LGroup
If GroupsEnabled Then
LGroup = GetGroup
If LGroup = "" Then LGroup = GetGroupForCategory(LMenuCategory)
If AlwaysDefaultGroupForMenu Then LGroup = GetDefaultGroup ' (SS,1/8/11)
Else
LGroup = ""
End If
' if not subcat specified then do not select it '
If CleanRequestQueryString("subcat") = "" Then LMenuSubcategory = ""
' (SS,27/7/11) if product/group/category/subcategory not specified then reset then category etc.
If Not CategoryOrProductSpecified Then
LGroup = GetDefaultGroup
LMenuCategory = ""
LMenuSubcategory = ""
' (SS,28/7/11) if only group is specified then clear the category and subcategory
ElseIf GroupOnlySpecified Then
LMenuCategory = ""
LMenuSubcategory = ""
End If
' if viewing of single product then find its category '
If CleanRequestQueryString("cmd") = "" And GetProductCodeQS <> "" Then
' (SS,1/8/11) added If AlwaysDefaultGroupForMenu and GetDefaultGroupCatSubcatForProduct to get the cat/sub for the default group
If AlwaysDefaultGroupForMenu Then
GetDefaultGroupCatSubcatForProduct GetProductCode, LMenuCategory, LMenuSubcategory
Else
GetFirstCatSubcatForProduct GetProductCode, "", LMenuCategory, LMenuSubcategory
End If
End If
' preserve for next time '
SetMenuCategory(LMenuCategory)
SetMenuSubcategory(LMenuSubcategory)
' (SS,19/2/13) moved SQL from to separate GetCategoryMenuSQL routine
OpenQuery(GetCategoryMenuSQL(LGroup))
LPrevCategory = ""
LEndSubcategoryTable = False
LSubcatCount = 0
LCatCount = 1 ' (SS,3/3/06)
' (SS,26/7/11) added following to use short name if specified and to also HTMLEncode
Dim LCategoryDisplayName, LSubcategoryDisplayName
Do While Not EndOfQuery
LCategory = GetQueryValue("Category")
LSubcategory = GetQueryValue("Subcategory")
LHRefCat = GetCategoryLink(LCategory)
LHRefCatJava = GetCategoryJavaLink(LCategory)
LHRefSubcat = GetSubcategoryLink(LCategory, LSubcategory)
' (SS,26/7/11)
LCategoryDisplayName = NB(GetQueryValue("CategoryMenuShortName"))
If LCategoryDisplayName = "" Then LCategoryDisplayName = LCategory
LCategoryDisplayName = HTMLEncode(LCategoryDisplayName)
LSubcategoryDisplayName = NB(GetQueryValue("SubcategoryMenuShortName"))
If LSubcategoryDisplayName = "" Then LSubcategoryDisplayName = LSubcategory
LSubcategoryDisplayName = HTMLEncode(LSubcategoryDisplayName)
If IsNull(LSubcategory) Then
If LCategory = LMenuCategory Then
If LCatCount Mod 2 = 1 Then
ShowMenuCategorySelected LCategoryDisplayName, LHRefCat
Else
ShowMenuCategorySelectedAlternateColor LCategoryDisplayName, LHRefCat
End If
Else
If LCatCount Mod 2 = 1 Then
ShowMenuCategory LCategoryDisplayName, LHRefCat
Else
ShowMenuCategoryAlternateColor LCategoryDisplayName, LHRefCat
End If
End If
ElseIf LCategory = LMenuCategory Then
If LPrevCategory <> LCategory Then
LEndSubcategoryTable = True
If LCatCount Mod 2 = 1 Then
ShowMenuSubcategoryHeader LCategoryDisplayName, LHRefCat
Else
ShowMenuSubcategoryHeaderAlternateColor LCategoryDisplayName, LHRefCat
End If
LSubcatCount = 0
If UseAlternateColorForCategories = True Then LCatCount = LCatCount + 1 ' (SS,3/3/06)
End If
LSubcatCount = LSubcatCount + 1
If LMenuSubcategory = LSubcategory Then
If LSubcatCount Mod 2 = 1 Then
ShowMenuSubcategorySelected LCategoryDisplayName, LSubcategoryDisplayName, LHRefSubcat
Else
ShowMenuSubcategorySelectedAlternateColor LCategoryDisplayName, LSubcategoryDisplayName, LHRefSubcat
End If
Else
If LSubcatCount Mod 2 = 1 Then
ShowMenuSubcategory LCategoryDisplayName, LSubcategoryDisplayName, LHRefSubcat
Else
ShowMenuSubcategoryAlternateColor LCategoryDisplayName, LSubcategoryDisplayName, LHRefSubcat
End If
End If
ElseIf LPrevCategory <> LCategory Then
If LCatCount Mod 2 = 1 Then
ShowMenuCategoryHasSubcategories LCategoryDisplayName, LHRefCat
Else
ShowMenuCategoryHasSubcategoriesAlternateColor LCategoryDisplayName, LHRefCat
End If
If UseAlternateColorForCategories = True Then LCatCount = LCatCount + 1 ' (SS,3/3/06)
End If
LPrevCategory = LCategory
NextQueryRecord
' make sure the sub category table is closed '
If LEndSubcategoryTable Then
LDoEndTable = False
If EndOfQuery Then
LDoEndTable = True
Else
LDoEndTable = LPrevCategory <> GetQueryValue("Category")
End If
If LDoEndTable Then
LEndSubcategoryTable = False
ShowMenuSubcategoryFooter
End If
End If
Loop
CloseQuery
' (SS,17/4/12) added special offers link from ShowSubCategoryMenu below
If AddSpecialOffersToSubcategoryMenu Then
LCategory = "Special Offers"
LHRefCat = "javascript:itp_sosearch()"
If LCase(CleanRequestQueryString("search")) = SPECIAL_OFFERS_SEARCH_TEXT Then
ShowMenuCategorySelected LCategory, LHRefCat
Else
If LCatCount Mod 2 = 1 Then
ShowMenuCategory LCategory, LHRefCat
Else
ShowMenuCategoryAlternateColor LCategory, LHRefCat
End If
End If
End If
ShowMenuFooter
End Sub
' (SS,19/2/13) moved SQL from ShowCategoryMenu to here, now also called from ShowHTMLSiteMap
' (SS,20/2/13) no longer called from ShowHTMLSiteMap
Function GetCategoryMenuSQL(AGroup)
Dim LSQL
' (SS,21/5/04) select all unique categories and subcategories that have been used '
' (SS,7/6/11) added join to products to look up ProductsDisabled, so that only categories containing at least one products are listed in the menu
LSQL = "SELECT productcategories.Category, productcategories.Subcategory, categories.MenuShortName AS CategoryMenuShortName, subcategories.MenuShortName AS SubcategoryMenuShortName" &_
" FROM productcategories" &_
" INNER JOIN categories ON categories.Category = productcategories.Category" &_
" INNER JOIN subcategories ON subcategories.Category = productcategories.Category AND subcategories.Subcategory = productcategories.Subcategory" &_
" INNER JOIN products ON products.ProductCode = productcategories.ProductCode"
' (SS,7/6/11) added following to ignore products which are disabled, allowing only categories that contain products to be shown
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
LSQL = LSQL + " WHERE products.ProductDisabled = FALSE" & GetProductsFilter
' (SS,17/5/11) added following to filter records if group selected
' (SS,7/6/11) replaced WHERE with AND, because WHERE added above
' (SS,22/7/11) added the missing " " before AND
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
If AGroup <> "" Then LSQL = LSQL + " AND GroupName = '" + CleanSQLStr(AGroup) + "'"
LSQL = LSQL &_
" GROUP BY Category, Subcategory" &_
" ORDER BY categories.SortOrder, productcategories.Category, subcategories.SortOrder, productcategories.Subcategory"
GetCategoryMenuSQL = LSQL
End Function
' (SS,20/6/05) added for use in Cufflinks, where a single category is used '
Sub ShowSubCategoryMenu()
Dim LMenuCategory, LMenuSubcategory, LCategory, LSubcategory, LHRefSubcat, LSubcatCount
' get menu category from query string, if not assigned then get from session '
LMenuCategory = CleanRequestQueryString("cat")
If LMenuCategory = "" Then
LMenuCategory = Session("MenuCategory")
End If
LMenuSubcategory = CleanRequestQueryString("subcat")
If LMenuSubcategory = "" Then
LMenuSubcategory = Session("MenuSubcategory")
End If
' if a search was done or cat command then clear the menu selection '
If (CleanRequestQueryString("search") <> "") or (CleanRequestQueryString("cmd") = "cat") or (CleanRequestQueryString("subcat") = "") Then
LMenuCategory = ""
LMenuSubcategory = ""
End If
ShowMenuHeader
' if viewing of single product then find its category '
If CleanRequestQueryString("cmd") = "" And GetProductCodeQS <> "" Then
GetFirstCatSubcatForProduct GetProductCodeQS, "", LMenuCategory, LMenuSubcategory
End If
' preserve for next time '
Session("MenuCategory") = LMenuCategory
Session("MenuSubcategory") = LMenuSubcategory
Dim LSQL
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "SELECT * FROM subcategories WHERE Category = '" & CleanSQLStr(GetCategoryForSubcategoryMenu) & "' ORDER BY SortOrder"
OpenQuery(LSQL)
LSubcatCount = 0
Do While Not EndOfQuery
LCategory = GetQueryValue("Category")
LSubcategory = GetQueryValue("Subcategory")
LHRefSubcat = GetSubcategoryLink(LCategory, LSubcategory)
LSubcatCount = LSubcatCount + 1
If LMenuSubcategory = LSubcategory Then
ShowMenuSubcategorySelected LCategory, LSubcategory, LHRefSubcat
Else
If LSubcatCount Mod 2 = 1 Then
ShowMenuSubcategory LCategory, LSubcategory, LHRefSubcat
Else
ShowMenuSubcategoryAlternateColor LCategory, LSubcategory, LHRefSubcat
End If
End If
NextQueryRecord
Loop
' add special offers link '
If AddSpecialOffersToSubcategoryMenu Then
LSubcatCount = LSubcatCount + 1
LSubcategory = "Special Offers"
LHRefSubcat = "javascript:itp_sosearch()"
If LCase(CleanRequestQueryString("search")) = SPECIAL_OFFERS_SEARCH_TEXT Then
ShowMenuSubcategorySelected LCategory, LSubcategory, LHRefSubcat
Else
If LSubcatCount Mod 2 = 1 Then
ShowMenuSubcategory LCategory, LSubcategory, LHRefSubcat
Else
ShowMenuSubcategoryAlternateColor LCategory, LSubcategory, LHRefSubcat
End If
End If
End If
CloseQuery
ShowMenuFooter
End Sub
' (SS,23/3/07) new type of menu that starts from group and shows 3 levels, i.e. groups, categories and subcategories
' AShowAll parameter allows all categories to be shown even if they don't contain a product
Sub ShowGroupMenu(AShowAll)
ShowMenuHeader
' (SS,23/4/09) added LMenuCategoryName
Dim LMenuGroup, LMenuCategory, LMenuSubcategory, LCategory, LSubcategory, LMenuCategoryName, LPrevCategory, LMenuSelected
Dim LHRefCat, LHRefCatJava, LHRefSubcat
Dim LGroup, LPrevGroup, LHRefGrp
Dim LFirstInGroup, LInGroup, LFirstInCategory, LInCategory, LInSubcategory, LCategoryHeaderShown, LSubcategoryHeaderShown
Dim LCategoryCount, LSubcategoryCount, LShowCategories, LShowSubcategories
' get menu category from query string, if not assigned then get from session '
LMenuGroup = CleanRequestQueryString("grp")
If LMenuGroup = "" Then
LMenuGroup = Session("MenuGroup")
Else ' if group selected then clear the category and subcategories in the session
Session("MenuCategory") = ""
Session("MenuSubcategory") = ""
End If
LMenuCategory = CleanRequestQueryString("cat")
If LMenuCategory = "" Then
LMenuCategory = Session("MenuCategory")
End If
LMenuSubcategory = CleanRequestQueryString("subcat")
If LMenuSubcategory = "" Then
LMenuSubcategory = Session("MenuSubcategory")
End If
' if code, cat and subcat not specified then clear selection
' (SS,20/7/07) was if (CleanRequestQueryString("search") <> "") or (CleanRequestQueryString("cmd") = "cat")
' If (CleanRequestQueryString("code") = "") and (CleanRequestQueryString("grp") = "") and (CleanRequestQueryString("cat") = "") and (CleanRequestQueryString("subcat") = "") Then
' (SS,27/7/11) replaced above with If Not CategoryOrProductSpecified Then
If Not CategoryOrProductSpecified Then
LMenuGroup = ""
LMenuCategory = ""
LMenuSubcategory = ""
End If
' if not subcat specified then do not select it '
If CleanRequestQueryString("subcat") = "" Then LMenuSubcategory = ""
' if viewing of single product then find its category '
If CleanRequestQueryString("cmd") = "" And GetProductCodeQS <> "" Then
GetFirstCatSubcatForProduct GetProductCodeQS, "", LMenuCategory, LMenuSubcategory
End If
LMenuSelected = LMenuGroup <> "" Or LMenuCategory <> "" Or LMenuSubcategory <> "" ' (SS,20/7/07)
' (SS,14/5/07) added following to always open main group main if only one group exists
If Not GroupsEnabled Then LMenuGroup = GROUP_MAIN
' if category isn't blank then find it's group
If LMenuCategory <> "" Then
LMenuGroup = GetGroupForCategory(LMenuCategory)
End If
' preserve for next time '
Session("MenuGroup") = LMenuGroup
Session("MenuCategory") = LMenuCategory
Session("MenuSubcategory") = LMenuSubcategory
Dim LSQL
' (SS,23/3/07) selects all subcategories, and looks up the group
' (SS,31/3/09) added c.GroupName to ORDER BY in case SortOrder is the same for all groups
' (SS,23/4/09) added c.MenuShortName
If AShowAll Then
LSQL = "SELECT c.GroupName, s.Category, s.Subcategory, c.MenuShortName" &_
" FROM subcategories s" &_
" INNER JOIN categories c ON c.Category = s.Category" &_
" INNER JOIN groups g ON g.GroupName = c.GroupName" &_
" GROUP BY GroupName, Category, Subcategory" &_
" ORDER BY g.SortOrder, c.GroupName, c.SortOrder, s.Category, s.SortOrder, s.Subcategory"
Else
LSQL = "SELECT c.GroupName, pc.Category, pc.Subcategory, c.MenuShortName" &_
" FROM productcategories pc" &_
" INNER JOIN categories c ON c.Category = pc.Category" &_
" INNER JOIN subcategories s ON s.Category = pc.Category AND s.Subcategory = pc.Subcategory" &_
" INNER JOIN groups g ON g.GroupName = c.GroupName" &_
" GROUP BY Category, Subcategory" &_
" ORDER BY g.SortOrder, c.GroupName, c.SortOrder, pc.Category, s.SortOrder, pc.Subcategory"
End If
' store the list in multi dimensional array
OpenQuery(LSQL)
Dim LArray, i, LItemCount
' (SS,23/4/09) added SHORT_CATEGORY_NAME
Const GROUP = 0, CATEGORY = 1, SUBCATEGORY = 2, SHORT_CATEGORY_NAME = 3, CATEGORY_COUNT = 4, SUBCATEGORY_COUNT = 5
Const MAX_FIRST_ELEMENT = 5 ' (SS,23/4/09)
i = 0
' (SS,23/4/09) replace 4 with MAX_FIRST_ELEMENT
Redim LArray(MAX_FIRST_ELEMENT, 1)
Do While Not EndOfQuery
' (SS,23/4/09) replace 4 with MAX_FIRST_ELEMENT
If i Mod 20 = 0 Then Redim Preserve LArray(MAX_FIRST_ELEMENT, i + 20) ' redimension in blocks of 20 to save resources
LArray(GROUP, i) = GetQueryValue("GroupName")
LArray(CATEGORY, i) = GetQueryValue("Category")
LArray(SUBCATEGORY, i) = GetQueryValue("Subcategory")
LArray(SHORT_CATEGORY_NAME, i) = NB(GetQueryValue("MenuShortName")) ' (SS,23/4/09)
NextQueryRecord
i = i + 1
Loop
LItemCount = i
CloseQuery
' go backwards through the array setting count of categories and subcategories
' this is used later to not show a category or subcategory if only one item exists in it
LPrevGroup = ""
LPrevCategory = ""
LCategoryCount = 0
LSubcategoryCount = 0
For i = LItemCount - 1 To 0 STEP -1
LGroup = LArray(GROUP, i)
LCategory = LArray(CATEGORY, i)
If LGroup = LPrevGroup Then
If LCategory = LPrevCategory Then
LSubcategoryCount = LSubcategoryCount + 1
Else
LCategoryCount = LCategoryCount + 1
LSubcategoryCount = 1
End If
Else
LCategoryCount = 1
LSubcategoryCount = 1
End If
LArray(CATEGORY_COUNT, i) = LCategoryCount
LArray(SUBCATEGORY_COUNT, i) = LSubcategoryCount
LPrevCategory = LCategory
LPrevGroup = LGroup
Next
LPrevGroup = ""
LPrevCategory = ""
LCategoryHeaderShown = False
LSubcategoryHeaderShown = False
For i = 0 To LItemCount - 1
LGroup = LArray(GROUP, i)
LCategory = LArray(CATEGORY, i)
LSubcategory = LArray(SUBCATEGORY, i)
' (SS,23/4/09) use short name if assigned
LMenuCategoryName = LArray(SHORT_CATEGORY_NAME, i)
If LMenuCategoryName = "" Then LMenuCategoryName = LCategory
LHRefGrp = GetGroupLink(LGroup)
LHRefCat = GetCategoryLink(LCategory)
LHRefCatJava = GetCategoryJavaLink(LCategory)
LHRefSubcat = GetSubcategoryLink(LCategory, LSubcategory)
LFirstInGroup = (LGroup <> LPrevGroup)
LInGroup = (LGroup = LMenuGroup)
LFirstInCategory = (LCategory <> LPrevCategory)
LInCategory = (LCategory = LMenuCategory)
LInSubcategory = (LSubcategory = LMenuSubcategory)
' if group has changed i.e. when first encountered in the list
If LFirstInGroup Then
' to only show categories if more than one exists for this group
LShowCategories = LArray(CATEGORY_COUNT, i) > 1
' close the subcategory header if it was already shown in previous group
If LSubcategoryHeaderShown Then
ShowMenuSubcategoryFooter
LSubcategoryHeaderShown = False
End If
' close the category header if it was already shown in previous group
If LCategoryHeaderShown Then
ShowMenuCategoryFooter
LCategoryHeaderShown = False
End If
' if group chosen in menu then show selected version, else unselected version
If LInGroup Then
ShowMenuGroupSelected LGroup, LHRefGrp
Else
ShowMenuGroup LGroup, LHRefGrp
End If
End If
' if in chosen group and first in category
If LInGroup And LFirstInCategory Then
' to only show categories if more than one exists for this category
LShowSubcategories = LArray(SUBCATEGORY_COUNT, i) > 1
' close the subcategory header if it was already shown in previous category
If LSubcategoryHeaderShown Then
ShowMenuSubcategoryFooter
LSubcategoryHeaderShown = False
End If
If LShowCategories Then
' if first category in group then show the category header
If LFirstInGroup And Not LCategoryHeaderShown Then
ShowMenuCategoryHeader
LCategoryHeaderShown = True
End If
' if category chosen in menu then show selected version, else unselected version
If LInCategory Then
ShowMenuCategorySelected LMenuCategoryName, LHRefCat ' (SS,29/4/09) replaced LCategory with LMenuCategoryName
Else
' (SS,20/7/07) if menu selected and groups aren't being used then use Javascript link
' to cause search engine not to follow it, else normal link
If LMenuSelected And Not GroupsEnabled Then
ShowMenuCategory LMenuCategoryName, LHRefCatJava ' (SS,29/4/09) replaced LCategory with LMenuCategoryName
Else
ShowMenuCategory LMenuCategoryName, LHRefCat ' (SS,29/4/09) replaced LCategory with LMenuCategoryName
End If
End If
End If
End If
' if in chosen category, or if in chosen group and categories are not shown because there's only one
If LInCategory Or (LInGroup And Not LShowCategories) Then
If LShowSubcategories Then
' if first subcategory in category then show the subcategory header
If LFirstInCategory And Not LSubcategoryHeaderShown Then
ShowMenuSubcategoryHeader
LSubcategoryHeaderShown = True
End If
' if subcategory chosen in menu then show selected version, else unselected version
If LInSubcategory Then
ShowMenuSubcategorySelected LSubcategory, LHRefSubcat
Else
ShowMenuSubcategory LSubcategory, LHRefSubcat
End If
End If
End If
LPrevCategory = LCategory
LPrevGroup = LGroup
Next
' make sure subcategory is closed
If LSubcategoryHeaderShown Then ShowMenuSubcategoryFooter
' make sure category is closed
If LCategoryHeaderShown Then ShowMenuCategoryFooter
ShowMenuFooter
End Sub
' (SS,11/5/15) AGroupList is a semicolon separated list, if empty string then use groups table
' based on Sub ShowMenuForCategories (below)
Sub ShowMenuForGroups(AGroupList)
ShowMenuHeader
If AGroupList = "" Then
' all groups with a category in sort order
OpenQuery("SELECT DISTINCT g.GroupName, g.SortOrder FROM groups g INNER JOIN categories c ON g.GroupName = c.GroupName ORDER BY g.SortOrder, g.GroupName")
Do While Not EndOfQuery
AGroupList = AGroupList + Iif(AGroupList = "", "", ";") + GetQueryValue("GroupName")
NextQueryRecord
Loop
CloseQuery
End If
Dim LGroups, LGroup
LGroups = Split(AGroupList, ";")
For Each LGroup In LGroups
ShowMenuForGroup LGroup
Next
ShowMenuFooter
End Sub
' (SS,11/5/15) create menu for given group, used for creating popup type menu for individual top level categories
Sub ShowMenuForGroup(AGroup)
ShowMenuCategoryHeader AGroup, GetGroupLink(AGroup)
Dim LCategory
OpenQuery2("SELECT * FROM categories WHERE GroupName = '" & CleanSQLStr(AGroup) & "' ORDER BY SortOrder, Category")
Do While Not EndOfQuery2
LCategory = GetQueryValue2("Category")
' (SS,14/5/15) if single level
'ShowMenuCategory LCategory, GetCategoryLink(LCategory)
ShowMenuForCategory LCategory
NextQueryRecord2
Loop
CloseQuery2
ShowMenuCategoryFooter
End Sub
' (SS,18/5/15)
' AType can be "G" for group, "C" for category
' (SS,15/9/15) can include "A" for all levels (i.e. include if only one subcategory)
' "E" to include empty subcategories
' e.g. AType of "CAE" means category level, all levels and include empty
' (SS,11/11/16) "F" means first menu item is group, Allows first to be group and rest to be category
Sub StartMultiMenu(AType)
SetMultiMenuType AType
ShowMenuHeader
End Sub
' -------------------------------------------
' Start of App Cache routines
' (SS,8/6/22) to be continued
' -------------------------------------------
' (SS,6/6/22)
Sub HTMLCacheClear
FHTMLCache = ""
End Sub
' (SS,6/6/22)
Sub HTMLCacheAdd(AHTML)
FHTMLCache = FHTMLCache + AHTML
End Sub
' (SS,6/6/22)
Function GetHTMLCache
GetHTMLCache = FHTMLCache
End Function
Sub ShowHTMLCache
Response.Write GetHTMLCache
End Sub
' (SS,6/6/22)
Function InAppCache(ACacheName)
' if AppCacheEnabled
HTMLCacheClear ' (SS,6/6/22)
InAppCache = False
End Function
' (SS,6/6/22) InAppCache needs to be called first
Function GetFromAppCache
End Function
' (SS,6/6/22)
Sub SaveAppCache(ACacheName)
End Sub
Sub ShowAppCache
Response.Write GetHTMLCache
End Sub
' -------------------------------------------
' End of App Cache routines
' -------------------------------------------
' (SS,21/5/15)
Sub SetMultiMenuType(AType)
FMultiMenuType = AType
FMultiMenuTopLevelItemCount = 0 ' (SS,11/11/16)
End Sub
' (SS,21/5/15)
' (SS,15/9/15) added InStr because FMultiMenuType can now contains more options
Function IsMultiMenuTypeGroup
' (SS,11/11/16) added [Or (FMultiMenuTopLevelItemCount = 1 And InStr(FMultiMenuType, "F") > 0)] to allow first item to be group where rest are category
IsMultiMenuTypeGroup = InStr(FMultiMenuType, "G") > 0
End Function
' (SS,11/11/16) to allow first item to be group where rest are category
Function IsMultiMenuTypeGroupForFirst
IsMultiMenuTypeGroupForFirst = FMultiMenuTopLevelItemCount = 1 And InStr(FMultiMenuType, "F") > 0
End Function
' (SS,21/5/15)
Function IsMultiMenuTypeAll
IsMultiMenuTypeAll = InStr(FMultiMenuType, "A") > 0
End Function
' (SS,21/5/15)
Function IsMultiMenuTypeIncludeEmpty
IsMultiMenuTypeIncludeEmpty = InStr(FMultiMenuType, "E") > 0
End Function
' (SS,22/5/15) used in inc-template-category-menu.asp to call the recursive AddMultiMenuLevel below with correct starting level number and default AMenuName2 of ""
' (SS,6/2/16) amended to allow AMenuName to have up to 3 levels separated by "|", normally applicable when called from MultiMenuAdditions where AMenuShortName and AMenuAdditionList are blank
Sub AddMultiMenu(AMenuName, AMenuShortName, AMenuAdditionList)
FMultiMenuTopLevelItemCount = FMultiMenuTopLevelItemCount + 1 ' (SS,11/11/16) used by IsMultiMenuTypeGroup to allow first item to be a group and rest to be category
Dim LLevelNo
' (SS,11/1/16) added Or IsMultiMenuTypeGroupForFirst
If IsMultiMenuTypeGroup Or IsMultiMenuTypeGroupForFirst Then
LLevelNo = 1
Else
LLevelNo = 2
End If
' (SS,6/2/16) two levels can now be passed on, default to second being none, only added if more than one level found in AMenuName, separated by "|"
Dim LMenuName1, LMenuName2
LMenuName1 = AMenuName
LMenuName2 = ""
' (SS,6/2/16 when called form MultiMenuAdditions we want to allow individual category and/or subcategory
' i.e. assuming | used as a divider, split into levels up to 3 for groups, category and subcategory
' added following to allow more specific category / subcategory separated by "|"
' if group type then AMenuName may contain 3 levels e.g. Pro Audio | Pro Audio | Headphones
If InStr(AMenuName, "|") > 0 Then
Dim LLevel1Name, LLevel2Name, LLevel3Name
LLevel1Name = Trim(NthSeparatedValue(AMenuName, "|", 1))
LLevel2Name = Trim(NthSeparatedValue(AMenuName, "|", 2))
LLevel3Name = Trim(NthSeparatedValue(AMenuName, "|", 3))
' determine LLevelNo and values for LMenuName1 and LMenuName2
' if group then ignore first level, just pass on the second which should be category and 3 if it exists as subcategory and there are 3 then start from LevelNo2 and use 2nd and 3rd
' (SS,11/1/16) added Or IsMultiMenuTypeGroupForFirst
If IsMultiMenuTypeGroup Or IsMultiMenuTypeGroupForFirst Then
' remember that LMenuName1 and LMenuName2 are reversed, if subcat and cat exist then subcat goes in LMenuName1 and cat in LMenuName2
If LLevel3Name <> "" Then
LLevelNo = 3
LMenuName1 = LLevel3Name ' subcategory
LMenuName2 = LLevel2Name ' category
Else
LLevelNo = 2
LMenuName1 = LLevel2Name ' category only
End If
Else ' for category there should always be two level names passed, so set level no to 3 and pass category and subcategory
LLevelNo = 3
LMenuName1 = LLevel2Name ' subcategory
LMenuName2 = LLevel1Name ' category
End If
End If
' (SS,6/2/16) as before, but added LMenuName2 after AMenuName to replace "" and replaced AMenuName with LMenuName1
AddMultiMenuLevel LLevelNo, LMenuName1, LMenuName2, AMenuShortName, "", AMenuAdditionList
End Sub
' check how many come off first level (i.e. categories in group or subcategories in category)
' recursive
' (SS,13/5/16) change to allow special dummy group/category to have a link set when prefixed with "URL:"
Sub AddMultiMenuLevel(ALevelNo, AMenuName, AMenuName2, AMenuShortName, AMenuShortName2, AMenuAdditionList)
Dim LMenuCaption, LMenuCaption2, LSQL, LSubmenuCount, LLink, LField1, LField2, LField3, LField4
' Response.Write "#" & AMenuName & ", " & AMenuName2 & ", " & AMenuShortName & ", " & AMenuShortName2 & BR
' determine captions depending on existence of short menu names
LMenuCaption = AMenuName
If AMenuShortName = "" Then
LMenuCaption = AMenuName
Else
LMenuCaption = AMenuShortName
End If
If AMenuShortName2 = "" Then
LMenuCaption2 = AMenuName2
Else
LMenuCaption2 = AMenuShortName2
End If
' Level 1 is Group, Level 2 is Category, Level 3 is Subcategory
If ALevelNo = 1 Then
' get all categories for given group
' (SS,1/7/15) added SortOrder, which if negative, can be used to hide it, quicker than running a query to see if there are any enabled products
' (SS,11/11/16) added If IsMultiMenuTypeGroupForFirst for new group query that only shows categories containing enabled products
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
If IsMultiMenuTypeGroupForFirst Then
LSQL = "SELECT DISTINCT c.Category, c.MenuShortName, c.SortOrder FROM categories c" &_
" INNER JOIN productcategories pc ON pc.Category = c.Category" &_
" INNER JOIN products p ON p.ProductCode = pc.ProductCode" &_
" WHERE p.ProductDisabled = FALSE AND GroupName = '" + CleanSQLStr(AMenuName) + "'" & GetProductsFilter &_
" ORDER BY c.SortOrder, c.Category"
Else ' (SS,11/11/16) as it was
LSQL = "SELECT Category, MenuShortName, SortOrder FROM categories WHERE GroupName = '" + CleanSQLStr(AMenuName) + "' ORDER BY SortOrder, Category"
End If
LLink = GetGroupLink(AMenuName)
LField1 = "Category"
LField2 = "MenuShortName"
LField3 = ""
LField4 = ""
ElseIf ALevelNo = 2 Then ' category level
' (SS,15/9/15) added code to only include subcategories containing at least one enabled product
If IsMultiMenuTypeIncludeEmpty Then
LSQL = "SELECT s.Category, s.Subcategory, c.MenuShortName AS CategoryMenuShortName, s.MenuShortName AS SubcategoryMenuShortName, s.SortOrder FROM subcategories s INNER JOIN categories c ON c.Category = s.Category WHERE s.Category = '" & CleanSQLStr(AMenuName) & "' ORDER BY s.SortOrder, s.Subcategory"
Else ' (SS,15/9/15) added following to exclude empty subcategories
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
LSQL = "SELECT DISTINCT s.Category, s.Subcategory, c.MenuShortName AS CategoryMenuShortName, s.MenuShortName AS SubcategoryMenuShortName, s.SortOrder" &_
" FROM subcategories s" &_
" INNER JOIN categories c ON c.Category = s.Category" &_
" INNER JOIN productcategories pc ON pc.Category = s.Category AND pc.Subcategory = s.Subcategory" &_
" INNER JOIN products p ON p.ProductCode = pc.ProductCode" &_
" WHERE p.ProductDisabled = FALSE AND s.Category = '" & CleanSQLStr(AMenuName) & "'" & GetProductsFilter &_
" ORDER BY s.SortOrder, s.Subcategory"
End If
LLink = GetCategoryLink(AMenuName)
LField1 = "Subcategory"
LField2 = "SubcategoryMenuShortName"
LField3 = "Category"
LField4 = "CategoryMenuShortName"
Else ' i.e. last level 3, subcategory
LSQL = ""
LSubmenuCount = 0
LLink = GetSubcategoryLink(AMenuName2, AMenuName)
End If
If LSQL <> "" Then
Dim LArray, i
Redim LArray(3, -1)
OpenQuery(LSQL)
' LSubmenuCount = GetQueryRecordCount
' (SS,3/6/22) removed GetQueryRecordCount above because it duplicates this query, count can be done in the loop below
LSubmenuCount = 0
Do While Not EndOfQuery
LSubmenuCount = LSubmenuCount + 1 ' (SS,3/6/22)
' (SS,1/7/15) added "If" to only add if SortOrder isn't negative
If NZ(GetQueryValue("SortOrder")) >= 0 Then
Redim Preserve LArray(3, UBound(LArray, 2) + 1)
LArray(0, UBound(LArray, 2)) = NB(GetQueryValue(LField1))
LArray(1, UBound(LArray, 2)) = NB(GetQueryValue(LField2))
If LField3 <> "" Then
LArray(2, UBound(LArray, 2)) = NB(GetQueryValue(LField3))
LArray(3, UBound(LArray, 2)) = NB(GetQueryValue(LField4))
Else
LArray(2, UBound(LArray, 2)) = ""
LArray(3, UBound(LArray, 2)) = ""
End If
End If
NextQueryRecord
Loop
CloseQuery
End If
' if there are sub items then add to dropdown, else show the single item
If LSubmenuCount = 0 Then
If AMenuAdditionList = "" Then
' show this menu item
ShowMenuSingle LMenuCaption, LLink, ALevelNo
Else
' ALink is set to "" because it's a dummy i.e. not a proper group
' (SS,13/5/16) added following to allow the link to be set when prefixed with URL:
Dim LLinkOverride
If Left(AMenuName, 4) = "URL:" Then
LLinkOverride = Mid(AMenuName, 5)
Else
LLinkOverride = ""
End If
ShowMenuDropdownHeader LMenuCaption, LLinkOverride, ALevelNo ' (SS,13/5/16) replaced "" with LLinkOverride
MultiMenuAdditions AMenuAdditionList
ShowMenuDropdownFooter
End If
Else
' if only one and name matches current then don't do a dropdown
'If LSubmenuCount > 1 Or LArray(0, 0) <> AMenuName Then ShowMenuDropdownHeader LMenuCaption, LLink, ALevelNo
' (SS,15/9/15) added "Or IsMultiMenuTypeAll" to always include if option chosen
If LSubmenuCount > 1 Or IsMultiMenuTypeAll Then ShowMenuDropdownHeader LMenuCaption, LLink, ALevelNo
' iterate array recursively calling this routine
For i = LBound(LArray, 2) To UBound(LArray, 2)
AddMultiMenuLevel ALevelNo + 1, LArray(0, i), LArray(2, i), LArray(1, i), LArray(3, i), ""
Next
MultiMenuAdditions AMenuAdditionList
'If LSubmenuCount > 1 Or LArray(0, 0) <> AMenuName Then ShowMenuDropdownFooter
' (SS,15/9/15) added "Or IsMultiMenuTypeAll" to always include if option chosen
If LSubmenuCount > 1 Or IsMultiMenuTypeAll Then ShowMenuDropdownFooter
End If
End Sub
' (SS,22/5/15)
Sub MultiMenuAdditions(AMenuAdditionList)
' do the addition list
If AMenuAdditionList <> "" Then
Dim LAdditions, LAddition, LAdditionClean
LAdditions = Split(AMenuAdditionList, ";")
For Each LAddition In LAdditions
' if empty then it means separator/divider
LAdditionClean = Trim(LAddition)
If LAdditionClean = "" Then
ShowMenuDivider
Else
AddMultiMenu LAdditionClean, "", ""
End If
' ALevelNo, AMenuName, AMenuName2, AMenuShortName, AMenuShortName2, AMenuAdditionList
'If AMenuAdditionList <> "" Then AddMultiMenuLevel ALevelNo, AMenuAdditionList, "", "", "", ""
Next
End If
End Sub
' (SS,18/5/15)
Sub EndMultiMenu
ShowMenuFooter
End Sub
' (SS,13/8/14) ACategoryList is a semicolon separated list, if empty string then use categories table
Sub ShowMenuForCategories(ACategoryList)
ShowMenuHeader
If ACategoryList = "" Then
OpenQuery("SELECT * FROM categories ORDER BY SortOrder, Category")
Do While Not EndOfQuery
ACategoryList = ACategoryList + Iif(ACategoryList = "", "", ";") + GetQueryValue("Category")
NextQueryRecord
Loop
CloseQuery
End If
Dim LCategories, LCategory
LCategories = Split(ACategoryList, ";")
For Each LCategory In LCategories
ShowMenuForCategory LCategory
Next
ShowMenuFooter
End Sub
' (SS,13/8/14) create menu for given category, used for creating popup type menu for individual top level categories
Sub ShowMenuForCategory(ACategory)
ShowMenuSubcategoryHeader ACategory, GetCategoryLink(ACategory)
Dim LSubcategory
OpenQuery("SELECT * FROM subcategories WHERE Category = '" & CleanSQLStr(ACategory) & "' ORDER BY SortOrder, Subcategory")
Do While Not EndOfQuery
LSubcategory = GetQueryValue("Subcategory")
ShowMenuSubcategory ACategory, LSubcategory, GetSubcategoryLink(ACategory, LSubcategory)
NextQueryRecord
Loop
CloseQuery
ShowMenuSubcategoryFooter
End Sub
' (SS,12/2/05) added Request.ServerVariables("QUERY_STRING") '
' added LHighlightFor, LHighlightValue '
Sub ShowMainMenu()
ShowMainMenuHeader
OpenQuery("SELECT * FROM menu ORDER BY SortOrder")
Dim LCurrentPageName, LPos, LIsSamePage, LHighlightFor, LHighlightValue
LCurrentPageName = Request.ServerVariables("SCRIPT_NAME")
If Request.ServerVariables("QUERY_STRING") <> "" Then LCurrentPageName = LCurrentPageName & "?" & Request.ServerVariables("QUERY_STRING")
LPos = InStrRev(LCurrentPageName, "/")
If LPos > 0 Then LCurrentPageName = Mid(LCurrentPageName, LPos + 1, Len(LCurrentPageName))
' (SS,12/2/05) determine category and group '
Dim LProductCode, LGroup, LCat, LSubcategory
LProductCode = GetProductCodeQS
LCat = CleanRequestQueryString("cat")
If LCat = "" Then
If LProductCode <> "" Then
' GetFirstCatSubcatForProduct LProductCode, LGroup, LCat, LSubcategory
' (SS,1/8/11) replaced above with following, to height correct menu item for group
GetBreadcrumbGroupCatSubcatForProduct LProductCode, LGroup, LCat, LSubcategory
Else
LGroup = ""
End If
Else
LGroup = GetGroupForCat(LCat)
End If
' (SS,12/2/05) used in GetProductsPageTitle '
If GroupsEnabled Then
strGroupFromMenu = LGroup
Else
strGroupFromMenu = ""
End If
Do While Not EndOfQuery
If (GetQueryValue("PageName") = LCurrentPageName) Or (GetQueryValue("Tag") = 1 And IsSearchPage) Then
LIsSamePage = True
Else
LIsSamePage = False
' (SS,12/2/05) added following to highlight for group or category '
LHighlightFor = GetQueryValue("HighlightFor")
LHighlightValue = GetQueryValue("HighlightValue")
If LHighlightFor = "cat" Then
If LCat = LHighlightValue Then
LIsSamePage = True
End If
ElseIf LHighlightFor = "grp" Then
If LCat <> "" Then
If LGroup = LHighlightValue Then
LIsSamePage = True
End If
End If
End if
End If
ShowMainMenuItem GetQueryValue("MenuItemName"), GetQueryValue("PageName"), GetQueryValue("Width"), LIsSamePage, GetQueryValue("ExtraHTML"), GetQueryValue("Tag")
NextQueryRecord
Loop
CloseQuery
ShowMainMenuFooter
End Sub
' (SS,15/8/05) new horizontal menu
Sub ShowMainMenuHorizontal()
ShowMainMenuHorizontalHeader
OpenQuery("SELECT * FROM menu ORDER BY SortOrder")
Dim LCurrentPageName, LPos, LIsSamePage, LHighlightFor, LHighlightValue
LCurrentPageName = Request.ServerVariables("SCRIPT_NAME")
If Request.ServerVariables("QUERY_STRING") <> "" Then LCurrentPageName = LCurrentPageName & "?" & Request.ServerVariables("QUERY_STRING")
LPos = InStrRev(LCurrentPageName, "/")
If LPos > 0 Then LCurrentPageName = Mid(LCurrentPageName, LPos + 1, Len(LCurrentPageName))
Do While Not EndOfQuery
If (GetQueryValue("PageName") = LCurrentPageName) Or (GetQueryValue("Tag") = 1 And IsSearchPage) Then
LIsSamePage = True
Else
LIsSamePage = False
End If
ShowMainMenuHorizontalItem GetQueryValue("MenuItemName"), GetQueryValue("PageName"), GetQueryValue("Width"), LIsSamePage, GetQueryValue("ExtraHTML"), GetQueryValue("Tag")
NextQueryRecord
Loop
CloseQuery
ShowMainMenuHorizontalFooter
End Sub
' (SS,12/2/05) returns Group for Cat, blank string if Category not found '
Function GetGroupForCat(ACat)
OpenQuery2("SELECT GroupName FROM categories WHERE Category = '" & CleanSQLStr(ACat) & "'")
If Not EndOfQuery2 Then
GetGroupForCat = GetQueryValue2("GroupName")
Else
GetGroupForCat = ""
End If
CloseQuery2
End Function
' (SS,28/4/05) returns product list category suffix from group table for given category '
' (SS,16/3/12) removed, no longer used, field ProductListCategorySuffix has been dropped from groups table
'Function GetProductListCategorySuffixForGroup(AGroup)
' OpenQuery2("SELECT * FROM groups WHERE GroupName = '" & CleanSQLStr(AGroup) & "'")
' If Not EndOfQuery2 Then
' GetProductListCategorySuffixForGroup = GetQueryValue2("ProductListCategorySuffix")
' Else
' GetProductListCategorySuffixForGroup = ""
' End If
' CloseQuery2
'End Function
' (SS,20/6/05) added following to get page text from highlights table '
' (SS,21/5/07) modified to only open database if not already open and close it if it had to be opened
' (SS,15/4/09) modified to use sitedetails table instead of highlights
' (SS,30/11/23) modified to add type "Blog Posts"
Function GetWebText(AWebTextCode)
Dim LWebText
' LWebText = GetValueFromQuery("Description", "SELECT * FROM highlights WHERE ShowThis <> 0 AND ProductCode = 'WEBTEXT-" & AWebTextCode & "'")
' (SS,15/4/09) replaced above with following
' (SS,6/5/09) corrected bug after was after first "=" moved to before "Type"
' (SS,12/6/12) added CleanSQLStr before AWebTextCode to prevent SQL injection
' (SS,30/10/23) added OR Type = 'Blog Posts'
LWebText = GetValueFromQuery("Text", "SELECT Text FROM sitedetails WHERE (Type = 'Page Content' OR Type = 'Other' OR Type = 'Blog Posts') AND Name = '" & CleanSQLStr(AWebTextCode) & "'")
If IsNull(LWebText) Then LWebText = ""
' (SS,15/4/09) added following token replacements
If InStr(LWebText, "{") > 0 Then ' (SS,16/6/09) added this to bypass following if "{" not found for speed
LWebText = ReplaceStr(LWebText, "{STORE_NAME}", GetStoreName)
LWebText = ReplaceStr(LWebText, "{STORE_ADDRESS}", GetStoreAddressAsHTML)
LWebText = ReplaceStr(LWebText, "{STORE_EMAIL}", GetStoreEmail)
LWebText = ReplaceStr(LWebText, "{STORE_FAX}", GetStoreFax)
LWebText = ReplaceStr(LWebText, "{STORE_TELEPHONE}", GetStoreTelephone)
LWebText = ReplaceStr(LWebText, "{VAT_REG_NO}", GetStoreVATRegNo)
LWebText = ReplaceStr(LWebText, "{VAT_RATE}", (GetVATRate * 100) & "")
' (SS,16/6/09)
LWebText = ReplaceStr(LWebText, "{WORLDPAY_INSTALL_ID}", GetWorldPayInstallID)
If InStr(LWebText, "{DELIVERY_") > 0 Then ' (SS,22/6/10) added extra check before doing the following slower replacements becaus GetDeliveryMatrix runs queries
LWebText = ReplaceStr(LWebText, "{DELIVERY_PRICE_BASED}", GetDeliveryMatrix("P", "", True, True))
LWebText = ReplaceStr(LWebText, "{DELIVERY_WEIGHT_BASED}", GetDeliveryMatrix("W", "", True, True))
' (SS,19/6/09)
LWebText = ReplaceStr(LWebText, "{DELIVERY_PRICE_BASED_EXC_VAT}", GetDeliveryMatrix("P", "", False, True))
LWebText = ReplaceStr(LWebText, "{DELIVERY_WEIGHT_BASED_EXC_VAT}", GetDeliveryMatrix("W", "", False, True))
End If
' (SS,14/5/09)
' (SS,18/5/09) because GetDeliveryCostInfo is a time consuming routine we only want to call it if {DELIVERY_COST_INFO} is in the string
If InStr(LWebText, "{DELIVERY_COST_INFO}") > 0 Then
LWebText = ReplaceStr(LWebText, "{DELIVERY_COST_INFO}", GetDeliveryCostInfo)
End If
' (SS,10/8/17) added following for Bank Transfer details from settings
If InStr(LWebText, "{BANK_TRANSFER_DETAILS") > 0 Then
' (SS,29/9/17) modified to allow two different GBP accounts
LWebText = ReplaceStr(LWebText, "{BANK_TRANSFER_DETAILS}", BankTransferDetailsToHTML(GetBankTransferDetailsForCurrency("GBP", ""))) ' GBP account for overseas customers
LWebText = ReplaceStr(LWebText, "{BANK_TRANSFER_DETAILS_GBP}", BankTransferDetailsToHTML(GetBankTransferDetailsForCurrency("GBP", "United Kingdom"))) ' (SS,29/9/17) account for UK customers
LWebText = ReplaceStr(LWebText, "{BANK_TRANSFER_DETAILS_EUR}", BankTransferDetailsToHTML(GetBankTransferDetailsForCurrency("EUR", "")))
LWebText = ReplaceStr(LWebText, "{BANK_TRANSFER_DETAILS_USD}", BankTransferDetailsToHTML(GetBankTransferDetailsForCurrency("USD", "")))
End If
' (SS,19/2/13) for sitemap replace {SITEMAP} token with sitemap, and custom version from customutils.asp
' (SS,20/2/13) added bypassing of ComposeDescription because sitemap can become very big and cause ComposeDescription to be slow, e.g. 500K takes about 60 seconds
Dim LBypassComposeDesc
LBypassComposeDesc = False
If InStr(LWebText, "{SITEMAP}") > 0 Then
LWebText = ReplaceStr(LWebText, "{SITEMAP}", GetHTMLSiteMap)
LBypassComposeDesc = True
End If
If InStr(LWebText, "{CUSTOM-SITEMAP}") > 0 Then
LWebText = ReplaceStr(LWebText, "{CUSTOM-SITEMAP}", GetCustomHTMLSitemap)
LBypassComposeDesc = True
End If
' (SS,29/10/20) add following to get custom content from customutils.asp, repeats until no more found
' e.g. {CUSTOM#TESTIMONIALS}
' e.g. {CUSTOM#TESTIMONIALS,3}
Dim LCustomWebTextFound
Do
LCustomWebTextFound = ReplaceCustomWebText(LWebText)
If LCustomWebTextFound Then
LBypassComposeDesc = True ' don't run ComposeDescription
End If
Loop Until Not LCustomWebTextFound
' (SS,6/6/11) added following to process tables, bullets, and tokens, first False parameters means not to convert new lines to HTML
' (SS,20/2/13) added If condition for bypassing
If Not LBypassComposeDesc Then LWebText = ComposeDescription(LWebText, False, False)
Else ' (SS,22/9/11) added following to encode special characters like pound signs etc (ComposeDescription does it of the above condition)
LWebText = HTMLEncodeSpecialChars(LWebText)
End If
GetWebText = LWebText
End Function
' (SS,30/10/20) replaces the custom text, returns True if something was found and replaced, will be called repeatedly until nothing found
Function ReplaceCustomWebText(ByRef AWebText)
Dim Result
' (SS,29/10/20) add following to get custom content from customutils.asp
' e.g. {CUSTOM#TESTIMONIALS}
' e.g. {CUSTOM#TESTIMONIALS,3}
Dim LCustomToken
LCustomToken = "{CUSTOM#"
If InStr(AWebText, LCustomToken) > 0 Then
Result = True
Dim LPos, LFullToken, LCustomName, LCustomOptions, LCustomText, i, LLen, LChar, LOptionsFound
LPos = InStr(AWebText, LCustomToken)
' determine name, i.e. text after # and before , } or space
LCustomName = ""
LCustomOptions = ""
LOptionsFound = False
LLen = Len(AWebText)
For i = LPos + 8 To LLen
LChar = Mid(AWebText, i, 1)
LCustomToken = LCustomToken + LChar ' full custom token name to replace with custom text later
' exit if CR, NL, }
If LChar = Chr(13) Or LChar = Chr(10) Or LChar = "}" Then
Exit For
End If
' trigger options if comma found
If Not LOptionsFound And LChar = "," Then
LOptionsFound = True
Else
If LOptionsFound Then
LCustomOptions = LCustomOptions + LChar
Else
LCustomName = LCustomName + LChar
End If
End If
Next
' trim off the leading/trailing spaces
LCustomName = Trim(LCustomName)
LCustomOptions = Trim(LCustomOptions)
' if name specified then call the custom routine
LCustomText = ""
If LCustomName <> "" Then
If FunctionExists("CustomGetWebText") Then
LCustomText = CustomGetWebText(LCustomName, LCustomOptions)
End If
End If
' replace the special token with the custom text
AWebText = ReplaceStr(AWebText, LCustomToken, LCustomText)
'Response.Write "##3##" & BR
'Response.Write "##LCustomName##" & LCustomName & BR
'Response.Write "##LCustomOptions##" & LCustomOptions & BR
Else
Result = False
End If
ReplaceCustomWebText = Result
End Function
' (SS,30/10/20)
Sub StartSpecialProductList(ACategory, ASubcategory, AOptions)
Dim LSQL, LIsSearch, LIsSpecialOffer, LSummaryList, LProductsFound
LSQL = GetProductSearchSQL(False, "", ACategory, ASubcategory, "", "", "", "", "", "", LIsSearch, LIsSpecialOffer, LSummaryList, LProductsFound, True)
LSQL = "SELECT DISTINCT products.ProductID, products.ProductCode, products.SortOrder, ProductName, ProductDescription, Dimensions " & LSQL
' Response.Write "###LSQL: " & LSQL & "###" & BR
OpenQuery LSQL
End Sub
' (SS,30/10/20)
Function EndOfSpecialProductList
EndOfSpecialProductList = EndOfQuery
End Function
' (SS,30/10/20)
Sub GetSpecialProductListItem(ByRef AProductID, ByRef AProductCode, ByRef ASortOrder, ByRef AProductName, ByRef AProductDescription, ByRef ADimensions)
AProductID = GetQueryField("ProductID")
AProductCode = GetQueryField("ProductCode")
ASortOrder = GetQueryField("SortOrder")
AProductName = GetQueryField("ProductName")
AProductDescription = GetQueryField("ProductDescription")
ADimensions = GetQueryField("Dimensions")
End Sub
' (SS,1/10/20)
Sub NextSpecialProductList
NextQueryRecord
End Sub
' (SS,30/10/20)
Sub CloseSpecialProductList
CloseQuery
End Sub
' (SS,5/3/13) same as GetWebText but allows a default if GetWebText returns blank
Function GetWebTextDef(AWebTextCode, ADefault)
Dim LResult
LResult = GetWebText(AWebTextCode)
If LResult = "" Then LResult = ADefault
GetWebTextDef = LResult
End Function
' (SS,4/8/15) used to get content of a given token, can be called from inc-template..
Function GetTokenText(ATokenName)
Dim LResult
LResult = GetSiteDetail("Tokens", ATokenName)
LResult = ComposeDescription(LResult, False, False)
GetTokenText = LResult
End Function
' (SS,5/6/09) gets site detail directly, quicker than using GetWebText
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Function GetSiteDetail(AType, AName)
GetSiteDetail = NB(GetValueFromQuery("Text", "SELECT Text FROM sitedetails WHERE Type = '" & CleanSQLStr(AType) & "' AND Name = '" & CleanSQLStr(AName) & "'"))
End Function
' (SS,21/4/21) save a token value, (available to user to change)
' feature added when CIRC required ability to save last despatch date used
Sub SetTokenText(ATokenName, ATokenText)
Dim LSQL
LSQL = "UPDATE sitedetails SET Text = '" & CleanSQLStr(ATokenText) & "' WHERE Type = 'Tokens' AND Name = '" & CleanSQLStr(ATokenName) & "'"
ExecuteQuery LSQL
End Sub
' (SS,27/9/11) returns true if page exists in sitedetails table
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,17/1/13) modified so that it's only called once in a page request by using FPageExists variable, to prevent repetitive calls to query
' (SS,5/2/13) changed to return True if home page i.e. APageName is ""
Function PageExists(APageName)
If FPageExists = "" Then
' (SS,5/2/13) return true if there is no page name, i.e. it's the home page
If APageName = "" Then
FPageExists = True
Else
FPageExists = GetSQLValue("SELECT COUNT(*) FROM sitedetails WHERE Type = 'Page Content' AND Name = '" & CleanSQLStr(APageName) & "'") > 0
End If
End If
PageExists = FPageExists
End Function
' (SS,27/9/11) returns Heading and Text for page content
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Function GetPageContent(APageName, ByRef AHeading)
AHeading = GetSQLValueAsString("SELECT ExtraField2 FROM sitedetails WHERE Type = 'Page Content' AND Name = '" & CleanSQLStr(APageName) & "'")
GetPageContent = GetWebText(APageName) ' because it processes tokens etc. but could be an issue if same name exists in Page Content and Other
End Function
' (SS,30/10/23)
Function GetBlogPostContent(ABlogPostName, ByRef AHeading)
AHeading = GetSQLValueAsString("SELECT ExtraField2 FROM sitedetails WHERE Type = 'Blog Posts' AND Name = '" & CleanSQLStr(ABlogPostName) & "'")
GetBlogPostContent = GetWebText(ABlogPostName) ' because it processes tokens etc. but could be an issue if same name exists in Page Content and Other
End Function
' (SS,9/12/10) now calls ShowHighlightsMain
Sub ShowHighlights()
ShowHighlightsMain(False) ' False means normal type, not the new grid type
End Sub
' (SS,9/12/10) for new grid format
Sub ShowHighlightsGrid()
ShowHighlightsMain(True)
End Sub
' (SS,9/12/10) changed name from ShowHighlights to ShowHighlightsMain, added AIsGrid parameter because it can be used in normal mode and new grid mode
Sub ShowHighlightsMain(AIsGrid)
Dim LCount, LRecordCount, LProductCode, LProductName, LHighlightDescription, LSalePrice, LStdPrice, LNumInStock, LCategory, LSubcategory, LShowCategoryPicture, LGroup
' (SS,20/6/05) added SUBSTRING(highlights.ProductCode FROM 1 FOR 8) <> 'WEBTEXT-' '
' (SS,27/6/05) changed LEFT to INNER JOIN removed WEBTEXT etc because INNER JOIN does it'
' because of only showing matching products. This also fixes problem where invalid code '
' in highlights table.'
'OpenQuery("SELECT * FROM highlights INNER JOIN products ON products.ProductCode = highlights.ProductCode WHERE ShowThis <> 0 ORDER BY highlights.SortOrder, highlights.ProductCode")
' (SS,15/4/09) replaced above with following, data moved from highlights to sitedetails
'OpenQuery("SELECT sitedetails.Text AS Description, products.* FROM sitedetails INNER JOIN products ON products.ProductCode = sitedetails.Name WHERE Type = 'Featured Products' AND CheckBoxField <> 0 ORDER BY sitedetails.SortOrder, products.ProductCode")
' (SS,23/6/10) replaced above with following, now linking to suppliers table to get availability
Dim LSQL
' (SS,12/12/11) added "AND NOT products.ProductDisabled" to not show disabled products, i.e. not relying on user to untick show this on edit featured products
LSQL = "SELECT sitedetails.Text AS Description, products.*, " & GetStockAvailabilityFieldList &_
" FROM sitedetails" &_
" INNER JOIN products ON products.ProductCode = sitedetails.Name" &_
" LEFT JOIN suppliers ON suppliers.SupplierID = products.SupplierID" &_
" WHERE Type = 'Featured Products' AND CheckBoxField <> 0 AND NOT products.ProductDisabled" &_
" ORDER BY sitedetails.SortOrder, products.ProductCode"
OpenQuery(LSQL)
LRecordCount = GetQueryRecordCount
LCount = 0
If Not EndOfQuery Then
' (SS,9/12/10) added If AIsGrid.. to call different header for grid format
If AIsGrid Then
ShowHighlightsHeaderForGrid
Else
ShowHighlightsHeader
End If
Do While Not EndOfQuery
LCount = LCount + 1
' (SS,26/5/07) added following to allow templates to determine whether at first or last records
SetAtFirstOrLastProduct LCount, LRecordCount
LProductCode = GetQueryValue("ProductCode")
LProductName = HTMLEncode(GetQueryValue("ProductName")) ' (SS,26/7/11) added HTMLEncode
' (SS,1/6/04) added & "" after GetFieldValue("Description") to prevent Invalid use of null error '
'LHighlightDescription = ReplaceStr(GetFieldValue("Description") & "", Chr(13) & Chr(10), "<br>")
'(SS,8/5/06) replaced above with following due to new table feature
LHighlightDescription = GetFieldValue("Description") & ""
LHighlightDescription = ComposeDescription(LHighlightDescription, True, False)
' (SS,25/5/11) following two lines removed, now in ComposeDescription itself
'LHighlightDescription = ConvertNewlinesEtcToHTML(LHighlightDescription) ' (SS,,23/5/11) replaces Replace(LHighlightDescription, Chr(13) & Chr(10), "<br>")
'LHighlightDescription = Replace(LHighlightDescription, "@@@", NL) ' (SS,8/5/06) replaces special table newline with proper newline
LSalePrice = GetQueryValue("SalePrice")
LStdPrice = GetQueryValue("StdPrice")
LNumInStock = GetQueryValue("NumInStock")
SetProductDimensions(GetFieldValue("Dimensions")) ' (SS,9/7/07)
' (SS,19/9/06)
LStdPrice = CorrectCurrencyNV(LStdPrice)
LSalePrice = CorrectCurrencyNV(LSalePrice)
' (SS,11/2/05) added LGroup '
GetFirstCatSubcatForProduct LProductCode, LGroup, LCategory, LSubcategory
LShowCategoryPicture = PictureExists("C", LCategory, "")
' (SS,24/7/07) added following because ShowHighlightsItem will get the lowest price using
' (SS,6/7/11) removed 0 parameter, added False, no need to look up options price
GetPricingFromProductRecord(False)
' (SS,23/6/10) added following to get stock availability incase it's used to show on highlights or determine whether to show buy button
' SetStockAvailability must be before SetStockInfo because SetStockInfo might use the result of SetStockAvailability
SetStockAvailabilityFromFields
SetStockInfo LNumInStock, GetFieldValue("DateStockDue")
' (SS,9/12/10) added If AIsGrid.. to call different routine for grid format
If AIsGrid Then
ShowHighlightsItemForGrid LCount, LProductCode, LProductName, LHighlightDescription, LSalePrice, LStdPrice, LNumInStock, LCategory, LSubcategory, LShowCategoryPicture
Else
ShowHighlightsItem LCount, LProductCode, LProductName, LHighlightDescription, LSalePrice, LStdPrice, LNumInStock, LCategory, LSubcategory, LShowCategoryPicture
End If
NextQueryRecord
Loop
' (SS,9/12/10) added If AIsGrid.. to call different footer for grid format
If AIsGrid Then
ShowHighlightsFooterForGrid
Else
ShowHighlightsFooter ' (SS,27/6/05) moved here from after CloseDatabase so this is only shown if header is shown
End If
End If
CloseQuery
End Sub
Sub SaveSettingsForContinue()
Session("Search") = strSearch
Session("Page") = strPage
Session("Category") = strCategory
Session("Subcategory") = strSubcategory
End Sub
Sub GetSettingsForContinue()
strSearch = Session("Search")
strPage = Session("Page")
strCategory = Session("Category")
strSubcategory = Session("Subcategory")
End Sub
Sub AddSearchToLog()
' (SS,17/12/10) modified to only log when strSearch is not blank and not
Dim LSQL
' (SS,18/1/13) added NEW_PRODUCTS_SEARCH_TEXT
If strSearch <> "" And LCase(strSearch) <> SPECIAL_OFFERS_SEARCH_TEXT And LCase(strSearch) <> NEW_PRODUCTS_SEARCH_TEXT Then
' (SS,17/12/10) removed saving of category and subcategory (", Category='" & CleanSQLStr(strCategory) & "', Subcategory='" & CleanSQLStr(strSubcategory) & "'")
' table no longer contains these fields
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,5/8/22) replaced CleanSQLStr(strSearch) with CleanSQLStrMax(strSearch, 100) to prevent "Data too long for column 'Search'" when more than 100 characters entered, rare but has happened at least once (for CIRC)
LSQL = "INSERT INTO searchlog SET SessionID='" & CleanSQLStr(FSessionID) & "', Search='" & CleanSQLStrMax(strSearch, 100) & "', Page='" & CleanSQLStr(strPage) & "'"
LSQL = LSQL + ", VisitorIP='" & CleanSQLStr(Request.ServerVariables("REMOTE_ADDR")) & "', ClientWidth='" & CleanSQLStr(strClientWidth) & "', ClientHeight='" & CleanSQLStr(strClientHeight) & "'"
ExecuteQuery LSQL
'Response.Write gsADOErrors ' (SS,17/12/10) removed
End If
End Sub
' (SS,12/4/19) a new search (used by Facebook Pixel 'Search' event)
Function IsNewSearch
Dim LSearch, LPageNo
LSearch = GetSearch
LPageNo = CleanRequestQueryString("pageno")
IsNewSearch = LSearch <> "" And LCase(LSearch) <> SPECIAL_OFFERS_SEARCH_TEXT And LCase(LSearch) <> NEW_PRODUCTS_SEARCH_TEXT And LPageNo = ""
End Function
' (SS,22/9/09) returns True if given product code is found and enabled
' (SS,12/6/12) added CleanSQLStr before AProductCode to prevent SQL injection
Function CheckEnabledProductExists(AProductCode)
CheckEnabledProductExists = GetValueFromQuery("NoRecs", "SELECT COUNT(*) AS NoRecs FROM products WHERE ProductCode = '" & CleanSQLStr(AProductCode) & "' AND ProductDisabled = 0") > 0
End Function
' (SS,22/9/09) returns search phrase from search engine referrer, blank if it doesn't exist
' looks for this in the q= query string
Function GetSearchForPhraseFromReferrer
Dim LReferrer
LReferrer = LCase(Request.ServerVariables("HTTP_REFERER"))
Dim LStoreURL
LStoreURL = LCase(GetStoreURL)
GetSearchForPhraseFromReferrer = ""
' if referrer is same as this site or blank the return with blank
If LReferrer = "" Or Left(LReferrer, Len(LStoreURL)) = LStoreURL Then Exit Function
' to get the search phrase, look for ?q= or &q= until end of string or &
Dim LPos
LPos = InStr(LReferrer, "?q=")
If LPos = 0 Then LPos = InStr(LReferrer, "&q=")
If LPos = 0 Then Exit Function ' if q= not found then return blank
' get the bit after q= and before next =
LPos = LPos + 3 ' position after the =
Dim LSearchFor, LReferrerLen
LReferrerLen = Len(LReferrer)
LSearchFor = ""
Do While LPos <= LReferrerLen And Mid(LReferrer, LPos, 1) <> "&"
LSearchFor = LSearchFor + Mid(LReferrer, LPos, 1)
LPos = LPos + 1
Loop
LSearchFor = URLDecode(LSearchFor) ' decode so that + become spaces
GetSearchForPhraseFromReferrer = LSearchFor
End Function
' (SS,12/9/12) added this to allow redirection to product page
' gets called when search results in a single product
' which is better because it prevents an extra "Product Search" header from being shown.
' it also helps with recently viewed items because we can get the current product code from querystring
' rather than relying on SetProductCode which can also set the global product code variable when parsing list of products
Sub SingleProductRedirect(AProductCode)
Response.Redirect GetProductLink(AProductCode)
End Sub
' (SS,25/5/21) changed to not show IsLocalModeProduct when not in local mode
Sub ShowSingleProduct(AProductCode)
' (SS,15/2/12) when doing a search the query string will not contain a code, but we need to tell other routines
' which product code we've chosen to go to, because this routine might have been called by a search where single product was found
SetProductCode AProductCode
' find the product, show info if product exists '
' (SS,23/6/10) modified to add stock availability which includes added join to new suppliers table
' was OpenQuery("SELECT * FROM products WHERE ProductCode = """ & AProductCode & """ AND ProductDisabled = 0")
' (SS,12/6/12) added CleanSQLStr before AProductCode to prevent SQL injection
' (SS,27/10/20) replaced ProductDisabled = 0 with ProductDisabled = FALSE for readability
' (SS,10/10/23) added brands.BrandName via new join to brands table, used later to pass onto GTM view_item event
Dim LSQL
LSQL = "SELECT products.*, brands.BrandName, " & GetStockAvailabilityFieldList &_
" FROM products" &_
" LEFT JOIN brands ON brands.BrandID = products.BrandID" &_
" LEFT JOIN suppliers ON suppliers.SupplierID = products.SupplierID" &_
" WHERE ProductCode = '" & CleanSQLStr(AProductCode) & "' AND ProductDisabled = FALSE"
' (SS,25/5/21) added following to not show IsLocalModeProduct when not in local mode
If LocalModeEnabled Then
If Not IsLocalMode Then
LSQL = LSQL & " AND NOT IsLocalModeProduct"
End If
End If
OpenQuery(LSQL)
If EndOfQuery Then
CloseQuery
' (SS,27/10/20) added following to check if product belongs to a special disabled category, and show it if it does
' open same query but with ProductDisabled = TRUE
LSQL = ReplaceStr(LSQL, " ProductDisabled = FALSE", " ProductDisabled = TRUE")
OpenQuery(LSQL)
Dim LFound
If EndOfQuery Then
LFound = False
Else
LFound = IsProductSpecialCategory(AProductCode)
End If
' (SS,27/10/20) added If Not LFound, rest as before
If Not LFound Then
ShowProductDetailNotFound HTMLEncode(AProductCode) ' (SS,24/8/17) added HTMLEncode to prevent xss injection
Exit Sub
End If
End If
' (SS,4/6/09)
AddToRecentlyViewed AProductCode
' get query values before closing query '
' (SS,30/6/11) added ProductID, this will be the primary key in future, instead of ProductCode
' (SS,10/10/23) added LBrandName, LProductName no longer HTML encoded
Dim LProductID, LProductName, LProductDesc, LBrandName, LDimensions, LSalePrice, LStdPrice, LNumInStock, LNew
LProductID = GetFieldValue("ProductID") ' (SS,30/6/11)
LProductName = GetFieldValue("ProductName") ' (SS,10/10/23) removed HTMLEncode
LDimensions = GetFieldValue("Dimensions")
LProductDesc = GetFieldValue("ProductDescription")
LBrandName = GetFieldValue("BrandName") ' (SS,10/10/23) added to pass onto GTM event
LSalePrice = GetFieldValue("SalePrice")
LStdPrice = GetFieldValue("StdPrice")
LNumInStock = GetFieldValue("NumInStock")
LNew = GetFieldValue("New") <> 0
' (SS,18/5/07) to handle 3 new price fields, discount and VATBand
' (SS,6/7/11) removed 0 parameter, added False, no need to look up options price
GetPricingFromProductRecord(False)
' (SS,23/6/10) must be before SetStockInfo because SetStockInfo might use the result of SetStockAvailability
SetStockAvailabilityFromFields
' (SS,16/11/07)
SetStockInfo LNumInStock, GetFieldValue("DateStockDue")
CloseQuery
' determine if larger picture exists, set flag if it does
Dim LShowLarge, LWidth, LHeight
' (SS,8/8/18) commented out following, now redundant, not used since RWD framework, LShowLarge, LWidth, LHeight will now have undefined values when passed to ShowTheProductDetail
'GetProductPictureSize AProductCode, LWidth, LHeight
' (SS,30/5/07) replaced LARGE_THUMBNAIL_WIDTH with FLargeThumbnailWidth and LARGE_THUMBNAIL_HEIGHT with FLargeThumbnailHeight
'LShowLarge = LWidth > LargeThumbnailWidth Or LHeight > LargeThumbnailHeight
' find the main category and subcategory of the product '
' (SS,11/2/05) added LGroup '
Dim LGroup, LCategory, LSubcategory
' GetFirstCatSubcatForProduct AProductCode, LGroup, LCategory, LSubcategory
' (SS,1/8/11) replaced above with following, because we want to show the path taken to get to product, rather then the first cat/subcat
GetBreadcrumbGroupCatSubcatForProduct AProductCode, LGroup, LCategory, LSubcategory
' show the you are here category and subcategory '
ShowProductDetailYouAreHere LGroup, LCategory, LSubcategory
' show the main details of the product '
' (SS,18/9/06) added CorrectCurrency
LStdPrice = CorrectCurrencyNV(GetStdPrice)
LSalePrice = CorrectCurrencyNV(GetSalePrice)
LProductDesc = ComposeDescription(LProductDesc, True, False) ' (SS,28/4/06), (SS,3/6/11) added False parameter
'LProductDesc = Replace(LProductDesc, Chr(13) & Chr(10), "<br>") '(SS,29/4/06) moved here due to ComposeTables added above
' (SS,25/5/11) following two lines removed, now in ComposeDescription itself
'LProductDesc = ConvertNewlinesEtcToHTML(LProductDesc) ' (SS,17/5/11) replaced above with this, which also does quotes and pounds
'LProductDesc = Replace(LProductDesc, "@@@", NL) ' (SS,29/4/06) replaces special table newline with proper newline
' (SS,18/5/09) renamed ShowProductDetail to ShowTheProductDetail
' (SS,30/6/11) added LProductID
' (SS,10/10/23) added LBrandName, LProductName (now without HTMLEncode)
ShowTheProductDetail LProductID, AProductCode, LProductName, LProductDesc, LBrandName, LDimensions, LSalePrice, LStdPrice, LNumInStock, LNew, LCategory, LSubcategory, LShowLarge, LWidth, LHeight
' (SS,13/5/11) moved ShowProductDetailViewOtherProductsHeader code from below to ShowTheProductDetail routine
End Sub
' --- START OF TABLE COMPOSING ROUTINES ---
' (SS,29/4/06) to allow creation of tables from comma separated text in description of product
' syntax:
' {table title="This is a title" class=abc cols=3 width=200,,100 align=c,l,r nowrap separator=~ option=altrow}
' #Heading
' 1,2,3
' 4,5,6
' 7,8,9
' {endtable}
'
' If no parameters are defined i.e. {table} is used it's own,
' defaults will be used. Which are 2 columns, no title,
' no widths assigned, no aligns assigned, separator is a comma,
' nowrap is not set. Classes used will be tbl-title, tbl-col1,
' tbl-col2, tbl-col3..., tbl-colhd1, tbl-colhd2, tbl-colhd3...,
' if option=altrow used, then alternative rows will use classes
' tbl-col1b, tbl-col2b, tbl-col3b...
' When there isn't enough data for all columns, the last one
' will have a colspan to fill in the missing columns.
' To use different sets of classes for diffent tables,
' class parameter can be used. E.g. class=abc will set the
' classes used by the table to be:
' tbl-abc-title, tbl-abc-col1, tbl-abc-col2, tbl-abc-colhd1,
' tbl-abc-colhd1, tbl-abc-col1b, tbl-abc-col2b, etc.
' If the first column in a row is preceded with "#" then
' it gets treated as a header row, using classes tbl-colhd1 etc.
' The title parameter creates a special title row with one column
' spanning to the last column with class tbl-title.
' The separator, e.g. comma can be used in the cell data
' if the cell data is surrounded by quotes. E.g. "This is, a cell"
' will create one cell with "This is, a cell" (quotes will be removed),
' instead of two cells, one containing "This is", second one
' containing "a cell". If the cell data in the last column
' contains a separator then this is ignored, i.e. is used as
' part of the cell data instead of creating a new column.
' (SS,2/2/12) new autohref functionality added first row containing autohref=2 where number is the column
' this automatically tries to add ahref to comma separated list of products
' (SS,8/7/07) new function to replace ComposeTables, now also composes bullet
' (SS,14/4/11) added token facility
' (SS,25/5/11) now also does the newline, and special char adjustments, also added code to handle null value
' (SS,3/6/11) had issues with too many <br />'s, NLs which shouldn't breaks, fixed
' by adding new AFromReplaceTokens parameter, which is false for main call, True when called from ReplaceTokens
' (SS,6/6/11) added AConvertNewLines parameter to keep new lines as they are when calling from GetWebText
' (SS,16/6/11) added called to RemoveHashCommentLines
Function ComposeDescription(ADesc, AConvertNewLines, AFromReplaceTokens)
Dim LConvertNewLines
LConvertNewLines = AConvertNewLines ' (SS,30/7/15) can now be changed by hash comment option in token NCNL which stands for no convert new lines
Dim LDesc
If IsNull(ADesc) Then
LDesc = ""
Else
LDesc = ADesc
End If
If LDesc <> "" Then
LDesc = ComposeDescWith(LDesc, "record", "endrecord", "GetRecordHTML") ' (SS,28/4/17) fetch values from record into session
LDesc = ComposeDescWith(LDesc, "action", "endaction", "GetActionHTML") ' (SS,13/12/18) to run a specific action e.g. rename a product see function GetActionHTML
LDesc = ComposeDescWith(LDesc, "table", "endtable", "GetTableHTML")
LDesc = ComposeDescWith(LDesc, "bullet", "endbullet", "GetBulletHTML")
' (SS,16/6/11) removes all lines beginning with #, must be after ComposeDescWith for tables, because # is a heading line in tables
' (SS,4/8/15) moved here from below LDesc = HTMLEncodeSpecialChars(LDesc), because we want to do it before ReplaceTokens, to take effect as early as possible
LDesc = RemoveHashCommentLines(LDesc)
LDesc = ReplaceTokens(LDesc) ' (SS,14/4/11) replaces all curly bracket tokens with text held in site details table
' (SS,25/5/11) following two lines moved here from after calls to ComposeDescription, don't know why they weren't here in the first place
'LDesc = ConvertNewlinesEtcToHTML(LDesc) ' (SS,17/5/11) also does quotes and pounds and other special characters
' (SS,6/6/11) replaced above with following to only convert new lines when AConvertNewLines is True
LDesc = HTMLEncodeSpecialChars(LDesc) ' (SS,22/2/13) NB. this routine will be slow if run on large amounts of text because it works char by char e.g. 2 to 5 secs on 100KB
' (SS,16/6/11) removes all lines beginning with #, must be after ComposeDescWith for tables, because # is a heading line in tables
' (SS,4/8/15) moved above, before ReplaceTokens
'LDesc = RemoveHashCommentLines(LDesc)
' (SS,30/7/15) for tokens, if NCNL found in hash comment line e.g. #OPTION NCNL then don't convert newlines into HTML BRs
' (SS,4/8/15) removed AFromReplaceTokens replaced with LConvertNewLines
If LConvertNewLines Then
If IsHashCommentLineOption("NCNL") Then LConvertNewLines = False
End If
If LConvertNewLines Then LDesc = ConvertNewlinesToHTML(LDesc)
' (SS,29/4/06) replaces special table newline with proper newline
' (SS,3/6/11) added If Not AFromReplaceTokens to ensure this is only done by the root call, otherwise we'll end up with too many <br>s, we want the newlines in bullets and tables to remain newlines
If Not AFromReplaceTokens Then
LDesc = Replace(LDesc, NEW_LINE_FIX, NL)
LDesc = RemoveBlankTableRows(LDesc) ' (SS,14/12/18) removes blank table rows, i.e. those contained special token REMOVE_BLANK_ROW
End If
End If
ComposeDescription = LDesc
End Function
' (SS,8/7/07) renamed from ComposeTables to ComposeDescWith
' made it general purpose to work with other types besides tables
' original parameter was ADesc, added AStartToken, AEndToken, AFunction
Function ComposeDescWith(ADesc, AStartToken, AEndToken, AFunction)
Dim LDesc, LNewDesc, LStart, LEnd
LDesc = ADesc
If IsNull(LDesc) Then LDesc = "" ' (SS,17/5/07) bug fix ADesc being Null was causing endless loop
LNewDesc = ""
Do
LStart = GetTokenStart(LDesc, AStartToken)
LEnd = GetTokenEnd(LDesc, AEndToken)
If (LStart > 0) And (LEnd > 0) And (LStart < LEnd) Then
' (SS,1/8/07) replaced GetTableHTML(Mid.. with Eval(AFunction + "(Mid..
' (SS,6/6/11) added AStartToken, AEndToken to call to function, used by GetBulletHTML and GetTableHTML
LNewDesc = LNewDesc + Mid(LDesc, 1, LStart - 1) + Eval(AFunction + "(Mid(LDesc, LStart, LEnd - LStart + 1), AStartToken, AEndToken)")
LDesc = Mid(LDesc, LEnd + 1)
End If
Loop Until LStart = 0 Or LEnd = 0 Or LStart > LEnd
ComposeDescWith = LNewDesc + LDesc
End Function
' (SS,16/6/11) removes all lines beginning with hash, i.e. comments used in tokens, product descriptions etc.
' (SS,22/8/14) allows special #SECTION used to separate sections, replaced with HTML comment
Function RemoveHashCommentLines(AText)
Dim LResult
LResult = AText
' (SS,19/4/12) added Not HasScriptOrStyle(AText) to not ignore # in such cases because # has a special meaning in such cases
If InStr(AText, "#") > 0 And Not HasScriptOrStyle(AText) Then
Dim i, LLines, LLastLine, LTrimLine
LLines = Split(AText, NL, -1, 0)
LResult = ""
LLastLine = UBound(LLines)
For i = LBound(LLines) to UBound(LLines)
LTrimLine = Trim(LLines(i))
If Left(LTrimLine, 1) <> "#" Then
LResult = LResult & LLines(i) & IIf(i = LLastLine, "", NL) ' only add newline if not last line to avoid extra newline
' (SS,22/8/14) added following to convert special #SECTION to HTML comment which is used by inc-template-product-details to separate description into sections
ElseIf UCase(Left(LTrimLine, 9)) = "#SECTION " Then
LResult = LResult & NEW_LINE_FIX & ReplaceStr(LTrimLine, "#SECTION ", "<!--SECTION ") & "-->" & NEW_LINE_FIX
' (SS,30/7/15) added following to allow options, converts to HTML comment
ElseIf UCase(Left(LTrimLine, 9)) = "#OPTIONS " Then
LResult = LResult & NEW_LINE_FIX & ReplaceStr(LTrimLine, "#OPTIONS ", "<!--OPTIONS ") & "-->" & NEW_LINE_FIX
SetHashCommentLineOptions Trim(UCase(Mid(LTrimLine, 10)))
End If
Next
End If
RemoveHashCommentLines = LResult
End Function
' (SS,30/7/15) sets options held in description / token text i.e. the bit after #OPTIONS
Sub SetHashCommentLineOptions(AOptions)
FHashCommentLineOptions = "," & AOptions & ","
End Sub
' (SS,30/7/15) returns options held in description / token text i.e. the bit after #OPTIONS
Function GetHashCommentLineOptions
GetHashCommentLineOptions = FHashCommentLineOptions
End Function
' (SS,30/7/15) returns true if given option exists in comma separated list
Function IsHashCommentLineOption(AOption)
IsHashCommentLineOption = InStr("," + FHashCommentLineOptions + ",", "," + UCase(AOption) + ",")
End Function
' (SS,14/12/18) removes blank table rows, i.e. those contained special token REMOVE_BLANK_ROW
Function RemoveBlankTableRows(AText)
Dim LResult, LPos
LResult = AText ' default to return whole string
LPos = InStr(AText, REMOVE_BLANK_ROW)
If LPos > 0 Then
Dim LRecStart, LRecEnd
' find the <tr> before and </tr> after
LRecStart = InStrRev(AText, "<tr>", LPos)
LRecEnd = InStr(LPos, AText, "</tr>" & NL)
' if row delimiters found then remove
If LRecStart <> 0 and LRecEnd <> 0 Then
LResult = Mid(AText, 1, LRecStart - 1) + Mid(AText, LRecEnd + 7, Len(AText))
End If
End If
' (SS,14/12/18) call recursively until no change i.e. all occurrences removed
If AText <> LResult Then
LResult = RemoveBlankTableRows(LResult)
End If
RemoveBlankTableRows = LResult
End Function
' first line and last line are tokens, beginning with {table} ending with {endtable)
' (SS,3/6/11) LNewLineFix replaced with NEW_LINE_FIX constant
' (SS,6/6/11) added AStartToken, AEndToken parameters which will contain starttable and endtable
' (SS,8/6/11) fixed issue that was introduced by allowing first line to contain a table row, this caused extra line to be added
' (SS,2/2/12) added auto href feature to automatically try to add ahref links to comma separated list of products
' (SS,22/8/14) added ability to get a custom table using CustomGetTableHTML if type=custom exists in the setting
' (SS,18/6/15) changed to work with RWD (Bootstrap) which has it's own special table classes
Function GetTableHTML(AStr, AStartToken, AEndToken)
Dim LStr, LLines, LCols, Result, LLine, LPos, LCell, LClass, r, c, n, LLen, LStart, LQuoted, LChar
Dim LHeading, LTitle, LFirstLine, LType, LClassPrefix, LWidth, LAlign, LNoWrap, LSeparator, LOption
Dim LWidths, LAligns, LNoWraps, LClassSet, LColspanSet, LWidthSet, LAlignSet, LNoWrapSet, LAlignVal, LAlternateRow, LNilClass
LStr = Replace(AStr, "{" + AEndToken + "}", "", 1, 1, 1) ' (SS,6/6/11) {endtable} is replaced with blank to allow last line to be part of table
LLines = Split(LStr, NL, -1, 0)
LFirstLine = LLines(0)
LTitle = GetTableSetting(LFirstLine, "title")
' (SS,22/8/14) added ability to get a custom table using CustomGetTableHTML
LType = LCase(GetTableSetting(LFirstLine, "type"))
If LType = "custom" Then
If FunctionExists("CustomGetTableHTML") Then
GetTableHTML = CustomGetTableHTML(LTitle)
Else
GetTableHTML = ""
End If
Exit Function
End If
LClassPrefix = GetTableSetting(LFirstLine, "class")
LNilClass = LCase(LClassPrefix) = "nil"
If LClassPrefix <> "" Then LClassPrefix = "-" + LClassPrefix
LCols = GetTableSetting(LFirstLine, "cols")
If LCols = "" Or Not IsNumeric(LCols) Then
LCols = 2
Else
LCols = CLng(LCols)
If LCols < 1 Then LCols = 1 ' don't allow less than 1 column
If LCols > 100 Then LCols = 100 ' don't allow over 100 columns
End If
LWidth = GetTableSetting(LFirstLine, "width")
If LWidth <> "" Then LWidths = Split(LWidth, ",")
LAlign = GetTableSetting(LFirstLine, "align")
If LAlign <> "" Then LAligns = Split(LAlign, ",")
LNoWrap = GetTableSetting(LFirstLine, "nowrap")
If LNoWrap <> "" Then LNoWraps = Split(LNoWrap, ",")
' (SS,2/2/12) added following to do an auto href using product names for specified column, e.g. autohref=2 to do auto hrefs for column 2
Dim LAutoHRefCol
LAutoHRefCol = GetTableSetting(LFirstLine, "autohref")
If LAutoHRefCol = "" Then
LAutoHRefCol = 0
Else
LAutoHRefCol = CInt(LAutoHRefCol)
End If
LSeparator = GetTableSetting(LFirstLine, "separator")
If LSeparator = "" Then LSeparator = ","
LOption = GetTableSetting(LFirstLine, "option")
' check for alternate row option
If InStr(1, "," + LOption + ",", ",altrow,", 1) > 0 Then
LAlternateRow = True
Else
LAlternateRow = False
End If
' (SS,18/6/15) different main and title class for RWD (i.e. Bootstrap), also th used instead of td in RWD
Dim LMainClass, LTitleClass, LTitleCellTag, LHeadingColCellTag
If IsRWD Then
' table-description is a special class that can be defined for use just in description tables
' (SS,7/6/17) removed table-striped after table-description, added table-bordered because border from bottom and left and right are not added by default, affects all site, may need to make optional ***
LMainClass = " class=""table table-description table-bordered table-condensed table-responsive"""
LTitleClass = ""
LTitleCellTag = "th"
LHeadingColCellTag = "th"
Else ' (SS,18/6/15) same as before for backward compatibility
LMainClass = Iif(LNilClass, "", " class=""tbl" + LClassPrefix + "-main""")
LTitleClass = Iif(LNilClass, "", " class=""tbl" + LClassPrefix + "-title""")
LTitleCellTag = "td"
LHeadingColCellTag = "td"
End If
' (SS,18/6/15) in following line replaced Iif(LNilClass, "", " class=""tbl" + LClassPrefix + "-main""") with LMainClass
Result = NEW_LINE_FIX + "<table" & LMainClass + ">" + NEW_LINE_FIX ' (SS,2/5/06) added new tbl-main class
If LTitle <> "" Then
' (SS,18/6/15) replaced Iif(LNilClass, "", " class=""tbl" + LClassPrefix + "-title""") with LTitleClass
' (SS,18/6/15) replaced td with LTitleCell
Result = Result + "<tr><" + LTitleCellTag + LTitleClass + " colspan=""" & LCols & """>" + LTitle + "</" & LTitleCellTag + "></tr>" + NEW_LINE_FIX
End If
' (SS,6/6/11) last line is ignored it it's blank, to allow last row to end in {endtable}
Dim LIgnoreLastLine
If Trim(LLines(UBound(LLines))) = "" Then
LIgnoreLastLine = 1
Else
LIgnoreLastLine = 0
End If
' (SS,18/6/15)
Dim LIsFirstCell, LCellTag
' (SS,6/6/11) replaced - 1 with LIgnoreLastLine to allow last row to contain {endtable}
For r = LBound(LLines) + 1 to UBound(LLines) - LIgnoreLastLine
LLine = Trim(LLines(r))
' Response.Write "[#" & r & "#" & LLine & "]" & BR ' *** debug code
Result = Result + "<tr>" + NEW_LINE_FIX
If Left(LLine, 1) = "#" Then
LHeading = True
LLine = Mid(LLine, 2) ' remove the leading #
Else
LHeading = False
End If
For c = 1 to LCols
' (SS,18/6/15) to allow first cell to be a th instead of td (in RWD)
LIsFirstCell = c = 1
If LIsFirstCell Or LHeading Then
LCellTag = LHeadingColCellTag
Else
LCellTag = "td"
End If
LPos = InStr(LLine, LSeparator)
If LPos = 0 Then
LCell = LLine
LLine = ""
Else
' ignore leading spaces
LLen = Len(LLine)
For n = 1 To LLen
If Mid(LLine, n, 1) <> " " Then Exit For
Next
LStart = n
If Mid(LLine, LStart, 1) = """" Then
LStart = LStart + 1 ' ignore leading quote
LQuoted = True
Else
LQuoted = False
End If
If c = LCols Then ' if last column take all remaining as the cell content
LCell = Trim(Mid(LLine, LStart))
' if it started with quoted then remove last quote
If LQuoted And Right(LCell, 1) = """" Then
LCell = Left(LCell, Len(LCell) - 1)
End If
Else
LCell = Mid(LLine, 1, LPos - 1)
LCell = ""
' add to string until quote or end reached
For n = LStart To LLen
LChar = Mid(LLine, n, 1)
If LQuoted And LChar = """" Then Exit For
If Not LQuoted And LChar = LSeparator Then Exit For ' if not quoted and separator then exit
LCell = LCell + LChar
Next
LLine = Trim(Mid(LLine, n + 1)) ' move to next char after separator, or quote if quoted string
If LQuoted And Mid(LLine, 1, 1) = LSeparator Then LLine = Trim(Mid(LLine, 2)) ' if was quoted then also remove the following separator
End If
End If
' (SS,2/2/12) adds href links to each comma separated item, matching with product name
If c = LAutoHRefCol Then
LCell = AddAutoProductHRefs(LCell)
End If
' set class
LClass = "tbl" + LClassPrefix
If LHeading Then
LClass = LClass + "-colhd"
Else
LClass = LClass + "-col"
End If
LClass = LClass & c
If LAlternateRow And (r Mod 2) = 0 Then LClass = LClass + "b"
' set width
LWidthSet = ""
If LWidth <> "" Then
If c <= UBound(LWidths) + 1 Then
If LWidths(c - 1) <> "" Then
LWidthSet = " width=""" + LWidths(c - 1) & """"
End If
End If
End If
' set align
LAlignSet = ""
If LAlign <> "" Then
If c <= UBound(LAligns) + 1 Then
If LAligns(c - 1) <> "" Then
Select Case UCase(LAligns(c - 1))
Case "C"
LAlignVal = "center"
Case "R"
LAlignVal = "right"
Case Else
LAlignVal = "left"
End Select
End If
' (SS,18/6/15) added IsRWD for align in Bootstrap
If IsRWD Then
LAlignSet = "text-" + LAlignVal ' sets the class to use
Else
LAlignSet = " align=""" + LAlignVal + """"
End If
End If
End If
' set nowrap
LNoWrapSet = ""
If LNoWrap <> "" Then
If c <= UBound(LNoWraps) + 1 Then
If LCase(LNoWraps(c - 1)) = "y" Then
LNoWrapSet = " nowrap"
End if
End If
End If
' set colspan for remaining columns
If LLine = "" And c < LCols Then
LColspanSet = " colspan=""" & LCols - c + 1 & """"
Else
LColspanSet = ""
End If
' if class is set to nil then don't apply the class
' (SS,18/6/15) added settings RWD, i.e. not normally, but alignment class if set
If IsRWD Then
' for align settings we use the class set in LAlignSet
If LAlignSet <> "" Then
LClassSet = " class=""" + LAlignSet + """"
LAlignSet = "" ' clear this so that it's not applied again below
Else
LClassSet = ""
End If
ElseIf LNilClass Then
LClassSet = ""
Else
LClassSet = " class=""" + LClass + """"
End If
' (SS,18/6/15) replaced "td" with LCellTag
Result = Result + "<" + LCellTag + LClassSet + LColspanSet + LWidthSet + LAlignSet + LNoWrapSet + ">" + LCell + "</" + LCellTag + ">" + NEW_LINE_FIX
If LLine = "" Then Exit For ' if nothing remaining then exit the column loop
Next
Result = Result + "</tr>" + NEW_LINE_FIX
Next
Result = Result + "</table>" + NEW_LINE_FIX
GetTableHTML = Result
End Function
Function GetTableSetting(AStr, AType)
Dim LPos, Result, i, LLen, LStart, LQuoted, LChar
LPos = InStr(1, AStr, " " + AType + "=", 1)
If LPos > 0 Then
LLen = Len(AStr)
LStart = LPos + Len(AType) + 2
' ignore leading spaces
For i = LStart To LLen
If Mid(AStr, i, 1) <> " " Then Exit For
Next
LStart = i
If Mid(AStr, LStart, 1) = """" Then
LStart = LStart + 1 ' ignore leading quote
LQuoted = True
Else
LQuoted = False
End If
Result = ""
' add to string until quote or end reached
For i = LStart To LLen
LChar = Mid(AStr, i, 1)
If LChar = """" Or LChar = "}" Then Exit For
If LChar = " " And Not LQuoted Then Exit For ' if not quoted and space then exit
Result = Result + LChar
Next
Else
Result = ""
End If
' (SS,28/4/17) if a token with square brackets is contained within this e.g. title="[FT, ProductName]" then run the ReplaceTokens function to replace the tokens e.g. fetch field value
LPos = InStr(Result, "[")
If LPos > 0 Then
' replace square brackets with curly which are understood by ReplaceTokens
Result = ReplaceStr(Result, "[", "{")
Result = ReplaceStr(Result, "]", "}")
' replace single quote with double, allows quotes within the token
Result = ReplaceStr(Result, "'", """")
' handle the token
Result = ReplaceTokens(Result)
End If
GetTableSetting = Result
End Function
' (SS,2/2/12) for new autohref in description tables
Function AddAutoProductHRefs(AList)
Dim Result, LListArray, i, LName, LNameBeforeAsterisk, LPos, LCode
Result = ""
If AList <> "" Then
LListArray = Split(AList, ",")
For i = 0 To UBound(LListArray)
LName = Trim(LListArray(i))
LPos = InStr(LName, "*")
If LPos > 0 Then
LNameBeforeAsterisk = Left(LName, LPos - 1)
Else
LNameBeforeAsterisk = LName
End If
LCode = GetProductCodeForAutoHRef(LNameBeforeAsterisk)
If LCode <> "" Then
Result = Result + "<a href=""" + GetProductLink(LCode) + """>" + LName + "</a>"
Else
Result = Result + LName
End If
If i <> UBound(LListArray) Then Result = Result + ", " ' add comma and space if not at last
Next
End If
AddAutoProductHRefs = Result
End Function
' (SS,2/2/12) for new autohref in description tables
Function GetProductCodeForAutoHRef(AValue)
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
GetProductCodeForAutoHRef = GetSQLValueAsString("SELECT ProductCode FROM products WHERE ProductName LIKE '" & CleanSQLStr(AValue) & "%' AND Not ProductDisabled" + GetProductsFilter)
End Function
' (SS,31/8/12) returns product code for given product name, blank string is returned if not found
Function GetProductCodeForName(AValue)
GetProductCodeForName = GetSQLValueAsString("SELECT ProductCode FROM products WHERE ProductName = '" & CleanSQLStr(AValue) & "' AND Not ProductDisabled")
End Function
' (SS,1/8/07) first line and last line are tokens, beginning with {bullet} ending with {endbullet)
' (SS,3/6/11) NL_FIX replaced with NEW_LINE_FIX global constant
' (SS,6/6/11) added AStartToken, AEndToken, also modified to allow {endbullet} to work on same line as bullet line
' (SS,9/3/16) modified to allow embedded bullet points via token
Function GetBulletHTML(AStr, AStartToken, AEndToken)
Dim LStr, LLines, Result, r
Dim LLine, LToken, LLines2, LLine2, t ' (SS,9/3/16)
' (SS,6/6/11) remove the {bullet} and {endbullet} to allow use on same line as bullet line
LStr = Replace(AStr, "{" + AStartToken + "}", "", 1, 1, 1)
LStr = Replace(LStr, "{" + AEndToken + "}", "", 1, 1, 1)
LLines = Split(LStr, NL, -1, 0)
Result = NEW_LINE_FIX + "<ul>" + NEW_LINE_FIX
' (SS,6/6/11) changed from [LBound(LLines) + 1 to UBound(LLines) - 1] to process all lines,
' allowing {startbullet} {endbullet} on same line as the bullet point
For r = LBound(LLines) To UBound(LLines)
LLine = Trim(LLines(r))
If LLine <> "" Then ' (SS,6/6/11) only if not blank
' (SS,9/3/16) check if bullet point is a token and detokenise it (only one level, not recursive)
LToken = GetToken(LLine)
If LToken <> "" Then
LLines2 = Split(GetSiteDetail("Tokens", LToken), NL, -1, 0)
For t = LBound(LLines2) To UBound(LLines2)
LLine2 = Trim(LLines2(t))
If LLine2 <> "" Then
Result = Result + "<li>" + LLine2 + "</li>" + NEW_LINE_FIX
End If
Next
LLine = "" ' to ignore adding of the token line below because it's been detokenised
End If
If LLine <> "" Then ' (SS,9/3/16) added If to ignore if line was detokenised above
Result = Result + "<li>" + LLine + "</li>" + NEW_LINE_FIX
End If
End If
Next
Result = Result + "</ul>" + NEW_LINE_FIX
GetBulletHTML = Result
End Function
' (SS,28/4/17) for fetching record
Function GetRecordHTML(AStr, AStartToken, AEndToken)
Dim LLines, LFirstLine, LKey, LTableName, LSetting
LKey = GetProductCode ' default to current product code as the key
LLines = Split(AStr, NL, -1, 0)
LFirstLine = LLines(0)
' existing code from GetTableSetting used to get the settings, which is in held in first line in same format e.g. table="specs_servo"
LTableName = GetTableSetting(LFirstLine, "table")
LSetting = GetTableSetting(LFirstLine, "key")
If LSetting <> "" Then LKey = LSetting ' override default product for current product
If LTableName <> "" And LKey <> "" Then
FetchRecordToSession LTableName, LKey
End If
GetRecordHTML = ""
End Function
' (SS,13/12/18) additional features e.g. rename the ProductName via something like:
' {action cmd="rename" field="ProductName" value="[FT, ProductName] Servo - [FN, TorqueV3,1]Kg.cm [FN, SpeedV3,2]s [FN, Weight,1]g [FN, Thickness, 0]mm"}{endaction}
' (SS,1/5/19) added logging the product rename to log_product_renames table for debugging
Function GetActionHTML(AStr, AStartToken, AEndToken)
Dim LProductCode, LCmd, LField, LValue
LProductCode = GetProductCode ' use the current page product code
' get values from the definition
Dim LLines, LFirstLine
LLines = Split(AStr, NL, -1, 0)
LFirstLine = LLines(0)
LCmd = GetTableSetting(LFirstLine, "cmd")
' make sure command is rename, do the rename if field is ProductName and value is defined
If LCmd = "rename" Then
LField = GetTableSetting(LFirstLine, "field")
LValue = Trim(GetTableSetting(LFirstLine, "value"))
If LField = "ProductName" And LValue <> "" Then
Dim LProductName
LProductName = GetFieldForProduct(LProductCode, "ProductName")
' only update if product name is different
If LProductName <> LValue Then
' (14/12/18) added Left function to limit to 100 characters to prevent Data too long for column MySQL error
ExecuteQuery("UPDATE products SET ProductName = '" & Left(CleanSQLStr(LValue), 100) & "' WHERE ProductCode = '" & CleanSQLStr(LProductCode) & "'")
' (SS,1/5/19) log to new log_product_renames for debugging purposes
ExecuteQuery("INSERT INTO log_product_renames SET IPAddress = '" & CleanSQLStr(Request.ServerVariables("REMOTE_ADDR")) & "', ProductCode = '" & CleanSQLStr(LProductCode) & "', Message = '" & CleanSQLStr(LProductName + " => " + LValue) & "'")
End If
End If
End If
GetActionHTML = "" ' nothing is returned
End Function
' (SS,22/8/14)
' replaces tab sections with HTML comment for start of tab and HTML comment for end of tab
Function GetTabHTML(AStr, AStartToken, AEndToken)
Dim Result
Result = "<!-- THIS IS THE TAB -->"
GetTabHTML = Result
End Function
' returns start of specified token within given string
Function GetTokenStart(AStr, AToken)
Dim LPos1, LPos2
LPos1 = InStr(1, AStr, "{" + AToken + "}", 1)
LPos2 = InStr(1, AStr, "{" + AToken + " ", 1)
If (LPos1 = 0) Or ((LPos2 > 0) and (LPos2 < LPos1)) Then LPos1 = LPos2 ' get the earliest position, otherwise the one with space could match too late
GetTokenStart = LPos1
End Function
' returns end of specified token within given string
Function GetTokenEnd(AStr, AToken)
Dim LPos
LPos = InStr(1, AStr, "{" + AToken + "}", 1)
If LPos > 0 Then LPos = LPos + Len(AToken) + 1
GetTokenEnd = LPos
End Function
' (SS,1/8/07) new function which does what RemoveTable did, but works with new types like "bullet"
Function RemoveComposes(AValue)
Dim LValue
LValue = AValue
LValue = RemoveCompose(LValue, "table", "endtable")
LValue = RemoveCompose(LValue, "bullet", "endbullet")
RemoveComposes = LValue
End Function
' (SS,21/5/07) removes the special table from given string i.e. everything between {table..} and {endtable} including the tokens
' (SS,1/8/07) renamed RemoveTable to RemoveCompose
' added new parameters AStartToken and AEndToken
Function RemoveCompose(AValue, AStartToken, AEndToken)
Dim LStart, LEnd
LStart = GetTokenStart(AValue, AStartToken)
LEnd = GetTokenEnd(AValue, AEndToken)
If (LStart > 0) And (LEnd > 0) Then
RemoveCompose = Mid(AValue, 1, LStart - 1) + Mid(AValue, LEnd + 1, Len(AValue))
Else
RemoveCompose = AValue
End If
End Function
' (SS,23/5/12) returns true if given text has a script to style sheet tag
Function HasScriptOrStyle(AText)
HasScriptOrStyle = InStr(1, AText, "</script>", 1) > 0 Or InStr(1, AText, "</style>", 1) > 0
End Function
' (SS,14/4/11) replace all tokens i.e. in curly brackets { } with text from site details
' (SS,23/5/11) modified for recursion via ComposeDescription and also to pass on parameters e.g. {spinner,30,10} where spinner is token name and %1 will be replaced with 30, %2 with 10
' (SS,30/7/15) modified to replace two semicolons with single semicolon, i.e. allow semicolon be shown in text by entering it as two
Function ReplaceTokens(ADesc)
' (SS,19/4/12) if description contains script or stylesheet tags which also use the {} brackets then don't replace tokens because it'll go wrong
' (SS,4/8/15) following commented out to fix bug, fixed bug by adding "If Not HasScriptOrStyle.." to GetToken
'If HasScriptOrStyle(ADesc) Then
' ReplaceTokens = ADesc
' Exit Function
'End If
' (SS,23/5/11) used to prevent too many recursions and stack overflow
Const MAX_RECURSIONS = 100
If FReplaceTokensRecursionCount > MAX_RECURSIONS Then
ReplaceTokens = "<strong>Recursion limited to " & MAX_RECURSIONS & " to prevent stack overflow. This could be due to token content referring to itself.</strong>"
Exit Function
End If
FReplaceTokensRecursionCount = FReplaceTokensRecursionCount + 1
Dim LDesc, LToken, LCount, LTokenName ' (SS,27/4/17) added token name
LDesc = ADesc
Do
LToken = GetToken(LDesc)
If LToken <> "" Then
Dim LTokenDesc
' (SS,23/5/11) check for comma separated token parameters, and replace %1, %2 etc with values from token name
If InStr(LToken, ",") > 0 Then
' Response.Write "##" & LToken & "##" & BR
Dim LParameters, i, LParameter
LParameters = Split(LToken, ",")
' (SS,27/4/17) check for special tokens and handle them
LTokenName = UCase(Trim(LParameters(0)))
If IsSpecialToken(LTokenName) Then
LTokenDesc = HandleSpecialToken(LTokenName, LParameters)
Else ' (SS,27/4/17) as before
LTokenDesc = GetSiteDetail("Tokens", LParameters(0)) ' lookup token ignoring the comma separated parameters
' for each parameter, replace the string %1, %2, %3 etc with the parameter value
For i = 1 to UBound(LParameters)
LParameter = Trim(LParameters(i))
LParameter = ReplaceStr(LParameter, ";", ",") ' semicolons are replaced with comma to allow passing of commas in text
LParameter = ReplaceStr(LParameter, ",,", ";") ' (SS,30/7/15) two semicolons are replaced with single semicolon, two commas used because above line converts two semicolon to comma
LTokenDesc = ReplaceStr(LTokenDesc, "%" & i, LParameter)
Next
End If
Else
LTokenDesc = GetSiteDetail("Tokens", LToken)
End If
' (SS,23/5/11) this may result in recursion because ComposeDescription could call ReplaceTokens
' (SS,3/6/11) added True parameter to ComposeDescription, to ensure special newlines are not converted to <br>s until the end
LDesc = ReplaceStr(LDesc, "{" + LToken + "}", ComposeDescription(LTokenDesc, True, True))
End If
Loop While LToken <> ""
FReplaceTokensRecursionCount = FReplaceTokensRecursionCount - 1 ' (SS,23/5/11) part of recursion prevention
ReplaceTokens = LDesc
End Function
' (SS,27/4/17) quickly check whether given token is a special number
Function IsSpecialToken(ATokenName)
' (SS,14/12/18) added APH and RBR
Const SPECIAL_TOKENS = ",FR,FT,FN,FX,FV,FMM,FCM,EV,APH,RBR,"
IsSpecialToken = InStr(SPECIAL_TOKENS, "," + ATokenName + ",") > 0
End Function
' (SS,27/4/17) handle special tokens, FR, FT, FN, FX, FV, Fmm, Fcm, EV
' To fetch record need to have following before using tokens below {record table="xx" productcode="xxx"} {endrecord}
' FT - Fetch given field name as text e.g. {FT, fieldname}
' FN - Fetch given field name as number and round to x decimal places e.g. {FN, maxwidth, 1}
' FX - Fetch given field name as number, multiply by constant and round to x decimal places e.g. {FX, maxwidth, 0.03937, 2}
' FV - Fetch given field name as number, divide into constant and round to x decimal places, if either parameter blank then record blank (do not cause overflow error) e.g. {FV, maxwidth, 25.4, 2}
' Fmm - Fetch given field name as number, convert mm to inches by dividing by 25.4 e.g. if fieldx contains 50.8 then {Fmm, fieldx, 1} returns 2.0
' Fcm - Fetch given field name as number, convert cm to inches by dividing by 2.4 e.g. if fieldx contains 5.08 then {Fmm, fieldx, 1} returns 2.0
' APH - Fetch given field as text and do an add auto product href via AddAutoProductHRefs
' RBR - Remove blank row, if given field is blank then table row isn't shown
' (SS,7/12/18) modified to trap error and return "?ERROR?"
Function HandleSpecialToken(ATokenName, AParameters)
Dim LResult, LParaCount
LResult = "" ' nothing to return by default
LParaCount = UBound(AParameters)
If ATokenName = "EV" Then ' special token to call Eval function and return its value
' combine all parameters into one string to pass to Eval function
Dim LAllParas, i
LAllParas = ""
For i = 1 To LParaCount
LAllParas = LAllParas + IIf(LAllParas = "", "", ", ") + AParameters(i)
Next
' (7/12/18) added following to turn off normal error handling
On Error Resume Next
LResult = CStr(Eval(LAllParas)) ' CStr or NB is required to prevent error
' (7/12/18) added following to trap error and show "?ERROR?" instead of failing
If Err.Number <> 0 Then
LResult = "?ERROR?"
End If
On Error Goto 0 ' reset error handling back to normal
ElseIf ATokenName = "FT" Then
If LParaCount = 1 Then
LResult = NB(FetchFieldFromSession(Trim(AParameters(1))))
End If
ElseIf ATokenName = "FN" Then
If LParaCount = 2 Then
LResult = HandleSpecialTokenNumber(AParameters(1), 1, 1, AParameters(2))
End If
ElseIf ATokenName = "FX" Then
If LParaCount = 3 Then
LResult = HandleSpecialTokenNumber(AParameters(1), AParameters(2), 1, AParameters(3))
End If
ElseIf ATokenName = "FV" Then
If LParaCount = 3 Then
LResult = HandleSpecialTokenNumber(AParameters(1), 1, AParameters(2), AParameters(3))
End If
ElseIf ATokenName = "FMM" Then
If LParaCount = 2 Then
LResult = HandleSpecialTokenNumber(AParameters(1), 1, 25.4, AParameters(2))
End If
ElseIf ATokenName = "FCM" Then
If LParaCount = 2 Then
LResult = HandleSpecialTokenNumber(AParameters(1), 1, 2.54, AParameters(2))
End If
' (SS,14/12/18) added following to an AddAutoProductHRefs for given field
ElseIf ATokenName = "APH" Then ' Remove Blank Row
If LParaCount = 1 Then
LResult = AddAutoProductHRefs(NB(FetchFieldFromSession(Trim(AParameters(1)))))
End If
' (SS,14/12/18) added following to remove blank row from table, if given field is blank, later removed by call to RemoveBlankTableRows
ElseIf ATokenName = "RBR" Then ' Remove Blank Row
If LParaCount = 1 Then
LResult = IIf(NB(FetchFieldFromSession(Trim(AParameters(1)))) = "", REMOVE_BLANK_ROW, "")
End If
End If
HandleSpecialToken = LResult
End Function
' (SS,27/4/17)
Function HandleSpecialTokenNumber(AFieldName, AMultiplyBy, ADivideBy, ADecimalPlaces)
Dim LValue, LDP, LResult
LValue = NB(FetchFieldFromSession(Trim(AFieldName)))
If LValue = "" Then ' return blank string if null
LResult = ""
Else
LDP = CInt(Trim(ADecimalPlaces))
LResult = FormatNumber(LValue * AMultiplyBy / ADivideBy, LDP)
End If
HandleSpecialTokenNumber = LResult
End Function
' (SS,27/4/17) shorthand function for FetchFieldFromSession called from Eval in HandleSpecialToken
Function FF(AFieldName)
FF = FetchFieldFromSession(AFieldName)
End Function
' (SS,14/4/11) returns first token found i.e. starting with { and ending in }, blank is returned if none found, token excluding curly brackets is returned otherwise
' (SS,4/8/15) if string contains ScriptOrStyle tag then a blank is returned, i.e. no token, to fix bug where script tag was being emptied
Function GetToken(AStr)
Dim LPosStart, LPosEnd, LResult
LResult = ""
' (SS,3/8/15) added check for HasScriptOrStyle, so that script is treated as normal (blank returned to cancel detokenising), because it can contain curly brackets, subsequent styles
If Not HasScriptOrStyle(AStr) Then
LPosStart = InStr(1, AStr, "{", 1)
If LPosStart > 0 Then
LPosEnd = InStr(LPosStart, AStr, "}", 1)
If LPosEnd > 0 Then
LResult = Mid(AStr, LPosStart + 1, LPosEnd - LPosStart - 1)
End If
End If
End If
GetToken = LResult
End Function
' (SS,22/8/14) returns given section no and the section name, first section has no name
' except for first section, if there are no more sections, ASectionName is returned with ""
Function GetDescriptionSection(ADesc, ASectionNo, ByRef ASectionName)
Dim LResult, LSectionNo, LSectionName, i, LLines, LTrimLine
If ASectionNo > 1 Then ASectionName = "" ' clear section name if > 1 because "" is returned for section name if section not found
LSectionNo = 1
LLines = Split(ADesc, NL, -1, 0)
LResult = ""
For i = LBound(LLines) to UBound(LLines)
LTrimLine = Trim(LLines(i))
' if start of new section then increment the section no and set section name
If UCase(Left(LTrimLine, 12)) = "<!--SECTION " Then
LSectionNo = LSectionNo + 1
LSectionName = Replace(LTrimLine, "<!--SECTION ", "", 1, 1, 1) ' case insensitive replace
LSectionName = Trim(ReplaceStr(LSectionName, "-->", ""))
If LSectionNo = ASectionNo Then ASectionName = LSectionName ' set section name if section no matches
ElseIf ASectionNo = LSectionNo Then ' if in same section then keep this line
LResult = LResult & IIf(LResult = "", "", NL) & LLines(i) ' only add newline if not first line
ElseIf LSectionNo > ASectionNo Then ' if beyond requested section then no need to continue
Exit For
End If
Next
GetDescriptionSection = TrimAll(TrimBRs(TrimAll(LResult)))
End Function
' (SS,22/8/14) show each section from production description, i.e. split into tabs or sections of accordian
Sub ShowProductDescriptionSections(AProductDesc)
Dim LSectionName, LSectionDesc, i
LSectionName = "Description"
i = 0
Do While LSectionName <> ""
i = i + 1
LSectionDesc = GetDescriptionSection(AProductDesc, i, LSectionName)
If LSectionName <> "" Then ShowProductDetailDescriptionSection LSectionDesc, LSectionName, i = 1 ' 3rd parameter is True for first i.e. active section
Loop
End Sub
' (SS,16/3/15) returns the first section only, used by Google Shopping
Function GetProductDescriptionFirstSection(AProductDesc)
Dim LSectionName ' used as a dummy ByRef parameter to GetDescriptionSection
GetProductDescriptionFirstSection = GetDescriptionSection(AProductDesc, 1, LSectionName)
End Function
' --- END OF TABLE COMPOSING ROUTINES ---
' (SS,27/5/04) called from two places, ShowSingleProduct and GetFirstCatSubcatForProduct
Function GetCategoryListSQL(AProductCode)
' (SS,18/5/12) replaced "categories.Priority, subcategories.Priority" in ORDER BY with "productcategories.Main DESC", i.e. the new Main flag field
GetCategoryListSQL = "SELECT * FROM productcategories" &_
" INNER JOIN categories ON categories.Category = productcategories.category" &_
" INNER JOIN subcategories ON subcategories.Category = productcategories.category AND subcategories.Subcategory = productcategories.Subcategory" &_
" WHERE ProductCode = '" + CleanSQLStr(AProductCode) + "'" &_
" ORDER BY productcategories.Main DESC, categories.SortOrder, subcategories.SortOrder"
End Function
' (SS,11/2/05) added ByRef AGroup
' (SS,1/8/11) changed from function to sub
Sub GetFirstCatSubcatForProduct(AProductCode, ByRef AGroup, ByRef ACategory, ByRef ASubcategory)
' database must be open at this point with query routines free to use '
' OpenQuery2("SELECT * FROM productcategories WHERE ProductCode = """ & AProductCode & """ ORDER BY Category, Subcategory")
' (SS,27/5/04) replaced above with this new query which uses new priority field to sort by
OpenQuery2(GetCategoryListSQL(AProductCode))
If Not EndOfQuery2 Then
AGroup = GetQueryValue2("GroupName") ' (SS,11/2/05)
ACategory = GetQueryValue2("Category")
ASubcategory = GetQueryValue2("Subcategory")
Else
ACategory = ""
ASubcategory = ""
End If
CloseQuery2
End Sub
' (SS,1/8/11) returns the category/subcategory the product has for the default group, to allow correct selection when only the default group is shown on the left menu (i.e. Brands for Clifton)
' blank is returned in ACategory, ASubcategory if not found
Sub GetDefaultGroupCatSubcatForProduct(AProductCode, ByRef ACategory, ByRef ASubcategory)
ACategory = ""
ASubcategory = ""
OpenQuery2(GetCategoryListSQL(AProductCode))
If Not EndOfQuery2 Then
Dim LGroup
LGroup = GetDefaultGroup
Do While Not EndOfQuery2
If GetQueryValue2("GroupName") = LGroup Then
ACategory = GetQueryValue2("Category")
ASubcategory = GetQueryValue2("Subcategory")
Exit Do
End If
NextQueryRecord2
Loop
End If
CloseQuery2
End Sub
' (SS,1/8/11) returns the correct, group, cat, subcat for given product, i.e. path taken to get there via menu
' if no valid path found then it returns the first group/cat/subcat for the product
Sub GetBreadcrumbGroupCatSubcatForProduct(AProductCode, ByRef AGroup, ByRef ACategory, ByRef ASubcategory)
' get the category / subcategory saved by the last menu selection
ACategory = GetBreadcrumbCategory
ASubcategory = GetBreadcrumbSubcategory
If ACategory <> "" And ASubcategory <> "" Then
If IsValidCatSubcatForProduct(AProductCode, ACategory, ASubcategory) Then
AGroup = GetGroupForCategory(ACategory)
Exit Sub
End If
End If
GetFirstCatSubcatForProduct AProductCode, AGroup, ACategory, ASubcategory
End Sub
' (SS,1/8/11) returns true if given category/subcategory is valid for given product
Function IsValidCatSubcatForProduct(AProductCode, ACategory, ASubcategory)
IsValidCatSubcatForProduct = "" <> GetSQLValueAsString("SELECT ProductCode FROM productcategories WHERE ProductCode = '" & CleanSQLStr(AProductCode) & "' AND Category = '" & CleanSQLStr(ACategory) & "' AND Subcategory = '" & CleanSQLStr(ASubcategory) & "'")
End Function
' (SS,1/8/11) following four routines added for more accurate breadcrumbs
Sub SetBreadcrumbCategory
Dim LCategory
LCategory = GetCategory
If LCategory <> "" Then
Session("BreadcrumbCategory") = LCategory
End If
End Sub
Sub SetBreadcrumbSubcategory
Dim LSubcategory
LSubcategory = GetSubcategory
If LSubcategory <> "" Then
Session("BreadcrumbSubcategory") = LSubcategory
End If
End Sub
Function GetBreadcrumbCategory
GetBreadcrumbCategory = Session("BreadcrumbCategory")
End Function
Function GetBreadcrumbSubcategory
GetBreadcrumbSubcategory = Session("BreadcrumbSubcategory")
End Function
' (SS,27/3/07)
Function GetGroupForCategory(ACategory)
' (SS,11/1/13) improved by making use of GetFieldForCategory
GetGroupForCategory = GetFieldForCategory(ACategory, "GroupName")
End Function
' (SS,26/7/11) returns MenuShortName for given category, ACategory is returned if not found
' (SS,2/8/11) added check for blank ACategory to prevent query
' (SS,11/1/13) replaced GetSQLValueAsString with GetFieldForCategory
Function GetShortNameForCategory(ACategory)
Dim LResult
If ACategory = "" Then
LResult = ""
Else
LResult = GetFieldForCategory(ACategory, "MenuShortName")
If LResult = "" Then LResult = ACategory
End If
GetShortNameForCategory = LResult
End Function
' (SS,26/7/11) returns MenuShortName for given subcategory, ASubcategory is returned if not found
' (SS,2/8/11) added check for blank ASubcategory to prevent query
' (SS,11/1/13) added missing ACategory parameter, it only had ASubcategory, replaced GetSQLValueAsString with GetFieldForSubcategory
Function GetShortNameForSubcategory(ACategory, ASubcategory)
Dim LResult
If ASubcategory = "" Then
LResult = ""
Else
LResult = GetFieldForSubcategory(ACategory, ASubcategory, "MenuShortName")
If LResult = "" Then LResult = ASubcategory
End If
GetShortNameForSubcategory = LResult
End Function
' (SS,19/9/06) returns comma separated list of subcategories for given category
Function GetSubcategoryListForCategory(ACategory)
OpenQuery2("SELECT * FROM subcategories WHERE Category = '" & CleanSQLStr(ACategory) & "' ORDER BY SortOrder, Subcategory")
Dim LCategoryList
LCategoryList = ""
Do While Not EndOfQuery2
LCategoryList = LCategoryList & Iif(LCategoryList = "", "", ", ") & GetQueryValue2("Subcategory")
NextQueryRecord2
Loop
CloseQuery2
GetSubcategoryListForCategory = LCategoryList
End Function
' (SS,10/1/13) returns given field for given category
Function GetFieldForCategory(ACategory, AFieldName)
GetFieldForCategory = GetSQLValueAsString("SELECT " & AFieldName & " FROM categories WHERE Category = '" & CleanSQLStr(ACategory) & "'")
End Function
' (SS,19/9/06) returns description for given subcategory
' (SS,10/1/13) rewrote using GetSQLValueAsString for compactness, from 8 lines to 1 line
' also renamed from GetSubcategoryDescription to GetFieldForSubcategory so it can return Description, Footer, Heading or any other field from subcategories table, had to added AFieldName parameter
Function GetFieldForSubcategory(ACategory, ASubcategory, AFieldName)
GetFieldForSubcategory = GetSQLValueAsString("SELECT " & AFieldName & " FROM subcategories WHERE Category = '" & CleanSQLStr(ACategory) & "' AND Subcategory = '" & CleanSQLStr(ASubcategory) & "'")
End Function
' (SS,16/9/04) returns given field value for given product code and field name '
Function GetFieldForProduct(AProductCode, AFieldName)
' database must be open at this point with query routines free to use '
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery2("SELECT * FROM products WHERE ProductCode = '" & CleanSQLStr(AProductCode) & "'")
If Not EndOfQuery2 Then
GetFieldForProduct = GetQueryValue2(AFieldName)
Else
GetFieldForProduct = ""
End If
CloseQuery2
End Function
' (SS,25/6/10) added stock availability check to also allow ordering if not in stock but available to order
' (SS,30/6/11) added ProductID to shoppingbaskets, currently looked up from products
' (SS,15/4/16) following can be deleted, now replaced by new version (see Sub AddToBasket below)
' *** to be deleted
Sub AddToBasketOld_(AProductCode, AAddQty)
' (SS,1/7/11) new options feature was added, call the new option handling routine, which might redirect to the product detail page, or do its own add to basket process
If ProductOptionsEnabled Then
' (SS,14/4/16) renamed ProcessAddToBasketForOptions to AddProductToBasketIncludingOptions, and added True for AAllowAlert, added 0 for AItemID (not specified)
AddProductToBasketIncludingOptions AProductCode, AAddQty, 0, True, True, "", "" ' True for allow redirection, True to allow alert, "" for no array, i.e. take options from form
Exit Sub
End If
Dim LFound
' (SS,15/6/04) added stock checking so user cannot add to basket if not in stock '
Dim LNumInStock, LProductID
LNumInStock = 0
' OpenQuery("SELECT NumInStock FROM products WHERE ProductCode = '" + AProductCode + "'")
' (SS,25/6/10) replaced above with following to adds fields to to stock available check
' (SS,30/6/11) added ProductID, because shoppingbaskets table now requires it for new shopping_basket_options
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT ProductID, NumInStock, " & GetStockAvailabilityFieldList & " FROM products " &_
"LEFT JOIN suppliers ON suppliers.SupplierID = products.SupplierID " &_
"WHERE ProductCode = '" + CleanSQLStr(AProductCode) + "'")
LFound = Not EndOfQuery
If LFound Then
LProductID = GetQueryValue("ProductID") ' (SS,30/6/11)
LNumInStock = GetQueryValue("NumInStock")
' (SS,25/6/10) added following because it decides whether product not stock can be ordered
SetStockAvailabilityFromFields
End If
CloseQuery
' If Not LFound Or Not InStock(LNumInStock) Then Exit Sub
' (SS,25/6/10) replaced above with following to not exit if IsStockAvailable is True
If Not LFound Then
Exit Sub
Else
If Not InStock(LNumInStock) And Not IsStockAvailable Then Exit Sub
End If
Dim LAddQty
LAddQty = AAddQty
' make sure it's a valid number, convert to integer, assume 1 if invalid
If IsNumeric(LAddQty) Then
LAddQty = CLng(LAddQty)
Else
LAddQty = 1
End if
If LAddQty > MAX_PRODUCT_QTY Then LAddQty = MAX_PRODUCT_QTY ' reduce to maximum '
' check if item already exists in basket '
Dim LQtyInBasket
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT * FROM shoppingbaskets WHERE SessionID = '" + CleanSQLStr(FSessionID) + "' AND ProductCode = '" + CleanSQLStr(AProductCode) + "'")
LFound = Not EndOfQuery
' (SS,17/11/04) added following for new "not allow more than what is in stock" feature '
If LFound Then
LQtyInBasket = GetQueryValue("Qty")
Else
LQtyInBasket = 0
End If
CloseQuery
' (SS,17/11/04) added following to reduce the qty to the amount in stock '
Dim LNewQty
LNewQty = LQtyInBasket + LAddQty
' (SS,25/6/10) added Not IsStockAvailable
' (SS,19/7/10) removed Not AllowProductOrderIfNoStock, IsStockAvailable does this check using GetAllowOutOfStockOrdering
If Not IsStockAvailable Then
If LNewQty > LNumInStock Then
LNewQty = LNumInStock
SetAlertMessage trx("Sorry we only have <x> of this item in stock", CStr(LNumInStock)) ' (SS,19/3/10), (SS,25/6/10) added CStr()
End If
End If
If LNewQty > MAX_PRODUCT_QTY Then LNewQty = MAX_PRODUCT_QTY ' reduce to maximum '
' if not found then add it, else increase the quantity '
If Not LFound Then
' make sure product code is valid '
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT * FROM products WHERE ProductCode = '" + CleanSQLStr(AProductCode) + "'")
LFound = Not EndOfQuery
CloseQuery
' if valid product code then add it to basket '
' (SS,30/6/11) added ProductID, now needs to be saved in shoppingbaskets
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
If LFound Then ExecuteQuery "INSERT INTO shoppingbaskets (SessionID, ProductID, ProductCode, Qty) VALUES ('" & CleanSQLStr(FSessionID) & "', '" & CleanSQLStr(LProductID) & "', '" & CleanSQLStr(AProductCode) & "', " & LNewQty & ");"
Else
' ExecuteQuery "UPDATE shoppingbaskets SET Qty = Qty + " & LQty & " WHERE SessionID = '" & FSessionID & "' AND ProductCode = '" & AProductCode & "'"
' (SS,17/11/04) modified above to following '
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
ExecuteQuery "UPDATE shoppingbaskets SET Qty = " & LNewQty & " WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND ProductCode = '" & CleanSQLStr(AProductCode) & "'"
End If
' delete all the products with zero or negative quantities '
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
ExecuteQuery "DELETE FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND Qty <= 0"
' (SS,18/2/14) if item was added then either redirect to basket page at the end of script or show pop up, or neither
' (SS,20/2/14) now calls SetAddToBasketAlert instead of SetPageRedirection
If LNewQty = LQtyInBasket + LAddQty Then
SetAddToBasketAlert LAddQty, AProductCode
End If
End Sub
' (SS,25/6/10) added stock availability check to also allow ordering if not in stock but available to order
' (SS,30/6/11) added ProductID to shoppingbaskets, currently looked up from products
' (SS,15/4/16) new version which always calls AddProductToBasketIncludingOptions even if ProductOptionsEnabled is False, it handles both
Sub AddToBasket(AProductCode, AAddQty)
' (SS,1/7/11) new options feature was added, call the new option handling routine, which might redirect to the product detail page, or do its own add to basket process
' (SS,15/4/16) removed If ProductOptionsEnabled Then so that it's always called, also removed "Exit Sub" which is not longer necessary
' redundant code from below was deleted
' (SS,14/4/16) renamed ProcessAddToBasketForOptions to AddProductToBasketIncludingOptions, and added True for AAllowAlert, added 0 for AItemID (not specified)
AddProductToBasketIncludingOptions AProductCode, AAddQty, 0, True, True, "", "" ' True for allow redirection, True to allow alert, "" for no array, i.e. take options from form
End Sub
' (SS,2/11/20) removes the given group of items from basket
' AItemID is ID of first item, AItemGroup is ig= value (e.g. Build 1"
Sub RemoveGroupFromBasket(AItemID, AOptionsList)
' Response.Write "### AItemID: " & AItemID & BR
' Response.Write "### AOptionsList: " & AOptionsList & BR
' find all items with this OptionsList i.e. OptionName + ": " + OptionValue
' e.g. for GSC "Build: 1 (Garden Office - Joist - 750mm - 8m x 8m)"
Dim LSQL
LSQL = "SELECT sb.ItemID, OptionName, OptionValue FROM shoppingbaskets sb INNER JOIN shopping_basket_options sbo ON sbo.ItemID = sb.ItemID WHERE SessionID = '" & CleanSQLStr(FSessionID) & "'"
OpenQuery LSQL
Do While Not EndOfQuery
If GetQueryValue("OptionName") & ": " & GetQueryValue("OptionValue") = AOptionsList Then
' Response.Write "### To delete: AItemID: " & GetQueryValue("ItemID") & BR
' call RemoveFromBasket to remove each item one by one
RemoveFromBasket GetQueryValue("ItemID")
End If
NextQueryRecord
Loop
CloseQuery
' call the custom remove group routine if it exists
If FunctionExists("CustomRemoveItemsGroup") Then
CustomRemoveItemsGroup AOptionsList
End If
End Sub
' (SS,5/7/11) replaced AProductCode with AItemID
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,25/10/18) added RemoveSubproductsFromBasket
Sub RemoveFromBasket(AItemID)
' (SS,18/10/22) send to Google Tag Manager
GTMSendBasketOperation AItemID, True, 0, False
' ExecuteQuery("DELETE FROM shoppingbaskets WHERE SessionID = '" & FSessionID & "' AND ProductCode = '" & AProductCode & "'")
' (SS,5/7/11) replaced above with following, now using ItemID instead of Product, kept SessionID for safety, to prevent rogue app on Internet from deleting other people's items
ExecuteQuery("DELETE t1, t2 FROM shoppingbaskets t1, shopping_basket_options t2 WHERE t1.ItemID = t2.ItemID AND t1.SessionID = '" & CleanSQLStr(FSessionID) & "' AND t1.ItemID = '" & CleanSQLStr(AItemID) & "'")
' (SS,5/7/11) following necessary because above only deletes record from shoppingbaskets if at least one option record exists
ExecuteQuery("DELETE FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND ItemID = '" & CleanSQLStr(AItemID) & "'")
' (SS,25/10/18)
RemoveSubproductsFromBasket(AItemID)
End Sub
' (SS,25/10/18) called from RemoveFromBasket, also from Function CustomAddSubproductsToBasket
Sub RemoveSubproductsFromBasket(AItemID)
If ProductSubproductsEnabled Then
' included FSessionID for safety (as used in RemoveFromBasket above)
ExecuteQuery "DELETE FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND SubproductItemID = '" & CleanSQLStr(AItemID) & "'"
End If
End Sub
' (SS,5/7/11) replaced AProductCode with AItemID
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,25/10/18) Sub DeductFromBasket is now redundant, was used by old more detailed shopping status
Sub DeductFromBasket_to_be_removed(AItemID)
' ExecuteQuery("UPDATE shoppingbaskets SET Qty = Qty - 1 WHERE SessionID = '" & FSessionID & "' AND ProductCode = '" & AProductCode & "'")
' ExecuteQuery("DELETE FROM shoppingbaskets WHERE SessionID = '" & FSessionID & "' AND ProductCode = '" & AProductCode & "' AND Qty <= 0")
' (SS,5/7/11) replaced above with following
ExecuteQuery("UPDATE shoppingbaskets SET Qty = Qty - 1 WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND ItemID = '" & CleanSQLStr(AItemID) & "'")
If GetSQLValueAsString("SELECT Qty FROM shoppingbaskets WHERE ItemID = '" & CleanSQLStr(AItemID) & "'") = "0" Then
RemoveFromBasket AItemID
End If
End Sub
' (SS,5/7/11) *** need to handle stock for options
' (SS,5/7/11) replaced Product Code with Item ID, form values QTY_ are now suffixed by ItemID
' (SS,15/1/15) changes to check voucher code
' (SS,14/4/16) new version which works correctly with options, calls AddProductToBasketIncludingOptions for each item
Sub RecalculateBasket
' (SS,16/2/12) added following to allow customer to change country in basket page to show delivery for their country
SetCountryFromBasketForm
' (SS,15/1/15)
' (SS,16/2/15) added parameter to SetVoucherCode
SetVoucherCode UCase(Trim(CleanRequestForm("VoucherCode")))
Dim LErrorMessage
If Not IsVoucherCodeValid(GetVoucherCode, LErrorMessage) Then SetAlertMessage LErrorMessage
' (SS,5/7/11) replaced LProductCodeWithPrefix with LItemIDWithPrefix
' (SS,14/4/16) added LQtyInBasket, LQtyToAdd
Dim objItem, LItemIDWithPrefix, LProductCode, LQty, LItemID, LQtyInBasket, LQtyToAdd
For Each objItem In Request.Form
LItemIDWithPrefix = objItem
LQty = CleanRequestForm(objItem)
If Left(LItemIDWithPrefix, 4) = "QTY_" Then
LItemID = CLng(Mid(LItemIDWithPrefix, 5)) ' (SS,14/4/16) added CLng to ensure integer
' LProductCode = ReplaceStr(LProductCode, "_", "-") ' convert the underscores to '-' because fields name already have fields with '-' converted to '_'
' Response.Write LProductCode & "=" & LQty & "<BR>"
' if quantity is zero or blank then delete the item, else change the quantity
If LQty = "0" Or LQty = "" Then
RemoveFromBasket LItemID
Else
' make sure it's a valid number, convert to integer, assume 1 if invalid
If IsNumeric(LQty) Then
LQty = CLng(LQty)
Else
LQty = 1
End if
' (SS,14/4/16) removed the following maximum limit
' If LQty > MAX_PRODUCT_QTY Then LQty = MAX_PRODUCT_QTY ' reduce to maximum '
' (SS,5/7/11) product code is required below, so we look it up using ItemID
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' LProductCode = GetSQLValueAsString("SELECT ProductCode FROM shoppingbaskets WHERE ItemID = '" & CleanSQLStr(LItemID) & "'")
' (SS,14/4/16) replaced above with following to also look up qty currently in basket
If GetSQL2Values("SELECT ProductCode, Qty FROM shoppingbaskets WHERE ItemID = '" & CleanSQLStr(LItemID) & "'", LProductCode, LQtyInBasket) Then
LQtyToAdd = LQty - LQtyInBasket
' (SS,14/4/16) rewrote to call AddProductToBasketIncludingOptions for each item in basket to add/remove the difference
If LQtyToAdd <> 0 Then
'If Not AddProductToBasketIncludingOptions(LProductCode, LQtyToAdd, LItemID, False, False, "", "") Then
' SetAlertMessage "Sorry, not enough of " & GetProductName(LProductCode) & " in stock"
'End If
AddProductToBasketIncludingOptions LProductCode, LQtyToAdd, LItemID, False, True, "", ""
End If
End If
End If
End If
Next
End Sub
' (SS,4/7/11) added ItemID and options for products, ItemID and OptionsList now passed to ShowBasketItem
' (SS,1/8/18) modified to additional info to options list via AddMoreOptionsInfo
' (SS,28/7/22) change to default the DeliveryCountry to Country if delivery address same as invoice (i.e. customer had already been to checkout) to fix postcode alert bug
' (SS,21/2/24) renamed to ShowBasketOld, replaced with new version
Sub ShowBasketOld
' (SS,28/11/13) clear values for remarketing tag
' (SS,6/3/18) removed following two lines no longer used
'SetRemarketingTagTotalValue(0)
'ClearRemarketingTagProductIDs
GetSettingsForContinue ' get the settings for the continue shopping button
' (SS,18/4/16) False to make sure detail records aren't deleted
' (SS,19/4/16) now moved to ProductsMain
' ClearExistingOrderPlaced False
' (SS,18/4/16) check items in basket are in stock, display alert if not
' *** may need to move below check below, currently fails due to query being held open below
CheckBasketInStock True
' (SS,23/5/07) replaced query with GetOrderItemsQuery(FSessionID)
' (SS,26/10/18) added False parameter to GetOrderItemsQuery to exclude subproducts
' (SS,16/10/23) BrandName, Category and Subcategory now added to query in GetOrderItemsQuery
OpenQuery(GetOrderItemsQuery(FSessionID, False))
' exit if there are no items '
If EndOfQuery Then
CloseQuery
ShowEmptyBasket
Exit Sub
End If
' (SS,28/7/22) when user leaves DeliveryCountry set to "United Kingdom" and sets a different country in checkout stage'
' e.g. Session("Country") = "United States", then Session("DeliveryCountry") remains at "United Kingdom"
' and basket pages tries to do a UK postcode check using the entered Postcode which is a zipcode because it's for the US
' this causes an invalid postcode alert email to be sent, solution was to set the DeliveryCountry to Country if delivery address same as invoice
' also added a basket page check to GetDeliveryRegionFromPostcode, to not sent the alert when customers switches back to UK
If Session("DeliveryAddressSameAsInvoice") And Session("Country") <> "" And Session("Country") <> Session("DeliveryCountry") Then
Session("DeliveryCountry") = Session("Country")
End If
' (SS,16/2/12) following ensures something is set for delivery country, else nothing may be selected in the new delivery country combo
' due to process order routine clearing Session("DeliveryCountry") when delivery address is same as invoice
SetDeliveryCountry(GetDeliveryCountry)
' show the heading '
ShowBasketHeader
' (SS,6/7/11) removed tp_ProductCodeDashAsUnderscore added LProductID
Dim tp_ProductCode, tp_ProductName, tp_PriceEach, tp_Qty, tp_ProductTotal, tp_SubTotal, LProductID
Dim tp_VATTotal, tp_Discount, tp_Delivery, tp_GrandTotal ' (SS,23/4/09) added tp_Discount
Dim LCount, LPriceEach
LCount = 0
' (SS,4/7/11)
' (SS,9/10/14) added LobjOptionsDict and LCustomGetOrderDeliveryInfoExists, LCustomProductInBasketExists
' (SS,16/10/23) added LOptionsListWithCustom
Dim LItemID, LOptionsList, LOptionsListWithCustom, LobjOptionsDict, LCustomGetOrderDeliveryInfoExists, LCustomProductInBasketExists
LCustomGetOrderDeliveryInfoExists = FunctionExists("CustomGetOrderDeliveryInfo")
LCustomProductInBasketExists = FunctionExists("CustomProductInBasket")
SetDeliveryInfo("")
' (SS,17/2/15)
Dim LBasketDesc
LBasketDesc = ""
' (SS,23/2/15) to save shopping basket prices in dictionary for use by email basket feature
Dim LobjBasketPricesDict
Set LobjBasketPricesDict = Server.CreateObject("Scripting.Dictionary")
' (SS,9/10/14)
Set LobjOptionsDict = CreateObject("Scripting.Dictionary")
LobjOptionsDict.CompareMode = vbTextCompare ' makes the keys case insensitive
' (SS,16/10/23) record view_cart ecommerce event for GA4/GTM
oGTM.EventViewCart
Do While Not EndOfQuery
' (SS,23/5/07)
' (SS,6/7/11) removed 0 parameter, added True, to look up options price
GetPricingFromProductRecord(True)
LCount = LCount + 1
LProductID = GetQueryValue("ProductID") ' (SS,6/7/11)
tp_ProductCode = GetFieldValue("ProductCode")
' (SS,6/3/18) removed following due to migration to gtag.js (Global Site Tag)
'AddRemarketingTagProductID(tp_ProductCode) ' (SS,28/11/13)
' replace dash with underscore to make sure + - in JavaScript work '
' (SS,6/7/11) removed following, ItemID now used
' tp_ProductCodeDashAsUnderscore = ReplaceStr(tp_ProductCode, "-", "_")
tp_Qty = NZ(GetFieldValue("Qty"))
tp_ProductName = GetFieldValue("ProductName")
LPriceEach = GetProductPrice
' (SS,4/7/11)
LItemID = GetQueryValue("ItemID")
LOptionsList = GetOptionsListForBasketItem(LItemID, "", LobjOptionsDict) ' (SS,9/10/14) added LobjOptionsDict which will be passed to a custom delivery estimation routine
' (SS,1/8/18) add additional custom info to options list
' (SS,16/10/23) replaced LOptionsList with LOptionsListWithCustom (to pass on original cleaner options to GTM)
LOptionsListWithCustom = AddMoreOptionsInfo(LProductID, LOptionsList)
' (SS,9/10/14) update delivery info for this product, at the end we'll have the actual one for the full order
If LCustomGetOrderDeliveryInfoExists Then SetDeliveryInfo(CustomGetOrderDeliveryInfo(GetDeliveryInfo, LProductID, LobjOptionsDict))
' (SS,10/10/14) if CustomProductInBasketExists function exists then call it to pass on product, qty and options, it may use it to recommend other products later
If LCustomProductInBasketExists Then CustomProductInBasket LProductID, tp_Qty, LobjOptionsDict
' (SS,1/4/08) added following to show VAT included prices, only for sites where entered prices don't include VAT and ShowIncVAT is true
'If Not PricesEnteredIncludeVAT And ShowIncVAT Then
' LPriceEach = Round2dp(LPriceEach + GetVATForProduct(LPriceEach))
'End If
' (SS,1/11/12) removed above, replaced CorrectCurrency in following two with CorrectCurrencyNV which removes VAT if it needs to
tp_PriceEach = CorrectCurrencyNV(LPriceEach)
tp_ProductTotal = CorrectCurrencyNV(LPriceEach * tp_Qty)
' (SS,23/2/15) added price each to dictionary
' (SS,26/2/15) causes "This key is already associated with an element of this collection" when same ProductID used same different options
' (SS,26/2/15) replaced LProductID with LItemID, because ProductID isn't unique enough
LobjBasketPricesDict.Add LItemID, LPriceEach
' (SS,17/2/15) added following for text to later send to PayPal Express
LBasketDesc = LBasketDesc + iif(LBasketDesc = "", "", ", ") + tp_ProductCode + " x " & tp_Qty
' (SS,4/7/11) added LProductID, LItemID and LOptionsList, removed tp_ProductCodeDashAsUnderscore and Server.URLEncode(tp_ProductCode)
' (SS,16/1023) replaced LOptionsList with LOptionsListWithCustom due to keeping original LOptionsList to pass to GTM below
If LCount Mod 2 = 1 Then
ShowBasketItem LItemID, LProductID, tp_ProductCode, tp_ProductName, LOptionsListWithCustom, tp_Qty, tp_PriceEach, tp_ProductTotal
Else
ShowBasketItemAlternateColor LItemID, LProductID, tp_ProductCode, tp_ProductName, LOptionsListWithCustom, tp_Qty, tp_PriceEach, tp_ProductTotal
End If
' (SS,16/10/23) add item to GTM, GetVATExcValue necessary for sites where VAT included in prices e.g. HF
oGTM.AddItem tp_ProductCode, tp_ProductName, LOptionsList, GetVATExcValue(LPriceEach), tp_Qty, GetFieldValue("BrandName"), GetFieldValue("Category"), GetFieldValue("Subcategory")
NextQueryRecord
Loop
Set LobjOptionsDict = Nothing ' (SS,9/10/14)
CloseQuery
' (SS,23/2/15) save basket prices dictionary to session, and free object
Set Session("BasketPricesDict") = LobjBasketPricesDict
Set LobjBasketPricesDict = Nothing
Dim LSubtotal, LDiscount, LTotalWeight, LNonWeightPrice, LVATTotal, LDelivery, LGrandTotal, LVATIncluded, LVATDeducted
' (SS,28/5/07) GetOrderTotals replaces previous code
' (SS,22/6/07) added LTotalWeight parameter
' (SS,23/4/09) added LDiscount parameter
GetOrderTotalsForBasket FSessionID, LSubtotal, LDiscount, LDelivery, LGrandTotal, LVATIncluded, LVATDeducted, LTotalWeight
Dim LIsVATDeducted
If LVATDeducted > 0 Then
tp_VATTotal = CorrectCurrency(LVATDeducted)
LIsVATDeducted = True
Else
tp_VATTotal = CorrectCurrency(LVATIncluded)
LIsVATDeducted = False
End If
SetVATLabel(LIsVATDeducted) ' (SS,28/5/07) sets label to use in basket footer
' (SS,1/4/08) added following to show VAT included prices, only for sites where entered prices don't include VAT and ShowIncVAT is true
' the inc-template-basket.asp has been adjusted to not show the VAT row unless VAT is deducted
If Not PricesEnteredIncludeVAT And ShowIncVAT Then
Dim LVATForDelivery, LVATForDiscount
LVATForDelivery = GetVATAmountToAdd(LDelivery)
LVATForDiscount = GetVATAmountToAdd(LDiscount) ' (SS,23/4/09)
' (SS,23/4/09) to following added - LVATForDiscount (remember Discount is negative)
LSubtotal = LSubtotal + LVATIncluded - LVATForDelivery - LVATForDiscount
LDiscount = LDiscount + LVATForDiscount ' (SS,23/4/09)
LDelivery = LDelivery + LVATForDelivery
' (SS,1/11/12) moved following 3 lines here from below
tp_Subtotal = CorrectCurrency(LSubtotal)
tp_Discount = CorrectCurrency(LDiscount)
tp_Delivery = CorrectCurrency(LDelivery)
Else ' added following to remove VAT from values if applicable to prevent totals from confusing buyers when VAT is deducted
tp_Subtotal = CorrectCurrencyNV(LSubtotal)
tp_Discount = CorrectCurrencyNV(LDiscount)
tp_Delivery = CorrectCurrencyNV(LDelivery)
End If
tp_GrandTotal = CorrectCurrency(LGrandTotal)
SetBasketGrandTotal(LGrandTotal) ' (SS,19/1/15) set basket grand total, can be used by PayPal Express checkout etc.
SetBasketDescription(LBasketDesc)' (SS,17/2/15) set basket description, can be used by PayPal Express checkout etc.
' (SS,23/2/15) added following for saving to basket feature
SetBasketSubtotal(LSubtotal)
SetBasketDiscount(LDiscount)
SetBasketDelivery(LDelivery)
SetBasketVAT(LVATIncluded)
' (SS,6/3/18) removed following due to migration to gtag.js (Global Site Tag)
'SetRemarketingTagTotalValue(LSubtotal) ' (SS,28/11/13) not 100% sure about being subtotal, or whether VAT is deducted as above
' show the footer '
' (SS,19/8/06) added GetCurrencyPostalArea
' (SS,23/4/09) added Session("VoucherCode"), tp_Discount
' (SS,4/6/09) added LTotalWeight
' (SS,27/1/10) changed GetCurrencyPostalArea to GetRegionCodeOrPostalArea
ShowBasketFooter GetRegionCodeOrPostalArea, tp_Subtotal, Session("VoucherCode"), tp_Discount, tp_Delivery, tp_VATTotal, LIsVATDeducted, tp_GrandTotal, LTotalWeight, GetContinueLink, GetCheckoutLink
' (SS,18/10/23) add discount as an additional item discount, voucher code
If LDiscount <> 0 Then
'oGTM.Discount = LDiscount
oGTM.DiscountCode = Session("VoucherCode")
oGTM.AddItem "DISCOUNT", "Discount Voucher Code: " & Session("VoucherCode"), "", GetVATExcValue(LDiscount), 1, "", "", ""
' (SS,19/10/23) following is a bit messy, we're saving the discount in a session because it's calculated by ShowBasket here, but is required by the begin_checkout event
Session("DiscountPassToGTM") = LDiscount
Else
oGTM.DiscountCode = ""
Session("DiscountPassToGTM") = "" ' don't use 0 because a check us done later for ""
End If
End Sub
' (SS,4/7/11) added ItemID and options for products, ItemID and OptionsList now passed to ShowBasketItem
' (SS,1/8/18) modified to additional info to options list via AddMoreOptionsInfo
' (SS,28/7/22) change to default the DeliveryCountry to Country if delivery address same as invoice (i.e. customer had already been to checkout) to fix postcode alert bug
' (SS,21/2/24) new version
Sub ShowBasket
' (SS,28/11/13) clear values for remarketing tag
' (SS,6/3/18) removed following two lines no longer used
'SetRemarketingTagTotalValue(0)
'ClearRemarketingTagProductIDs
GetSettingsForContinue ' get the settings for the continue shopping button
' (SS,18/4/16) False to make sure detail records aren't deleted
' (SS,19/4/16) now moved to ProductsMain
' ClearExistingOrderPlaced False
' (SS,18/4/16) check items in basket are in stock, display alert if not
' *** may need to move below check below, currently fails due to query being held open below
CheckBasketInStock True
' (SS,23/5/07) replaced query with GetOrderItemsQuery(FSessionID)
' (SS,26/10/18) added False parameter to GetOrderItemsQuery to exclude subproducts
' (SS,16/10/23) BrandName, Category and Subcategory now added to query in GetOrderItemsQuery
OpenQuery(GetOrderItemsQuery(FSessionID, False))
' exit if there are no items '
If EndOfQuery Then
CloseQuery
ShowEmptyBasket
Exit Sub
Else
' (SS,21/2/24) closed here due to call to GetOrderTotalsForBasket being moved before the main loop, open again just before loop
' ### perhaps create a new quicker empty basket check routine
CloseQuery
End If
' (SS,28/7/22) when user leaves DeliveryCountry set to "United Kingdom" and sets a different country in checkout stage'
' e.g. Session("Country") = "United States", then Session("DeliveryCountry") remains at "United Kingdom"
' and basket pages tries to do a UK postcode check using the entered Postcode which is a zipcode because it's for the US
' this causes an invalid postcode alert email to be sent, solution was to set the DeliveryCountry to Country if delivery address same as invoice
' also added a basket page check to GetDeliveryRegionFromPostcode, to not sent the alert when customers switches back to UK
If Session("DeliveryAddressSameAsInvoice") And Session("Country") <> "" And Session("Country") <> Session("DeliveryCountry") Then
Session("DeliveryCountry") = Session("Country")
End If
' (SS,16/2/12) following ensures something is set for delivery country, else nothing may be selected in the new delivery country combo
' due to process order routine clearing Session("DeliveryCountry") when delivery address is same as invoice
SetDeliveryCountry(GetDeliveryCountry)
' show the heading '
' (SS,21/2/24) moved below
' ShowBasketHeader
' (SS,6/7/11) removed tp_ProductCodeDashAsUnderscore added LProductID
Dim tp_ProductCode, tp_ProductName, tp_PriceEach, tp_Qty, tp_ProductTotal, tp_SubTotal, LProductID
Dim tp_VATTotal, tp_Discount, tp_Delivery, tp_GrandTotal ' (SS,23/4/09) added tp_Discount
Dim LCount, LPriceEach
LCount = 0
' (SS,4/7/11)
' (SS,9/10/14) added LobjOptionsDict and LCustomGetOrderDeliveryInfoExists, LCustomProductInBasketExists
' (SS,16/10/23) added LOptionsListWithCustom
Dim LItemID, LOptionsList, LOptionsListWithCustom, LobjOptionsDict, LCustomGetOrderDeliveryInfoExists, LCustomProductInBasketExists
LCustomGetOrderDeliveryInfoExists = FunctionExists("CustomGetOrderDeliveryInfo")
LCustomProductInBasketExists = FunctionExists("CustomProductInBasket")
SetDeliveryInfo("")
' show the heading
' (SS,21/2/24) moved here from above
ShowBasketHeader
' === START OF BASKET TOTAL CODE ===
' (SS,21/2/24) moved here from end of sub, to show totals earlier
Dim LSubtotal, LDiscount, LTotalWeight, LNonWeightPrice, LVATTotal, LDelivery, LGrandTotal, LVATIncluded, LVATDeducted, LItems
' (SS,28/5/07) GetOrderTotals replaces previous code
' (SS,22/6/07) added LTotalWeight parameter
' (SS,23/4/09) added LDiscount parameter
' (SS,21/2/24) added LItems parameter
GetOrderTotalsForBasket FSessionID, LSubtotal, LDiscount, LDelivery, LGrandTotal, LVATIncluded, LVATDeducted, LTotalWeight, LItems
Dim LIsVATDeducted
If LVATDeducted > 0 Then
tp_VATTotal = CorrectCurrency(LVATDeducted)
LIsVATDeducted = True
Else
tp_VATTotal = CorrectCurrency(LVATIncluded)
LIsVATDeducted = False
End If
SetVATLabel(LIsVATDeducted) ' (SS,28/5/07) sets label to use in basket footer
' (SS,1/4/08) added following to show VAT included prices, only for sites where entered prices don't include VAT and ShowIncVAT is true
' the inc-template-basket.asp has been adjusted to not show the VAT row unless VAT is deducted
If Not PricesEnteredIncludeVAT And ShowIncVAT Then
Dim LVATForDelivery, LVATForDiscount
LVATForDelivery = GetVATAmountToAdd(LDelivery)
LVATForDiscount = GetVATAmountToAdd(LDiscount) ' (SS,23/4/09)
' (SS,23/4/09) to following added - LVATForDiscount (remember Discount is negative)
LSubtotal = LSubtotal + LVATIncluded - LVATForDelivery - LVATForDiscount
LDiscount = LDiscount + LVATForDiscount ' (SS,23/4/09)
LDelivery = LDelivery + LVATForDelivery
' (SS,1/11/12) moved following 3 lines here from below
tp_Subtotal = CorrectCurrency(LSubtotal)
tp_Discount = CorrectCurrency(LDiscount)
tp_Delivery = CorrectCurrency(LDelivery)
Else ' added following to remove VAT from values if applicable to prevent totals from confusing buyers when VAT is deducted
tp_Subtotal = CorrectCurrencyNV(LSubtotal)
tp_Discount = CorrectCurrencyNV(LDiscount)
tp_Delivery = CorrectCurrencyNV(LDelivery)
End If
tp_GrandTotal = CorrectCurrency(LGrandTotal)
' show the footer '
' (SS,19/8/06) added GetCurrencyPostalArea
' (SS,23/4/09) added Session("VoucherCode"), tp_Discount
' (SS,4/6/09) added LTotalWeight
' (SS,27/1/10) changed GetCurrencyPostalArea to GetRegionCodeOrPostalArea
' ShowBasketFooter GetRegionCodeOrPostalArea, tp_Subtotal, Session("VoucherCode"), tp_Discount, tp_Delivery, tp_VATTotal, LIsVATDeducted, tp_GrandTotal, LTotalWeight, GetContinueLink, GetCheckoutLink
' (SS,21/2/24) replaced ShowBasketFooter with following to show totals and product to checkout earlier, added new LItems parameter
ShowBasketDeliveryTotals GetRegionCodeOrPostalArea, tp_Subtotal, LItems, Session("VoucherCode"), tp_Discount, tp_Delivery, tp_VATTotal, LIsVATDeducted, tp_GrandTotal, LTotalWeight, GetContinueLink, GetCheckoutLink
' === END OF BASKET TOTAL CODE ===
' (SS,21/2/24) new routine in basket template
ShowBasketItemHeader
' (SS,17/2/15)
Dim LBasketDesc
LBasketDesc = ""
' (SS,23/2/15) to save shopping basket prices in dictionary for use by email basket feature
Dim LobjBasketPricesDict
Set LobjBasketPricesDict = Server.CreateObject("Scripting.Dictionary")
' (SS,9/10/14)
Set LobjOptionsDict = CreateObject("Scripting.Dictionary")
LobjOptionsDict.CompareMode = vbTextCompare ' makes the keys case insensitive
' (SS,16/10/23) record view_cart ecommerce event for GA4/GTM
oGTM.EventViewCart
' (SS,23/5/07) replaced query with GetOrderItemsQuery(FSessionID)
' (SS,26/10/18) added False parameter to GetOrderItemsQuery to exclude subproducts
' (SS,16/10/23) BrandName, Category and Subcategory now added to query in GetOrderItemsQuery
' (SS,21/2/24) moved here from above
OpenQuery(GetOrderItemsQuery(FSessionID, False))
Do While Not EndOfQuery
' (SS,23/5/07)
' (SS,6/7/11) removed 0 parameter, added True, to look up options price
GetPricingFromProductRecord(True)
LCount = LCount + 1
LProductID = GetQueryValue("ProductID") ' (SS,6/7/11)
tp_ProductCode = GetFieldValue("ProductCode")
' (SS,6/3/18) removed following due to migration to gtag.js (Global Site Tag)
'AddRemarketingTagProductID(tp_ProductCode) ' (SS,28/11/13)
' replace dash with underscore to make sure + - in JavaScript work '
' (SS,6/7/11) removed following, ItemID now used
' tp_ProductCodeDashAsUnderscore = ReplaceStr(tp_ProductCode, "-", "_")
tp_Qty = NZ(GetFieldValue("Qty"))
tp_ProductName = GetFieldValue("ProductName")
LPriceEach = GetProductPrice
' (SS,4/7/11)
LItemID = GetQueryValue("ItemID")
LOptionsList = GetOptionsListForBasketItem(LItemID, "", LobjOptionsDict) ' (SS,9/10/14) added LobjOptionsDict which will be passed to a custom delivery estimation routine
' (SS,1/8/18) add additional custom info to options list
' (SS,16/10/23) replaced LOptionsList with LOptionsListWithCustom (to pass on original cleaner options to GTM)
LOptionsListWithCustom = AddMoreOptionsInfo(LProductID, LOptionsList)
' (SS,9/10/14) update delivery info for this product, at the end we'll have the actual one for the full order
If LCustomGetOrderDeliveryInfoExists Then SetDeliveryInfo(CustomGetOrderDeliveryInfo(GetDeliveryInfo, LProductID, LobjOptionsDict))
' (SS,10/10/14) if CustomProductInBasketExists function exists then call it to pass on product, qty and options, it may use it to recommend other products later
If LCustomProductInBasketExists Then CustomProductInBasket LProductID, tp_Qty, LobjOptionsDict
' (SS,1/4/08) added following to show VAT included prices, only for sites where entered prices don't include VAT and ShowIncVAT is true
'If Not PricesEnteredIncludeVAT And ShowIncVAT Then
' LPriceEach = Round2dp(LPriceEach + GetVATForProduct(LPriceEach))
'End If
' (SS,1/11/12) removed above, replaced CorrectCurrency in following two with CorrectCurrencyNV which removes VAT if it needs to
tp_PriceEach = CorrectCurrencyNV(LPriceEach)
tp_ProductTotal = CorrectCurrencyNV(LPriceEach * tp_Qty)
' (SS,23/2/15) added price each to dictionary
' (SS,26/2/15) causes "This key is already associated with an element of this collection" when same ProductID used same different options
' (SS,26/2/15) replaced LProductID with LItemID, because ProductID isn't unique enough
LobjBasketPricesDict.Add LItemID, LPriceEach
' (SS,17/2/15) added following for text to later send to PayPal Express
LBasketDesc = LBasketDesc + iif(LBasketDesc = "", "", ", ") + tp_ProductCode + " x " & tp_Qty
' (SS,4/7/11) added LProductID, LItemID and LOptionsList, removed tp_ProductCodeDashAsUnderscore and Server.URLEncode(tp_ProductCode)
' (SS,16/1023) replaced LOptionsList with LOptionsListWithCustom due to keeping original LOptionsList to pass to GTM below
If LCount Mod 2 = 1 Then
ShowBasketItem LItemID, LProductID, tp_ProductCode, tp_ProductName, LOptionsListWithCustom, tp_Qty, tp_PriceEach, tp_ProductTotal
Else
ShowBasketItemAlternateColor LItemID, LProductID, tp_ProductCode, tp_ProductName, LOptionsListWithCustom, tp_Qty, tp_PriceEach, tp_ProductTotal
End If
' (SS,16/10/23) add item to GTM, GetVATExcValue necessary for sites where VAT included in prices e.g. HF
oGTM.AddItem tp_ProductCode, tp_ProductName, LOptionsList, GetVATExcValue(LPriceEach), tp_Qty, GetFieldValue("BrandName"), GetFieldValue("Category"), GetFieldValue("Subcategory")
NextQueryRecord
Loop
Set LobjOptionsDict = Nothing ' (SS,9/10/14)
CloseQuery
' (SS,21/2/24) new routine in basket template
ShowBasketItemFooter LTotalWeight
' (SS,21/2/24) moved here, parameters are now redundant
ShowBasketFooter
' (SS,23/2/15) save basket prices dictionary to session, and free object
Set Session("BasketPricesDict") = LobjBasketPricesDict
Set LobjBasketPricesDict = Nothing
SetBasketGrandTotal(LGrandTotal) ' (SS,19/1/15) set basket grand total, can be used by PayPal Express checkout etc.
SetBasketDescription(LBasketDesc)' (SS,17/2/15) set basket description, can be used by PayPal Express checkout etc.
' (SS,23/2/15) added following for saving to basket feature
SetBasketSubtotal(LSubtotal)
SetBasketDiscount(LDiscount)
SetBasketDelivery(LDelivery)
SetBasketVAT(LVATIncluded)
' (SS,6/3/18) removed following due to migration to gtag.js (Global Site Tag)
'SetRemarketingTagTotalValue(LSubtotal) ' (SS,28/11/13) not 100% sure about being subtotal, or whether VAT is deducted as above
' (SS,18/10/23) add discount as an additional item discount, voucher code
If LDiscount <> 0 Then
'oGTM.Discount = LDiscount
oGTM.DiscountCode = Session("VoucherCode")
oGTM.AddItem "DISCOUNT", "Discount Voucher Code: " & Session("VoucherCode"), "", GetVATExcValue(LDiscount), 1, "", "", ""
' (SS,19/10/23) following is a bit messy, we're saving the discount in a session because it's calculated by ShowBasket here, but is required by the begin_checkout event
Session("DiscountPassToGTM") = LDiscount
Else
oGTM.DiscountCode = ""
Session("DiscountPassToGTM") = "" ' don't use 0 because a check us done later for ""
End If
End Sub
' (SS,17/4/07) code moved to new routine called ShowShoppingStatusMain
Sub ShowShoppingStatus
ShowShoppingStatusMain False, 0, 0, 0, False
End Sub
' (SS,17/4/07) new summary version of shopping status
Sub ShowShoppingStatusSummary
Dim LTotalQty, LItemLines, LSubtotal, LIsEmpty
ShowShoppingStatusMain True, LTotalQty, LItemLines, LSubtotal, LIsEmpty
ShowShoppingStatusSummaryVersion LTotalQty, LItemLines, CorrectCurrencyNV(LSubtotal), LIsEmpty
End Sub
' (SS,11/4/07) renamed from ShowShoppingStatusMain, added 5 parameters for use by ShowShoppingStatusSummary
' called from 2 places: ShowShoppingStatus and ShowShoppingStatusSummary
' modified to make use of new parameters
' (SS,12/9/12) modified to use ItemID instead of ProductCode for LDeleteHRef
' (SS,25/10/18) note that AIsSummary being False (i.e. more detailed) as been redundant since new Bootstrap framework
' was only used for more detailed shopping status, which isn't used any more
' (SS,26/10/18) added GetShoppingBasketFilter to query to exclude subproducts
Sub ShowShoppingStatusMain(AIsSummary, ByRef ATotalQty, ByRef AItemLines, ByRef ASubtotal, ByRef AIsEmpty)
' following ordered by ItemID, ensuring most recent item will appear last '
' OpenQuery("SELECT shoppingbaskets.*, products.ProductName, products.StdPrice, products.SalePrice FROM shoppingbaskets LEFT JOIN products ON shoppingbaskets.ProductCode = products.ProductCode WHERE SessionID = '" + FSessionID + "' ORDER By ItemID")
' (SS,21/5/07) above replaced by following
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,26/10/18) added GetShoppingBasketFilter to filter out subproducts
OpenQuery("SELECT s.*, p.ProductName, " + GetPricingFieldsForSQL("p") + " FROM shoppingbaskets s LEFT JOIN products p ON p.ProductCode = s.ProductCode WHERE SessionID = '" + CleanSQLStr(FSessionID) + "'" + GetShoppingBasketFilter(False) + " ORDER BY ItemID")
' show the heading '
If Not AIsSummary Then ShowShoppingStatusHeader
ATotalQty = 0
AItemLines = 0
ASubtotal = 0
AIsEmpty = EndOfQuery
' if basket empty then just show the empty text else list the products '
If AIsEmpty Then
If Not AIsSummary Then ShowShoppingStatusEmpty
Else
If Not AIsSummary Then ShowShoppingStatusItemHeader
Dim LCount, LRecordCount, LProductCode, LProductName, LPrice, LQty, LProductCodeDashAsUnderscore, LDeleteHRef
LRecordCount = GetQueryRecordCount ' (SS,26/5/07)
Do While Not EndOfQuery
' (SS,26/5/07) added following to allow templates to determine whether at first or last records
SetAtFirstOrLastProduct LCount, LRecordCount
AItemLines = AItemLines + 1
LQty = NZ(GetFieldValue("Qty"))
ATotalQty = ATotalQty + LQty
LProductCode = GetFieldValue("ProductCode")
' (SS,21/5/07)
' (SS,6/7/11) removed LQty parameter, added True, to look up options price
GetPricingFromProductRecord(True)
LPrice = GetProductPrice
' (SS,1/4/08) added following to show VAT included prices, only for sites where entered prices don't include VAT and ShowIncVAT is true
If Not PricesEnteredIncludeVAT And ShowIncVAT Then
LPrice = Round2dp(LPrice + GetVATForProduct(LPrice))
End If
ASubtotal = ASubtotal + (LPrice * LQty)
If Not AIsSummary Then
' replace dash with underscore to make sure + - in JavaScript work '
LProductCodeDashAsUnderscore = ReplaceStr(LProductCode, "-", "_")
LProductName = HTMLEncode(GetFieldValue("ProductName")) ' (SS,26/7/11) added HTMLEncode
' (SS,25/10/18) NB. following is now redundant
LDeleteHRef = "javascript:itp_delete('" & GetFieldValue("ItemID") & "')" ' (SS,12/9/12) replaced LProductCode with GetFieldValue("ItemID")
ShowShoppingStatusItem LProductCode, LProductCodeDashAsUnderscore, Server.URLEncode(LProductCode), LProductName, LQty, CorrectCurrencyNV(LPrice), LDeleteHRef
End If
NextQueryRecord
Loop
End If
If Not AIsSummary Then ShowShoppingStatusFooter CorrectCurrencyNV(ASubtotal), AIsEmpty
CloseQuery
End Sub
Sub ShowSpecialOffers
Dim LProductCode, LProductCodeDashAsUnderscore
Dim LMaxSpecialOfferProducts, LSpecialOfferCount, LSQL, LWhere, LLimit, LDoneCount, LDiscountPercentage
Dim LGroup, LCategory, LSubcategory ' (SS,18/2/05) '
Dim LStdPrice, LSalePrice ' (SS,19/9/06)
ShowSpecialOffersHeader
' select products that have a sale price
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
LWhere = "WHERE ProductDisabled = 0" + GetProductsFilter
' (SS,18/5/07) added FUseDiscountFieldForSpecialOffers etc to use new Discount field for special offers
If FUseDiscountFieldForSpecialOffers Then
LWhere = LWhere + " AND IFNULL(Discount, 0) > 0"
Else
LWhere = LWhere + " AND NOT ISNULL(SalePrice)"
End If
OpenQuery("SELECT COUNT(*) AS Count FROM products " + LWhere)
LSpecialOfferCount = GetQueryValue("Count")
CloseQuery
' exit if there are no items '
If LSpecialOfferCount = 0 Then
ShowSpecialOffersEmpty
Else
LMaxSpecialOfferProducts = GetProductsMaxSpecialOffer
' (SS,18/5/07) replaced "ProductCode, ProductName, StdPrice, SalePrice" with * (instead of adding Discount because some installs may not have the Discount field)
LSQL = "SELECT * FROM products " + LWhere + " ORDER BY ProductName "
LLimit = "LIMIT " & Session("SpecialOfferCount") & "," & LMaxSpecialOfferProducts
LDoneCount = 0
OpenQuery(LSQL & LLimit)
Do While Not EndOfQuery
' (SS,26/5/07)
' (SS,6/7/11) removed 0 parameter, added False, no need to look up options price
GetPricingFromProductRecord(False)
LProductCode = GetFieldValue("ProductCode")
' replace dash with underscore to make sure + - in JavaScript work '
LProductCodeDashAsUnderscore = ReplaceStr(LProductCode, "-", "_")
' (SS,18/2/05) added following to get Group and Category for product, also to the end of ShowSpecialOffersItem '
GetFirstCatSubcatForProduct LProductCode, LGroup, LCategory, LSubcategory
' (SS,18/9/06) added following two lines for multicurrency
LStdPrice = CorrectCurrency(GetStdPrice) ' (SS,28/5/07) replaced GetFieldValue("StdPrice") with GetStdPrice
LSalePrice = CorrectCurrency(GetSalePrice)' (SS,28/5/07) replaced GetFieldValue("SalePrice") with GetSalePrice
LDiscountPercentage = GetDiscountPercentage ' (SS,28/5/07) discount code moved to GetDiscountPercentage
ShowSpecialOffersItem LProductCode, LProductCodeDashAsUnderscore, Server.URLEncode(LProductCode), GetFieldValue("ProductName"), LStdPrice, LSalePrice, LDiscountPercentage, LGroup, LCategory, LSubcategory
LDoneCount = LDoneCount + 1
NextQueryRecord
Session("SpecialOfferCount") = Session("SpecialOfferCount") + 1
' if no more records then try to wrap around to the start if applicable'
If EndOfQuery And LDoneCount < LMaxSpecialOfferProducts And LSpecialOfferCount > LMaxSpecialOfferProducts Then
Session("SpecialOfferCount") = 0
CloseQuery
LLimit = "LIMIT " & Session("SpecialOfferCount") & "," & LMaxSpecialOfferProducts - LDoneCount
OpenQuery(LSQL & LLimit)
End If
Loop
' wrap around if it goes beyond last special offer record '
If Session("SpecialOfferCount") >= LSpecialOfferCount Then Session("SpecialOfferCount") = 0
CloseQuery
End If
ShowSpecialOffersFooter("javascript:itp_sosearch()")
End Sub
' (SS,27/5/10) made speed improvements, now only run once per day, held in new bestsellers table
Sub ShowBestSellers
Dim LProductCode, LProductCodeDashAsUnderscore
Dim LMaxBestSellers, LBestSellerCount, LSQL, LOrderBy, LDoneCount, LPrice
Dim LGroup, LCategory, LSubcategory ' (SS,18/2/05)
LMaxBestSellers = GetBestSellersMax
' (SS,21/10/05) added best sellers order option of by TotalValue or TotalSold (was TotalValue)
' because cufflink wanted by TotalSold (not TotalValue as it is for Clifton)
' (SS,27/5/10) moved here from below and now saving in LOrderBy
If GetBestSellersSortOrder = "TotalSold" Then
LOrderBy = "TotalSold DESC, PriceEach DESC"
Else
LOrderBy = "TotalValue DESC, TotalSold DESC, PriceEach DESC"
End If
' check best sellers table, and update table once per day, querystring also forces an update updatebs=yes
Dim LUpdateBestSellers
LSQL = "SELECT *, DateUpdated < CURDATE() AS UpdateBestSellers FROM bestsellers ORDER BY ID, " & LOrderBy ' ORDER BY ID ensures ID 0 record is first
If CleanRequestQueryString("updatebs") = "yes" Then
LUpdateBestSellers = True
Else
OpenQuery(LSQL)
If EndOfQuery Then
LUpdateBestSellers = True
Else
LUpdateBestSellers = IntToBool(GetQueryValue("UpdateBestSellers"))
End If
CloseQuery ' (SS,18/5/12) moved here from just before Application.Lock below
End If
'If LUpdateBestSellers And Application("UpdatingBestSellers") <> True Then ' <> True (instead of = False) because default value of Application variable is ""
If LUpdateBestSellers And Application("UpdatingBestSellers") <> True Then ' <> True (instead of = False) because default value of Application variable is ""
' (SS,27/5/10) ensure only one instance can update the best sellers table
Application.Lock
Application("UpdatingBestSellers") = True
Application.UnLock
' *** may be good to add an on error resume next? to ensure flag is set to flag i.e. like try..finally in Delphi
' (SS,17/7/13) added ability to ignore products with Exclude from Best Sellers
Dim LAttributeID
If ProductAttributesEnabled Then
LAttributeID = GetAttributeIDForName("Exclude from Best Sellers")
Else
LAttributeID = ""
End If
ExecuteQuery("TRUNCATE bestsellers") ' (SS,27/5/10) empty the table
ExecuteQuery("INSERT INTO bestsellers SET ID = 0, DateUpdated = CURDATE()") ' (SS,27/5/10) special record holding date updated, at least this record will always exist
' (SS,18/2/05) added "AND ProductDisabled = 0" so disabled products are not shown '
' (SS,4/4/05) modified to include TotalValue, ORDER BY changed from TotalSold DESC, PriceEach DESC to TotalValue DESC
' (SS,27/5/10) added INSERT INTO bestsellers SELECT CURDATE() AS DateUpdated, removed surplus SUM(Qty * PriceEach) AS TotalValue
' (SS,18/5/12) replaced the "LEFT JOIN" with "INNER JOIN", link to productcategories was causing product to be included more than once if it belonged to more than one category
' fixed this by adding "AND Main" to productcategories join.
' (SS,29/5/12) replaced orderdetails.ProductName with products.ProductName, to use current product name rather than historical which may change
Dim LSQL2
LSQL2 = "INSERT INTO bestsellers" &_
" SELECT 1, CURDATE() AS DateUpdated, orderdetails.ProductCode, products.ProductName, PriceEach, SUM(Qty) AS TotalSold, SUM(Qty * PriceEach) AS TotalValue, Category, Subcategory, StdPrice, SalePrice" &_
" FROM orderdetails" &_
" INNER JOIN orders ON orders.OrderNo = orderdetails.OrderNo" &_
" INNER JOIN productcategories ON productcategories.ProductCode = orderdetails.ProductCode AND Main " &_
" INNER JOIN products ON products.ProductCode = orderdetails.ProductCode"
' (SS,17/7/13) to exclude products marked with "Exclude from Best Sellers" attribute
If LAttributeID <> "" Then LSQL2 = LSQL2 + " LEFT JOIN product_attributes ON product_attributes.ProductID = products.ProductID AND product_attributes.AttributeID = " & LAttributeID
' (SS,31/10/18) added GetOrderDetailsFilter to filter out subproducts
LSQL2 = LSQL2 + " WHERE (orders.Status = 'PAYMENT RECEIVED' OR orders.Status = 'COMPLETED') AND PriceEach > 0 AND ProductDisabled = 0" &_
" AND TO_DAYS(CURDATE()) - TO_DAYS(orders.DateTimeOrdered) <= " & GetBestSellersPastDays + GetOrderDetailsFilter
' (SS,17/7/13) to exclude products marked with "Exclude from Best Sellers" attribute
If LAttributeID <> "" then LSQL2 = LSQL2 + " AND product_attributes.AttributeID IS NULL"
' (SS,18/5/12) moved the group by and order by from above query to following, because it's also used by the new per_category query below
ExecuteQuery(LSQL2 + " GROUP BY orderdetails.ProductCode ORDER BY " & LOrderBy + " LIMIT " & LMaxBestSellers) ' (SS,27/5/10) was OpenQuery(LSQL)
' (SS,18/5/12) added following to create bestsellers per category/subcategory
ExecuteQuery("CREATE TABLE IF NOT EXISTS bestsellers_per_category LIKE bestsellers")
ExecuteQuery("TRUNCATE bestsellers_per_category") ' in case table existed before create above
' same as overall query above but with different table name AND Main removed, and different group by, no order by and no limit
LSQL2 = ReplaceStr(LSQL2, "INSERT INTO bestsellers", "INSERT INTO bestsellers_per_category")
LSQL2 = ReplaceStr(LSQL2, " AND Main ", "")
ExecuteQuery(LSQL2 + " GROUP BY Category, Subcategory, orderdetails.ProductCode")
' (SS,27/5/10) clear the flag so it can be updated again
Application.Lock
Application("UpdatingBestSellers") = False
Application.UnLock
' (SS,18/5/12) removed following, open now done below
' OpenQuery(LSQL) ' open the query with new data
End If
' (SS,18/5/12) determine which table to use, bestsellers for main, if category or subcategory applicable then use bestsellers_per_category
' we're using the menu category and subcategory settings to determine which category/subcategory we're in
' (SS,22/5/12) added LSQLPre, i.e. * replaced with DISTINCT ProductCode, ProductName, StdPrice, SalePrice,
' prevents duplicates when looking at Category where product appears in more than one subcategory for same category
Dim LSQLPre
LSQLPre = "SELECT DISTINCT ProductCode, ProductName, StdPrice, SalePrice, TotalSold, TotalValue FROM "
If GetMenuCategory <> "" And GetMenuSubcategory <> "" Then
LSQL = LSQLPre + "bestsellers_per_category WHERE Category = '" & CleanSQLStr(GetMenuCategory) & "' AND Subcategory = '" & CleanSQLStr(GetMenuSubcategory) & "'"
ElseIf GetMenuCategory <> "" Then
LSQL = LSQLPre + "bestsellers_per_category WHERE Category = '" & CleanSQLStr(GetMenuCategory) & "'"
Else ' i.e. GetMenuCategory = "" And GetMenuSubcategory = ""
LSQL = LSQLPre + "bestsellers WHERE ID = 1"
End If
OpenQuery(LSQL + " ORDER BY " + LOrderBy + " LIMIT " & LMaxBestSellers) ' (SS,18/5/12)
' count the records (SS,26/5/07) improved version which uses new GetQueryRecordCount function
' (SS,28/5/10) - 1 to ignore the special ID 0 record
' (SS,18/5/12) moved here from above, no need of "- 1" because we have ID = 1 above
LBestSellerCount = GetQueryRecordCount
' exit if there are less than required number of best sellers
' (SS,18/5/12) replaced LBestSellerCount < LMaxBestSellers with LBestSellerCount = 0
If LBestSellerCount = 0 Then
ShowBestSellersEmpty
Else
ShowBestSellersHeader
LDoneCount = 0
' (SS,22/5/12) added allow TotalSold and TotalValue to show when querystring bstotals=y exists
Dim LProductName, LShowTotals
If CleanRequestQueryString("bstotals") = "y" Then
Session("bstotals") = True
ElseIf CleanRequestQueryString("bstotals") = "n" Then
Session("bstotals") = False
End If
LShowTotals = Session("bstotals") = True
Do While Not EndOfQuery
' (SS,22/5/12) removed "If GetQueryField("ID") <> 0 Then" ' ignore the ID 0 record
LDoneCount = LDoneCount + 1
' (SS,26/5/07) added following to allow templates to determine whether at first or last records
SetAtFirstOrLastProduct LDoneCount, LBestSellerCount
LProductCode = GetQueryField("ProductCode")
' replace dash with underscore to make sure + - in JavaScript work '
LProductCodeDashAsUnderscore = ReplaceStr(LProductCode, "-", "_")
If IsNull(GetQueryField("SalePrice")) Then
LPrice = GetQueryField("StdPrice")
Else
LPrice = GetQueryField("SalePrice")
End If
LPrice = CorrectCurrency(LPrice) ' (SS,18/9/06)
' (SS,18/2/05) added following to get Group and Category for product, also to the end of ShowBestSellersItem '
GetFirstCatSubcatForProduct LProductCode, LGroup, LCategory, LSubcategory
' (SS,22/5/12) add the total sold and value after the product name if enabled
LProductName = GetQueryField("ProductName")
' (SS,30/4/13) added Round because it was showing many DP, also added bold
If LShowTotals Then LProductName = LProductName & "<br />(<b>" & Round(GetQueryField("TotalValue"), 0) & " / " & GetQueryField("TotalSold") & "</b>)"
ShowBestSellersItem LDoneCount, LProductCode, LProductCodeDashAsUnderscore, Server.URLEncode(LProductCode), LProductName, LPrice, LGroup, LCategory, LSubcategory
NextQueryRecord
Loop
ShowBestSellersFooter
End If
CloseQuery
End Sub
' (SS,17/1/13)
' (SS,6/6/1/17) renamed from ShowNewProducts to ShowNewProductsOld. *** can be removed, new RWD version is below
Sub ShowNewProductsOld
Dim LNewProductsCount, LDoneCount
OpenQuery("SELECT ProductCode, ProductName FROM products WHERE DateAdded IS NOT NULL AND NOT ProductDisabled ORDER BY DateAdded DESC, SortOrder LIMIT 10")
LNewProductsCount = GetQueryRecordCount
If LNewProductsCount = 0 Then
ShowNewProductsEmpty
Else
ShowNewProductsHeader
LDoneCount = 0
Do While Not EndOfQuery
LDoneCount = LDoneCount + 1
ShowNewProductsItem LDoneCount, GetFieldValue("ProductCode"), GetFieldValue("ProductName")
NextQueryRecord
Loop
ShowNewProductsFooter
End If
CloseQuery
End Sub
' (SS,17/1/13)
' (SS,6/6/17) new version for RWD which can show a full product list, works in similar way to highlights or featured products, i.e. SalePrice, StdPrice and NumInStock
' added new parameters AMaxToShow, AExtraOptions, AExtraOptions not currently used. DoneCount counter removed.
' *** can be removed
Sub ShowNewProductsOld2(AMaxToShow, AExtraOptions)
Dim LSQL, LNewProductsCount, LStdPrice, LSalePrice
LSQL = "SELECT ProductCode, ProductName, SalePrice, StdPrice, NumInStock FROM products WHERE DateAdded IS NOT NULL AND NOT ProductDisabled"
LSQL = LSQL + " AND EXISTS(SELECT PictureID FROM pictures WHERE Type = 'P' AND Code = products.ProductCode AND Enabled)"
LSQL = LSQL + " ORDER BY DateAdded DESC, SortOrder LIMIT " & AMaxToShow
OpenQuery(LSQL)
LNewProductsCount = GetQueryRecordCount
If LNewProductsCount = 0 Then
ShowNewProductsEmpty
Else
ShowNewProductsHeader
Do While Not EndOfQuery
LStdPrice = CorrectCurrencyNV(GetFieldValue("StdPrice"))
LSalePrice = CorrectCurrencyNV(GetFieldValue("SalePrice"))
ShowNewProductsItem GetFieldValue("ProductCode"), GetFieldValue("ProductName"), LSalePrice, LStdPrice, GetFieldValue("NumInStock")
NextQueryRecord
Loop
ShowNewProductsFooter
End If
CloseQuery
End Sub
' (SS,18/7/17) replaced Sub ShowNewProductsOld2 above with this one which make use of existing ShowProducts
' where strSearch is set to NEW_PRODUCTS_SEARCH_TEXT and LMax to limit for how many to show
Sub ShowNewProducts(AMaxToShow, AExtraOptions)
' ShowProducts strGroup, strCategory, strSubcategory, strSearch, strPage, LAttributeID, LMin, LMax, LVal
ShowProducts "", "", "", NEW_PRODUCTS_SEARCH_TEXT, "", "", "", AMaxToShow, ""
End Sub
' (SS,15/2/12) original version
' (SS,13/5/21) routine seems redundant, changed to with Normal or Trustpilot by adding AMaxCount and AOptions
' if AOptions contains "TP" then ShowRecentReviewsTrustpilot is called else ShowRecentReviewsNormal
Sub ShowRecentReviews(AMaxCount, AOptions)
'ShowRecentReviewsMain 10, False
' (SS,13/5/21) above replaced with following to normal or Trustpilot reviews
If InStr(AOptions, "TP") Then
ShowRecentReviewsTrustpilot AMaxCount, AOptions
Else
ShowRecentReviewsNormal AMaxCount, AOptions
End If
End Sub
' (SS,26/8/14) version 2
' (SS,13/5/21) once all calls to ShowRecentReviewsV2 have been renamed to ShowRecentReviews, this routine can then be deleted
Sub ShowRecentReviewsV2(AMaxCount)
' ShowRecentReviewsMain AMaxCount, True
' (SS,13/5/21) replaced above with following, due to ShowRecentReviewsMain renamed to ShowRecentReviewsNormal
ShowRecentReviewsNormal AMaxCount, ""
End Sub
' (SS,15/2/12) original version
' (SS,26/8/14) code more here from ShowRecentReviews above, called from two places, i.e. ShowRecentReviewsV2
' (SS,17/8/15) modified to handle Trustpilot reviews held in trustpilot_reviews table
' (SS,13/5/21) moved Trustpilot code to separate ShowRecentReviewsTP due to CIRC now showing both normal and Trustpilot
' Also removed the AIsVersion2 parameter. Rename this from ShowRecentReviewsMain to ShowRecentReviewsNormal, added AOptions for future expansion
Sub ShowRecentReviewsNormal(AMaxCount, AOptions)
Dim LSQL, LReviewCount, LDoneCount, LProductCode, LReviewerName
' (SS,26/8/14) replaced 10 with AMaxCount, added fields ReviewTitle, ProductRating, ReviewerName, ReviewText
' (SS,14/9/17) added " GROUP BY ReviewText, DATE(ReviewDateTime), ReviewerName" to prevent reviews with duplicate ReviewTexts appearing compromising SEO on home page
LSQL = "SELECT ReviewID, pr.ProductCode, DATE_FORMAT(ReviewDateTime, '%e %b %Y') AS ReviewDate, ReviewTitle, ProductRating, ReviewerName, ReviewText" &_
" FROM productreviews pr" &_
" INNER JOIN products p ON p.ProductCode = pr.ProductCode" &_
" WHERE ShowOnSite AND NOT p.ProductDisabled AND ReviewType = 'R'" &_
" GROUP BY ReviewText, DATE(ReviewDateTime), ReviewerName" &_
" ORDER BY ReviewDateTime DESC LIMIT " & AMaxCount
OpenQuery(LSQL)
LReviewCount = GetQueryRecordCount
If LReviewCount = 0 Then
ShowRecentReviewsEmpty
Else
ShowRecentReviewsHeader
LDoneCount = 0
Do While Not EndOfQuery
LDoneCount = LDoneCount + 1
LProductCode = GetQueryField("ProductCode")
LReviewerName = GetQueryField("ReviewerName")
If LReviewerName = "" Then LReviewerName = "Anonymous"
ShowRecentReviewsItem LDoneCount, GetQueryField("ReviewID"), LProductCode, GetProductName(LProductCode), GetQueryField("ReviewDate"), GetQueryField("ReviewTitle"), GetQueryField("ProductRating"), LReviewerName, GetQueryField("ReviewText")
NextQueryRecord
Loop
ShowRecentReviewsFooter
End If
CloseQuery
End Sub
' (SS,13/5/21) special version for Trustpilot, previously this combined in ShowRecentReviewsMain
' was become too messy when both normal and Trustpilot reviews were required for CIRC
' so made sense to separate out from ShowRecentReviewsMain due to calling ShowRecentReviews.. functions with suffix at the end
' Also had to adjust the calls in EM (inc-template-reviews.asp) to suffix with TP for Trustpilot
' AOptions parameter is for future expansion
Sub ShowRecentReviewsTrustpilot(AMaxCount, AOptions)
' get the aggregate values from record with ID of 1
Dim LAverageRating, LRatingTitle, LReviewCount
If GetSQL3Values("SELECT ReviewBody, ReviewTitle, ReviewerName FROM trustpilot_reviews WHERE ReviewID = 1", LAverageRating, LRatingTitle, LReviewCount) Then
LAverageRating = CDbl(LAverageRating)
LRatingTitle = NB(LRatingTitle)
LReviewCount = CInt(LReviewCount)
Else
LAverageRating = 0
LRatingTitle = ""
LReviewCount = 0
End If
Dim LSQL, LDoneCount
LSQL = "SELECT *, DATE_FORMAT(ReviewDateTime, '%e %b %Y') AS ReviewDate FROM trustpilot_reviews WHERE ReviewID > 1 ORDER BY ReviewDateTime DESC LIMIT " & AMaxCount
OpenQuery(LSQL)
If EndOfQuery Then ' if no reviews
ShowRecentReviewsEmptyTP
Else
ShowRecentReviewsHeaderTP LAverageRating, LRatingTitle, LReviewCount
LDoneCount = 0
Do While Not EndOfQuery
LDoneCount = LDoneCount + 1
ShowRecentReviewsItemTP LDoneCount, GetQueryField("ReviewID"), "", "", GetQueryField("ReviewDate"), GetQueryField("ReviewTitle"), GetQueryField("ReviewRating"), GetQueryField("ReviewerName"), GetQueryField("ReviewBody")
NextQueryRecord
Loop
ShowRecentReviewsFooterTP
End If
CloseQuery
End Sub
' (SS,18/09/06) moved ShowProductPrice and ShowProductPriceExcVAT here from inc-template-product-detail
' (SS,16/1/13) replaced IsCurrencyVATable with IsCountryVATable
Sub ShowProductPrice(ASalePrice, AStdPrice)
If ASalePrice <> "" Then ' (SS,18/9/06) was Not IsNull(ASalePrice)
' (SS,18/9/06) removed FormatNumber because ASalePrice and AStdPrice are now correctly formatted
%>
<span class="lst_saleprice"><%=AStdPrice%></span>
<span class="lst_price"><%=ASalePrice%></span>
<span class="lst_vat">
<%If ShowIncVAT And IsCountryVATable Then Response.Write(" inc VAT")%>
</span>
<%
Else
%>
<span class="lst_price"><%=AStdPrice%></span>
<span class="lst_vat">
<%If ShowIncVAT And IsCountryVATable Then Response.Write(" inc VAT")%>
</span>
<%
End if
End Sub
' (SS,10/8/15) modified to remove the <br> from Responsive Web Design
Sub ShowProductPriceExcVAT(ASalePrice, AStdPrice)
' (SS,19/9/06) added following
' (SS,16/1/13) replaced IsCurrencyVATable with IsCountryVATable
If Not ShowExcVAT Or Not IsCountryVATable Then
Exit Sub
End If
Dim LPrice, LVATRate
If ASalePrice <> "" Then ' (SS,18/9/06) was Not IsNull(ASalePrice)
LPrice = ASalePrice
Else
LPrice = AStdPrice
End If
LVATRate = GetVATRate
' (SS,19/9/06) a bit messy but had to be done this way
' remove the currency symbol, else following calculation will fail
If Left(LPrice, Len(GetCurrencySymbol)) = GetCurrencySymbol Then
LPrice = Mid(LPrice, Len(GetCurrencySymbol) + 1, 999)
End If
LPrice = CDbl(LPrice) * (1/(1 + LVATRate))
' (SS,10/8/15) replaced <br> with following
If not IsRWD Then
Response.Write BR
End If
%>
<span class="price_exc_vat">
<%Response.Write(GetCurrencySymbol & FormatNumber(LPrice, 2) & " exc VAT")%>
</span>
<%
End Sub
' (SS,12/5/11) New version of show product price, with boolean parameters to show out price crossed out, and actual price in large
' (SS,26/5/11) added AOptions, "saveprice" or "savepc"
Sub ShowProductPriceV2(ASalePrice, AStdPrice, AOldPriceCrossedOut, AActualPriceLarge, AOptions)
' old price crossed out
If AOldPriceCrossedOut And ASalePrice <> "" Then
%><span class="price-std-crossed-out"><%=AStdPrice%></span> <%
End If
' actual price
If AActualPriceLarge Then
%><span class="price-actual-large"><%
End If
If ASalePrice <> "" Then ' i.e. it's a sale price
%><span class="price-sale"><%=ASalePrice%></span><%
Else
%><span class="price-std"><%=AStdPrice%></span><%
End If
If AActualPriceLarge Then ' close the span open for actual price large
%></span><%
End If
' (SS,16/1/13) replaced IsCurrencyVATable with IsCountryVATable
If ShowIncVAT And IsCountryVATable Then Response.Write(" inc VAT")
' (SS,26/5/11) added following for save price/percentage
If ASalePrice <> "" Then
Dim LDoSavePrice, LDoSavePC
LDoSavePrice = InStr(AOptions, "saveprice") > 0
LDoSavePC = InStr(AOptions, "savepc") > 0
If LDoSavePrice or LDoSavePC Then Response.Write " save "
If LDoSavePrice Then
%><span class="price-save"><%=CorrectCurrencyNV(GetStdPrice - GetSalePrice)%></span><%
End If
If LDoSavePC Then
%><span class="price-save-pc"><%=IIf(LDoSavePrice," (","") & FormatNumber(GetDiscountPercentage, 0) & "%" & IIf(LDoSavePrice,")","")%></span><%
End If
End If
End Sub
' (SS,20/8/14) calls ShowProductPriceV2 above and includes VAT in the prices, assuming the price excludes VAT normally
' don't use the "saveprice" option here because the difference will be wrong if prices entered exclude VAT
' calls CorrectCurrencyWV to add VAT if country is VATable
' (SS,2/9/14) not used (as of 2/9/14) was going to be used for new Cast Iron Radiator Centre site to make inc VAT price more prominent
Sub ShowProductPriceIncVAT(ASalePrice, AStdPrice, AOldPriceCrossedOut, AActualPriceLarge, AOptions)
Dim LStdPrice, LSalePrice
LStdPrice = CorrectCurrencyWV(GetStdPrice)
LSalePrice = CorrectCurrencyWV(GetSalePrice)
ShowProductPriceV2 LSalePrice, LStdPrice, AOldPriceCrossedOut, AActualPriceLarge, AOptions
End Sub
' (SS,19/8/14) simply shows the price, no spans or classes added
' price obtained from GetProductPrice, AIncVATParameter set to True to include VAT
Sub ShowProductPriceSimple(AIncVATParameter)
Dim LPrice, LResult
LPrice = GetProductPrice
If AIncVATParameter Then
LResult = CorrectCurrencyWV(LPrice)
Else
LResult = CorrectCurrencyNV(LPrice)
End If
Response.Write LResult
End Sub
' (SS,16/2/16) replacement of ShowProductPriceSimple above but returns the value and can specify AWithCurrencySymbol parameter
Function GetProductPriceSimple(AIncVAT, AWithCurrencySymbol)
Dim LPrice, LResult
LPrice = GetProductPrice
If AIncVAT Then
LResult = CorrectCurrencyWV(LPrice)
Else
LResult = CorrectCurrencyNV(LPrice)
End If
If Not AWithCurrencySymbol Then
LResult = RemoveCurrencySymbol(LResult)
End If
GetProductPriceSimple = LResult
End Function
' (SS,22/9/17) modified version of GetProductPriceSimple without AWithCurrencySymbol parameter also removes comma (Google doesn't like commas in microdata)
Function GetProductPriceForMicrodata(AIncVAT)
Dim LResult
LResult = GetProductPriceSimple(AIncVAT, False)
GetProductPriceForMicrodata = Replace(LResult, ",", "")
End Function
' (SS,16/11/20) for (GSC, custom utils), returns the product price for given product ID
' makes use of existing variables FStdPrice, FSalePrice and function GetProductPriceSimple
Function GetProductPriceForProductID(AProductID, AIncVAT, AWithCurrencySymbol)
Dim LStdPrice, LSalePrice
LStdPrice = GetFieldForProductID(AProductID, "StdPrice")
LSalePrice = GetFieldForProductID(AProductID, "SalePrice")
' FStdPrice, FSalePrice are referred to by GetProductPriceSimple
FStdPrice = ENKN(LStdPrice) ' ENKN ensures number keeping null
FSalePrice = ENKN(LSalePrice)
GetProductPriceForProductID = GetProductPriceSimple(AIncVAT, AWithCurrencySymbol)
End Function
' (SS,22/9/17) used for microdata in inc-template-product-detail.asp
Function GetProductConditionForMicrodata(AProductID)
Dim LResult
LResult = GetProductAttributeByName(AProductID, "Condition")
If LResult = "" Then
LResult = "NewCondition"
Else
LResult = Proper(LResult) & "Condition"
End If
GetProductConditionForMicrodata = LResult
End Function
' (SS,6/7/06)
' (SS,25/2/10) LImageCount changed to FProductImageCount global
' (SS,22/11/12) renamed from ShowProductMoreImages and added AMax parameter, called by ShowProductMoreImages above, if AExludeCount is 0 then all images are shown
' (SS,22/11/12) can also be called from inc-template-product-details.asp if we need to specify images to exclude, e.g. if magic360 or youtube video exists
' (SS,22/11/12) code moved to ShowProductMoreImagesExclude, this is called from inc-template-product-details.asp
' (SS,22/8/14) new version which doesn't use image no and makes use of new Enabled, Caption and SortOrder fields
' (SS,11/9/14) added AExcludeCount and AOptions, renamed it from ShowProductMoreImagesV2 to ShowProductMoreImages, removed previous ShowProductMoreImages and ShowProductMoreImagesExclude
Sub ShowProductMoreImages(AProductCode, AExcludeCount, AOptions)
Dim LSQL, LCount, LCaption
LSQL = "SELECT PictureID, Caption FROM pictures WHERE Type = 'P' AND Code = '" & CleanSQLStr(AProductCode) & "' AND Enabled ORDER BY SortOrder, Code2, PictureID"
OpenQuery(LSQL)
FProductImageCount = GetQueryRecordCount
' (SS,11/9/14) added following to exclude 1 or 2 pictures using AExcludeCount because we may have a magic 360 or youtube video
If AExcludeCount > 0 And FProductImageCount > (GetMaxPicturesPerProduct - AExcludeCount) Then FProductImageCount = GetMaxPicturesPerProduct - AExcludeCount
' only if more than one image exists
If FProductImageCount > 1 Then
OpenQuery(LSQL)
ShowProductMoreImagesHeader
LCount = 0
' (SS,11/9/14) added And LCount < FProductImageCount
Do While Not EndOfQuery And LCount < FProductImageCount
LCount = LCount + 1
LCaption = NB(GetQueryValue("Caption")) ' NB important to treat null as ""
' (SS,11/9/14) added tr() to Picture and of
If LCaption = "" Then LCaption = tr("Picture") & " " & LCount & " " & tr("of") & " " & FProductImageCount ' set default caption if none found
ShowProductMoreImagesItem GetQueryValue("PictureID"), LCount, FProductImageCount, LCaption
NextQueryRecord
Loop
ShowProductMoreImagesFooter
End If
CloseQuery
End Sub
' (SS,25/2/10) returns FProductImageCount set by ShowProductMoreImages to allow captions like "Image 2 of 3"
Function GetProductImageCount
GetProductImageCount = FProductImageCount
End Function
' (SS,6/7/06)
' (SS,1/11/06) added LHeaderShown
Sub ShowProductFiles(AProductCode)
If Not GetProductFilesEnabled Then Exit Sub
Dim LSQL, LFileName, LFileNameNoExt, LPos, LFileType, LFileSize, LHeaderShown
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "SELECT Code2, FileName, FileSize FROM files WHERE Type = 'P' AND Code = '" & CleanSQLStr(AProductCode) & "' ORDER BY Code2"
OpenQuery(LSQL)
LHeaderShown = False
Do While Not EndOfQuery
If Not LHeaderShown Then
ShowProductFilesHeader
LHeaderShown = True
End If
LFileName = Trim(GetQueryValue("FileName"))
LPos = InStrRev(LFileName, ".")
If LPos > 0 Then
LFileType = LCase(Trim(Mid(LFileName, LPos + 1, 20)))
LFileNameNoExt = Trim(Mid(LFileName, 1, LPos - 1))
Else
LFileType = "pdf" ' default to pdf it no extension
LFileNameNoExt = LFileName
End If
LFileSize = Int(GetQueryValue("FileSize") / 1024) & "kb"
ShowProductFilesItem AProductCode, LFileName, LFileNameNoExt, GetQueryValue("Code2"), LFileType, LFileSize
NextQueryRecord
Loop
CloseQuery
If LHeaderShown Then ShowProductFilesFooter
End Sub
' (SS,17/5/07)
Sub ShowProductRelatedOld(AProductCode)
' (SS,9/6/07) following line is important because when GetProductLink is called by ShowProductRelatedItem
' and get product is showing second image, we don't want all products links for related products
' to link to 2 or 3 image, it might show image not available when related product is clicked
' (SS,8/8/18) following removed
' strImageNo = ""
Dim LSQL, LHeaderShown, LRecordCount, LCount
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "SELECT pr.RelatedProductCode AS ProductCode, ProductName, ProductDescription, pr.SortOrder FROM productrelated pr" +_
" INNER JOIN products p ON p.ProductCode = pr.RelatedProductCode" +_
" WHERE pr.ProductCode = '" + CleanSQLStr(AProductCode) + "' AND ProductDisabled = 0" +_
" ORDER BY SortOrder, ProductCode"
OpenQuery(LSQL)
LRecordCount = GetQueryRecordCount
LHeaderShown = False
LCount = 0
Do While Not EndOfQuery
LCount = LCount + 1
SetAtFirstOrLastProduct LCount, LRecordCount
SetProductDescription(GetFieldValue("ProductDescription"))
If Not LHeaderShown Then
ShowProductRelatedHeader
LHeaderShown = True
End If
' (SS,27/7/11) added HTMLEncode
ShowProductRelatedItem GetQueryValue("ProductCode"), HTMLEncode(GetQueryValue("ProductName")), GetQueryValue("ProductDescription")
NextQueryRecord
Loop
CloseQuery
If LHeaderShown Then ShowProductRelatedFooter
End Sub
' (SS,17/5/07)
' (SS,13/5/11) renamed from ShowProductRelated to ShowRelatedProducts, added code to prevent being called twice
' because it can be called from within inc-template-product-detail for more accurate positioning
' (SS,15/5/11) added code to lookup price and stock info
' (SS,4/10/13) added SortOrder back
' (SS,30/12/14) rewritten to avoid temporary create and insert queries to prevent adding to binary log for replication, now uses a union query
Sub ShowRelatedProducts(AProductCode)
' (SS,13/5/11) prevent being called more than once
If FShowRelatedProductsCalled Then Exit Sub
FShowRelatedProductsCalled = True
' (SS,9/6/07) following line is important because when GetProductLink is called by ShowProductRelatedItem
' and get product is showing second image, we don't want all products links for related products
' to link to 2 or 3 image, it might show image not available when related product is clicked
' (SS,8/8/18) following removed
' strImageNo = ""
Dim LSQL, LHeaderShown, LRecordCount, LCount
' (SS,14/11/07) added facility to show all related products in group
' (SS,14/11/07) build temporary table with all related products from productrelated
' (SS,30/12/14) temporary table replaced with union query
LSQL = "(SELECT RelatedProductCode AS ProductCode, SortOrder FROM productrelated WHERE ProductCode = '" + CleanSQLStr(AProductCode) + "')"
If ShowRelatedProductsInGroup Then
' (SS,14/11/07) find this product used as related product for other products, and use this to add all the related products
' from these other products
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,30/12/14) replaced insert with union
Dim LSQL2
LSQL2 = "SELECT ProductCode, SortOrder FROM productrelated WHERE RelatedProductCode = '" + CleanSQLStr(AProductCode) + "'"
OpenQuery(LSQL2)
Do While Not EndOfQuery
' (SS,30/12/14) replaced insert with union
LSQL = LSQL + NL + "UNION ALL"
LSQL = LSQL + NL + "(SELECT RelatedProductCode AS ProductCode, SortOrder FROM productrelated WHERE ProductCode = '" + CleanSQLStr(GetFieldValue("ProductCode")) + "')"
' (SS,15/11/07) also the product for which the related products exist with sort order 0
' (SS,30/12/14) replaced insert with union
LSQL = LSQL + NL + "UNION ALL"
LSQL = LSQL + NL + "(SELECT '" + CleanSQLStr(GetFieldValue("ProductCode")) + "', 0)"
NextQueryRecord
Loop
CloseQuery
Else ' (SS,v171,19/5/09) add products that also link to this product (i.e. reciprocal)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,30/12/14) replaced insert with union
LSQL = LSQL + NL + "UNION ALL"
LSQL = LSQL + NL + "(SELECT ProductCode, SortOrder FROM productrelated WHERE RelatedProductCode = '" + CleanSQLStr(AProductCode) + "')"
End If
' "ProductCode <> " used to not include this product i.e. linking to itself
' (SS,16/5/11) added NumInStock, DateStockDue, GetPricingFieldsForSQL("") and GetStockAvailabilityFieldList to allow price and stock info to be shown in related products list,
' also had to add join to suppliers and removed the p alias due to GetStockAvailabilityFieldList
' (SS,6/7/11) added products.ProductID
' (SS,12/1/11) removed SortOrder from ORDER BY, as requested by Neil
' (SS,18/5/12) added join to productcategories table to get main category/subcategory which is used to sort on
' ORDER BY changed from "ProductCode" to "pc.Category, pc.Subcategory, r.ProductCode"
' also added IF(COALESCE(NumInStock, 1) = 0, 0, 1) AS InStock and conditionally "InStock DESC" to order by to ensure out of stock items appear at the end
' New setting RelatedProductsOutOfStock can be Normal, End or Hide, this used to adjust the order by and where clause
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,4/10/13) added SortOrder which was removed before
' (SS,30/12/2014) modified to use the union statements above instead of temporary table
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
LSQL = "SELECT products.ProductID, r.ProductCode, ProductName, ProductDescription, MIN(r.SortOrder) AS SortOrder, NumInStock, DateStockDue, " + GetPricingFieldsForSQL("") + "," +_
" IF(COALESCE(NumInStock, 1) = 0, 0, 1) AS InStock, " +_
GetStockAvailabilityFieldList & " FROM" +_
NL + "(" + NL + LSQL + NL + ") r" + NL +_
"INNER JOIN products ON products.ProductCode = r.ProductCode" + NL +_
"INNER JOIN productcategories pc ON pc.ProductCode = products.ProductCode AND pc.Main" + NL +_
"LEFT JOIN suppliers ON suppliers.SupplierID = products.SupplierID " + NL +_
"WHERE ProductDisabled = 0" & GetProductsFilter & " AND r.ProductCode <> '" + CleanSQLStr(AProductCode) + "'" + IIf(RelatedProductsOutOfStockHide, " AND COALESCE(NumInStock, 1) > 0", "") + NL +_
"GROUP BY r.ProductCode, ProductName, ProductDescription" + NL + _
"ORDER BY " + IIf(RelatedProductsOutOfStockEnd, "InStock DESC, ", "") + "SortOrder, pc.Category, pc.Subcategory, r.ProductCode"
OpenQuery(LSQL)
LRecordCount = GetQueryRecordCount
LHeaderShown = False
LCount = 0
Do While Not EndOfQuery
LCount = LCount + 1
SetAtFirstOrLastProduct LCount, LRecordCount
SetProductDescription(GetFieldValue("ProductDescription"))
If Not LHeaderShown Then
ShowProductRelatedHeader
LHeaderShown = True
End If
' (SS,16/5/11) add following to allow price and availability info to be shown
' (SS,6/7/11) removed 0 parameter from GetPricingFromProductRecord, added False, no need to look up options price
GetPricingFromProductRecord(False)
SetStockAvailabilityFromFields
SetStockInfo GetFieldValue("NumInStock"), GetFieldValue("DateStockDue")
' (SS,27/7/11) added HTMLEncode
ShowProductRelatedItem GetQueryValue("ProductCode"), HTMLEncode(GetQueryValue("ProductName")), GetQueryValue("ProductDescription")
NextQueryRecord
Loop
CloseQuery
If LHeaderShown Then ShowProductRelatedFooter
End Sub
' (SS,3/8/04) returns true if account holder logged in '
Function AccountLoggedIn
AccountLoggedIn = Session("AccountID") <> ""
End Function
' (SS,28/5/09) returns true if customer tried to login by filling in email and password
' (SS,15/6/21) now using new login value to better detect login attempt
Function AccountOptionalLoginAttempt
' AccountOptionalLoginAttempt = Trim(CleanRequestForm("LoginEmail")) <> "" And Trim(CleanRequestForm("LoginPassword")) <> ""
' (SS,15/6/21) replaced above with following
AccountOptionalLoginAttempt = CleanRequestForm("login") = "yes"
End Function
' (SS,3/8/04) returns true if accounts enabled for this application '
Function AccountsEnabled
AccountsEnabled = FAccountsEnabled ' (SS,30/5/07) was Application("AccountsEnabled")
End Function
' (SS,27/5/09) replaced AccountsCompulsory with AccountCompulsory
Function AccountsCompulsory
AccountsCompulsory = AccountsEnabled And FAccountTypes = AT_COMPULSORY
End Function
' (SS,27/5/09)
Function AccountsOptional
AccountsOptional = AccountsEnabled And FAccountTypes = AT_OPTIONAL
End Function
' (SS,27/5/09)
Function AccountsAdmin
AccountsAdmin = AccountsEnabled And FAccountTypes = AT_ADMIN
End Function
' (SS,30/5/07)
Function UseEmailAddressForLogin
UseEmailAddressForLogin = FUseEmailAddressForLogin
End Function
' (SS,30/5/07) returns true if new account type (with Email address) are being used
Function NewAccountMethod
NewAccountMethod = AccountsEnabled And UseEmailAddressForLogin
End Function
' (SS,3/8/04) returns true if different delivery address enabled for this application '
Function AllowDifferentDeliveryAddress
AllowDifferentDeliveryAddress = FAllowDifferentDeliveryAddress
End Function
' (SS,5/8/04) returns true if different delivery address has been entered by user '
Function DeliveryAddressEntered
DeliveryAddressEntered = AllowDifferentDeliveryAddress And Not Session("DeliveryAddressSameAsInvoice")
End Function
' (SS,12/8/05) returns true if user had selected place order on account
Function IsPlaceOrderOnAccount()
IsPlaceOrderOnAccount = CleanRequestForm("options") = "OnAccount"
End Function
' (SS,2/9/05) returns true it site is secure i.e. HTTPS
Function IsSecureSite()
IsSecureSite = UCase(Request.ServerVariables("HTTPS")) = "ON"
End Function
' (SS,19/5/09) simple email validation, contains a @ and '.' and no space
' shortest a@a.cn (i.e. at least 6 chars)
Function IsValidEmailAddress(AEmail)
IsValidEmailAddress = Len(AEmail) > 5 And InStr(AEmail, "@") > 0 And InStr(AEmail, ".") > 0 And InStr(AEmail, " ") = 0
End Function
' (SS,23/3/12) returns true if given email address has placed a completed order
Function EmailAddressHasOrdered(AEmail)
EmailAddressHasOrdered = Not IsNull(GetSQLValue("SELECT OrderNo FROM orders WHERE EmailAddress = '" & CleanSQLStr(AEmail) & "' AND Status = 'COMPLETED'"))
End Function
' (SS,12/8/05) set up session values in secure site as they were in non secure site
' (SS,19/5/21) following redundant code commented out
'Sub CopyMainSessionToSecureSession
' Session("ReferrerAdded") = True
' Session("OrderNoPlaced") = CLng(CleanRequestForm("DP_OrderNo"))
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' OpenQuery("SELECT * FROM orders WHERE OrderNo = '" & CleanSQLStr(Session("OrderNoPlaced")) & "'")
' If Not EndOfQuery Then
' Session("AccountID") = GetQueryValue("CustomerID")
' Session("Title") = GetQueryValue("Title")
' Session("FirstName") = GetQueryValue("FirstName")
' Session("Surname") = GetQueryValue("Surname")
' Session("CompanyName") = GetQueryValue("CompanyName")
' Session("Address1") = GetQueryValue("AddressLine1")
' Session("Address2") = GetQueryValue("AddressLine2")
' Session("Town") = GetQueryValue("Town")
' Session("County") = GetQueryValue("County")
' Session("Postcode") = GetQueryValue("Postcode")
' Session("Country") = GetQueryValue("Country")
' Session("Telephone") = GetQueryValue("Telephone")
' Session("Mobile") = GetQueryValue("Mobile") ' (SS,22/4/09)
' Session("Email") = GetQueryValue("EmailAddress")
' Session("PurchaseOrderNo") = GetQueryValue("PurchaseOrderNo")
' Session("Message") = GetQueryValue("Message")
' Session("DeliveryWillCollect") = IntToBool(GetQueryValue("DeliveryWillCollect")) ' (SS,14/11/07)
' Session("DeliveryAddressSameAsInvoice") = IntToBool(GetQueryValue("DeliveryAddressSameAsInvoice"))
' Session("DeliveryName") = GetQueryValue("DeliveryName")
' Session("DeliveryCompanyName") = GetQueryValue("DeliveryCompanyName")
' Session("DeliveryAddress1") = GetQueryValue("DeliveryAddressLine1")
' Session("DeliveryAddress2") = GetQueryValue("DeliveryAddressLine2")
' Session("DeliveryTown") = GetQueryValue("DeliveryTown")
' Session("DeliveryCounty") = GetQueryValue("DeliveryCounty")
' Session("DeliveryPostcode") = GetQueryValue("DeliveryPostcode")
' Session("DeliveryCountry") = GetQueryValue("DeliveryCountry")
' Session("PaymentAmount") = FormatNumber(GetFieldValue("GrandTotal"), 2)
' Session("VATNumber") = GetQueryValue("VATNumber") ' (SS,16/11/07)
' (SS,12/2/21) replaced above with following even though this routine is no longer applicable
' Session("EORINumber") = GetQueryValue("EORINumber")
' Session("XIEORINumber") = GetQueryValue("XIEORINumber")
' Session("VoucherCode") = GetVoucherCodeForVoucherID(GetQueryValue("VoucherID")) ' (SS,22/4/09), (SS,19/6/09) added GetVoucherCodeForVoucherID and corrected field "VoucherCode" to "VoucherID"
' If ChooseDeliveryDate Then Session("DeliveryDate") = GetQueryValue("DeliveryDate") ' (SS,22/4/09)
' End If
' CloseQuery
'End Sub
' (SS,4/10/20) added server post call (i.e. for NetPay)
' also renamed from CheckOut to DoCheckout
Sub DoCheckout
' (SS,4/10/20) do server post if requested i.e. xcmd = "serverpost" for NetPay payments
' moved here due to complications using cmd=payment in ProductsMain, best to stick with cmd=checkout
If CleanRequestQueryString("xcmd") = "serverpost" Then
' (SS,17/9/20) handle Server Post for NetPay
' (SS,4/10/20) was using cmd=payment and type=netpay before
If CleanRequestQueryString("pt") = ptNetPay Then
NetPayServerPost
End If
' above should redirect, following ensures that it doesn't continue in this routine
Exit Sub
End If
Dim LCurrentStage, LNextStage, LShowNextStageButton, LShowMakePaymentButton, LShowCheckoutFormFooter, LShowPlaceOrderOnAccountButton
' LCurrentStage = Request("stage") ' (SS,14/8/05) was CleanRequestForm("stage")
' (SS,21/2/14) replaced above with following, Form takes priority over querystring
' due to stage="co" being used for cheque/bank transfer payments in URL which also has stage = "ConfirmPayment"
' stage="co" used to give a different URL for AdWord purposes (requested by Clifton AdWord company)
LCurrentStage = CleanRequestForm("stage")
If LCurrentStage = "" Then LCurrentStage = CleanRequestQueryString("stage")
LNextStage = ""
LShowNextStageButton = True
LShowMakePaymentButton = False
LShowPlaceOrderOnAccountButton = False
LShowCheckoutFormFooter = True
' (SS,19/2/14) added following to allow different URL with querystring i.e. products.asp?cmd=checkout&xcmd=filled, for Google AdWord purposes requested by Clifton
' also only set when order no already created as an extra check, to prevent redirect loop
Dim LConfirmOrderRedirect
LConfirmOrderRedirect = CleanRequestQueryString("xcmd") = "filled" And GetOrderNo <> ""
' (SS,30/5/07) if start of checkout, not logged in and using new login method then show the login page
' (SS,27/5/09) added AccountsCompulsory
If LCurrentStage = "" And Not AccountLoggedIn And NewAccountMethod And AccountsCompulsory Then
DoAccount
Exit Sub
End If
' (SS,2/10/20) fixed a loophole that was allowing checkout when quota reached and some customer already had items in their baskets
If LCurrentStage = "" Or LCurrentStage = GET_PERSONAL_DETAILS Or LCurrentStage = GET_DELIVERY_ADDRESS Then
' if items in basket are suspended from ordering e.g. CIRC due to quota being reached then show message and exit
If ProductsInBasketOrderingSuspended Then
Response.Write "<div class=""alert alert-info"" role=""alert"">"
Response.Write GetMessage("OrderingSuspended")
Response.Write "</div>"
Exit Sub
End If
End If
' (SS,18/11/14)
If LCurrentStage = CS_PAYPAL_EXPRESS_CHECKOUT Then
' (SS,18/4/18) added If ReturnFromPayPalExpressLaterStage and oPayPalExpress True, to handle PayPal from later stage
' i.e. the fact that there's no redirect page to handle the payment page
If ReturnFromPayPalExpressLaterStage Then
DoPayPalExpress True
Else
DoPayPalExpress False
End If
' (SS,10/12/14) if cancelled in PayPal Express checkout then go to start of checkout
ElseIf LCurrentStage = CS_PAYPAL_EXPRESS_CANCEL Then
LCurrentStage = ""
ElseIf LCurrentStage = CS_PAYPAL_EXPRESS_RETURN Then
' *** may need to do some validation before doing the following
' (SS,16/12/14) if returned from PayPal when initiated at the later normal PayPal stage then we need to complete the order
'Response.Write "### Reached here: 0###<br>"
If ReturnFromPayPalExpressLaterStage Then
'Response.Write "### Reached here: 0.1###<br>"
LNextStage = COMPLETE_ORDER
Else ' if reached here from proper PayPal Express checkout
'Response.Write "### Reached here: 0.2###<br>"
If GetDetailsFromPayPalExpress Then
LNextStage = CONFIRM_ORDER
End If
End If
' if form details just entered then save them in session
' (SS,19/11/14) added Else to combine with above PayPal Express checkout
ElseIf LCurrentStage = GET_PERSONAL_DETAILS Then
' (SS,15/6/21) fixed bug where Voucher Code was being lost when entered in basket page and customer login used
' fixed by only setting voucher code if it's not a login attempt, i.e. only run following if not a login attempt
If AccountsOptional And Not AccountLoggedIn And AccountOptionalLoginAttempt Then
GetLoginDetailsFromForm ' (SS,15/6/21) new routine which just gets the login form fields
Else ' (SS,15/6/21) as before
' place form values in session
If Not AccountLoggedIn Then ' only get these if not on account '
GetPersonalDetailsFromForm ' (SS,31/5/07) moved code to GetPersonalDetailsFromForm
End If
' (SS,15/6/21) separated from GetPersonalDetailsFromForm, called whether logged in or not, fixes issue where newly entered values were not being saved for existing customers
GetHearAboutUsFromForm
' (SS,3/10/16)
If IsLocalMode Then
GetLocalModeDetailsFromForm
End If
Session("DeliveryDate") = CleanRequestForm("DeliveryDate") ' (SS,17/4/09)
' (SS,18/4/12) added "CollectionOnlyOrder Or" to following because disabled DeliveryWillCollect checkbox doesn't return "checked" when checkbox is disabled
Session("DeliveryWillCollect") = CollectionOnlyOrder Or (CleanRequestForm("DeliveryWillCollect") = "checked") ' (SS,14/11/07)
Session("DeliveryAddToExistingOrder") = CleanRequestForm("DeliveryAddToExistingOrder") = "checked" ' (SS,31/3/17)
Session("DeliveryAddressSameAsInvoice") = (CleanRequestForm("DeliveryAddressSameAsInvoice") = "checked") ' (SS,5/6/07) we need to ensure we get this in case GetPersonalDetailsFromForm not called above
' (SS,1/3/24) removed following, voucher no longer in first checkout form, only in basket
' Session("VoucherCode") = UCase(Trim(CleanRequestForm("VoucherCode"))) ' (SS,22/04/09)
' (SS,17/3/09) added following to ensure this value is set to true when DeliveryAddressSameAsInvoice checkbox isn't shown
If Not AllowDifferentDeliveryAddress Then Session("DeliveryAddressSameAsInvoice") = True
Session("PurchaseOrderNo") = CleanRequestForm("PurchaseOrderNo")
' (SS,21/8/12) added Left(.., GetMaxMessageLength) to limit length to x characters, currently 600, form also has this limit (using truncation prevents hackers/spammers from posting very long strings)
Session("Message") = Left(CleanRequestForm("Message"), GetMaxMessageLength)
' (SS,31/3/17) if Session("DeliveryAddToExistingOrder") is true then prefix with special message, or remove it
' (SS,3/5/19) code moved to separate subs AddToExistingOrderAddMessage and AddToExistingOrderRemoveMessage
If GetDeliveryAddToExistingOrder Then
AddToExistingOrderAddMessage
Else ' remove it
AddToExistingOrderRemoveMessage
End If
End If
' if delivery details just entered then save them in session '
' (SS,19/11/14) added Else and combined with above "If LCurrentStage = GET_PERSONAL_DETAILS"
ElseIf LCurrentStage = GET_DELIVERY_ADDRESS Then
' place form values in session '
GetDeliveryDetailsFromForm ' (SS,31/5/07) moved code to GetDeliveryDetailsFromForm
End If
' (SS,1/6/07) move default code to new routine, called from two places
SetCheckoutAccountDefaults
' (SS,3/8/04) added If And AccountsEnabled And Not AccountLoggedIn '
' (SS,27/5/09) added AccountsAdmin
' (SS,19/2/14) added If LConfirmOrderRedirect, to go straight to confirm because we're going via redirect to add xcmd=filled to querystring
If LConfirmOrderRedirect Then
LNextStage = CONFIRM_ORDER ' stay at same stage
ElseIf LCurrentStage = "" And AccountsEnabled And Not AccountLoggedIn And AccountsAdmin Then
LNextStage = GET_ACCOUNT_TYPE
ElseIf LCurrentStage = "" Or LCurrentStage = GET_ACCOUNT_TYPE Then ' (SS,3/8/04) added LStage = GET_ACCOUNT_TYPE '
' (SS,4/8/04) validate the Account details
If LCurrentStage = GET_ACCOUNT_TYPE Then
' check account details if account ID or password entered
' (SS,31/5/07) added CleanRequestForm("Email") = ""
' (SS,19/6/12) removed CleanRequestForm("AccountID") = ""
If CleanRequestForm("Email") = "" And CleanRequestForm("Password") = "" Then
LNextStage = GET_PERSONAL_DETAILS
Else
' (SS,28/5/09) added 3 parameters to CheckValidAccountDetails, because routine is also called from optional accounts
' (SS,19/6/12) removed parameter CleanRequestForm("AccountID"), no longer used
If CheckValidAccountDetails(CleanRequestForm("Email"), CleanRequestForm("Password")) Then
LNextStage = GET_PERSONAL_DETAILS
End If
End If
Else
LNextStage = GET_PERSONAL_DETAILS
End If
' if first name hasn't been entered then default the DeliveryAddressSameAsInvoice to checked '
' this seemed like the only simple way of doing this '
If Session("FirstName") = "" Then
Session("DeliveryAddressSameAsInvoice") = True
End If
' (SS,18/4/12) check if there are any collection only items by checking product attributes
' if there are then set for collection only, which means ticking and disabling "Don't charge postage, I will collect", and showing alert "Please be aware that this order is for collection only"
If HasCollectionOnlyInBasket Then
SetCollectionOnlyOrder True
Session("DeliveryWillCollect") = True
SetAlertMessage "Please be aware that this order is for collection only"
Else
SetCollectionOnlyOrder False
' (SS,12/2/21) added If Not AllowCollectionBasketPage to not set to false if this is enabled on basket page, i.e. allow it to be carried through from basket page
If Not AllowCollectionBasketPage Then
Session("DeliveryWillCollect") = False
End If
End If
ElseIf LCurrentStage = GET_PERSONAL_DETAILS Then
' (SS,28/5/09) for optional accounts process the log in if email and password entered
If AccountsOptional And Not AccountLoggedIn And AccountOptionalLoginAttempt Then
If CheckValidAccountDetails(Session("LoginEmail"), Session("LoginPassword")) Then ' (SS,19/6/12) removed first parameter ""
' to normal personal details form so customer can check
LNextStage = GET_PERSONAL_DETAILS
Else
' show error message if incorrect login, happens to be the same stage as above
LNextStage = GET_PERSONAL_DETAILS
' (SS,2/10/17) used to show proceed without log in (bypass) only if account already exists
' (SS,16/6/21) corrected following from Session("Email") to Session("LoginEmail")
If AccountExists(Session("LoginEmail")) Then
gsErrorMessage = gsErrorMessage & BR & "If you have forgotten the password then click 'Forgot Password' below to reset it." & BR & GetCheckoutAccountBypassTextAndLink
End If
End If
' validate personal details if valid then go to next stage (Delivery Address or Confirmation) '
ElseIf CheckValidPersonalDetails Then
LNextStage = CONFIRM_ORDER ' (SS,27/7/05) was CONFIRM_DETAILS '
' (SS,22/4/09) if voucher code entered then make sure it's valid
If Session("VoucherCode") <> "" Then
Dim LVoucherErrorMessage
If Not CheckVoucherCode(Session("VoucherCode"), LVoucherErrorMessage) Then
ShowCheckoutErrorMessage(LVoucherErrorMessage)
SetAlertMessage(LVoucherErrorMessage)
LNextStage = GET_PERSONAL_DETAILS ' to stay in same form and show error message '
End If
End If
' (SS,3/5/19) if customer tick "Add To Existing Order" and doesn't have an existing order then show alert asking customer to uncheck
If GetDeliveryAddToExistingOrder Then
If Not CustomerHasExistingOrder(Session("Email")) Then
Dim LExistOrderErrorMessage
LExistOrderErrorMessage = "No existing order found." & BR & "'Don't charge delivery, add to existing order' has been unticked."
ShowCheckoutErrorMessage(LExistOrderErrorMessage)
SetAlertMessage(LExistOrderErrorMessage)
SetDeliveryAddToExistingOrder False ' untick it so user doesn't need to
LNextStage = GET_PERSONAL_DETAILS ' to stay in same form and show error message '
End If
End If
' if different delivery address chosen then next stage is to ask for the delivery address '
' (SS,22/4/09) added LNextStage = CONFIRM_ORDER because error invalid VoucherCode may have been entered
If LNextStage = CONFIRM_ORDER And AllowDifferentDeliveryAddress Then
If Not Session("DeliveryAddressSameAsInvoice") Then
LNextStage = GET_DELIVERY_ADDRESS
' default the delivery address values if DeliveryName is blank '
If Session("DeliveryName") = "" Then
Session("DeliveryName") = Trim(Session("Title") + " " + Session("FirstName") + " " + Session("Surname"))
' (SS,7/2/12) removed following, requested by Neil, customer had changed the delivery address but forgot to change the postcode, decided best to leave blank
'Session("DeliveryCompanyName") = Session("CompanyName")
'Session("DeliveryAddress1") = Session("Address1")
'Session("DeliveryAddress2") = Session("Address2")
'Session("DeliveryTown") = Session("Town")
'Session("DeliveryCounty") = Session("County")
'Session("DeliveryPostcode") = Session("Postcode")
' (SS,16/2/12) added following back in and added "if" to set the same country as invoice if not already blank
If Session("DeliveryCountry") = "" Then Session("DeliveryCountry") = Session("Country")
End If
End If
End If
Else
LNextStage = GET_PERSONAL_DETAILS ' to stay in same form and show error message '
End If
ElseIf LCurrentStage = GET_DELIVERY_ADDRESS Then
If CheckValidDeliveryAddress Then
LNextStage = CONFIRM_ORDER ' (SS,27/7/05) was CONFIRM_DETAILS '
Else
LNextStage = GET_DELIVERY_ADDRESS ' to stay in same form and show error message '
End If
' (SS,27/7/05) '
ElseIf LCurrentStage = CONFIRM_ORDER Then
' (SS,23/6/09) added "If AccountLoggedIn And IsPlaceOrderOnAccount Then..." because Payment on account had stopped work for toner2desk
If AccountLoggedIn And IsPlaceOrderOnAccount Then
LNextStage = COMPLETE_ORDER ' this will occur if payment on account method used '
End If
' (SS,14/8/05)
' (SS,21/2/14) moved here from above, i.e. make sure it's after "ElseIf LCurrentStage = CONFIRM_ORDER Then"
' because
ElseIf LCurrentStage = RETURN_FROM_THIRD_PARTY_PAYMENT Then
LNextStage = COMPLETE_ORDER
' (SS,29/5/09) for cheque or bank transfer payments
' (SS,10/12/14) also for PayPal Express
ElseIf LCurrentStage = CONFIRM_PAYMENT Then
' LNextStage = PAYMENT_CONFIRMED
' (SS,19/4/12) replaced above with following to bypass the confirm payment / comfirm order stage
LNextStage = COMPLETE_ORDER
End If
DeleteDisabledProductsFromBasket
' (SS,28/5/09) just before confirm order stage, if accounts optional and not logged in
If LNextStage = CONFIRM_ORDER And AccountsOptional And Not AccountLoggedIn Then
' if password entered then try to create an account
If Session("Password") <> "" Then
' don't process order if account couldn't be create i.e. account already exists for this customer (same email)
If CreateAccount(True, 0) Then
' get the AccountID into Session("AccountID") to use for order (function is highly unlikely to fail)
' (SS,19/6/12) removed first parameter 0, i.e. AccountID, no longer used
If Not GetAccountDetails(Session("Email"), Session("Password"), "") Then
LNextStage = GET_PERSONAL_DETAILS
End If
Else ' create account failed, go back to start of checkout showing error message
LNextStage = GET_PERSONAL_DETAILS
End If
End If
End If
ShowCheckoutHeader
' (SS,4/10/19) place here because it adds a form tag and this needs to appear before call to ShowCheckoutFormHeader
' (SS,7/10/19) added "And Not IsBasketEmpty" to not sure when basket is empty (as before)
If LNextStage = GET_PERSONAL_DETAILS And Not IsBasketEmpty Then
' (SS,4/10/19) now separated from ShowCheckoutPersonalDetailsEntryForm in inc-template-checkout.asp, still on same page
' (SS,21/2/24) removed log in
' ShowCheckoutLoginForm gsErrorMessage
' (SS,8/3/24) for HyperFlight add following to show a link to login
If IsHyperFlight Then
ShowCheckoutLoginLink
End If
End If
ShowCheckoutFormHeader(LNextStage = CONFIRM_ORDER) ' (SS,4/6/09) added LNextStage parameter
' (SS,15/8/05) added LCurrentStage <> RETURN_FROM_THIRD_PARTY_PAYMENT
' to prevent empty basket from showing when return from PayPal etc
If IsBasketEmpty And LCurrentStage <> RETURN_FROM_THIRD_PARTY_PAYMENT Then
ShowEmptyBasket
LShowNextStageButton = False
ElseIf LNextStage = GET_ACCOUNT_TYPE Then
' If UseEmailAddressForLogin Then ' (SS,31/5/07) new login system
' DoAccountLogin
' Else ' old type of login as used by toner2desk
ShowCheckoutGetAccountType gsErrorMessage
' End If
ElseIf LNextStage = GET_PERSONAL_DETAILS Then
' (SS,3/5/19) remove the special message for adding to existing order in case it was added
' tidier not to show it on the message text box in case user comes back to this stage of the checkout
AddToExistingOrderRemoveMessage
ShowCheckoutPersonalDetailsEntryForm gsErrorMessage, AllowDifferentDeliveryAddress
' (SS,3/10/16) if local mode then show the addition feature
If IsLocalMode Then
ShowCheckoutLocalModeFeatures
End If
If LCurrentStage <> GET_PERSONAL_DETAILS Then ShowCheckoutAlertMessage ' (SS,23/10/08)
ElseIf LNextStage = GET_DELIVERY_ADDRESS Then
ShowCheckoutDeliveryAddressEntryForm gsErrorMessage
ElseIf LNextStage = CONFIRM_ORDER Then ' (SS,27/8/05) was CONFIRM_DETAILS
' (SS,4/10/20) added check for LConfirmOrderRedirect to prevent another call to ProcessOrder
' this prevents items being added to stock and taken out multiple times (i.e. 3 entries in stock audit instead of just one)
' not necessary in this page redirect stage or when this page is refreshed
' "If" doesn't work in VB as it does in other languages, i.e. the second condition is evalutated in an "and" when first is false
' so had to do this via new variable LProcessOrderResult
Dim LProcessOrderResult
If LConfirmOrderRedirect Then
LProcessOrderResult = True ' already processed prior to redirect, no need to do again, assume result was successful
Else
' (SS,5/11/24) if spam detected then redirect to basket page, else process as before
If SpamDetection Then
LProcessOrderResult = False
SetPageRedirection GetBasketPageURL
Else
' (SS,4/10/20) moved here from If below, process the order and save the returned result to use in If below
LProcessOrderResult = ProcessOrder(FSessionID)
End If
End If
' (SS,18/2/04) added FSessionID parameter
' (SS,14/9/06) added If Then
' (SS,4/10/20) replaced ProcessOrder(FSessionID) with LProcessOrderResult (see comments above)
If LProcessOrderResult Then
'ShowCheckoutPersonalDetailsConfirmation Session("OrderNoPlaced"), AccountLoggedIn, AllowDifferentDeliveryAddress
' (SS,19/4/18) added following message for PayPal Express return
' because the "Make PayPal Payment" button is shown and might be missed by buyer
If LCurrentStage = CS_PAYPAL_EXPRESS_RETURN Or InPayPalExpress Then
SetUpPayPalExpressConfirmButton
End If
' (SS,21/2/24) moved following after the payment buttons
'ShowOrderDetailsMaster True, Session("OrderNoPlaced")
'ShowOrderDetails True, Session("OrderNoPlaced")
' (SS,21/2/24)
ShowCheckoutTotalToPay
ShowCheckoutMessage ' (SS,11/12/07)
If AccountLoggedIn And PaymentOnAccountEnabled Then
ShowCheckoutAccountsMessage
LShowPlaceOrderOnAccountButton = True
Else
If Not InPayPalExpress Then ' (SS,24/11/14) added If to only show if not in PayPal Express
ShowCheckoutSecurePaymentMessage ' was ShowCheckoutWorldPayMessage
End If
End If
ShowCheckoutFormFooter(LNextStage) ' must be done before setting up payment forms '
' (SS,26/1/16) moved call here from Sage section in SetUpPaymentButton, and added optional setting
' (SS,5/10/16) added Not IsLocalMode to not show in local mode
If CheckoutConfirmTermAndConditions And Not IsLocalMode Then
ShowCheckoutTermsAndConditionsCheckBox
End If
' (SS,20/11/14)
' (SS,24/11/14) added "Or InPayPalExpress" because of redirect
' (SS,22/1/15) added
If LCurrentStage = CS_PAYPAL_EXPRESS_RETURN Or InPayPalExpress Then
SetUpPayPalExpressConfirmButton
Else
' (SS,20/11/08) moved SetUpPayment to REDIRECT_TO_PAYMENT_SITE, added following here
SetUpPaymentButtons
End If
LShowNextStageButton = False ' (SS,26/7/05) because SetUpPayment above will show this button
LShowCheckoutFormFooter = False ' (SS,11/8/05) to prevent form footer from being show again
' EmailOrder(Session("OrderNoPlaced")) ' for test purposes &&&
' (SS,18/2/14) to do a redirect only to ensure the URL is unique i.e. with &xcmd=filled at the end (for Clifton's AdWord campaign)
' only done when it's not already in a redirect to prevent redirect loop
' (SS,18/4/16) moved here from below, because when ProcessOrder fails because basket not in stock it needs to redirect to basket page, and following is I think only applicable if ProcessOrder returns true
If Not LConfirmOrderRedirect Then
Session("PreviousCheckoutStage") = LCurrentStage ' (SS,24/11/14) to preserve within redirect to ?cmd=checkout&xcmd=filled, so that payment methods aren't shown
SetPageRedirection GetCheckoutConfirmOrderURL
Else
Session("PreviousCheckoutStage") = "" ' if not redirecting then reset the previous stage
End If
' (SS,21/2/24) moved here from above
ShowOrderDetailsMaster True, Session("OrderNoPlaced")
ShowOrderDetails True, Session("OrderNoPlaced")
Else ' (SS,18/4/16) depending on reason for failure, a redirect to basket page may be done here if basket not fully in stock
LShowNextStageButton = False
End If
ElseIf LNextStage = COMPLETE_ORDER Then
' Response.Write "### Reached here: 0.1.1###<br>"
If AccountLoggedIn And IsPlaceOrderOnAccount Then ' process the order on account '
ProcessOrderOnAccount Session("OrderNoPlaced"), FSessionID
' (SS,5/10/07) removed following no longer applicable, probably never gets run
' we can now have more than one payment type so we won't know which one
' ElseIf IsPayPalPayment Or IsWorldPayPayment Or IsEPDQPayment Then
' ProcessOrderThirdPartyPayment False, Session("OrderNoPlaced"), FSessionID, ""
' (SS,21/3/13) if returning from successful payment from Sage Pay
ElseIf ReturnFromPaymentProvider(ptSagePay) Then
ProcessSagePayCallback
' (SS,26/4/18) EPDQ now works similar to Payzone and SagePay, callback done via the browser
ElseIf ReturnFromPaymentProvider(ptEPDQ) Then
ProcessEPDQRedirectCallback
' (SS,30/3/18)
ElseIf ReturnFromPaymentProvider(ptPayzone) Then
ProcessPayzoneCallback
' (SS,17/9/20)
ElseIf ReturnFromPaymentProvider(ptNetPay) Then
ProcessNetPayCallback
' (SS,16/6/22)
ElseIf ReturnFromPaymentProvider(ptClover) Then
ProcessCloverCallback(False) ' false indicates it's from browser i.e. not a server to server callback
' (SS,28/5/09) added following for cheque or bank transfer payments
' (SS,6/10/16) added IsLocalMode for local mode payments, also renamed called to ProcessOrderChequeOrBankTransferOrLocalModePayment
ElseIf IsChosenPaymentCheque Or IsChosenPaymentBankTransfer Or IsLocalMode Then
ProcessOrderChequeOrBankTransferOrLocalModePayment Session("OrderNoPlaced"), FSessionID
' (SS,10/12/14) PayPal Express
ElseIf IsChosenPaymentPayPalExpress Or ReturnFromPayPalExpressLaterStage Then
'Response.Write "### Reached here: 1###<br>"
ProcessOrderPayPalExpressPayment Session("OrderNoPlaced"), FSessionID
'Response.Write "### Reached here: 2###<br>"
' (SS,10/5/12) following run when return from third party payment provider
' noticed nothing shown for ePDQ, possibly other payments too, so added simple message, to be improved in future
ElseIf LCurrentStage = RETURN_FROM_THIRD_PARTY_PAYMENT Then
' Response.Write "Return from payment provider"
' (SS,15/5/12) for now, just say thank you for your order
' Response.Write "Thank you for your order."
' (SS,24/2/14) replaced thank you for your order with following to to show thank you message with order reference etc. If session has expired it will only show thank you
If GetOrderNo <> "" Then
' (SS,31/7/17) added following to help with payment debugging, previously when checking out, payment logged wasn't saved unless using PayPal expresscheckout from basket page
' (SS,23/8/17) added "Return" and removed True
AddToPaymentLog "Return", "Return from payment provider"
ShowOrderThankYou GetOrderNo, GetStoreName
Else
Response.Write "<p>Thank you for your order.</p>"
End If
End If
' (SS,1/3/13) order would be processed at this point, so abandon the session to delete all session variables, will also empty the basket in case it hasn't already via global.asa
' requested by Neil because he would like to get rid of previous details when entering orders on behalf of customers
' (SS,8/3/13) removed because it caused an alert issue, order was being added back to stock
' I think due to PayPal not being quick enough to do a callback, or our server couldn't be contacted
' happened on two occasions, returning to site before callback was the reason
' to get around this we could detect this and not add back to stock when session is ended
' which might also fix the issue itself because it can be marked as almost completed due to the URL used from payment provider.
' Session.Abandon
LShowNextStageButton = False
'Response.Write "### Reached here: 0.1.2###<br>"
End If
If LShowNextStageButton Then ShowCheckoutNextStageButton(GetCheckoutSubmitLink)
If LShowMakePaymentButton Then ShowCheckoutMakePaymentButton(GetCheckoutSubmitLink)
If LShowPlaceOrderOnAccountButton Then ShowCheckoutPlaceOrderOnAccountButton("javascript:itp_submit_option('OnAccount')")
If LShowCheckoutFormFooter Then ShowCheckoutFormFooter(LNextStage)
' (SS,23/6/22) added following to show the payment buttons here if session okay
' this is after return from payment provider with a failure, error message shown with buttons to try again
' has to be here to ensure it's not embedded inside the checkout form above
If IsReturnFromPaymentProviderPage And IsCreditCardPaymentProviderFailure And GetOrderNo <> "" Then
SetUpPaymentButtons
End If
ShowCheckoutFooter
End Sub
' (SS,28/5/09)
Function GetCheckoutSubmitLink
'GetCheckoutSubmitLink = "javascript:document.frmCheckout.submit()"
' (SS,6/10/11) replaced above with following, to allow VAT number validation in javascript
GetCheckoutSubmitLink = "javascript:itp_checkout_submit()"
End Function
' (SS,23/10/08)
Sub ShowCheckoutAlertMessage
' (SS,31/7/09) now gets message from FCheckoutAlertMessage setting
If FCheckoutAlertMessage <> "" Then
SetAlertMessage FCheckoutAlertMessage
End If
End Sub
' (SS,4/0/17)
Function GetCheckoutAccountBypassTextAndLink
GetCheckoutAccountBypassTextAndLink = "Alternatively, click <a href=""" & GetCheckOutJavascriptLink("bypass") & """><u>here</u></a> to proceed without using your account."
End Function
' (SS,1/6/07)
Sub SetCheckoutAccountDefaults
' if country is blank then default it to the UK '
If Session("Country") = "" Then Session("Country") = GetDefaultCountry
' (SS,8/9/06) if Title is blank then default it to default
If Session("Title") = "" And GetDefaultTitle <> "" Then Session("Title") = GetDefaultTitle
' (SS,8/11/07) default for Subscribe now set to True
' (SS,22/5/18) default now changed to False due to GDPR
If Session("Subscribe") = "" Then Session("Subscribe") = False
End Sub
' (SS,31/5/07) was in CheckOut, moved here also used by account creation
' (SS,1/6/07) added Trim
' (SS,4/6/07) added Password & Password2
' (SS,23/6/10) added Proper and CorrectPostcode
' (SS,4/10/17) added clearing of password if bypass clicked
Sub GetPersonalDetailsFromForm
Session("Title") = CleanRequestForm("Title")
Session("FirstName") = Proper(Trim(CleanRequestForm("FirstName")))
Session("Surname") = Proper(Trim(CleanRequestForm("Surname")))
Session("CompanyName") = Proper(Trim(CleanRequestForm("CompanyName")))
Session("Address1") = Proper(Trim(CleanRequestForm("Address1")))
Session("Address2") = Proper(Trim(CleanRequestForm("Address2")))
Session("Town") = Proper(Trim(CleanRequestForm("Town")))
Session("County") = Proper(Trim(CleanRequestForm("County")))
Session("Postcode") = CorrectPostcode(Trim(CleanRequestForm("Postcode")), CleanRequestForm("Country"))
Session("Country") = CleanRequestForm("Country")
Session("Telephone") = Trim(CleanRequestForm("Telephone"))
'Session("Mobile") = Trim(CleanRequestForm("Mobile")) ' (SS,17/4/09)
' (SS,19/5/21) replaced Mobile with AlternativePhone and only if feature enabled
If AlternativePhoneEnabled Then
Session("AlternativePhone") = Trim(CleanRequestForm("AlternativePhone"))
End If
Session("Email") = Trim(CleanRequestForm("Email"))
Session("Password") = Trim(CleanRequestForm("Password"))
Session("Password2") = Trim(CleanRequestForm("Password2"))
' (SS,18/4/12) added "CollectionOnlyOrder Or" to following because disabled DeliveryWillCollect checkbox doesn't return "checked" when checkbox is disabled
Session("DeliveryWillCollect") = CollectionOnlyOrder Or (CleanRequestForm("DeliveryWillCollect") = "checked") ' (SS,14/11/07)
Session("DeliveryAddressSameAsInvoice") = (CleanRequestForm("DeliveryAddressSameAsInvoice") = "checked")
' (SS,1/6/07)
Session("Subscribe") = (CleanRequestForm("Subscribe") = "checked")
' (SS,19/5/21) added If HearAboutUsEnabled i.e. only do if enabled
' (SS,15/6/21) moved HearAboutUsCode from here to Sub GetHearAboutUsFromForm below, to fix issue with existing customers
'Session("VATNumber") = UCase(StripSpaces(CleanRequestForm("VATNumber"))) ' (SS,16/11/07) ' (SS,17/6/09) added UCase and changed Trim to StripSpaces
' (SS,12/2/21) replaced above with following due to Brexit
Session("EORINumber") = UCase(StripSpaces(CleanRequestForm("EORINumber")))
Session("XIEORINumber") = UCase(StripSpaces(CleanRequestForm("XIEORINumber")))
' (SS,28/5/09) added following for optional accounts
' (SS,15/6/21) moved to separate Sub GetLoginDetailsFromForm
' (SS,4/10/17) added following to clear the password to prevent attempting to log in and bypass, bypass won't work if password filled in
If CleanRequestForm("options") = "bypass" Then
Session("Password") = ""
Session("Password2") = ""
End If
End Sub
' (SS,15/6/21) moved following here from Sub GetPersonalDetailsFromForm above
Sub GetLoginDetailsFromForm
' (SS,28/5/09) added following for optional accounts
Session("LoginEmail") = Trim(CleanRequestForm("LoginEmail"))
Session("LoginPassword") = Trim(CleanRequestForm("LoginPassword"))
' (SS,21/6/22) add following to prevent DeliveryWillCollect tick setting from being lost, Neil mentioned this after customer(s) mentioning it
Session("DeliveryWillCollect") = CleanRequestForm("DeliveryWillCollect") = "checked"
Session("Message") = Left(CleanRequestForm("Message"), GetMaxMessageLength)
Session("VoucherCode") = CleanRequestForm("VoucherCode")
End Sub
' (SS,15/6/21) to fix issue where latest hear about us details weren't being saved for existing logged in customers
' due to allowing changes in the question and options for this feature, and now showing this on the first stage for all customers (not just new)
' moved getting these values here from Sub GetPersonalDetailsFromForm
Sub GetHearAboutUsFromForm
' (SS,19/5/21) added If HearAboutUsEnabled i.e. only do if enabled
If HearAboutUsEnabled Then
Session("HearAboutUs") = CleanRequestForm("HearAboutUs")
Session("HearAboutUsOther") = CleanRequestForm("HearAboutUsOther") ' (SS,19/5/21)
End If
End Sub
' (SS,31/5/07) was in CheckOut, moved here also used by account creation
' (SS,1/6/07) added Trim
' (SS,7/6/07) removed Delivery region
' (SS,23/6/10) added Proper and CorrectPostcode
Sub GetDeliveryDetailsFromForm
Session("DeliveryName") = Proper(Trim(CleanRequestForm("DeliveryName")))
Session("DeliveryCompanyName") = Proper(Trim(CleanRequestForm("DeliveryCompanyName")))
Session("DeliveryAddress1") = Proper(Trim(CleanRequestForm("DeliveryAddress1")))
Session("DeliveryAddress2") = Proper(Trim(CleanRequestForm("DeliveryAddress2")))
Session("DeliveryTown") = Proper(Trim(CleanRequestForm("DeliveryTown")))
Session("DeliveryCounty") = Proper(Trim(CleanRequestForm("DeliveryCounty")))
Session("DeliveryPostcode") = CorrectPostcode(Trim(CleanRequestForm("DeliveryPostcode")), CleanRequestForm("DeliveryCountry"))
Session("DeliveryCountry") = CleanRequestForm("DeliveryCountry")
End Sub
' (SS,16/11/22) foreign non-latin characters are causing conversion to HTML entities to be sent from browser
' therefore sometimes resulting in strings longer than the field will allow each unicode char ends up being 7 chars long e.g. р
' address line fields are 100 in length, form only allows 50, 50 x 7 = 350
' this routine is called before saving data into the orders (not used for customers form or tables yet), data already in session variables
' returns true if any field was truncated, the fields and values truncated are in GetFormDataTruncationInfo
Function CheckTruncateFormData
ClearFormDataTruncationInfo
CheckTruncateFormField "FirstName", 100
CheckTruncateFormField "Surname", 100
CheckTruncateFormField "CompanyName", 100
CheckTruncateFormField "Address1", 100
CheckTruncateFormField "Address2", 100
CheckTruncateFormField "Town", 100
CheckTruncateFormField "County", 100
CheckTruncateFormField "Postcode", 20
CheckTruncateFormField "Country", 50
CheckTruncateFormField "Telephone", 100
CheckTruncateFormField "Email", 100
CheckTruncateFormField "DeliveryName", 100
CheckTruncateFormField "DeliveryCompanyName", 100
CheckTruncateFormField "DeliveryAddress1", 100
CheckTruncateFormField "DeliveryAddress2", 100
CheckTruncateFormField "DeliveryTown", 100
CheckTruncateFormField "DeliveryCounty", 100
CheckTruncateFormField "DeliveryPostcode", 20
CheckTruncateFormField "DeliveryCountry", 50
CheckTruncateFormData = GetFormDataTruncationInfo <> ""
End Function
' (SS,16/11/22)
Sub CheckTruncateFormField(AFieldName, AMaxLength)
Dim LValueStr, LLength
LValueStr = Session(AFieldName)
LLength = Len(LValueStr)
If LLength > AMaxLength Then
AddFormDataTruncationInfo AFieldName & "=" & LValueStr
Session(AFieldName) = Left(LValueStr, AMaxLength)
End If
End Sub
' (SS,16/11/22)
Sub ClearFormDataTruncationInfo
Session("FormDataTruncationInfo") = ""
End Sub
' (SS,16/11/22)
Sub SetFormDataTruncationInfo(AInfo)
Session("FormDataTruncationInfo") = AInfo
End Sub
' (SS,16/11/22)
Sub AddFormDataTruncationInfo(AInfo)
If AInfo <> "" Then
If Session("FormDataTruncationInfo") <> "" Then Session("FormDataTruncationInfo") = Session("FormDataTruncationInfo") & NL
Session("FormDataTruncationInfo") = Session("FormDataTruncationInfo") & AInfo
End If
End Sub
' (SS,16/11/22)
Function GetFormDataTruncationInfo
GetFormDataTruncationInfo = Session("FormDataTruncationInfo")
End Function
' (SS,4/10/19) checkout login now separated from ShowCheckoutPersonalDetailsEntryForm
' call to this added just before call to ShowCheckoutPersonalDetailsEntryForm
' (SS,15/6/21) message change
Sub ShowCheckoutLoginForm(ByRef AErrorMessage)
If AccountsOptional And Not AccountLoggedIn Then
Dim LLoginErrorMessage
If AccountOptionalLoginAttempt Then
LLoginErrorMessage = AErrorMessage
AErrorMessage = "" ' i.e. to not show in main section as well
' (SS,15/6/21) added following as requested by Neil, replaces "Following fields must be filled in: Email, Password."
' message "Email and/or Password is incorrect" is retained by "if" below
If InStr(1, LLoginErrorMessage, "incorrect") = 0 Then
LLoginErrorMessage = "Login is optional, but if you want to log in enter your email and password."
End If
Else
LLoginErrorMessage = ""
End If
ShowCheckoutLoginFormHeader ' (SS,4/10/19) header for separate form
ShowCheckoutLoginSection LLoginErrorMessage ' ShowCheckoutLoginSection is in inc-template-checkout.asp
ShowCheckoutLoginFormFooter ' (SS,4/10/19) footer for separate form
End If
End Sub
' (SS,4/10/19) separated this from main checkout form, for improved validation feature
' call to ShowCheckoutLoginSection removed from ShowCheckoutPersonalDetailsEntryForm in inc-templatate-checkout.asp
' now called before call to ShowCheckoutPersonalDetailsEntryForm
Sub ShowCheckoutLoginFormHeader
Dim FClass
If IsBootstrap4 Then
' (SS,30/9/19) added following for validation prior to actual submit
FClass = "needs-validation-login"
Else
FClass = "form-horizontal"
End If
' (SS,21/6/22) added missing quotes from name="frmCheckoutLogin", works without but standard is to have quotes
%>
<form name="frmCheckoutLogin" class="<%=FClass%>" role="form" method="post" action="<%=GetScriptName%>?cmd=checkout" novalidate>
<%
End Sub
' (SS,4/10/19) added for separate "form" tag for log in section (improved validation)
' (SS,15/6/21) added hidden name login with value "yes" to make login detection easier
' (SS,21/6/22) added name="DeliveryWillCollect", "Message" and "VoucherCode" to preserve these values from main form
Sub ShowCheckoutLoginFormFooter
%>
<input type="hidden" name="stage" value="<%=GET_PERSONAL_DETAILS%>">
<input type="hidden" name="login" value="yes">
<input type="hidden" name="DeliveryWillCollect" value="">
<input type="hidden" name="Message" value="">
<input type="hidden" name="VoucherCode" value="">
</form>
<%If IsBootstrap4 Then ' added following %>
<script>
// Example starter JavaScript for disabling form submissions if there are invalid fields
// specific to this form using needs-validation-login
(function() {
'use strict';
window.addEventListener('load', function() {
// Fetch all the forms we want to apply custom Bootstrap validation styles to
var forms = document.getElementsByClassName('needs-validation-login');
// Loop over them and prevent submission
var validation = Array.prototype.filter.call(forms, function(form) {
form.addEventListener('submit', function(event) {
if (form.checkValidity() === false) {
event.preventDefault();
event.stopPropagation();
}
form.classList.add('was-validated');
}, false);
});
}, false);
})();
</script>
<%End If
' (SS,21/6/22) added following script to pass the values DeliveryWillCollect, VoucherCode and Message in the login form section to retain these values when user logs in
' called from the login button GetButtonLoginInCheckout
%>
<script>
function itp_preserve_checkout_login_values()
{
$('form[name="frmCheckoutLogin"] input[name=DeliveryWillCollect]').val( ($("#DeliveryWillCollect").prop('checked') ? "checked" : "") );
$('form[name="frmCheckoutLogin"] input[name=Message]').val( $("#Message").val() );
$('form[name="frmCheckoutLogin"] input[name=VoucherCode]').val( $("#VoucherCode").val() );
}
</script>
<%
End Sub
' (SS,8/3/24)
Sub ShowCheckoutLoginLink
If AccountsOptional And Not AccountLoggedIn Then
%>
<div style="padding-left:15px; padding-bottom: 5px">
<p>
<a href="<%=GetAccountLink%>">Existing customers log in (optional)</a>
</p>
</div>
<%
End If
End Sub
' (SS,4/6/09) added ARedirectToPayment which is true for links that redirect to payment site
' add &xmcd=pay to the URL which can help in google analytic goals
' (SS,16/2/12) replaced products.asp with GetScriptName to allow more flexiblity for development purposes e.g. products-dev.asp to be used
' (SS,27/2/13) replaced &xcmd with &xcmd
' (SS,4/9/14) added class="form-horizontal" role="form" for Bootstrap
' (SS,8/9/14) removed quotes "" from second condition of IIf there were incorrectly showing, i.e. replaced """" with ""
' (SS,27/9/19) modified to not use "form-horizontal" for Bootstrap 4 which is only applicable to Bootstrap 3
' (SS,30/9/19) for Bootstrap 4 modified to add validation in browser for required fields, by adding class "needs-validation" also novalidate to override built in validation
Sub ShowCheckoutFormHeader(ARedirectToPayment)
Dim FClass
If IsBootstrap4 Then
' (SS,30/9/19) added following for validation prior to actual submit
FClass = "needs-validation"
Else
FClass = "form-horizontal"
End If
' (SS,30/9/19) added "novalidate" to form tag to prevent the built-in HTML validation from being called
' (SS,21/6/22) added missing quotes from name="frmCheckout", works without but standard is to have quotes
' (SS,21/2/24) added replaced novalidate with data-toggle="validator" for validation via validator.js, added id="frmCheckout" for easier jquery selector
%>
<form name="frmCheckout" id="frmCheckout" class="<%=FClass%>" role="form" method="post" action="<%=GetScriptName%>?cmd=checkout<%=IIf(ARedirectToPayment, "&xcmd=pay","")%>" data-toggle="validator">
<%
End Sub
' (SS,20/11/08) added paymenttype form field
' (SS,29/11/09) added =GetChosenPaymentType to allow chosen payment type to be passed back for cheque payments
' (SS,6/10/16) added payment ref for local mode, also change made to javascript.js to pass on this value
' (SS,21/7/17) added banktransferoption to hold which bank transfer option chosen by user via modal (only for HyperFlight currency)
' (SS,28/9/18) removed banktransferoption, not required here, it's passed on via frmBankTransferPay (SetUpBankTransferPayForm)
' Also had to make a fix in javascript.js function itp_payment_banktransfer to refer to frmBankTransferPay (not frmCheckout which was a bug)
Sub ShowCheckoutFormFooter(AStage)
%>
<input type="hidden" name="stage" value="<%=AStage%>">
<input type="hidden" name="paymenttype" value="<%=GetChosenPaymentType%>">
<input type="hidden" name="options" value="<%=CleanRequestForm("options")%>">
<%If IsLocalMode Then%><input type="hidden" name="paymentref" value="<%=GetLocalModePaymentReference%>"><%End If%>
</form>
<%If IsBootstrap4 Then ' added following %>
<script>
// Example starter JavaScript for disabling form submissions if there are invalid fields
(function() {
'use strict';
window.addEventListener('load', function() {
// Fetch all the forms we want to apply custom Bootstrap validation styles to
var forms = document.getElementsByClassName('needs-validation');
// Loop over them and prevent submission
var validation = Array.prototype.filter.call(forms, function(form) {
form.addEventListener('submit', function(event) {
if (form.checkValidity() === false) {
event.preventDefault();
event.stopPropagation();
}
form.classList.add('was-validated');
}, false);
});
}, false);
})();
</script>
<%End If
End Sub
' (SS,28/5/09) added parameters
' (SS,19/6/12) removed AAccountID parameter, no longer applicable because only email is now used to log in, removed code no longer applicable
Function CheckValidAccountDetails(AEmail, APassword)
Dim strError
strError = ""
If AEmail = "" Then strError = strError + IIf(strError = "", "", ", ") + "Email"
If APassword = "" Then strError = strError + IIf(strError = "", "", ", ") + "Password"
If strError <> "" Then
strError = "Following fields must be filled in: " + strError + "."
gsErrorMessage = strError
CheckValidAccountDetails = False
Exit Function
End If
' validate the account ID and password and get address details '
' (SS,30/5/07) added CleanRequestForm("Email")
' (SS,19/6/12) removed AAccountID parameter, no longer applicable
If Not GetAccountDetails(AEmail, APassword, "") Then
gsErrorMessage = tr("Email and/or Password is incorrect")
CheckValidAccountDetails = False
Exit Function
End If
CheckValidAccountDetails = True
End Function
' (SS,4/8/04) check account id and get address details
' (SS,30/5/07) added AEmailAddress to allow login using email address
' this routine sets Session("AccountID") to the customer ID
' (SS,22/5/12) now allows login in with special password, for internal use
' (SS,19/6/12) removed ACustomerID parameter and "If UseEmailAddressForLogin", login using CustomerID and password has been removed, setting UseEmailAddressForLogin is not longer applicable
' (SS,20/9/12) added ACustomerID, when set and others are blank it overrides the normal log in, used by auto login
Function GetAccountDetails(AEmailAddress, APassword, ACustomerID)
GetAccountDetails = False
If AEmailAddress = "" And APassword = "" And ACustomerID = "" Then Exit Function ' (SS,1/6/07)
' (SS,20/9/12) if customer ID not provided then do as before
If ACustomerID = "" Then
' (SS,12/6/12) replaced APassword with LPassword
'OpenQuery("SELECT * FROM customers WHERE EmailAddress = '" & LEmailAddress & "' AND Password = '" + LPassword + "'")
' (SS,18/6/12) replaced above with following to check encrypted password
On Error Resume Next ' (SS,19/6/12) added to prevent showing of normal SQL error, because we don't want to expose the hash/encryption method in error message
OpenQuery("SELECT * FROM customers WHERE EmailAddress = '" & CleanSQLStr(Trim(AEmailAddress)) & "' AND Password = " & GetSQLForPasswordEncryption(APassword, False))
' (SS,19/6/12) check for error, unlikely to error occur, prevent exposure of SQL if it ever does
If Err.Number <> 0 Then
LogErrorToFile("Following error occurred while in GetAccountDetails: " & Err.Description)
Response.Write("Checking account details failed. Sorry for any inconvenience caused. Please contact us.")
Exit Function
End If
On Error GoTo 0 ' cancel the error handling
' (SS,22/5/12) added following for special log in using email address and special password, for internal use,
' password is first 5 letters of store name lowercase, 123 and first 3 letters of current day, e.g. hyper123tue
If EndOfQuery Then
If APassword = LCase(Left(GetStoreName, 5) & "123" & Left(WeekDayName(DatePart("w", Now())), 3)) Then
CloseQuery
OpenQuery("SELECT * FROM customers WHERE EmailAddress = '" & CleanSQLStr(Trim(AEmailAddress)) & "'")
End If
End If
Else ' (SS,20/9/12) else find using customer ID
OpenQuery("SELECT * FROM customers WHERE CustomerID = '" & CleanSQLStr(ACustomerID) & "'")
End If
If Not EndOfQuery Then
GetAccountDetails = True
' customer has successfully logged in '
' so set account ID and get the address details
' (SS,4/6/07) if new account method then get customer ID from the record, else as before use the customer id passed to this function
' (SS,19/6/12) removed If NewAccountMethod, because old method of using AccountID to log in no longer used (was only for Toner2Desk)
Session("AccountID") = GetQueryValue("CustomerID")
Session("Title") = GetQueryValue("Title")
Session("FirstName") = GetQueryValue("FirstName")
Session("Surname") = GetQueryValue("Surname")
Session("AccountName") = GetFullName(Session("Title"), Session("FirstName"), Session("Surname"))
Session("CompanyName") = GetQueryValue("CompanyName")
Session("Address1") = GetQueryValue("AddressLine1")
Session("Address2") = GetQueryValue("AddressLine2")
Session("Town") = GetQueryValue("Town")
Session("County") = GetQueryValue("County")
Session("Postcode") = GetQueryValue("Postcode")
Session("Country") = GetQueryValue("Country")
Session("Telephone") = GetQueryValue("Telephone")
' Session("Mobile") = GetQueryValue("Mobile") ' (SS,17/4/09)
' (SS,19/5/21) replaced Mobile with AlternativePhone and only if feature enabled
If AlternativePhoneEnabled Then
Session("AlternativePhone") = Trim(CleanRequestForm("AlternativePhone"))
End If
Session("Subscribe") = GetQueryValue("Subscribe") ' (SS,5/6/07)
' (SS,19/5/21) added If HearAboutUsEnabled i.e. only do if enabled, also added HearAboutUsOther
If HearAboutUsEnabled Then
Session("HearAboutUs") = GetQueryValue("HearAboutUs") ' (SS,5/6/07)
Session("HearAboutUsOther") = GetQueryValue("HearAboutUsOther") ' (SS,19/5/21)
End If
Session("Email") = GetQueryValue("EmailAddress")
' (SS,19/6/12) following removed because password is now hashed and encrypted
'Session("Password") = GetQueryValue("Password") ' (SS,5/6/07) ' (SS,18/6/12) *** was Password
'Session("Password2") = Session("Password") ' (SS,5/6/07)
' (SS,1/6/07) removed: "If AllowDifferentDeliveryAddress Then"
Session("DeliveryAddressSameAsInvoice") = IntToBool(GetQueryValue("DeliveryAddressSameAsInvoice") <> 0)
If Not Session("DeliveryAddressSameAsInvoice") Then
Session("DeliveryName") = GetQueryValue("DeliveryName")
Session("DeliveryCompanyName") = GetQueryValue("DeliveryCompanyName")
Session("DeliveryAddress1") = GetQueryValue("DeliveryAddressLine1")
Session("DeliveryAddress2") = GetQueryValue("DeliveryAddressLine2")
Session("DeliveryTown") = GetQueryValue("DeliveryTown")
Session("DeliveryCounty") = GetQueryValue("DeliveryCounty")
Session("DeliveryPostcode") = GetQueryValue("DeliveryPostcode")
Session("DeliveryCountry") = GetQueryValue("DeliveryCountry")
End If
' (SS,1/6/07)
' (SS,19/5/21) removed following because they already appear above
'Session("Subscribe") = IntToBool(GetQueryValue("Subscribe"))
'Session("HearAboutUs") = GetQueryValue("HearAboutUs")
'Session("VATNumber") = GetQueryValue("VATNumber") ' (SS,16/11/07)
' (SS,12/2/21) replaced above with following due to Brexit
Session("EORINumber") = GetQueryValue("EORINumber")
Session("XIEORINumber") = GetQueryValue("XIEORINumber")
End If
CloseQuery
End Function
' (SS,28/5/09) returns true if account exists for given email address
Function AccountExists(AEmailAddress)
' (SS,19/12/12) (SS,22/2/13) added AND Password <> '', now account is assumed to only exist if both email address and password have been entered
' if password is blank then customer hasn't officially created an account
AccountExists = GetValueFromQuery("Accounts", "SELECT COUNT(*) AS Accounts FROM customers WHERE EmailAddress = '" + CleanSQLStr(AEmailAddress) + "' AND Password <> ''") > 0
End Function
' (SS,19/3/10) added tr() for translation
Function CheckValidPersonalDetails
Dim strError
strError = ""
' (SS,3/10/19) removed title, no longer required, decided not necessary, even Amazon and eBay don't use it
' If Session("Title") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Title")
If Session("FirstName") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("First Name")
If Session("Surname") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Surname")
If Session("Address1") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Address Line 1")
If Session("Town") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Town/City")
' (SS,13/2/08) removed forcing of postcode, because some countries don't have it e.g. Republic of Ireland
' (SS,12/11/08) added back in
If Session("Postcode") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Postcode/Zip")
If Session("Country") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Country")
If Session("Telephone") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Mobile") ' (SS,19/5/21) replaced Telephone with Mobile because label has been this for some time
If Session("Email") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Email Address")
If strError <> "" Then strError = tr("Following fields must be filled in") + ": " + strError + "."
' check that email and confirm email matches
' (SS,28/5/09) email confirm removed, now calls IsValidEmailAddress
If strError = "" And Not IsValidEmailAddress(Session("Email")) Then strError = tr("Valid Email address must be entered") + "."
' (SS,30/11/07) make sure Country exists in countries table
' added to prevent order when Country has since been removed/disabled from Countries table and accounts are used
' this occured when Republic of Ireland was removed from gsmailorder.co.uk
If strError = "" Then
If Not IsAllowedCountry(Session("Country")) Then strError = trx("Country <x> not allowed", Session("Country"))
End If
' (SS,12/2/21) commented out following
' (SS,17/6/09) validate VATNumber
'If strError = "" And Session("VATNumber") <> "" Then
' If FunctionExists("CustomValidVATNumber") Then
' If Not CustomValidVATNumber(Session("VATNumber")) Then
' strError = tr("VAT Number must be in the correct format prefixed by the country code")
' End If
' Else
' (SS,15/5/10) added following new method of validating VATNumber, eventually CustomValidVATNumber above will be removed
' (SS,11/8/16) renamed IsVATNumberValid to IsVATNumberFormatValid
' If Not IsVATNumberFormatValid(Session("Country"), Session("VATNumber")) Then
' strError = tr("VAT Number must be in the correct format prefixed by the country code")
' strError = strError + ", " + GetVATNumberExample + "." ' (SS,25/5/10)
' Else ' (SS,10/8/16) validate number using external website, strError is set if error
' If CheckVATNumber(Session("VATNumber"), strError) Then
' nothing to do here because strError used later to alert error message
' End If
' End If
' End If
'End If
' (SS,12/2/21) replaced above VAT number check with following for EORI
If strError = "" And Trim(Session("CompanyName")) <> "" Then
strError = CheckEORIEnteredIfRequired(Session("CompanyName"), Session("Country"), Session("Postcode"), Session("EORINumber"), Session("XIEORINumber"))
End If
' (SS,20/11/21) additional custom checks (GSC, for not allowing delivery for Northern Ireland)
If strError = "" And FunctionExists("CustomCheckAddressDetails") Then
' CustomCheckAddressDetails returns blank if no error
' "B" for billing address details "D" for delivery address details
strError = CustomCheckAddressDetails("P", Session("CompanyName"), Session("Postcode"), Session("Country"), Session("DeliveryWillCollect"))
End If
gsErrorMessage = strError
CheckValidPersonalDetails = (strError = "")
End Function
' (SS,12/2/21) no validation currently, just checks that it's entered if applicable
' if company name entered and not UK then EORI Number required
' also if UK and Northern Ireland i.e. postcode starts with BT then both EORI and XIEORI Number required
' returns "" if okay, error message otherwise
Function CheckEORIEnteredIfRequired(ACompanyName, ACountry, APostcode, AEORI, AXIEORI)
Dim LResult, LEORIEntered, LXIEOREntered
LResult = ""
LEORIEntered = Trim(AEORI) <> ""
LXIEOREntered = Trim(AXIEORI) <> ""
If Trim(ACompanyName) <> "" Then
If Not IsUK(ACountry) Then
' (SS,16/2/21) added IsEU to ensure EORI Number is entered for EU countries, i.e. not compulsory for RW
If Not LEORIEntered And IsEU(ACountry) Then
LResult = "EORI Number must be entered"
End If
ElseIf IsNorthernIreland(ACountry, APostcode) Then
If Not LEORIEntered Then
LResult = "EORI Number must be entered"
ElseIf Not LXIEOREntered Then
LResult = "XI EORI Number must be entered"
End If
End If
End If
CheckEORIEnteredIfRequired = LResult
End Function
' (SS,4/8/04)
' (SS,19/3/10) added tr() for translation
Function CheckValidDeliveryAddress
Dim strError
strError = ""
' (SS,5/6/07) added "Delivery " to strError
If Session("DeliveryName") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Delivery Name")
If Session("DeliveryAddress1") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Delivery Address Line 1")
If Session("DeliveryTown") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Delivery Town/City")
' (SS,13/2/08) removed forcing of postcode, because some countries don't have it e.g. Republic of Ireland
' (SS,12/11/08) added back in
If Session("DeliveryPostcode") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Delivery Postcode/Zip")
If Session("DeliveryCountry") = "" Then strError = strError + IIf(strError = "", "", ", ") + tr("Delivery Country")
' (SS,30/11/07) make sure Country exists in countries table
' added to prevent order when Country has since been removed/disabled from Countries table and accounts are used
' this occured when Republic of Ireland was removed from gsmailorder.co.uk
If strError = "" Then
' (SS,19/3/10) added trx, also corrected Session("Country") to Session("DeliveryCountry") after not allowed
If Not IsAllowedCountry(Session("DeliveryCountry")) Then strError = trx("Country <x> not allowed", Session("DeliveryCountry"))
End If
If strError <> "" Then strError = "Following fields must be filled in: " + strError + "."
' (SS,20/11/21) additional custom checks (GSC, for not allowing delivery for Northern Ireland)
If strError = "" And FunctionExists("CustomCheckAddressDetails") Then
' CustomCheckAddressDetails returns blank if no error
' "B" for billing address details "D" for delivery address details
strError = CustomCheckAddressDetails("D", Session("DeliveryCompanyName"), Session("DeliveryPostcode"), Session("DeliveryCountry"), Session("DeliveryWillCollect"))
End If
gsErrorMessage = strError
CheckValidDeliveryAddress = (strError = "")
End Function
Function GetFullName(ATitle, AFirstName, ASurname)
Dim LFullName
LFullName = ""
If ATitle <> "" Then LFullName = ATitle
If AFirstName <> "" Then LFullName = LFullName + Iif(LFullName = "", "", " ") + AFirstName
If ASurname <> "" Then LFullName = LFullName + Iif(LFullName = "", "", " ") + ASurname
GetFullName = LFullName
End Function
' (SS,10/8/05)
Function GetBillingAddress()
Dim LBillingAddress
LBillingAddress = ""
If Session("CompanyName") <> "" Then LBillingAddress = LBillingAddress + Session("CompanyName") + NL
If Session("Address1") <> "" Then LBillingAddress = LBillingAddress + Session("Address1") + NL
If Session("Address2") <> "" Then LBillingAddress = LBillingAddress + Session("Address2") + NL
If Session("Town") <> "" Then LBillingAddress = LBillingAddress + Session("Town") + NL
If Session("County") <> "" Then LBillingAddress = LBillingAddress + Session("County") + NL
If Session("Postcode") <> "" Then LBillingAddress = LBillingAddress + Session("Postcode") + NL
If Session("Country") <> "" Then LBillingAddress = LBillingAddress + Session("Country") + NL
GetBillingAddress = Trim(LBillingAddress)
End Function
' (SS,10/8/05) calls GetBillingAddress above but replaces newlines with <br>s
Function GetBillingAddressForHTML()
GetBillingAddressForHTML = ConvertNewlinesEtcToHTML(GetBillingAddress) ' (SS,17/5/11) changed from ConvertNewlinesToHTML to ConvertNewlinesEtcToHTML for quotes and pounds to show correctly
End Function
' (SS,14/8/05)
Function GetAddress(AName, ACompanyName, AAddress1, AAddress2, ATown, ACounty, APostcode, ACountry)
Dim LAddress
LAddress = ""
If AName <> "" Then LAddress = LAddress + AName + NL
If ACompanyName <> "" Then LAddress = LAddress + ACompanyName + NL
If AAddress1 <> "" Then LAddress = LAddress + AAddress1 + NL
If AAddress2 <> "" Then LAddress = LAddress + AAddress2 + NL
If ATown <> "" Then LAddress = LAddress + ATown + NL
If ACounty <> "" Then LAddress = LAddress + ACounty + NL
If APostcode <> "" Then LAddress = LAddress + APostcode + NL
If ACountry <> "" Then LAddress = LAddress + ACountry + NL
GetAddress = Trim(LAddress)
End Function
' (SS,14/8/05)
Function GetAddressForHTML(AName, ACompanyName, AAddress1, AAddress2, ATown, ACounty, APostcode, ACountry)
GetAddressForHTML = ConvertNewlinesEtcToHTML(GetAddress(AName, ACompanyName, AAddress1, AAddress2, ATown, ACounty, APostcode, ACountry)) ' (SS,17/5/11) changed from ConvertNewlinesToHTML to ConvertNewlinesEtcToHTML for quotes and pounds to show correctly
End Function
' returns link to be used for checkout page '
' (SS,20/2/12) replaced products.asp with GetScriptName
Function GetCheckoutLink()
GetCheckoutLink = GetScriptName + "?cmd=checkout"
End Function
' (SS,3/6/09) allows bypass for extra check for account already existing, i.e. checkout without account even though you already have one
Function GetCheckoutJavascriptLink(AValue)
GetCheckoutJavascriptLink = "javascript:itp_checkout('" & AValue & "')"
End Function
' (SS,17/1/13) we're now using this to show basket first rather than going straight to checkout, basket page has the actual checkout button via proceed to checkout
Function GetBasketLink()
GetBasketLink = GetScriptName + "?cmd=basket"
End Function
' returns link to be used to continue shopping from basket '
Function GetContinueLink()
GetContinueLink = "javascript:itp_continue('" & strSearch & "','" & strPage & "','" & strCategory & "','" & strSubcategory & "')"
End Function
' (SS,30/5/07) move here from inc-template-checkcount.asp, also called from inc-template-account.asp
Function GetTitleCombo(AEnabled)
' (SS,16/7/09) added "" new parameter, change was made to GetLookupCombo in dbfunctions.asp
GetTitleCombo = GetLookupCombo("Titles", "Title", "SortOrder", Session("Title"), True, "", AEnabled, "", "")
End Function
' (SS,15/9/06) renamed from GetCountryLookupCombo to GetCountryCombo
' (SS,11/9/07) now uses countries only (removed "SELECT DISTINCT Country FROM deliveryregions WHERE Country IS NOT NULL ORDER BY Country")
' (SS,19/3/10) added tr() for translation
' (SS,16/2/12) discovered a bug which resulted in DeliveryCountry defaulting to country held in Session("Country") rather than Session("DeliveryCountry")
' fixed by replacing Session("Country") with Session(ASelectName)
Function GetCountryCombo(ASelectName, AExtras)
' (SS,17/7/07) changed False in following to "--Please select--"
' (SS,16/7/09) added "" new parameter, change was made to GetLookupCombo in dbfunctions.asp
' (SS,16/2/12) replaced Session("Country") with Session(ASelectName)
GetCountryCombo = GetLookupCombo("countries", "Country", "SortOrder, Country", Session(ASelectName), tr("Please select..."), ASelectName, AExtras, GetCriteriaForCountryCombo, "")
End Function
' (SS,14/8/05) returns filter criteria to use for country combo
' (SS,17/4/18) modified so that it's now only based on Enabled, WorldPay, PayPal and DirectPay field are not relevant anymore
' because we also have more than one payment method and SagePay and Payzone
Function GetCriteriaForCountryCombo
' (SS,17/4/18) commented out following redundant code
'If IsPayPalPayment Then
' GetCriteriaForCountryCombo = "Enabled='Yes' AND PayPal='Yes'"
' (SS,7/9/06) added IsEPDQPayment
'ElseIf IsWorldPayPayment Or IsEPDQPayment Then
' GetCriteriaForCountryCombo = "Enabled='Yes' AND WorldPay='Yes'"
'Else
' GetCriteriaForCountryCombo = "Enabled='Yes' AND DirectPay='Yes'"
'End If
' (SS,17/4/18) replaced above with following
GetCriteriaForCountryCombo = "Enabled='Yes'"
End Function
' (SS,9/6/14)
' (SS,20/6/17) modified to add allow a customised version held in inc-template-currency.asp
' if ASelectName = "" then call the show currency routines in inc-template-currency.asp
Function GetCurrencyCombo(ASelectName, AExtras)
' (SS,20/6/17) as before
If ASelectName <> "" Then
' (SS,10/6/14) added SortOrder IS NULL so that null values appear after non-null values
GetCurrencyCombo = GetLookupCombo("currencies", "CurrencyName", "SortOrder IS NULL, SortOrder, Currency", Session(ASelectName), tr("Please select..."), ASelectName, AExtras, "", "Currency")
Else
Dim LSQL, LCurrencyCode, LCurrencyName, LIsSelected
LSQL = "SELECT * FROM currencies ORDER BY SortOrder IS NULL, SortOrder, Currency"
ShowCurrencyComboHeader(Session("CurrencyCode"))
OpenQuery(LSQL)
Do While Not EndOfQuery
LCurrencyCode = GetQueryValue("Currency")
LCurrencyName = GetQueryValue("CurrencyName")
LIsSelected = LCurrencyCode = Session("CurrencyCode")
ShowCurrencyComboItem LCurrencyCode, LCurrencyName, LIsSelected
NextQueryRecord
Loop
CloseQuery
ShowCurrencyComboFooter
GetCurrencyCombo = "" ' return nothing, not need because above functions do the rendering
End If
End Function
Function GetHearAboutUsCombo
' (SS,17/7/07) added dashes
' (SS,19/3/10) added tr() for translation
' (SS,6/9/14) changed default i.e. placeholder from tr("Please select...") to "» " & tr("Select how you heard about us")
' (SS,17/5/21) replaced tr("Select how you heard about us") with "Please select " & GetHearAboutUsLabel, it can now have a different label
' also replaced FHearAboutUsList with GetHearAboutUsList
GetHearAboutUsCombo = GetListCombo("HearAboutUs", FHearAboutUsList, Session("HearAboutUs"), "» " & "Please select " & LCase(GetHearAboutUsLabel) & "...")
End Function
' (SS,30/5/07)
' (SS,17/5/21) renamed from HearAboutUsList to GetHearAboutUsList
Function GetHearAboutUsList
GetHearAboutUsList = FHearAboutUsList
End Function
' (SS,17/5/21)
Function HearAboutUsEnabled
HearAboutUsEnabled = FHearAboutUsEnabled
End Function
' (SS,17/5/21)
Function GetHearAboutUsLabel
GetHearAboutUsLabel = FHearAboutUsLabel
End Function
' (SS,17/4/09) to pass to ShowOrderDetailsMaster in inc-template-checkout.asp
'Function GetMobile
' GetMobile = Session("Mobile")
'End Function
' (SS,19/5/21) replaced GetMobile above with this
Function GetAlternativePhone
GetAlternativePhone = Session("AlternativePhone")
End Function
' (SS,17/4/09) to pass to ShowOrderDetailsMaster in inc-template-checkout.asp
Function GetDeliveryDate
GetDeliveryDate = Session("DeliveryDate")
End Function
' (SS,14/8/05)
Sub ShowOrderDetailsMaster(AInCheckout, AOrderNo)
' (SS,12/5/10) replaced '%D %M %Y' with GetLanguageDateFormat(False)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT *, DATE_FORMAT(DateTimeOrdered, '" & GetLanguageDateFormat(False) & "') AS DateOfOrderLong FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
If Not EndOfQuery Then
' (SS,1/8/17) if not in checkout then we're displaying old orders, so get the currency code and exchange rate from this order
' fixes issue where old non-GBP orders would shown in current exchange rate and currency code
If Not AInCheckout Then
SetCurrencyForOrder GetQueryValue("CurrencyCode"), GetQueryValue("ExchangeRate")
End If
Dim LDateOfOrder, LStatus, LAccountID, LFullName, LDeliveryAddressSameAsInvoice, LBillingAddress, LDeliveryAddress, LTelephone, LEmailAddress, LPurchaseOrderNo, LMessage
LDateOfOrder = GetQueryValue("DateOfOrderLong")
LStatus = GetQueryValue("Status")
LAccountID = GetQueryValue("CustomerID")
LDeliveryAddressSameAsInvoice = IntToBool(GetQueryValue("DeliveryAddressSameAsInvoice"))
LBillingAddress = GetAddressForHTML(GetFullName(GetQueryValue("Title"), GetQueryValue("FirstName"), GetQueryValue("Surname")), GetQueryValue("CompanyName"), GetQueryValue("AddressLine1"), GetQueryValue("AddressLine2"), GetQueryValue("Town"), GetQueryValue("County"), GetQueryValue("Postcode"), GetQueryValue("Country"))
LDeliveryAddress = GetAddressForHTML(GetQueryValue("DeliveryName"), GetQueryValue("DeliveryCompanyName"), GetQueryValue("DeliveryAddressLine1"), GetQueryValue("DeliveryAddressLine2"), GetQueryValue("DeliveryTown"), GetQueryValue("DeliveryCounty"), GetQueryValue("DeliveryPostcode"), GetQueryValue("DeliveryCountry"))
LTelephone = GetQueryValue("Telephone")
LEmailAddress = GetQueryValue("EmailAddress")
LPurchaseOrderNo = GetQueryValue("PurchaseOrderNo")
LMessage = ReplaceStr(GetQueryValue("Message"), Chr(13) + Chr(10), "<br>")
' (SS,3/6/09)
Dim LPaymentMethod, LPaymentReference, LCourier, LTrackingNo, LMessageToCustomer
LPaymentMethod = GetQueryValue("PaymentMethod")
LPaymentReference = GetQueryValue("PaymentReference")
LCourier = GetQueryValue("Courier")
LTrackingNo = GetQueryValue("TrackingNo")
LMessageToCustomer = GetQueryValue("MessageToCustomer")
' (SS,3/6/09) added LPaymentMethod, LPaymentReference, LCourier, LTrackingNo, LMessageToCustomer
' (SS,8/3/13) added StatusForCustomer to convert COMPLETED to DESPATCHED
ShowCheckoutOrderDetailsMaster AInCheckout, AOrderNo, LDateOfOrder, StatusForCustomer(LStatus), LAccountID, LDeliveryAddressSameAsInvoice, LBillingAddress, LDeliveryAddress, LTelephone, LEmailAddress, LPurchaseOrderNo, LMessage, LPaymentMethod, LPaymentReference, LCourier, LTrackingNo, LMessageToCustomer
End If
CloseQuery
End Sub
' (SS,1/8/17) modified to fix issue where orders shown in accounts was always show in current currency and exchange rate
' fixed by checking for AInCheckout not True and setting the currency code, exchange rate and symbol from the original order, then restoring it later
' (SS,12/5/20) commented out '- not valid' text for voucher when discount is 0, because it can be zero for free delivery
Sub ShowOrderDetails(AInCheckout, AOrderNo)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,31/10/18) added GetOrderDetailsFilter to filter out subproducts
OpenQuery("SELECT * FROM orderdetails WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'" & GetOrderDetailsFilter & " ORDER BY OrderDetailID")
ShowCheckoutOrderDetailsHeader AInCheckout
' (SS,23/4/09) added tp_Discount
Dim tp_ProductCode, tp_ProductName, tp_Price, tp_Qty, tp_ProductTotal, tp_Subtotal, tp_Discount
Dim tp_VATIncluded, tp_VATDeducted, tp_Delivery, tp_GrandTotal
Dim LCount, LPrice, LQty, LPaymentDesc
LCount = 0
LPaymentDesc = ""
Do While Not EndOfQuery
LCount = LCount + 1
tp_ProductCode = GetFieldValue("ProductCode")
LQty = GetFieldValue("Qty")
tp_Qty = LQty
tp_ProductName = GetFieldValue("ProductName")
LPrice = GetFieldValue("PriceEach")
tp_price = CorrectCurrencyNV(LPrice) ' (SS,1/11/12) changed CorrectCurrency to CorrectCurrencyNV
tp_ProductTotal = CorrectCurrencyNV(CDbl(LPrice) * CInt(LQty)) ' (SS,1/11/12) changed CorrectCurrency to CorrectCurrencyNV
' (SS,6/7/11) added OptionsList
ShowCheckoutOrderDetailsItem AInCheckout, tp_ProductCode, tp_ProductName, GetFieldValue("OptionsList"), tp_Qty, tp_price, tp_ProductTotal
LPaymentDesc = LPaymentDesc + iif(LPaymentDesc = "", "", ", ") + tp_ProductCode + " x " & tp_Qty
NextQueryRecord
Loop
CloseQuery
' get the total values from orders
' OpenQuery("SELECT * FROM orders WHERE OrderNo = " & AOrderNo)
' (SS,23/4/09) replaced above with following to also lookup voucher code, although I could get it instead from the session variable
OpenQuery("SELECT orders.*, vouchers.VoucherCode FROM orders LEFT JOIN vouchers ON vouchers.VoucherID = orders.VoucherID WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
DIM LVATIncluded, LVATDeducted, LVoucherCode
tp_Subtotal = CorrectCurrencyNV(GetFieldValue("Subtotal")) ' (SS,1/11/12) changed CorrectCurrency to CorrectCurrencyNV
tp_Discount = CorrectCurrencyNV(GetFieldValue("Discount")) ' (SS,23/4/09) ' (SS,1/11/12) changed CorrectCurrency to CorrectCurrencyNV
tp_Delivery = CorrectCurrencyNV(GetFieldValue("Delivery")) ' (SS,1/11/12) changed CorrectCurrency to CorrectCurrencyNV
LVATIncluded = NZ(GetFieldValue("VATIncluded"))
LVATDeducted = NZ(GetFieldValue("VATDeducted"))
tp_VATIncluded = CorrectCurrency(LVATIncluded)
tp_VATDeducted = CorrectCurrency(LVATDeducted)
tp_GrandTotal = CorrectCurrency(GetFieldValue("GrandTotal"))
LVoucherCode = GetFieldValue("VoucherCode") ' (SS,23/4/09)
' (SS,12/5/20 removed following because discount can be 0 when voucher code provides free delivery
'If NZD(GetFieldValue("Discount")) = 0 Then LVoucherCode = LVoucherCode + " - not valid" ' (SS,8/5/09) as requested by Neil
Session("PaymentDescription") = LPaymentDesc
Session("PaymentAmount") = Round2dp(CorrectCurrencyNF(GetFieldValue("GrandTotal")))
Session("PaymentAmountGBP") = GetFieldValue("GrandTotal") ' (SS,17/2/12) payment in GBP pounds, for passing on to payment providers only dealing with GBP when multi-currency used
Session("PaymentAmountFormatted") = CorrectCurrency(GetFieldValue("GrandTotal")) ' (SS,17/2/12) formatted and with currency symbol, for displaying on cheque/bank transfer info
Session("BankTransferPaymentLine") = GetBankTransferPaymentLine ' (SS,19/12/14) payment amounts shown in bank transfer details
Session("BankTransferDetails") = GetBankTransferDetailsAsHTML ' (SS,19/12/14) bank transfer details to be shown
' (SS,16/11/07) added following to show intra-community supply message
Dim LExtraMessage
If IntToBool(GetFieldValue("IntraCommunitySupply")) Then
LExtraMessage = tr(INTRA_COMMUNITY_SUPPLY_MESSAGE) ' (SS,19/3/10) added tr
Else
LExtraMessage = ""
End If
' (SS,4/6/09) show message to customer, i.e. out of stock message
Dim LMessageToCustomer
LMessageToCustomer = ReplaceNewLinesWithBR(GetFieldValue("MessageToCustomer"))
SetAlertMessage LMessageToCustomer
' (SS,9/10/14) to pass on delivery into to ShowCheckoutOrderDetailsFooter routine
SetDeliveryInfo GetFieldValue("DeliveryInfo")
' (SS,22/4/21)
SetDeliveryOptionLabel GetFieldValue("DeliveryOption")
CloseQuery
' (SS,23/4/09) added LVoucherCode and tp_Discount
ShowCheckoutOrderDetailsSubtotal tp_Subtotal, LVoucherCode, tp_Discount, tp_Delivery
' (SS,28/5/07) VAT totals now only shown if VAT Registered
' function ShowCheckoutOrderDetailsVAT is called if it exists, may not exist in old version of inc-template-checkout.asp
If FunctionExists("ShowCheckoutOrderDetailsVAT") Then
SetVATLabel(LVATDeducted > 0)
' (SS,1/11/12) added "If LVATIncluded > 0 Then" so that VAT Deducted is no longer shown because VAT has now been removed from values shown above, to prevent customer confusion
If LVATIncluded > 0 Then
ShowCheckoutOrderDetailsVAT GetVATLabel, IIf(LVATIncluded > 0, tp_VATIncluded, tp_VATDeducted)
End If
Else ' old version
If LVATIncluded > 0 Then ShowCheckoutOrderDetailsVATIncluded tp_VATIncluded
' (SS,1/11/12) removed following VAT Deducted no longer shown because VAT has now been removed from values shown above, to prevent customer confusion
'If LVATDeducted > 0 Then ShowCheckoutOrderDetailsVATDeducted tp_VATDeducted
End If
ShowCheckoutOrderDetailsGrandTotal tp_GrandTotal
' (SS,14/6/07) added AInCheckout and AOrderNo parameters
' (SS,16/11/07) added message parameter
' (SS,4/6/09) added LMessageToCustomer parameter
ShowCheckoutOrderDetailsFooter AInCheckout, AOrderNo, LExtraMessage, LMessageToCustomer
End Sub
' (SS,18/2/04) added basket session ID parameter because now called from secure site with different session id '
' (SS,25/6/10) changed ProcessOrder variable to Result to avoid confusion/recursion
' (SS,7/3/13) added code to send an alert email if there's a failure while processing order, also removed contractprices reference
' (SS,2/11/16) fix to return False when there's a failure, e.g. delivery couldn't be calculated
' (SS,20/4/21) added calender READ to LOCK TABLES for CIRC
' (SS,1/7/21) added optional call to CustomGetAdditionalLockTables
' (SS,25/6/22) improved error handling to trap timeout in LOCK TABLES statement, previously it would just continue with next statement if it failed straight after LOCK statement
' Been experiencing hangs due to waiting for table metalock. Now set 50 second lock_wait_timeout in MariaDB which will abort the LOCK statement if it can't complete in 50 secs
' (SS,21/7/22) Decided to remove the LOCK and UNLOCK statements due the the hassle they're causing for very little benefit if any:
' Orders table is now autoinc on OrderNo field, so no need for NextOrderNo in settings table.
' Every table we access, even for reading has to be locked, which is a pain, especially to make the CIRC code for DespatchDatesEnabled.
' Hopefully this will also prevent the locking deadlock issue we've experienced in MariaDB
' CIRC has been running perfectly fine with LOCK failing since 20/4/21 when lock on "calender READ" was added, no such table i.e. misspelt and it's in common.calendar and no rights to lock it
' Function CustomGetAdditionalLockTables is now redundant and can be removed from customutils.asp, it will now never be called.
Function ProcessOrder(ABasketSessionID)
Dim Result, LErrorMsg, LBody ' (SS,7/3/13) added LErrorMsg, LBody to help with alert email
Result = True
' following is a bit like a try and finally in delphi
' if ProcessTheOrder fails the tables will still get unlocked
On Error Resume Next
LErrorMsg = "" ' (SS,25/6/22) moved here from below
'gbDebugOn = True
' lock the tables
' (SS,5/8/04) added "contractprices READ" because GetProductPrice now used which may use contractprices table
' (SS,14/9/06) added "deliveryregions READ, deliverycosts READ" now used by delivery calculation
' (SS,21/5/07) now uses LSQL and contractprices only added if enabled
' (SS,23/4/09) added vouchers WRITE
' (SS,8/5/09) added productcategories READ
' (SS,13/5/09) added voucherproducts READ
' (SS,25/6/10) added suppliers READ
' (SS,6/7/11) added shopping_basket_options READ and product_option_values WRITE for calculating options price and weight, and updating stock
' (SS,6/7/11) order_detail_options WRITE for adding options to order
' (SS,5/10/11) added product_attributes READ, attributes READ, due to new GetAttributeInBasketCount which is used by delivery calc i.e. covdem
' (SS,8/9/14) added product_options READ, due to new function ProductOptionExists used by castironradcen
' (SS,18/12/14) added currencies READ due to default payment currency code and rate lookup, used by hyperflight
'Dim LSQL, LTablesLocked
'LTablesLocked = False ' (SS,25/6/22)
'LSQL = "LOCK TABLES settings WRITE, products WRITE, shoppingbaskets WRITE, orders WRITE, orderdetails WRITE, countries READ, deliveryregions READ, deliverycosts READ, " &_
' "vouchers WRITE, productcategories READ, voucherproducts READ, suppliers READ, " &_
' "shopping_basket_options READ, product_option_values WRITE, order_detail_options WRITE, " &_
' "product_attributes READ, attributes READ, product_options READ, currencies READ"
' (SS,21/7/21) locking code above now removed
' (SS,16/1/15) added following, table used when UseDeliveryPostcodes setting is true
' (SS,21/7/22) following removed, no longer using LOCK
'If UseDeliveryPostcodes Then LSQL = LSQL & ", delivery_postcodes READ"
' (SS,20/4/21) added calender READ used by CIRC for despatch days calculation, this is a table in the common database
' (SS,21/4/21) added sitedetails WRITE, because last used despatch by date is saved here
' (SS,21/7/22) following removed, no longer using LOCK, calender READ was incorrect anyway
If DespatchDatesEnabled Then LSQL = LSQL & ", sitedetails WRITE, calender READ"
' (SS,1/7/21) added following custom routine to add additional custom tables to lock, e.g. log_priority used in CustomGetDelivery by HyperFlight
' (SS,21/7/22) following removed, no longer using LOCK
'If FunctionExists("CustomGetAdditionalLockTables") Then LSQL = LSQL & ", " & CustomGetAdditionalLockTables
' (SS,21/7/22) following removed, no longer using LOCK
'ExecuteQuery(LSQL)
' (SS,25/6/22) new check for error i.e. timeout in above lock statement
' (SS,21/7/22) following removed, no longer using LOCK
'If Err.Number <> 0 Then
' LErrorMsg = "Following error occurred in ProcessOrder (LOCK TABLES): " & Err.Description
' Result = False
'Else ' tables succesfully locked, to clear later
' LTablesLocked = True
'End IF
' (SS,25/6/22) added If LTablesLocked Then, to now only run TryProcessOrder if no error above, i.e. tables locked succesfully
' (SS,21/7/22) removed "If LTablesLocked Then" locking no longer used
'If LTablesLocked Then
Result = TryProcessOrder(ABasketSessionID) ' (SS,18/4/16) TryProcessOrder is now a function, returns False when basket not in stock
If Err.Number <> 0 Then
' (SS,25/6/10) changed DebugLog to LogErrorToFile
LErrorMsg = "Following error occurred in ProcessOrder (TryProcessOrder): " & Err.Description
Result = False ' (SS,2/11/16) because TryProcessOrder will have returned True and this is an error condition which should return False
' (SS,22/10/08) if delivery calculation failed then don't progress any further, alert message will be shown to user
ElseIf FDeliveryCalculationFailure Then
LErrorMsg = "Delivery Calculation Failure occurred in ProcessOrder"
Result = False ' (SS,2/11/16) because TryProcessOrder will have returned True and this is an error condition which should return False
End If
'End If ' (SS,21/7/22) removed
' unlock the tables
' (SS,25/6/22) added if to only run if they were succesfully locked above
' (SS,21/7/22) removed UNLOCK code below, not required because no longer using LOCK
'If LTablesLocked Then
' ExecuteQuery("UNLOCK TABLES")
' ' (SS,25/6/22) check for error in above UNLOCK
' If Err.Number <> 0 Then
' If LErrorMsg <> "" Then LErrorMsg = LErrorMsg & "; "
' LErrorMsg = LErrorMsg + "Following error occurred in ProcessOrder (UNLOCK TABLES): " & Err.Description
' Result = False
' End IF
'End If
' (SS,22/10/08) added following error message
' (SS,19/4/16) replaced Not Result with LErrorMsg <> "" because False can be returned now when basket not in stock
If LErrorMsg <> "" Then
LogErrorToFile(LErrorMsg)
ShowCheckoutErrorMessage("Processing of order failed. Sorry for any inconvenience caused. Please contact us.")
' (SS,7/3/13) added emailing of error message for alert purposes, together with session variables and basket
LBody = LErrorMsg & NL
LBody = LBody & NL & "SessionID = " & ABasketSessionID
LBody = LBody & NL & "IPAddress = " & Request.ServerVariables("REMOTE_ADDR")
LBody = LBody & NL & "DateTimeOrdered = " & Now
LBody = LBody & NL & SessionVarList("OrderNoPlaced,AccountID,Title,FirstName,Surname,CompanyName,Address1,Address2,Town,County,Postcode,Country,VATNumber,Telephone,Email,VoucherCode,Subscribe,HearAboutUs" &_
",Message,DeliveryDate,DeliveryWillCollect,DeliveryAddressSameAsInvoice,DeliveryName,DeliveryCompanyName,DeliveryAddress1,DeliveryAddress2,DeliveryTown,DeliveryCounty,DeliveryPostcode,DeliveryCountry")
' items in basket
' (SS,25/6/22) commented out the following for now due to shoppingbaskets being the table causing the hanging, therefore following might hang and also prevent alert email from being sent
'LBody = LBody & NL & "Basket:"
' (SS,26/10/18) added False parameter to GetOrderItemsQuery to exclude subproducts
'OpenQuery(GetOrderItemsQuery(ABasketSessionID, False))
'Do While Not EndOfQuery
' LBody = LBody & NL & GetQueryValue("Qty") & ", " & GetQueryValue("ProductCode") & ", " & GetQueryValue("ProductName")
' NextQueryRecord
'Loop
'CloseQuery
SendAlertEmail "Failure while processing order", LBody, False
End If
ProcessOrder = Result
End Function
' (SS,15/6/07) moved this code from TryProcessOrder to here, used elsewhere too
Sub ClearDeliveryDetailsIfSameAsInvoice
' If delivery address same as invoice then clear the delivery address values
If Session("DeliveryAddressSameAsInvoice") Then
Session("DeliveryName") = ""
Session("DeliveryCompanyName") = ""
Session("DeliveryAddress1") = ""
Session("DeliveryAddress2") = ""
Session("DeliveryTown") = ""
Session("DeliveryCounty") = ""
Session("DeliveryPostcode") = ""
Session("DeliveryCountry") = ""
End If
End Sub
' (SS,18/2/04) added basket session ID parameter because now called from secure site with different session id '
' (SS,6/10/11) added NoteVATValidation
' (SS,4/3/15) fixed issue where delivery price not calculated as on basket page, due to missing call to CustomProductInBasket
' (SS,12/4/16) changes to call ClearExistingOrderPlaced
' (SS,18/4/16) added CheckBasketInStock to check basket in stock, also changed from Sub to Function to return False if early exit due to basket not in stock
' (SS,20/4/16) slight change to getting next order no
' (SS,1/12/16) added code to always set priority and get it from CustomGetPriority
' (SS,18/4/18) change to preserve payment log which was being lost when this routine called again for same order
' (SS,29/10/18) change to allow new SubproductOrderDetailID field to set for products that are subproducts
' (SS,21/7/22) orders table no now has an AUTO_INCREMENT field for OrderNo, changed the "REPLACE" statement to "UPDATE" an order record is added by GetNextOrderNo
' (SS,17/11/22) added call to CheckTruncateFormData, and sending email alert and saving info to Notes field (if applicable) to prevent failure due to form field values being bigger than field size, when values get encoded to HTML entities for non-Latin characters
' (SS,30/10/23) bugfix to prevent Notes entered in localmode being lost due to truncated form data info being added previously
Function TryProcessOrder(ABasketSessionID)
ShowDebug "TryProcessOrder start" ' (SS,12/5/22)
TryProcessOrder = False ' (SS,18/4/16) now a function
' (SS,12/4/16) code from here moved to separate routine which is called elsewhere, add stock previous taken from stock back to stock and delete the existing order detail records
' (SS,18/4/16) this must be called before CheckBasketInStock below
ClearExistingOrderPlaced True ' True to make sure order detail records are deleted
' (SS,18/4/16) make sure products in basket are in stock, exit sub and redirect to basket page if not in stock
If Not CheckBasketInStock(False) Then
SetPageRedirection GetBasketPageURL
Exit Function ' False is returned
End If
Dim LOrderNo, LSQL
'LOrderNo = GetOrderNo
'' if no order no from above then get next available one, else reuse it
'If LOrderNo = "" Then
' LOrderNo = GetNextOrderNo
'End If
' (SS,20/4/16) replaced above with following because GetNextOrderNo will try to reuse the same OrderNo if possible until order processed (i.e. email sent)
' i.e. it will either return the same order no or next available one
' (SS,21/7/22) GetNextOrderNo routine now inserts an order record if applicable, OrderNo is now an autoinc field
LOrderNo = GetNextOrderNo
ClearDeliveryDetailsIfSameAsInvoice ' (SS,15/6/07) placed code here into separate sub
' create the order header record, replacing if it already exists
' (SS,19/2/04) added new DeliveryName & Address and Credit Card fields
Dim LDeliveryAddressSameAsInvoice
If Session("DeliveryAddressSameAsInvoice") Then
LDeliveryAddressSameAsInvoice = 1 ' i.e. True '
Else
LDeliveryAddressSameAsInvoice = 0 ' i.e. False '
End If
' (SS,18/12/14) get the default payment currency from currencies table where applicable, mainly to determine amount to show for bank transfers
Dim LDefaultPaymentCurrencyCode, LDefaultPaymentCurrencyRate
GetDefaultPaymentCurrency GetCurrencyCode, LDefaultPaymentCurrencyCode, LDefaultPaymentCurrencyRate
' (SS,18/4/18) added following to ensure PaymentLog is preserved because REPLACE orders SQL statement will delete it
' we are now looking up the current value and saving it in the REPLACE command below, if order doesn't exist then blank will be returned
Dim LPaymentLog
LPaymentLog = NB(GetOrderFieldValue(LOrderNo, "PaymentLog"))
' (SS,17/11/22) make sure form field values will fit into the field size, browser (for non-latin) may post HTML entities where is char is 7 chars and cause UPDATE SQL statement to fail
Dim LFormDataTruncationInfo
If CheckTruncateFormData Then
LFormDataTruncationInfo = "Fields Truncated Alert!" & NL & GetFormDataTruncationInfo
SendAlertEmail "Fields Truncated for Order", LFormDataTruncationInfo, True
Else
LFormDataTruncationInfo = ""
End If
' (SS,14/9/06) added DeliveryRegion
' (SS,19/9/06) added CurrencyCode and ExchangeRate
' (SS,22/6/07) removed DeliveryRegion
' (SS,14/9/07) added Subscribe and HearAboutUs
' (SS,14/11/07) added DeliveryWillCollect
' (SS,16/11/07) added VATNumber and IntraCommunitySupply
' (SS,17/4/09) added Mobile and DeliveryDate
' (SS,23/4/09) added VoucherID
' (SS,8/5/09) removed quotes from DeliveryDate so Null can also be assigned
' ConvertUKToMySQLDate in dbfunction changed to return date without '-'
' (SS,7/3/13) corrected bug introduced yesterday due to CustomerID changing from VARCHAR to INT, was setting to '' and causing failure, when it should be NULL
' i.e. replaced: {", CustomerID='" & CleanSQLStr(Session("AccountID")) & "'" &_} with
' {", CustomerID=" & IIf(Session("AccountID") = "", "NULL", "'" & CleanSQLStr(Session("AccountID")) & "'" &_}
' (SS,18/12/14) added DefaultPaymentCurrencyCode and DefaultPaymentCurrencyRate
' (SS,18/4/18) added PaymentLog to preserve it, previous values were being overwritten for same order
' (SS,28/6/18) added DeliveryOption
' (SS,16/2/21) added EORINumber and XIEORINumber
' (SS,12/5/22) moved DeliveryOption from here to update SQL below because GetDeliveryCost calling CustomGetDeliveryCost will affect it
' (SS,21/7/22) REPLACE change to UPDATE due to OrderNo now being an AUTO_INCREMENT field, removed OrderNo from SET (OrderNo=" & LOrderNo &_), added WHERE clause for OrderNo
LSQL = "UPDATE orders SET SessionID='" & ABasketSessionID & "'" &_
", IPAddress='" & CleanSQLStr(Request.ServerVariables("REMOTE_ADDR")) & "'" &_
", CustomerID=" & IIf(Session("AccountID") = "", "NULL", "'" & CleanSQLStr(Session("AccountID")) & "'") &_
", Title='" & CleanSQLStr(Session("Title")) & "'" &_
", FirstName='" & CleanSQLStr(Session("FirstName")) & "'" &_
", Surname='" & CleanSQLStr(Session("Surname")) & "'" &_
", CompanyName='" & CleanSQLStr(Session("CompanyName")) & "'" &_
", AddressLine1='" & CleanSQLStr(Session("Address1")) & "'" &_
", AddressLine2='" & CleanSQLStr(Session("Address2")) & "'" &_
", Town='" & CleanSQLStr(Session("Town")) & "'" &_
", County='" & CleanSQLStr(Session("County")) & "'" &_
", Postcode='" & CleanSQLStr(Session("Postcode")) & "'" &_
", Country='" & CleanSQLStr(Session("Country")) & "'" &_
", Telephone='" & CleanSQLStr(Session("Telephone")) & "'" &_
", EmailAddress='" & CleanSQLStr(Session("Email")) & "'" &_
", Subscribe= " & BoolToInt(Session("Subscribe")) &_
", PurchaseOrderNo='" & CleanSQLStr(Session("PurchaseOrderNo")) & "'" &_
", Message='" & CleanSQLStr(Session("Message")) & "'" &_
", DateTimeOrdered=NOW()" &_
", DeliveryDate=" & ConvertUKToMySQLDate(Session("DeliveryDate")) &_
", DeliveryWillCollect=" & BoolToInt(Session("DeliveryWillCollect")) &_
", DeliveryAddressSameAsInvoice=" & LDeliveryAddressSameAsInvoice &_
", DeliveryName='" & CleanSQLStr(Session("DeliveryName")) & "'" &_
", DeliveryCompanyName='" & CleanSQLStr(Session("DeliveryCompanyName")) & "'" &_
", DeliveryAddressLine1='" & CleanSQLStr(Session("DeliveryAddress1")) & "'" &_
", DeliveryAddressLine2='" & CleanSQLStr(Session("DeliveryAddress2")) & "'" &_
", DeliveryTown='" & CleanSQLStr(Session("DeliveryTown")) & "'" &_
", DeliveryCounty='" & CleanSQLStr(Session("DeliveryCounty")) & "'" &_
", DeliveryPostcode='" & CleanSQLStr(Session("DeliveryPostcode")) & "'" &_
", DeliveryCountry='" & CleanSQLStr(Session("DeliveryCountry")) & "'" &_
", Status='" & ORDER_PLACED_STATUS & "'" &_
", CurrencyCode='" & CleanSQLStr(GetCurrencyCode) & "'" &_
", ExchangeRate=" & GetCurrencyRate &_
", DefaultPaymentCurrencyCode='" & CleanSQLStr(LDefaultPaymentCurrencyCode) & "'" &_
", DefaultPaymentCurrencyRate='" & CleanSQLStr(LDefaultPaymentCurrencyRate) & "'" &_
", VATNumber='" & CleanSQLStr(Session("VATNumber")) & "'" &_
", EORINumber='" & CleanSQLStr(Session("EORINumber")) & "'" &_
", XIEORINumber='" & CleanSQLStr(Session("XIEORINumber")) & "'" &_
", IntraCommunitySupply=" & BoolToInt(IsIntraCommunitySupply) &_
", VoucherID=" & GetVoucherIDForVoucherCode(Session("VoucherCode")) &_
", PaymentLog='" & CleanSQLStr(LPaymentLog) & "'"
' (SS,6/10/16) also save the extra local mode values
If IsLocalMode Then
LSQL = LSQL &_
", Notes='" & CleanSQLStr(Session("Notes")) & "'" &_
", LocalMode=1" &_
", Exchange=" & BoolToInt(Session("Exchange")) &_
", ExchangeReason='" & CleanSQLStr(Session("ExchangeReason")) & "'"
End If
' (SS,19/5/21) save AlternativePhone if enabled, Mobile removed from above, not used
If AlternativePhoneEnabled Then
' ", Mobile='" & CleanSQLStr(Session("Mobile")) & "'" &_
LSQL = LSQL & ", AlternativePhone = '" & CleanSQLStrMax(Session("AlternativePhone"), 100) & "'"
End If
' (SS,19/5/21) optionally include HearAboutUs and HearAboutUsOther, HearAboutUs removed from above
If HearAboutUsEnabled Then
' ", HearAboutUs= '" & CleanSQLStr(Session("HearAboutUs")) & "'" &_
LSQL = LSQL &_
", HearAboutUs = '" & CleanSQLStrMax(Session("HearAboutUs"), 100) & "'" &_
", HearAboutUsOther = '" & CleanSQLStrMax(Session("HearAboutUsOther"), 100) & "'"
End If
' (SS,12/5/22) SetPriority code was here, moved below to update section because it could be modified by CustomGetPriority which can be called by Function CustomGetDelivery
' (SS,15/10/20) save the extras (e.g. Build details for GSC) on new Extras field, custom function with AType set to "O"
If FunctionExists("CustomGetExtras") Then
LSQL = LSQL & ", Extras='" & CleanSQLStr(CustomGetExtras("O", "")) & "'"
End If
' (SS,21/7/22) added WHERE due to REPLACE above being changed to UPDATE (OrderNo is now an AUTO_INCREMENT field)
LSQL = LSQL & " WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'"
ExecuteQuery(LSQL)
ShowDebug "TryProcessOrder save order" ' (SS,12/5/22)
' (SS,16/1/15) added following to save paymentlog to orders table (for PayPal Express)
' (SS,23/8/17) replaced SavePaymentLog with following to force saving of PaymentLog from Session
AddToPaymentLog "", ""
' (SS,6/10/11) to note VAT Number validation
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
NoteVATValidation "orders", "OrderNo = '" & CleanSQLStr(LOrderNo) & "'"
' create the order detail records from shoppingbasket, decrement the non blank stock values in products
' (SS,23/5/07) replaced "products.StdPrice, products.SalePrice" in following with GetPricingFieldsForSQL("products")
' (SS,28/5/07) replaced with GetOrderItemsQuery(ABasketSessionID)
' (SS,26/10/18) added True parameter to GetOrderItemsQuery to include subproducts where applicable
OpenQuery(GetOrderItemsQuery(ABasketSessionID, True))
Dim LPriceEach, LSubtotal, LOrderDetailID, LItemID, LProductID
' (SS,9/10/14) added following to get the delivery info
Dim LobjOptionsDict, LCustomGetOrderDeliveryInfoExists, LCustomProductInBasketExists, LQty
LCustomGetOrderDeliveryInfoExists = FunctionExists("CustomGetOrderDeliveryInfo")
LCustomProductInBasketExists = FunctionExists("CustomProductInBasket") ' (SS,4/3/15) missed from before
SetDeliveryInfo("")
Set LobjOptionsDict = CreateObject("Scripting.Dictionary")
LobjOptionsDict.CompareMode = vbTextCompare ' makes the keys case insensitive
' (SS,29/10/18) to allow new SubproductOrderDetailID field to be set correctly, assumes correct sequence of ItemID in shoppingbaskets
Dim LIsSubproduct, LLastMainOrderDetailID
LSubtotal = 0
Do While Not EndOfQuery
' (SS,23/5/07)
' (SS,6/7/11) removed GetFieldValue("Qty") parameter, added True, to look up options price
GetPricingFromProductRecord(True)
LProductID = GetFieldValue("ProductID") ' (SS,9/10/14)
LQty = GetFieldValue("Qty") ' (SS,4/3/15) now saving in LQty, now used in at least 3 places
LPriceEach = GetProductPrice
LSubtotal = LSubtotal + (LPriceEach * LQty)
' (SS,29/10/18)
LIsSubproduct = Not IsNull(GetFieldValue("SubproductItemID"))
' (SS,6/7/11) added ProductID and OptionsList
' (SS,30/5/12) added NumInStock to keep historical record of number in stock
' (SS,1/6/12) renamed NumInStock to PrevStock due to ambigious error in queries i.e. Stock Required report
' (SS,13/6/12) for PrevStock, replaced NB with NNULL, because it was failing when PrevStock was blank, tried '' but this fails with incorrect integer value because '' isn't NULL
' (SS,9/10/14) added LobjOptionsDict
LSQL = "INSERT INTO orderdetails SET OrderNo=" & LOrderNo &_
", ProductID=" & GetFieldValue("ProductID") &_
", ProductCode='" & CleanSQLStr(GetFieldValue("ProductCode")) & "'" &_
", ProductName='" & CleanSQLStr(GetFieldValue("ProductName")) & "'" &_
", OptionsList='" & CleanSQLStr(GetOptionsListForBasketItem(GetFieldValue("ItemID"), "", LobjOptionsDict)) & "'" &_
", Qty=" & LQty &_
", PriceEach=" & LPriceEach &_
", PrevStock=" & NNULL(GetFieldValue("NumInStock"))
' (SS,29/10/18) set the new SubproductOrderDetailID with OrdedDetailID of parent product
If LIsSubproduct Then LSQL = LSQL & ", SubproductOrderDetailID=" & LLastMainOrderDetailID
ExecuteQuery(LSQL)
' (SS,29/10/18) if this product is a main product i.e. with subproducts then get the last insert id to use as SubproductOrderDetailID for subsequent subproduct records
If Not LIsSubproduct Then LLastMainOrderDetailID = GetSQLLastInsertID
' (SS,9/10/14) update delivery info for this product, at the end we'll have the actual one for the full order
If LCustomGetOrderDeliveryInfoExists Then SetDeliveryInfo(CustomGetOrderDeliveryInfo(GetDeliveryInfo, LProductID, LobjOptionsDict))
' (SS,4/3/15) missed from update made on (SS,10/10/14) if CustomProductInBasketExists function exists then call it to pass on product, qty and options, it may use it to recommend other products later
If LCustomProductInBasketExists Then CustomProductInBasket LProductID, LQty, LobjOptionsDict
' (SS,6/7/11) add the order detail option records from shopping basket options
If ProductOptionsEnabled Then
LOrderDetailID = GetSQLLastInsertID
LItemID = GetQueryValue("ItemID")
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
ExecuteQuery("INSERT INTO order_detail_options SELECT NULL, '" & CleanSQLStr(LOrderNo) & "', " & LOrderDetailID & ", ProductOptionID, ProductOptionValueID, OptionName, OptionValue FROM shopping_basket_options WHERE ItemID = " & LItemID)
End If
NextQueryRecord
Loop
Set LobjOptionsDict = Nothing
CloseQuery ' (SS,27/7/05) added because it was missing
' (SS,23/4/09) added LDiscount
Dim LDiscount, LDelivery, LGrandTotal, LVATIncluded, LVATDeducted, LTotalWeight, LItems
' (SS,27/7/05) added following line and moved code from here to new GetOrderTotals '
' (SS,22/6/07) added LTotalWeight parameter
' (SS,23/4/09) added LDiscount parameter
' (SS,21/2/24) added LItems parameter
GetOrderTotalsForBasket ABasketSessionID, LSubtotal, LDiscount, LDelivery, LGrandTotal, LVATIncluded, LVATDeducted, LTotalWeight, LItems
' check if products out of stock and set MessageToCustomer
Dim LOutOfStockDetails
' LOutOfStockDetails = GetOutOfStockDetails(ABasketSessionID)
' (SS,18/4/16) replaced above with following, no longer used because customer is prevented from ordering if not in stock
LOutOfStockDetails = ""
' (SS,20/4/21) populate the two new DespatchFromDate and DespatchByDate fields using custom CustomGetDespatchDatesForOrder from Delivery Info value, otherwise set to NULL
Dim LDespatchFromDate, LDespatchByDate
LDespatchFromDate = "NULL"
LDespatchByDate = "NULL"
If DespatchDatesEnabled Then
If FunctionExists("CustomGetDespatchDatesFromDeliveryInfo") Then
If CustomGetDespatchDatesFromDeliveryInfo(GetDeliveryInfo, LDespatchFromDate, LDespatchByDate) Then
LDespatchFromDate = ConvertUKToMySQLDate(LDespatchFromDate)
LDespatchByDate = ConvertUKToMySQLDate(LDespatchByDate)
End If
End If
End If
' (SS,1/12/16) now priority is always set, because HyperFlight overrides it depending on items ordered and delivery address
' moved here from within "If IsLocalMode Then" above
' also added CustomGetPriority used to set priority via CustomGetDelivery earlier
' (SS,12/5/22) moved here from above, together with added Priority to SQL below
If FunctionExists("CustomGetPriority") Then SetPriority CustomGetPriority
' place subtotal, vat total, delivery cost etc in order
' (SS,22/6/07) added TotalWeight
' (SS,23/4/09) added Discount
' (SS,4/6/09) added MessageToCustomer
' (SS,21/7/10) added CleanSQLStr to LOutOfStockDetails to fix bug
' (SS,12/6/12) added CleanSQLStr before LOrderNo to prevent SQL injection
' (SS,9/10/14) added DeliveryInfo
' (SS,20/4/21) added DespatchFromDate and DespatchByDate fields
' (SS,12/5/22) moved DeliveryOption here from above because CustomGetDeliveryCost may change it (HF)
' (SS,12/5/22) also added Priority (which was originally in the REPLACE orders SQL above)
' (SS,17/11/22) added Notes, set to either NULL or LFormDataTruncationInfo
' (SS,30/10/23) "Notes" set above in local mode being lost, added CONCAT(IF(COALESCE(Notes), "") = "", "", CONCAT(Notes, NL, (Notes
LSQL = "UPDATE orders SET Subtotal=" & LSubtotal & ", Discount=" & LDiscount & ", Delivery=" & LDelivery &_
", VATIncluded=" & LVATIncluded & ", VATDeducted=" & LVATDeducted & ", GrandTotal=" & LGrandTotal &_
", TotalWeight=" & LTotalWeight &_
", MessageToCustomer='" & CleanSQLStr(LOutOfStockDetails) & "'" &_
", DeliveryInfo='" & CleanSQLStr(GetDeliveryInfo) & "'" &_
", DespatchFromDate=" & LDespatchFromDate &_
", DespatchByDate=" & LDespatchByDate &_
", DeliveryOption='" & CleanSQLStr(GetDeliveryOption) & "'" &_
", Priority='" & CleanSQLStr(GetPriority) & "'" &_
" WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'"
ExecuteQuery(LSQL)
' (SS,30/10/23) separated Note from above to fix bug where it was being overwritten in local mode, only need to set or append when LFormDataTruncationInfo has a value, also adds a newline separator
If LFormDataTruncationInfo <> "" Then
' ", Notes=" & IIf(LFormDataTruncationInfo = "", "NULL", "'" & CleanSQLStr(LFormDataTruncationInfo) & "'") &_
ExecuteQuery "UPDATE orders SET Notes = CONCAT(COALESCE(Notes, ''), '\r\n', '" & CleanSQLStr(LFormDataTruncationInfo) & "') WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'" ' above is the previous version
End If
ShowDebug "TryProcessOrder update order" ' (SS,12/5/22)
' (SS,1/10/20) if free delivery voucher was used then note the usage
NoteFreeDeliveryVoucherUsage
' take the products out of stock (only if stock qty has a value) '
'LSQL = "UPDATE products, shoppingbaskets SET NumInStock = NumInStock - shoppingbaskets.Qty" &_
' " WHERE shoppingbaskets.SessionID = '" & ABasketSessionID & "' AND products.ProductCode = shoppingbaskets.ProductCode"
'ExecuteQuery(LSQL)
' (SS,7/7/11) above replaced with following, which works correctly when same product appears more than once
TakeProductsFromStock LOrderNo, True
ShowDebug "TryProcessOrder End" ' (SS,12/5/22)
TryProcessOrder = True ' (SS,18/4/16) now a function
End Function
' (SS,12/4/16) clears existing order already placed, putting items back into stock and deleting the order detail and option records
' moved code here from Sub TryProcessOrder (with slight improvements), also called from basket routines to simplify stock handling
' and also releases the stock for others to buy while this use continues to make changes to their basket
' (SS,20/4/16) fix to ensure it's only down if OrderNoCanBeReused
Sub ClearExistingOrderPlaced(ADeleteOrderDetailRecords)
Dim LOrderNo
LOrderNo = GetOrderNo
' only do if order already placed and in 'ORDER PLACED' status, and detail records exist
' (SS,20/4/16) added OrderNoCanBeReused to ensure it's only done if order no hasn't been processed i.e. can be reused, otherwise there's chance that previous order can be put back in stock and lines deleted
' (SS,21/9/16) replaced [LOrderNo <> "" And OrderNoCanBeReused] with [OrderNoCanBeReused(LOrderNo)]
' Function OrderNoCanBeReused which now does a check for ORDER_PLACED_STATUS or ORDER_CANCELLED_STATUS and prevents order details being deleted from previous order
If OrderNoCanBeReused(LOrderNo) Then
' If GetValueFromQuery("Status", "SELECT Status FROM orders WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'") = ORDER_PLACED_STATUS Then
' (SS,21/9/16) replaced above with following If, does the same thing
If CheckOrderInStatus(LOrderNo, ORDER_PLACED_STATUS) Then
' add the items back in stock from orderdetails
TakeProductsFromStock LOrderNo, False
' mark order as cancelled if at ORDER PLACED status (just in case it gets changed above while doing TakeProductsFromStock and TakeProductOptionsFromStock)
ExecuteQuery("UPDATE orders SET Status = '" & ORDER_CANCELLED_STATUS & "' WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "' AND Status = '" & ORDER_PLACED_STATUS & "'")
End If
' delete records if requested, normally from TryProcessOrder
' (SS,21/9/16) order detail records were being deleted from previous order when same customer tried to place another order (or went as far as order records being created in checkout)
' New OrderNoCanBeReused function should prevent this because it checks for order being in ORDER_PLACED_STATUS or ORDER_CANCELLED_STATUS before doing this
If ADeleteOrderDetailRecords Then
' delete the order detail records
ExecuteQuery("DELETE FROM orderdetails WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'")
' (SS,6/7/11) delete the order detail option records
If ProductOptionsEnabled Then
ExecuteQuery("DELETE FROM order_detail_options WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'")
End If
End If
End If
End Sub
' (SS,4/6/09) called from TryProcessOrder, returns list of items that are out of stock
' (SS,25/6/10) modified to use new stock availability feature
' (SS,21/7/10) remove stock availability feature, replaced with new ShowOutOfStockMessage setting
' which only calls this function when this setting is true
' (SS,18/4/16) *** no longer used, redundant code, can be removed
Function GetOutOfStockDetails(ASessionID)
Dim LSQL, LResult
LResult = ""
If ShowOutOfStockMessage Then
' select all products in basket that are potentially out of stock
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "SELECT shoppingbaskets.ProductCode, ProductName, shoppingbaskets.Qty - GREATEST(products.NumInStock, 0) AS QtyOutOfStock " &_
"FROM shoppingbaskets " &_
"INNER JOIN products ON products.ProductCode = shoppingbaskets.ProductCode " &_
"LEFT JOIN suppliers ON suppliers.SupplierID = products.SupplierID " &_
"WHERE SessionID = '" & CleanSQLStr(ASessionID) & "' AND products.NumInStock IS NOT NULL AND products.NumInStock < shoppingbaskets.Qty " &_
"ORDER BY ItemID"
OpenQuery(LSQL)
Do While Not EndOfQuery
If LResult <> "" Then LResult = LResult & NL
LResult = LResult & GetQueryValue("QtyOutOfStock") & " x " & GetQueryValue("ProductName")
NextQueryRecord
Loop
If LResult <> "" Then LResult = tr("Following items are currently out of stock") & ":" & NL & LResult
CloseQuery
End If
GetOutOfStockDetails = LResult
End Function
' (SS,14/9/06)
' (SS,26/10/18) added AIncludeSubproducts, which is passed onto GetShoppingBasketFilter to include subproducts or not
Function GetOrderItemsQuery(ASessionID, AIncludeSubproducts)
' following ordered by ItemID, ensuring most recent item will appear last
' (SS,26/5/07) replaced products.StdPrice, products.SalePrice with GetPricingFieldsForSQL("products")
' (SS,22/10/08) added products.CustomFlag
' (SS,30/5/12) added products.NumInStock, used to hold a historical value
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,26/10/18) added GetShoppingBasketFilter to ignore subproducts
' (SS,16/10/23) added BrandName via join to brands table, added Category and Subcategory via join to productcategories
' (SS,21/2/24) added products.IsSubproduct, to allow accurate counting of items i.e. excluding subproducts
GetOrderItemsQuery = "SELECT shoppingbaskets.*, products.ProductName, " + GetPricingFieldsForSQL("products") + ", products.PostalWeight, products.CustomFlag, products.NumInStock, products.IsSubproduct," &_
" brands.BrandName, productcategories.Category, productcategories.Subcategory" &_
" FROM shoppingbaskets" &_
" LEFT JOIN products ON products.ProductCode = shoppingbaskets.ProductCode" &_
" LEFT JOIN brands ON brands.BrandID = products.BrandID" &_
" LEFT JOIN productcategories ON productcategories.ProductCode = products.ProductCode AND productcategories.Main = TRUE" &_
" WHERE SessionID = '" + CleanSQLStr(ASessionID) + "'" + GetShoppingBasketFilter(AIncludeSubproducts) + " ORDER BY ItemID"
End Function
' (SS,26/10/18) called from shopping basket queries to not show subproducts
Function GetShoppingBasketFilter(AIncludeSubproducts)
If Not ProductSubproductsEnabled Or AIncludeSubproducts Then
GetShoppingBasketFilter = ""
Else
GetShoppingBasketFilter = " AND SubproductItemID IS NULL"
End If
End Function
' (SS,31/10/18) similar to GetShoppingBasketFilter above but works with order details, i.e. don't show subproduct records
Function GetOrderDetailsFilter
If ProductSubproductsEnabled Then
GetOrderDetailsFilter = " AND SubproductOrderDetailID IS NULL"
Else
GetOrderDetailsFilter = ""
End If
End Function
' (SS,31/10/18) similar to GetShoppingBasketFilter and GetOrderDetailsFilter above with works with products, i.e. don't show subproduct records
' (SS,25/5/21) added IsLocalModeProduct flag, new field IsLocalModeProduct added to products table
Function GetProductsFilter
Dim LResult
LResult = ""
If ProductSubproductsEnabled Then
LResult = " AND NOT IsSubproduct"
End If
' (SS,25/5/21) hide local mode products when not in local mode
If LocalModeEnabled Then
If Not IsLocalMode Then
LResult = LResult & " AND NOT IsLocalModeProduct"
End If
End If
GetProductsFilter = LResult
End Function
' (SS,27/7/05) moved here from TryProcessOrder
' (SS,12/9/06) now calculates delivery using weight too
' (SS,28/5/07) modified for prices not including VAT, VAT Bands, also called from ShowBasket
' (SS,22/6/07) added ATotalWeight parameter weight is now saved in Order Record
' (SS,23/4/09) added ByRef ADiscount parameter, voucher code used to determine this
' (SS,15/5/09) renamed from GetOrderTotals to GetOrderTotalsForBasket
' (SS,19/3/20) modified to allow voucher to set free delivery
' (SS,1/10/20) modified to flag free delivery voucher being used (to record a note later)
' (SS,29/9/21) modified to include subproducts for weight calculation for radiators for CIRC, false in call to GetOrderItemsQuery changed to true
' (SS,21/2/24) added ByRef AItems
Sub GetOrderTotalsForBasket(ABasketSessionID, ByRef ASubtotal, ByRef ADiscount, ByRef ADelivery, ByRef AGrandTotal, ByRef AVATIncluded, ByRef AVATDeducted, ByRef ATotalWeight, ByRef AItems)
Dim LPriceEach, LTotalWeight, LNonWeightPrice, LWeight, LQty, LVATTotal
ASubtotal = 0
ADiscount = 0 ' (SS,23/4/09)
AItems = 0 ' (SS,21/2/24)
LTotalWeight = 0
LNonWeightPrice = 0
LVATTotal = 0
' (SS,22/10/08)
Dim LFlaggedWeight, LNonFlaggedWeight
LFlaggedWeight = 0
LNonFlaggedWeight = 0
' go through basket calculating the subtotal '
' (SS,12/9/06) added PostalWeight
' (SS,26/10/18) added False parameter to GetOrderItemsQuery to exclude subproducts
' (SS,29/9/21) change False to True to include subproducts, to ensure the weight is calculated from radiator section subproducts (for CIRC)
OpenQuery(GetOrderItemsQuery(ABasketSessionID, True))
Do While Not EndOfQuery
LQty = GetFieldValue("Qty")
' (SS,26/5/07)
' (SS,6/7/11) removed LQty parameter, added True, to look up options price
GetPricingFromProductRecord(True)
LPriceEach = GetProductPrice
ASubtotal = ASubtotal + (LPriceEach * LQty)
LWeight = NZ(GetFieldValue("PostalWeight")) + FOptionsWeight ' (SS,6/7/11) added FOptionsWeight
LTotalWeight = LTotalWeight + (LWeight * LQty)
If LWeight = 0 Then LNonWeightPrice = LNonWeightPrice + (LPriceEach * LQty) ' (SS,14/9/06)
' (SS,22/10/08)
If IntToBool(GetFieldValue("CustomFlag")) Then
LFlaggedWeight = LFlaggedWeight + (LWeight * LQty)
Else
LNonFlaggedWeight = LNonFlaggedWeight + (LWeight * LQty)
End If
' (SS,27/5/07) calculate VAT and add to VAT total, also takes VAT Band into account
' if PricesEnteredIncludeVAT then it's the VAT content of the Price
LVATTotal = LVATTotal + GetVATForProduct(LPriceEach * LQty)
' (SS,21/2/24) count items excluding subproducts
If Not IntToBool(GetFieldValue("IsSubproduct")) Then
AItems = AItems + LQty
End If
NextQueryRecord
Loop
CloseQuery
ATotalWeight = LTotalWeight ' (SS,22/6/07)
ASubtotal = Round2dp(ASubtotal) ' (SS,28/5/07) make sure it's rounded to 2dp
' (SS,28/5/07) modified to copy with prices not including VAT and VAT bands
' (SS,22/10/08) added LFlaggedWeight and LNonFlaggedWeight to GetDeliveryCost
ADelivery = GetDeliveryCost(ASubtotal, LNonWeightPrice, LTotalWeight, LFlaggedWeight, LNonFlaggedWeight, LVATTotal) ' will include VAT if PricesEnteredIncludeVAT
' (SS,7/5/21) added following to check if adjusted total weight has been set, which may occur with HF when GetDeliveryCost calls CustomGetDelivery
' this is then passed back to save in the order record
If IsAdjustedWeightSet Then
ATotalWeight = GetAdjustedTotalWeight
End If
' Dim LVoucherErrorMessage ' required to call IsVoucherCodeValid
' If IsVoucherCodeValid(Session("VoucherCode"), LVoucherErrorMessage) Then
' ADiscount = GetDiscountUsingVoucherCode(Session("VoucherCode"), ABasketSessionID, ASubtotal)
' End If
' (SS,23/4/09) added following to determine discount amount if there is a voucher
' (SS,16/2/15) replaced above with following
Dim LVoucherErrorMessage, LVoucherCode ' LVoucherErrorMessage required to call IsVoucherCodeValid
LVoucherCode = GetVoucherCode
' (SS,1/10/20) added following to clear free delivery voucher used (used to record a note later)
ClearFreeDeliveryVoucherUsed
' (SS,4/8/23) added following to ensure discount info is cleared for when no voucher or invalid voucher
ClearDiscountInfo
' (SS,4/10/16) added discount override when using local mode
If LVoucherCode = DISCOUNT_OVERRIDE_VOUCHER_CODE Then ' clear the internal voucher, will get set below if there is an override discount value
SetVoucherCode ""
End If
If IsDiscountOverride Then
ADiscount = GetDiscountOverride(ASubtotal) ' (SS,23/3/17) added ASubtotal
SetVoucherCode DISCOUNT_OVERRIDE_VOUCHER_CODE ' because it's held in a session variable
LVoucherCode = GetVoucherCode
Else ' (SS,4/10/16) as before
If IsVoucherCodeValid(LVoucherCode, LVoucherErrorMessage) Or LVoucherCode = "" Then
Dim LFreeDelivery ' (SS,19/3/20)
LFreeDelivery = False ' (SS,19/3/20) default to no free delivery
If LVoucherCode = "" Or IsVoucherCodeAuto(LVoucherCode) Then
' (SS,19/3/20) added ADelivery, LFreeDelivery parameter
ADiscount = GetDiscountUsingAutoVoucherCode(ABasketSessionID, ASubtotal, ADelivery, LFreeDelivery) ' also sets the voucher code if one was found
Else
' (SS,19/3/20) added ADelivery, LFreeDelivery parameter
ADiscount = GetDiscountUsingVoucherCode(LVoucherCode, ABasketSessionID, ASubtotal, ADelivery, LFreeDelivery)
End If
' (SS,19/3/20) if voucher indicates free delivery then set delivery to 0
If LFreeDelivery Then
ADelivery = 0
' (SS,1/10/20) added following to set free delivery voucher used (used to record a note later)
SetFreeDeliveryVoucherUsed
End If
End If
End If
If PricesEnteredIncludeVAT Then
' (SS,28/5/07) add the VAT content of delivery to VAT Total, working backwards
' (SS,23/4/09) added GetVATAmount(ADiscount) working backwards
LVATTotal = Round2dp(Round2dp(LVATTotal) + GetVATAmount(ADelivery) + GetVATAmount(ADiscount))
' get VAT that is included for UK and EU orders
AVATIncluded = GetVATIncludedAmount(LVATTotal) ' (SS,28/5/07) replaced LGrandTotal with LVATTotal
' get VAT to deduct from GrandTotal for Rest of the World orders
AVATDeducted = GetVATDeductedAmount(LVATTotal) ' (SS,28/5/07) replaced LGrandTotal with LVATTotal
' (SS,23/4/09) added " + ADiscount" which is a negative amount
AGrandTotal = Round2dp(ASubtotal + ADiscount + ADelivery - AVATDeducted) ' also deduct the VAT for countries not VATable because prices include VAT
Else
' (SS,23/4/09) added following to calculate VAT for discounts this can get complicated if some products are non vatable
' because we're giving an overall discount off the subtotal
Dim LVATForDiscount
LVATForDiscount = GetVATAmountToAddNR(ADiscount)
' don't allow the VAT for discount to be greater than Subtotal's VAT
If LVATForDiscount > LVATTotal Then LVATForDiscount = LVATTotal
' (SS,28/5/07)
' (SS,23/4/09) added "+ LVATForDiscount"
LVATTotal = Round2dp(LVATTotal + GetVATAmountToAddNR(ADelivery) + LVATForDiscount) ' also add the VAT of delivery to VAT Total
AVATIncluded = GetVATIncludedAmount(LVATTotal) ' only adds VAT if country is VATable
AVATDeducted = 0
' (SS,23/4/09) added " + ADiscount" which is a negative amount
AGrandTotal = Round2dp(ASubtotal + ADiscount + ADelivery + AVATIncluded) ' also add the VAT because prices don't include VAT
End If
End Sub
' (SS,30/4/21) used by HF to help optimise delivery costs for customer ordering multiple gliders (called from customutils.asp)
' accepts category, large reference weight, medium ref weight,
' returns true if >= large found, heaviest weight, total weight of all >= medium ref weight, total weight of all other items, also returns total weight
' Somes implementation notes:
' Get largest RC model weight >=1500kg
' all other models >= 1kg, apply weight factor (i.e. 0.3)
' all other count as normal
' Routine to get no items in a given category
' also routine to get max weight of an item in a given category
' (SS,10/5/21) correction to fix bug
' Function GetWeightRangeForCategory(ACategory, AHeavyRefWeight, AMediumRefWeight, ByRef AHeaviestItemWeight, ByRef AAboveMediumTotalWeight, ByRef ACategoryTotalWeight, ByRef ATotalWeight)
' (SS,12/5/21) removed AMediumRefWeight, changed AAboveMediumTotalWeight to AHeavyRCModelTotalWeight
' (SS,22/11/23) removed duplicate link to productcategories table causing error in HF
Function GetWeightRangeForCategory(ACategory, AHeavyRefWeight, ByRef AHeaviestItemWeight, ByRef AHeavyRCModelTotalWeight, ByRef ACategoryTotalWeight, ByRef ATotalWeight)
' iterate each item in basket (linked to main category)
' similar to loop in GetOrderTotalsForBasket above
Dim LSQL
LSQL = GetOrderItemsQuery(GetSessionID, False) ' False means ignore subproducts (not applicable for HF)
' add join to productcategories table to get the main category
' (SS,22/11/23) removed following, causing error in HF due to productcategories being add to GetOrderItemsQuery on 16/10/23 to get brand name
'LSQL = ReplaceStr(LSQL, " FROM shoppingbaskets ", ", productcategories.Category FROM shoppingbaskets LEFT JOIN productcategories ON productcategories.ProductCode = shoppingbaskets.ProductCode AND productcategories.Main ")
Dim LQty, LWeight
' clear values that are passed back
AHeaviestItemWeight = 0
'AAboveMediumTotalWeight = 0
AHeavyRCModelTotalWeight = 0
ACategoryTotalWeight = 0
ATotalWeight = 0
OpenQuery(LSQL)
Do While Not EndOfQuery
LQty = GetFieldValue("Qty")
GetPricingFromProductRecord(True) ' True parameter looks up options price via FOptionsWeight
LWeight = NZ(GetFieldValue("PostalWeight")) + FOptionsWeight
ATotalWeight = ATotalWeight + (LWeight * LQty)
If GetFieldValue("Category") = ACategory Then
ACategoryTotalWeight = ACategoryTotalWeight + LWeight
' (SS,10/5/21) corrected AHeaviestItemWeight to AHeavyRefWeight
If LWeight >= AHeavyRefWeight Then ' single item weight
'AHeaviestItemWeight = LWeight
' (SS,10/5/21) replaced above with following
If LWeight > AHeaviestItemWeight Then
AHeaviestItemWeight = LWeight
End If
' (SS,12/5/21) added following to total the weight for heavy models
AHeavyRCModelTotalWeight = AHeavyRCModelTotalWeight + (LWeight * LQty)
End If
' (SS,12/5/21) removed following, medium ref no longer used
'If LWeight >= AMediumRefWeight Then
' AAboveMediumTotalWeight = AAboveMediumTotalWeight + (LWeight * LQty)
'End If
End If
NextQueryRecord
Loop
CloseQuery
GetWeightRangeForCategory = AHeaviestItemWeight > 0
End Function
' (SS,7/5/21)
Sub SetAdjustedTotalWeight(AAdjustedTotalWeight)
FAdjustedTotalWeight = AAdjustedTotalWeight
End Sub
' (SS,7/5/21)
Function IsAdjustedWeightSet
IsAdjustedWeightSet = FAdjustedTotalWeight <> 0
End Function
' (SS,7/5/21)
Function GetAdjustedTotalWeight
GetAdjustedTotalWeight = FAdjustedTotalWeight
End Function
' (SS,19/1/15) used by PayPal Express checkout, to send approx total
Sub SetBasketGrandTotal(AGrandTotal)
Session("BasketGrandTotal") = AGrandTotal
End Sub
' (SS,19/1/15) used by PayPal Express checkout, to send approx total
Function GetBasketGrandTotal
GetBasketGrandTotal = Session("BasketGrandTotal")
End Function
' (SS,17/2/15) used by PayPal Express checkout, to send summary description
Sub SetBasketDescription(ADescription)
Session("BasketDescription") = ADescription
End Sub
' (SS,17/2/15) used by PayPal Express checkout, to send summary description
Function GetBasketDescription
GetBasketDescription = Left(Session("BasketDescription"), 127) ' max of 127 chars
End Function
' (SS,23/2/15) added following subs and functions for email/save basket
Sub SetBasketSubtotal(ASubtotal)
Session("BasketSubtotal") = ASubtotal
End Sub
Sub SetBasketDiscount(ADiscount)
Session("BasketDiscount") = ADiscount
End Sub
Sub SetBasketDelivery(ADelivery)
Session("BasketDelivery") = ADelivery
End Sub
Sub SetBasketVAT(AVAT)
Session("BasketVAT") = AVAT
End Sub
Function GetBasketSubtotal
GetBasketSubtotal = Session("BasketSubtotal")
End Function
Function GetBasketDiscount
GetBasketDiscount = Session("BasketDiscount")
End Function
Function GetBasketDelivery
GetBasketDelivery = Session("BasketDelivery")
End Function
Function GetBasketVAT
GetBasketVAT = Session("BasketVAT")
End Function
' get next order no from setting or orders table
' (SS,20/4/16) changed to return same order no if it can be reused, i.e. order not fully processed
' (SS,21/7/22) modified to now get the next order number from the orders table itself, i.e. OrderNo field is now an AUTO_INCREMENT field,
' we're also getting rid of the LOCK statement, for which one of the reasons was getting the next order number form the settings table
Function GetNextOrderNo
Dim LOrderNo, LNextOrderNo
' (SS,27/6/16)
LOrderNo = GetOrderNo
LNextOrderNo = ""
' (SS,20/4/16) added if to reuse same order no if not blank and reuse flag is true
' (SS,27/6/16) modified to all check that order is in order placed or cancelled status, because in CIRC orders paid for, completed with confirmation emails sent were being overwritten
'If LOrderNo <> "" And OrderNoCanBeReused Then
' If CheckOrderInStatus(LOrderNo, ORDER_PLACED_STATUS) Or CheckOrderInStatus(LOrderNo, ORDER_CANCELLED_STATUS) Then
' LNextOrderNo = LOrderNo
' End If
'End If
' (SS,21/9/16) replaced above with following
If OrderNoCanBeReused(LOrderNo) Then
LNextOrderNo = LOrderNo
End If
If LNextOrderNo = "" Then
'Dim LOrderNoFromSettings, LHighestOrderNoUsed ' (SS,21/7/22) moved these here from above, not relevant anymore
'LOrderNoFromSettings = GetSetting("Application", "NextOrderNo") ' GetSetting always returns a string value or null if not found
'If IsNull(LOrderNoFromSettings) Then
' LOrderNoFromSettings = 1
'Else
' ' (SS,9/11/07) in following replaced CInt with CLng because CInt only allows -32,768 to 32,767
' ' it was causing overflow when NextOrderNo was 50001
' LOrderNoFromSettings = CLng(LOrderNoFromSettings)
' If LOrderNoFromSettings <= 0 Then LOrderNoFromSettings = 1
'End If
'LHighestOrderNoUsed = GetValueFromQuery("HighestOrderNoUsed", "SELECT MAX(OrderNo) AS HighestOrderNoUsed FROM orders")
'If IsNull(LHighestOrderNoUsed) Then LHighestOrderNoUsed = 0
'If LHighestOrderNoUsed > LOrderNoFromSettings Then
' LNextOrderNo = LHighestOrderNoUsed + 1
'Else
' LNextOrderNo = LOrderNoFromSettings
'End If
' set next order no to be used in settings table
'SetSetting "Application", "NextOrderNo", LNextOrderNo + 1
' (SS,21/7/22) replaced above with following to getting order number from orders by adding a new empty orders record
ExecuteQuery "INSERT INTO orders (OrderNo) VALUES (NULL)" ' insert an empty record just to get the OrderNo
LNextOrderNo = GetSQLLastInsertID
' (SS,12/4/15) following moved here from TryProcessOrder (after call to this GetNextOrderNo function)
' store the order no in session
' Session("OrderNoPlaced") = LNextOrderNo
' (SS,20/4/16) replaced above with following, which places in session and sets flag to reuse
SetOrderNo LNextOrderNo
End If
' return the next order no
GetNextOrderNo = LNextOrderNo
End Function
' (SS,8/6/07) returns order no in current session
Function GetOrderNo
GetOrderNo = Session("OrderNoPlaced")
End Function
' (SS,20/4/16) places in session and sets reuse flag
Sub SetOrderNo(AOrderNo)
Session("OrderNoPlaced") = AOrderNo
Session("OrderNoReuse") = True
End Sub
' (SS,20/4/16) returns True if existing order no can be reused, i.e hasn't been cleared using ClearOrderNo
' (SS,21/9/16) modified to add parameter AOrderNo and do a status check for order also checks for "" value,
' True is only returned if it isn't "" and Session("OrderNoReuse") is True and the order is in order placed or cancelled status
Function OrderNoCanBeReused(AOrderNo)
Dim LResult
If AOrderNo <> "" And Session("OrderNoReuse") <> False Then ' N.B. Session("OrderNoReuse") can be "" Or True i.e. <> False
LResult = CheckOrderInStatus(AOrderNo, ORDER_PLACED_STATUS) Or CheckOrderInStatus(AOrderNo, ORDER_CANCELLED_STATUS)
Else
LResult = False
End If
OrderNoCanBeReused = LResult
End Function
' (SS,18/4/16) clears order no from session to prevent it being used again
' (SS,20/4/16) renamed from ClearOrderNo to StopOrderNoReuse to prevent same order being reused via Session("OrderNoReuse") flag
Sub StopOrderNoReuse
' Session("OrderNoPlaced") = ""
' (SS,20/4/16) rather than clearing a flag is set to prevent same number being reused when order is next created
' this overcomes issue when there's a redirect in later stage PayPal express PayPal to ensure specific where OrderNo was being lost for Thank You display
' using Session("OrderNoReuse") flag was a more elegant solution and keeps order no as long as possible
Session("OrderNoReuse") = False
End Sub
' (SS,26/1/21)
Sub SetCallbackOrderNoForPaymentLog(AOrderNo)
FCallbackOrderNo = AOrderNo
End Sub
' (SS,26/1/21)
Function GetCallbackOrderNoForPaymentLog
GetCallbackOrderNoForPaymentLog = FCallbackOrderNo
End Function
' (SS,8/6/07)
Function GetSessionID
GetSessionID = FSessionID
End Function
' (SS,8/6/07)
Function GetIPAddress
GetIPAddress = Request.ServerVariables("REMOTE_ADDR")
End Function
' (SS,14/6/07) moved code here from EmailOrder to create separate routine called from more than one place
' (SS,29/5/09) renamed from GetOrderConfirmationURL to GetOrderDetailsURL
Function GetOrderDetailsURL(AOrderNo)
Dim LSessionID, LIPAddress
' (SS,10/6/07) get credentials for showing order
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery2("SELECT SessionID, IPAddress FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
LSessionID = GetQueryValue2("SessionID")
LIPAddress = GetQueryValue2("IPAddress")
CloseQuery2
' (SS,29/5/09) renamed order-confirmation.asp to order-details.asp
GetOrderDetailsURL = GetStoreURL + "/order-details.asp?orderno=" & AOrderNo & "&sid=" & LSessionID & "&ip=" & LIPAddress
End Function
' (SS,1/6/09) added following to use a slightly different URL for email
' allowing the HTML email to be slightly different, most email clients don't load the email logo, so email looks untidy
' but fine for browsing on screen
Function GetOrderDetailsURLForEmail(AOrderNo)
GetOrderDetailsURLForEmail = GetOrderDetailsURL(AOrderNo) & "&cmd=foremail"
End Function
' (SS,29/5/09) same as GetOrderDetailsURL but with cmd=paymentslip at the end
Function GetPaymentSlipURL(AOrderNo)
GetPaymentSlipURL = GetOrderDetailsURL(AOrderNo) & "&cmd=paymentslip"
End Function
' (SS,22/5/09) returns field value for given order and field
Function GetOrderFieldValue(AOrderNo, AField)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
GetOrderFieldValue = GetValueFromQuery(AField, "SELECT " & AField & " FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
End Function
' (SS,25/4/19) returns up to 5 given order field values, needs to be called with a minimum of 1 field (use GetOrderFieldValue above for 1 field)
Function GetOrderFieldValues(AOrderNo, AField1, ByRef AValue1, AField2, ByRef AValue2, AField3, ByRef AValue3, AField4, ByRef AValue4, AField5, ByRef AValue5)
Dim LSQL
LSQL = "SELECT " & AField1
If AField2 <> "" Then LSQL = LSQL & ", " & AField2
If AField3 <> "" Then LSQL = LSQL & ", " & AField3
If AField4 <> "" Then LSQL = LSQL & ", " & AField4
If AField5 <> "" Then LSQL = LSQL & ", " & AField5
LSQL = LSQL & " FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'"
GetOrderFieldValues = GetSQL5Values(LSQL, AValue1, AValue2, AValue3, AValue4, AValue5)
End Function
' (SS,15/2/11) added order number to end of subject
' (SS,11/8/16) change to VAT alert email to include more details via new check, new function EmailOrderVATAlertAddFields added
' (SS,23/1/17) change to subject, now store name, followed by Order Confirmation (& VAT Invoice) / Despatched / Cancelled then order no (no hyphen)
' (SS,12/3/18) modified to send the email body content directly, rather than via URL and SendEmailByITPEmailer
' To fix issue where some email client e.g. Outlook 2016 were ending up with an empty attached file
' (SS,18/11/21) added LVoucherNotificationEmail and to BCC to this address
Sub EmailOrder(AOrderNo)
' (SS,7/1/16) removed Dim LBody and Const USE_DUNDAS and SEND_VIA_URL
'Const USE_DUNDAS = False
' (SS,29/6/07) set this to false if the hanging bug occurs again, via url has the advantage of embedding the logo
' (SS,23/7/07) same thing happened to order 2164 (previously 1955), service pack 2 was installed a couple of weeks before
' decided to set to False, i.e. CDO still used but image not embedded
' but order 2164 worked okay when I did it manually using "view order in browser" and adding &cmd=email
' (SS,15/8/07) CDO_SEND_VIA_URL = False failed on Order 2398, (True also failed, Dundas also failed)
' restarting IIS fixed the problem. Did notice earlier today when I logged in that, a IIS worker process error.
' (SS,4/9/07) another failure (order: 2623), even USE_DUNDAS = False would hang, but the plain text email worked fine
' so it could be caused by the GetWebPageContents routine, building the HTML, rather the getting the webpage
' might resolve the problem.
'Const SEND_VIA_URL = True ' (SS,30/1/08) renamed from CDO_SEND_VIA_URL to SEND_VIA_URL, also changed to True
' (SS,12/3/18) following not longer applicable
' LURL = GetOrderDetailsURLForEmail(AOrderNo) ' (SS,10/6/07) get URL for order confirmation web page
' (SS,10/6/07) following was only necessary for Dundas, not required for CDO
' (SS,29/6/07) modified to use Dundas if the USE_DUNDAS constant is True
' did this to investigate emailing with CDO hanging with Galleon Order No 1955
' (SS,7/1/16) moved following no longer used
'If USE_DUNDAS Or Not SEND_VIA_URL Then
' LBody = GetWebPageContents(LURL)
'Else
' LBody = ""
'End If
' (SS,10/6/07) SendEmail i.e. "Dundas.Mailer" replaced by CDO, because Dundas cannot accurately send HTML
' it insert newlines every 1000 or so characters and breaks HTML tags to cause corrupt HTML
' CDO also has a useful create from web page feature, so don't need to use GetWebPageContents
' (SS,29/6/07) added If USE_DUNDAS to force sending using Dundas, also added CDO_SEND_VIA_URL flag to send without URL
' (SS,7/1/16) USE_DUNDAS removed
'If USE_DUNDAS Then
' SendEmail LEmailAddress, LBcc1, LBcc2, LFrom, LSubject, LBody, HTMLEmailsEnabled
'Else
' If Not SEND_VIA_URL Then LURL = ""
' If Not SendEmailByCDO(LEmailAddress, LBcc1, LBcc2, LFrom, LSubject, LBody, "", HTMLEmailsEnabled, LURL) Then
' (SS,30/1/08) replaced above CDO method with new hopefully more reliable ITP method
'End If
' (SS,7/1/16) replaced LBody with "" and HTMLEmailsEnabled with True
'If Not SendEmailByITPEmailer(LEmailAddress, LBcc1, LBcc2, LFrom, LSubject, "", True, LURL) Then
' Response.Write("<br>!!! Email failure !!!<br>")
'End If
' (SS,7/1/15) removed "If HTMLEmailsEnabled" because now always HTML
' (SS,12/3/18) removed LURL, no longer used
' added LBody and LTitle, also moved others here form below
' (SS,18/11/21) added LVoucherNotificationEmail
Dim LEmailAddress, LBcc1, LBcc2, LFrom, LSubject, LVoucherNotificationEmail
Dim LBody, LTitle, LStatus, LIsPaymentSlip, LFullName
LBcc1 = FEmailOrderConfirmationBcc1
LBcc2 = FEmailOrderConfirmationBcc2
LFrom = FEmailOrderConfirmationFrom
LIsPaymentSlip = CleanRequestQueryString("cmd") = "paymentslip" ' (SS,12/3/18)
' (SS,12/3/18) added following to fetch the body (before we were fetching from URL)
' Values for LEmailAddress, LFullName, LStatus, LTitle are returned
' removed duplicated code that was creating the subject from order status, returned LTitle used instead
' 3rd parameter AForEmail is True
' (SS,18/11/21) added LVoucherNotificationEmail
' (SS,17/12/21) added False for AHidePersonalDetails, i.e. don't hide personal details
LBody = GetEmailBody(AOrderNo, LIsPaymentSlip, True, LEmailAddress, LFullName, LStatus, LTitle, LVoucherNotificationEmail, False)
' (SS,17/12/21) BCC version, copy emailed to store, protecting customer's data privacy
Dim LBodyBcc
LBodyBcc = GetEmailBody(AOrderNo, LIsPaymentSlip, True, LEmailAddress, LFullName, LStatus, LTitle, LVoucherNotificationEmail, True)
' (SS,23/1/17) replaced above with following
' (SS,12/3/18) replaced tr(LSubject) in following with tr(LTitle)
LSubject = GetStoreName + " " + tr(LTitle) & " " & AOrderNo
' (SS,18/11/21) if voucher notification email set and order completed status and then bcc a copy to this email as well
If LVoucherNotificationEmail <> "" And LStatus = ORDER_COMPLETED_STATUS Then
If LBcc1 <> "" Then LBcc1 = LBcc1 + ";"
LBcc1 = LBcc1 + LVoucherNotificationEmail
End If
' (SS,12/3/18) replaced above SendEmailByITPEmailer with following SendEmailByCDO
' we're no longer getting from webpage, but building from returned strings,
' SendEmailByITPEmailer has an issue with emails looking like they have an empty attachment in Outlook 2016, and worse in some other email clients
' (SS,17/12/21) removed LBcc1, LBcc2, replaced with "", "", to only email this copy with personal details to the customer
SendEmailByCDO LEmailAddress, "", "", LFrom, LSubject, LBody, "", True, "", ""
' (SS,17/12/21) added following to email a copy to LBcc1 (store address), Bcced to LBcc2, uses LBodyBcc instead of LBody
If LBcc1 <> "" Then
SendEmailByCDO LBcc1, LBcc2, "", LFrom, LSubject, LBodyBcc, "", True, "", ""
End If
' (SS,11/8/16) code moved to separate routine
SendVATNumberAlertEmail AOrderNo, LStatus
' (SS,18/5/17) if completed status and ReviewTypeIsTrustpilot and AFS email address specified then send the Trustpilot AFS email
' (SS,12/3/18) moved following here from after EmailOrder in ShowEmailConfirmationHTML
If LStatus = ORDER_COMPLETED_STATUS And ReviewTypeIsTrustpilot And GetTrustpilotAFSEmailAddress <> "" Then
SendTrustpilotAFSEmail LFullName, AOrderNo, LEmailAddress
End If
' (SS,20/3/18) send SMS if applicable for order status
If LStatus = PAYMENT_RECEIVED_STATUS Or LStatus = AWAITING_PAYMENT_STATUS Or LStatus = ORDER_COMPLETED_STATUS Then
Dim LSMSType
' i.e. ORDER_COMPLETED_STATUS then send order despatched SMS
If LStatus = ORDER_COMPLETED_STATUS Then
LSMSType = ST_ORDER_DESPATCHED
Else ' for PAYMENT_RECEIVED_STATUS or AWAITING_PAYMENT_STATUS send the order confirmation SMS
LSMSType = ST_ORDER_CONFIRMATION
End If
' (SS,2/12/21) added 4 empty parameters not used here: "", "", "", ""
SendSMS AOrderNo, LSMSType, "", "", "", ""
End If
End Sub
' (SS,16/4/19) returns True if OrderNo, Session ID and IP address provided in query string are valid, also returns the order no itself
' Code moved here from ShowEmailConfirmationHTML, so it can be called from new cancelled order feature
' Also returns OrderNo set in AOrderNo
Function AuthenticateOrderNo(ByRef AOrderNo)
Dim LSessionID, LIPAddress, LResult
AOrderNo = CleanRequestQueryString("orderno")
If AOrderNo = "" Then AOrderNo = GetOrderNo
LSessionID = CleanRequestQueryString("sid")
If LSessionID = "" Then LSessionID = GetSessionID
LIPAddress = CleanRequestQueryString("ip")
If LIPAddress = "" Then LIPAddress = GetIPAddress
If AOrderNo = "" Or LSessionID = "" Or LIPAddress = "" Then
Response.Write("Sorry, not enough info to show order details<br>")
LResult = False
Else
LResult = True
End If
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
If LResult Then
If IsNull(GetValueFromQuery("OrderNo", "SELECT OrderNo FROM orders WHERE OrderNo = '" + CleanSQLStr(AOrderNo) + "' AND SessionID = '" + LSessionID + "' AND IPAddress = '" + LIPAddress + "'")) Then
Response.Write("Sorry, not enough credentials to show order details<br>")
LResult = False
End If
End If
AuthenticateOrderNo = LResult
End Function
' (SS,8/6/07) shows HTML version of confirmation for emailing
' (SS,12/3/18) modified version which gets string from GetEmailBody which is rendered using Response.Write
' This routine is only called from order-details.asp to show order details on a page.
' order-details.asp is no longer fetched to get the content to send via email.
' Change was made to improve reliability and prevent blank attachments that were resulting in Outlook 2016
' (SS,16/4/19) modified to call new function AuthenticateOrderNo
' (SS,18/11/21) added LVoucherNotificationEmail
Sub ShowEmailConfirmationHTML
Dim LOrderNo
' (SS,16/4/19) replaced code moved from above to AuthenticateOrderNo, LOrderNo is returned from AuthenticateOrderNo
If Not AuthenticateOrderNo(LOrderNo) Then
Exit Sub
End If
' (SS,29/5/09) added code for checking for payment slip
' (SS,18/5/17) added LFullName, LStatus
' (SS,12/3/18) added LTitle
' (SS,18/11/21) added LVoucherNotificationEmail
Dim LEmailAddress, LCmd, LFullName, LStatus, LTitle, LVoucherNotificationEmail
LCmd = CleanRequestQueryString("cmd")
' (SS,29/5/09) added LCmd = "paymentslip"
' nothing is returned but HTML response is done
' (SS,1/6/09) added LCmd = "foremail", if cmd is foremail then we must return the email version
' (SS,7/1/16) removed True for AIsHTML because it's now always HTML
' GetEmailBody LOrderNo, LCmd = "paymentslip", LEmailAddress, LCmd = "foremail"
' (SS,18/5/17) swapped parameters LEmailAddress and LCmd = "foremail", added LFullName to return full name, and LStatus to return status
' to be used by Trustpilot review (AFS) email
' (SS,12/3/18) removed 3rd parameter (LCmd = "foremail") doesn't appear to be used for anything, add new LTitle parameter
' also added Response.Write because GetEmailBody is now a function which returns a string instead of rendering directly
' 3rd parameter AForEmail is False
' (SS,18/11/21) added LVoucherNotificationEmail, not used here, was added to GetEmailBody
' (SS,17/12/21) added False for AHidePersonalDetails, i.e. don't hide personal details
Response.Write GetEmailBody(LOrderNo, LCmd = "paymentslip", False, LEmailAddress, LFullName, LStatus, LTitle, LVoucherNotificationEmail, False)
' (SS,29/6/07) added following to send an email when querystring has cmd="email"
If LCmd = "email" Then
EmailOrder(LOrderNo)
End If
End Sub
' (SS,8/6/07) returns Body, also sets AEmailAddress to the email address to use
' (SS,29/5/09) added AIsPaymentSlip parameter
' (SS,1/6/09) added AForEmail
' (SS,19/3/10) added translation using function tr for HTML only,
' (SS,16/2/11) added tr to INTRA_COMMUNITY_SUPPLY_MESSAGE and added text to status message for English version
' (SS,3/10/12) added SetInvoiceCountry for correct VAT deducted figures for overseas orders
' (SS,23/10/15) modified to not show order details when status is order completed, now text is taken from message to customer field
' (SS,26/10/15) modified to use custom confirmation email text from GetSiteDetail("Other", "ConfirmationEmailTemplate")
' (SS,7/1/16) cleaned up code, was becoming hard to maintain, split to new routines: GetEmailBodyOrderDetails, GetEmailBodyAddressDetails, GetEmailBodyOrderItems, GetEmailBodyMessage
' removed Dim NL now defined globally, cleaned up dated comments
' changed to Sub because no value is returned, calls made to inc-template-email-html.asp to output straight to HTML i.e. Response.Write
' references to strBody removed, old plain text version
' 2nd parameter AIsHTML removed, because it's always HTML
' EmailOrderConfirmationFooter in inc-template-messages.asp no longer used (was only used by plain text)
' Also changed from Function to Sub
' (SS,18/5/17) parameters changed from AOrderNo, AIsPaymentSlip, ByRef AEmailAddress, AForEmail
' to AOrderNo, AIsPaymentSlip, AForEmail, ByRef AEmailAddress, ByRef AFullName, ByRef AStatus
' (SS,12/3/18) changed from Sub to Function which returns a string rather than render directly
' Also replaced ShowEmailHeader with GetOrderEmailHeader
' Added ByRef ATitle as a parameter to return it back to caller to prevent duplication i.e. used in subject of email
' LTitle renamed to ATitle in function
' (SS,18/11/21) added AVoucherNotificationEmail
' (SS,17/12/21) added AHidePersonalDetails, this allows a special version for BCC where personal details are not shown for internal copies, to protect customer privacy
' (SS,31/3/22) added different subject and message if it's a collection i.e. DeliveryWillCollect is true
Function GetEmailBody(AOrderNo, AIsPaymentSlip, AForEmail, ByRef AEmailAddress, ByRef AFullName, ByRef AStatus, ByRef ATitle, ByRef AVoucherNotificationEmail, AHidePersonalDetails)
' (SS,12/3/18) LResult holds the returned email HTML content
Dim LResult
LResult = ""
' open order, looking up voucher code and nicely formatted date/time
' (SS,18/11/21) added vouchers.NotificationEmail
OpenQuery("SELECT orders.*, DATE_FORMAT(orders.DateTimeOrdered, '" & GetLanguageDateFormat(True) & "') AS FormattedDateTime, vouchers.VoucherCode, vouchers.NotificationEmail FROM orders LEFT JOIN vouchers ON vouchers.VoucherID = orders.VoucherID WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
Dim LStatus, LFullName
LStatus = GetFieldValue("Status")
LFullName = GetFullName(GetFieldValue("Title"), GetFieldValue("FirstName"), GetFieldValue("Surname"))
' (SS,31/3/22)
Dim LCollection
LCollection = GetFieldValue("DeliveryWillCollect") = 1
' header, determine title depending on order status
' Dim LTitle ' (SS,12/3/18) replaced by ATitle in parameter of this function
If AIsPaymentSlip Then ' (SS,29/5/09)
ATitle = "Payment Slip"
ElseIf LStatus = ORDER_COMPLETED_STATUS Then
' (SS,31/3/22) added different title for LCollection
If LCollection Then
ATitle = "Order Ready for Collection"
Else
ATitle = "Order Despatched"
End If
ElseIf LStatus = ORDER_CANCELLED_STATUS Then
ATitle = "Order Cancelled"
Else
' (SS,14/6/10) if email confirmation is also receipt then set title to "Invoice" followed by last 2 letters for domain and order no
If EmailConfirmationIsVATReceipt Then
' LTitle = tr("Invoice") & " " & UCase(Right(GetStoreURL, 2)) & AOrderNo
' (SS,25/11/16) replaced above with following
ATitle = "Order Confirmation & VAT Invoice"
Else
ATitle = "Order Confirmation"
End If
End If
' (SS,1/6/09) added AForEmail, (SS,19/3/10) added tr for translation
' (SS,12/3/18) replaced ShowEmailHeader with GetOrderEmailHeader, and added LResult = LResult &
LResult = LResult & GetOrderEmailHeader(tr(ATitle), AForEmail)
' (SS,23/10/15) if not order completed status, i.e. not order despatched, only then include the order details
If LStatus <> ORDER_COMPLETED_STATUS Then
' (SS,12/3/18) GetEmailBodyOrderDetails is now a function which returns a value (also added LResult = LResult &)
LResult = LResult & GetEmailBodyOrderDetails(AOrderNo, AIsPaymentSlip, LFullName, AHidePersonalDetails)
End If
' the main message of email
' (SS,29/5/09) added AIsPaymentSlip to bring up in print preview for payment slip
' (SS,4/4/17) added IsLocalMode which also needs to show print preview
' (SS,12/3/18) replaced ShowEmailFooter with GetOrderEmailFooter, and added LResult = LResult &
' (SS,13/12/18) added AOrderNo to GetEmailBodyMessage
' (SS,31/3/22) added LCollection to GetEmailBodyMessage
LResult = LResult & GetOrderEmailFooter(LFullName, GetEmailBodyMessage(AOrderNo, LStatus, LCollection, LFullName), AIsPaymentSlip Or IsLocalMode)
' (SS,15/4/16) if complete/despatched email place details at the bottom
If LStatus = ORDER_COMPLETED_STATUS Then
' (SS,12/3/18) GetEmailBodyOrderDetails is now a function which returns a value (also added LResult = LResult &)
LResult = LResult & GetEmailBodyOrderDetails(AOrderNo, AIsPaymentSlip, LFullName, AHidePersonalDetails)
End If
AEmailAddress = GetFieldValue("EmailAddress") ' return email address
' (SS,18/5/17) added following to now also return full name and status (ByRef)
AFullName = LFullName
AStatus = LStatus
' (SS,18/11/21) added following to return new NotificationEmail field from vouchers table
AVoucherNotificationEmail = TrimAll(GetFieldValue("NotificationEmail"))
CloseQuery ' close orders table
' (SS,12/3/18) now returns a string value
GetEmailBody = LResult
End Function
' (SS,7/1/15) moved code here from GetEmailBody, assumes access to orders record using GetFieldValue
' AExtraMessage returns extra text to add to email message
' (SS,8/8/17) change to call to ShowEmailOrderHeader to also pass on GBP Grand Total
' (SS,12/3/18) changed from Sub to Function which returns a string rather than render directly
' (SS,16/2/21) added EORINumber and XIEORINumber, change also made to this routine in inc-template-email-html.asp
' (SS,17/12/21) added AHidePersonalDetails
' (SS,14/2/23) bugfix to correctly remove VAT for prices shown
Function GetEmailBodyOrderDetails(AOrderNo, AIsPaymentSlip, AFullName, AHidePersonalDetails)
' (SS,12/3/18) LResult holds the returned email HTML content
Dim LResult
LResult = ""
' (SS,14/2/23) bug fix, caused by CorrectCurrencyNV via call to IsCountryVATable and subsequent call to GetDeliveryCountry and fetching from Session("DeliveryCountry") or Session("Country")
' was result in a default being used from local browser, usually UK, then the prices listed could wrongly show VAT included instead of VAT being removed, especially for
' despatch emails triggered from Shopping Admin, incorrect figures also show in browser via "View Order in Browser", overall GrandTotal is still correct, but other figures may show VAT included
' when they shouldn't. Caused by Session("DeliveryCountry") not being fetched from the order record, fixed by adding the following two lines to set session country values from field values
Session("Country") = GetFieldValue("Country")
Session("DeliveryCountry") = GetFieldValue("DeliveryCountry")
' !!! debug code
' Response.Write "##Country: " & Session("Country") & BR
' Response.Write "##Delivery Country: " & Session("DeliveryCountry") & BR
Dim LStatus
LStatus = GetFieldValue("Status") ' (SS,22/5/09)
' (SS,12/3/18) added "LResult = LResult & ", GetEmailBodyAddressDetails is now a function
LResult = LResult & GetEmailBodyAddressDetails(AIsPaymentSlip, AFullName, AHidePersonalDetails) ' (SS,7/1/16) code moved to this routine
' (SS,19/9/06) set the currency code, rate, symbols for calls to CorrectCurrencyNV etc to work correctly
' (SS,1/8/17) moved code to separate SetCurrencyForOrder routine
SetCurrencyForOrder GetFieldValue("CurrencyCode"), GetFieldValue("ExchangeRate")
' (SS,8/11/07) added GetFieldValue("DateTimeOrdered")
' (SS,16/11/07) added GetFieldValue("VATNumber")
' (SS,20/4/09) added GetFieldValue("Mobile"), GetFieldValue("DeliveryDate"), LVoucherCode
' (SS,29/5/09) added LStatus
' (SS,13/5/10) replaced DateTimeOrdered with FormattedDateTime
' (SS,8/3/13) added StatusForCustomer to convert COMPLETED to DESPATCHED
' (SS,8/8/17) added new parameter GBPGrandTotal ( FormatNumber(GetFieldValue("GrandTotal", 2)) ) to the end to be show in multicurrency sites
' (SS,12/3/18) added "LResult = LResult & and replaced ShowEmailOrderHeader with GetOrderEmailHeaderDetails which is now a function
' (SS,16/2/21) added EORINumber and XIEORINumber, change also made to this routine in inc-template-email-html.asp
' (SS,20/5/21) replaced GetFieldValue("Mobile") with GetFieldValue("AlternativePhone")
' (SS,17/12/21) modified to set values according to new AHidePersonalDetails
Dim LMessage, LTelephone, LAlternativePhone, LEmailAddress, LPaymentReference
LMessage = HideSensitiveData(AHidePersonalDetails, GetFieldValue("Message"))
LTelephone = HideSensitiveData(AHidePersonalDetails, GetFieldValue("Telephone"))
LAlternativePhone = HideSensitiveData(AHidePersonalDetails, Trim(GetFieldValue("AlternativePhone")))
LEmailAddress = HideSensitiveData(AHidePersonalDetails, GetFieldValue("EmailAddress"))
LPaymentReference = HideSensitiveData(AHidePersonalDetails, GetFieldValue("PaymentReference"))
LResult = LResult & GetOrderEmailHeaderDetails(AOrderNo, GetFieldValue("FormattedDateTime"), StatusForCustomer(LStatus), GetFieldValue("CustomerID"), GetFieldValue("PurchaseOrderNo"), LMessage, LTelephone, LAlternativePhone, LEmailAddress, GetFieldValue("VATNumber"), GetFieldValue("EORINumber"), GetFieldValue("XIEORINumber"), GetFieldValue("DeliveryDate"), NB(GetFieldValue("VoucherCode")), GetFieldValue("PaymentMethod"), LPaymentReference, FormatNumber(GetFieldValue("GrandTotal"), 2))
' (SS,12/3/18) added "LResult = LResult & ", GetEmailBodyOrderItems is now a function
LResult = LResult & GetEmailBodyOrderItems(AOrderNo) ' (SS,7/1/16) moved code to separate routine
Dim LVATLabel, LVATAmount ' (SS,8/6/07)
LVATLabel = ""
LVATAmount = 0
' (SS,28/5/07) added If IsVATRegistered to not show VAT if not registered
If IsVATRegistered Then
' (SS,8/6/07) improvements to VAT
LVATAmount = NZ(GetFieldValue("VATIncluded"))
If PricesEnteredIncludeVAT Then
If NZ(GetFieldValue("VATDeducted")) > 0 Then
LVATLabel = "" ' (SS,2/11/12) was "VAT Deducted" changed to "" to ensure it's no longer shown, no need to because all prices shown now have VAT deducted
LVATAmount = NZ(GetFieldValue("VATDeducted"))
Else
LVATLabel = "VAT Included"
End If
Else
LVATLabel = "VAT"
End If
LVATLabel = tr(LVATLabel) ' (SS,19/3/10) for translation
End If
' (SS,10/6/07) moved email address and message higher up
' (SS,22/6/07) added following to show weight in HTML email
Dim LTotalWeight
If GetShowWeightInEmail Then
LTotalWeight = Format2dp(NZ(GetFieldValue("TotalWeight"))) & " " & GetWeightUnits
LTotalWeight = CorrectCommasAndDP(LTotalWeight) ' (SS,13/5/10) corrects commas and dp for language
Else
LTotalWeight = Null
End If
' (SS,8/6/07)
' (SS,20/4/09) added GetFieldValue("Discount") <> 0 and CorrectCurrency(GetFieldValue("Discount"))
' (SS,2/11/09) replaced "VAT" with LVATLabel
' (SS,2/11/12) replaced CorrectCurrency with CorrectCurrencyNV for Subtotal, Discount and Delivery, to ensure VAT is removed for countries who aren't charged VAT, to prevent confusion
' (SS,12/3/18) added "LResult = LResult & ", renamed ShowEmailOrderFooter to GetOrderEmailFooterDetails which is now a function
LResult = LResult & GetOrderEmailFooterDetails(CorrectCurrencyNV(GetFieldValue("Subtotal")), GetFieldValue("Discount") <> 0, CorrectCurrencyNV(GetFieldValue("Discount")), CorrectCurrencyNV(GetFieldValue("Delivery")), LVATLabel, CorrectCurrency(LVATAmount), CorrectCurrency(GetFieldValue("GrandTotal")), LTotalWeight)
' (SS,12/3/18) now returns a string containing the content
GetEmailBodyOrderDetails = LResult
End Function
' (SS,17/12/21) if AInclude is True then the value is returned as it is, if False and "", then returned as it is, if not blank then returns "****"
Function HideSensitiveData(AHide, AValue)
Dim Result
Result = AValue
If AHide Then
If NB(AValue) <> "" Then
Result = "****"
End If
End If
HideSensitiveData = Result
End Function
' (SS,17/12/21) called from GetEmailBodyAddressDetails below
Function AddNewlineIfNotBlank(AValue)
If AValue = "" Then
AddNewlineIfNotBlank = ""
Else
AddNewlineIfNotBlank = AValue & NL
End If
End Function
' (SS,7/1/16) code moved here from GetEmailBody, assumes access to orders record using GetFieldValue
' (SS,12/3/18) changed from Sub to Function which returns a string rather than render directly
' (SS,24/11/21) modified to allow a customer message for collection via GetMessage
' (SS,17/12/21) added AHidePersonalDetails, and calls to HideSensitiveData
' Also added new AddNewlineIfNotBlank to replace having to use: iif(GetFieldValue("CompanyName") = "", "", GetFieldValue("CompanyName") & NL) etc
Function GetEmailBodyAddressDetails(AIsPaymentSlip, AFullName, AHidePersonalDetails)
Dim LInvoiceAddress, LDeliveryAddress
LInvoiceAddress = AFullName & NL
LInvoiceAddress = LInvoiceAddress + AddNewlineIfNotBlank(GetFieldValue("CompanyName"))
LInvoiceAddress = LInvoiceAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("AddressLine1")))
LInvoiceAddress = LInvoiceAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("AddressLine2")))
LInvoiceAddress = LInvoiceAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("Town")))
LInvoiceAddress = LInvoiceAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("County")))
LInvoiceAddress = LInvoiceAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("Postcode")))
LInvoiceAddress = LInvoiceAddress + AddNewlineIfNotBlank(GetFieldValue("Country"))
' (SS,3/11/12) added following to get Country for CorrectCurrencyNV which may deduct VAT depending on Invoice Country, emails are sent from outside of a Session
' this was resulting in emails with VAT not deducted from total figures, add this solved the problem because it puts the country into session variable so that GetInvoiceCountry returns it for CorrectCurrencyNV
SetInvoiceCountry GetFieldValue("Country")
' (SS,12/12/12) added following to VATNumber into session for CorrectCurrencyNV to work correctly to deduct VAT for Intra-Community supply
SetVATNumberForIntraCommunity GetFieldValue("VATNumber")
' (SS,16/11/07) added AllowCollection to show collection text instead
If AllowCollection And IntToBool(GetFieldValue("DeliveryWillCollect")) Then
LDeliveryAddress = "There will be no delivery charge." & NL
' (SS,24/11/21) added following to allow custom text
If GetMessage("DeliveryWillCollect") <> "" Then
LDeliveryAddress = LDeliveryAddress & GetMessage("DeliveryWillCollect")
Else ' (SS,24/11/21) as before
LDeliveryAddress = LDeliveryAddress & "Please contact us to arrange a time to collect your goods."
End If
ElseIf IntToBool(GetFieldValue("DeliveryAddressSameAsInvoice")) Then
LDeliveryAddress = LInvoiceAddress
Else
LDeliveryAddress = LDeliveryAddress + AddNewlineIfNotBlank(GetFieldValue("DeliveryName"))
LDeliveryAddress = LDeliveryAddress + AddNewlineIfNotBlank(GetFieldValue("DeliveryCompanyName"))
LDeliveryAddress = LDeliveryAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("DeliveryAddressLine1")))
LDeliveryAddress = LDeliveryAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("DeliveryAddressLine2")))
LDeliveryAddress = LDeliveryAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("DeliveryTown")))
LDeliveryAddress = LDeliveryAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("DeliveryCounty")))
LDeliveryAddress = LDeliveryAddress + AddNewlineIfNotBlank(HideSensitiveData(AHidePersonalDetails, GetFieldValue("DeliveryPostcode")))
LDeliveryAddress = LDeliveryAddress + AddNewlineIfNotBlank(GetFieldValue("DeliveryCountry"))
End If
SetDeliveryInfo GetFieldValue("DeliveryInfo") ' (SS,9/10/14)
SetDeliveryOptionLabel GetFieldValue("DeliveryOption") ' (SS,22/4/21)
' (SS,29/5/09) modified to use store address when payment slip
' (SS,19/3/10) added tr for translation
' (SS,12/3/18) renamed from ShowEmailAddressDetails and also now returns a string i.e. GetEmailBodyAddressDetails =
GetEmailBodyAddressDetails = GetOrderEmailAddressDetails(tr(iif(AIsPaymentSlip, "To", "Delivery Address")), iif(AIsPaymentSlip, GetStoreAddressAsHTML, ReplaceNewLinesWithBR(LDeliveryAddress)), tr(iif(AIsPaymentSlip, "From", "Billing Address")), ReplaceNewLinesWithBR(LInvoiceAddress))
End Function
' (SS,7/1/16) code moved here from GetEmailBody, also modified to use OpenQuery2 instead of OpenQuery to prevent clash issue
' (SS,12/3/18) changed from Sub to Function which returns a string rather than render directly
' (SS,1/8/18) modified to add additional info to options list (for CIRC)
Function GetEmailBodyOrderItems(AOrderNo)
' (SS,12/3/18) LResult holds the returned email HTML content
Dim LResult
LResult = ""
' (SS,1/8/18) added following to allow additional info to be added for an option
Dim LOptionsList
' (SS,31/10/18) added GetOrderDetailsFilter to filter out subproducts
OpenQuery2("SELECT * FROM orderdetails WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'" & GetOrderDetailsFilter & " ORDER BY OrderDetailID")
Dim tp_ProductCode, tp_ProductName, tp_Price, tp_Qty, tp_ProductTotal
Dim LPrice, LQty
Do While Not EndOfQuery2
tp_ProductCode = GetQueryValue2("ProductCode")
LQty = NZ(GetQueryValue2("Qty"))
tp_Qty = LQty
tp_ProductName = GetQueryValue2("ProductName")
LPrice = NZ(GetQueryValue2("PriceEach"))
tp_Price = FormatNumber(CorrectCurrencyNF(LPrice), 2)
tp_ProductTotal = FormatNumber(CorrectCurrencyNF(LPrice * LQty), 2)
' (SS,1/8/18) add additional custom info to options list
LOptionsList = AddMoreOptionsInfo(GetQueryValue2("ProductID"), GetQueryValue2("OptionsList"))
' (SS,6/7/11) added ProductID and OptionsList
' (SS,2/11/12) changed CorrectCurrency to CorrectCurrencyNV to show prices without VAT for countries that aren't charged VAT
' (SS,12/3/18) renamed from ShowEmailOrderItem, now a function which returns a string, added LResult = LResult &
' (SS,1/8/18) replaced GetQueryValue2("OptionsList") with LOptionsList to allow additional info to be added above
LResult = LResult & GetOrderEmailProductItem(GetQueryValue2("ProductID"), tp_ProductCode, tp_ProductName, LOptionsList, tp_Qty, CorrectCurrencyNV(LPrice), CorrectCurrencyNV(LPrice * LQty))
NextQueryRecord2
Loop
CloseQuery2
' (SS,12/3/18) now returns a string instead of direct rendering
GetEmailBodyOrderItems = LResult
End Function
' (SS,7/1/16) code from GetEmailBody to create just the message
' (SS,28/1/16) fix to prevent MessageToCustomer from being added twice when EmailUseMessageToCustomerForDespatch is True, via LMessageToCustomerAlreadyUsed
' (SS,3/3/16) change to show date on despatch email
' (SS,10/5/16) change to add the text "Tracking may not start working for a few hours"
' (SS,13/12/18) added AOrderNo parameter for use by CancelOrderAllowed and GetCancelOrderURL
' (SS,28/6/19) added additional message for completed order email
' (SS,1/7/21) added call to AddNewlinesToHTMLBreaks to reduce line length for emails, try to keep below 1000, adds NLs after BRs
' (SS,31/3/22) added ACollection, if True then message is "Your order is ready for collection." instead of "Your order was despatched..."
' (SS,15/6/23) change to tracking number to show the tracking link even if DeliveryOption is untracked
' (SS,19/1/24) change to not show tracking if DeliveryOption is "CRL24" even though the tracking no field has a value
Function GetEmailBodyMessage(AOrderNo, AStatus, ACollection, AFullName)
' (SS,29/5/09) added LPaymentMethod
Dim LPaymentMethod
LPaymentMethod = GetFieldValue("PaymentMethod") ' (SS,29/5/09)
Dim LConfirmationEmailTemplateUsed ' (SS,30/10/15)
LConfirmationEmailTemplateUsed = False ' (SS,7/1/15)
' (SS,28/1/16) added following to prevent message to customer from being added twice
Dim LMessageToCustomerAlreadyUsed
LMessageToCustomerAlreadyUsed = False
' (SS,22/5/09) added code to allow different message for cancelled and completed order
Dim LStatusMessage, LCourier
LCourier = NB(GetFieldValue("Courier"))
If AStatus = ORDER_COMPLETED_STATUS Then
' (SS,23/10/15) if MessageToCustomer is not blank then use this, else obey the previous standard
Dim LMessageToCustomer
If EmailUseMessageToCustomerForDespatch Then
LMessageToCustomerAlreadyUsed = True ' (SS,28/1/16) to prevent MessageToCustomer from being added again later
LMessageToCustomer = Trim(NB(GetFieldValue("MessageToCustomer")))
' (SS,30/10/15) if nothing set then get the default
If LMessageToCustomer = "" Then
LMessageToCustomer = GetSiteDetail("Delivery Agents", "Default")
End If
Else
LMessageToCustomer = ""
End If
If LMessageToCustomer <> "" Then
LMessageToCustomer = ReplaceStr(LMessageToCustomer, "{STORE_NAME}", GetStoreName)
LMessageToCustomer = ReplaceStr(LMessageToCustomer, "{STORE_EMAIL}", GetStoreEmail)
LStatusMessage = ConvertNewlinesToHTML(LMessageToCustomer)
Else
' (SS,31/3/22) added different text for collection
If ACollection Then
LStatusMessage = "Your order is ready for collection."
Else
If LCourier <> "" Then LCourier = "via " & LCourier & " "
' LStatusMessage = "Your order has been despatched for delivery " & LCourier & "and should be with you shortly."
' (SS,19/3/10) replaced above with following for translation
'LStatusMessage = trx("Your order has been despatched for delivery <x>and should be with you shortly", LCourier) & "."
' (SS,3/3/16) replaced above with following to add the date on despatch email
LCourier = "on " & FormatDateTime(GetFieldValue("DateTimeCompleted"), 1) & " " & LCourier
' (SS,24/3/16) replaced "Your order was despatched for delivery" with "Your order was despatched"
LStatusMessage = trx("Your order was despatched <x>and should be with you shortly", LCourier) & "."
End If
End If
ElseIf AStatus = ORDER_CANCELLED_STATUS Then
LStatusMessage = tr("Your order has been cancelled") & "." ' (SS,19/3/10) added tr
Else ' email confirmation
' (SS,26/10/15) get from template, override the default if it exists
LStatusMessage = GetSiteDetail("Other", "ConfirmationEmailTemplate")
LConfirmationEmailTemplateUsed = LStatusMessage <> ""
If LStatusMessage = "" Then
LStatusMessage = trx("Thank you for ordering from <x>", GetStoreName) & "."
' (SS,16/2/11) added following for English version only
If IsEnglish Then LStatusMessage = LStatusMessage & " This email is to confirm that your order has been received and we will dispatch the goods as soon as possible."
Else ' (SS,26/10/15)
LStatusMessage = ReplaceStr(LStatusMessage, "{STORE_NAME}", GetStoreName)
LStatusMessage = ReplaceStr(LStatusMessage, "{STORE_EMAIL}", GetStoreEmail)
End If
End If
Dim LEmailMessage ' (SS,7/1/16)
' (SS,16/11/07) added following IntraCommunity Supply message
If IntToBool(GetFieldValue("IntraCommunitySupply")) Then
If LEmailMessage <> "" Then LEmailMessage = LEmailMessage & NL & NL
LEmailMessage = LEmailMessage & tr(INTRA_COMMUNITY_SUPPLY_MESSAGE)
End If
' (SS,22/5/09) message to customer and tracking details
' (SS,13/3/13) tidied the code slightly
Dim LMsg, LTrackingNo
LMsg = ""
LTrackingNo = Trim(GetFieldValue("TrackingNo"))
' (SS,29/3/22) added IsDeliveryOptionUntracked
' (SS,15/6/23) removed "And Not IsDeliveryOptionUntracked(GetFieldValue("DeliveryOption"))"
' because a tracking service is sometimes used even if user has chosen "Untracked", so just check whether TrackingNo has been entered, no need to look at the DeliveryOption
' (SS,19/1/24) added AND InStr(GetFieldValue("DeliveryOption"), "CRL24") = 0 to not show tracking if "CRL24" is in Delivery Option e.g. "Untracked - CRL24" (requested by Neil, see email 17/1/24)
If LTrackingNo <> "" AND InStr(GetFieldValue("DeliveryOption"), "CRL24") = 0 Then
If IsURL(LTrackingNo) Then
LMsg = "The Tracking URL is <a href=""" & LTrackingNo & """>" & LTrackingNo & "</a>." ' (SS,10/5/16) added the fullstop
Else
LMsg = "The Tracking Number is "
' (SS,13/3/13) added following to add URL to tracking number
Dim LTrackingURL, LTrackingPostcode
' (SS,16/5/13) added Postcode because some courier sites require it
LTrackingPostcode = NB(GetQueryValue("DeliveryPostcode"))
If LTrackingPostcode = "" Then LTrackingPostcode = NB(GetQueryValue("Postcode"))
LTrackingURL = GetTrackingURLForCourier(GetQueryValue("DeliveryAgentName"), GetQueryValue("Courier"), GetFieldValue("TrackingNo"), LTrackingPostcode)
If LTrackingURL <> "" Then
' LTrackingNo = "<a href=""" & LTrackingURL & """>" & LTrackingNo & "</a>"
' (SS,16/5/13) replaced above with following
LTrackingNo = LTrackingNo & ". Please click <a href=""" & LTrackingURL & """>here</a> to track"
End If
LMsg = LMsg & LTrackingNo & "."
End If
LMsg = LMsg & " Tracking may not start working for a few hours." ' (SS,10/5/16) added this, requested by Neil
If LEmailMessage <> "" Then LEmailMessage = LEmailMessage & NL & NL
LEmailMessage = LEmailMessage & LMsg
End If
' (SS,28/1/16) added "If" to prevent MessageToCustomer from being added twice because it may have already been added above
If Not LMessageToCustomerAlreadyUsed Then
LMsg = GetFieldValue("MessageToCustomer")
If LMsg <> "" Then
If LEmailMessage <> "" Then LEmailMessage = LEmailMessage & NL & NL
LEmailMessage = LEmailMessage & LMsg
End If
End If
' (SS,29/5/09) added payment details for cheque or bank transfer
If AStatus = AWAITING_PAYMENT_STATUS Then
If LEmailMessage <> "" Then LEmailMessage = LEmailMessage & NL & NL
If LPaymentMethod = ptCheque Then
LEmailMessage = LEmailMessage & "You have chosen to pay by cheque. Please send a cheque for the full amount payable to " & GetChequesPayableTo & " to the following address: " & NL & NL & TrimAll(GetStoreAddress(False, False))
ElseIf IsPaymentBankTransfer(LPaymentMethod) Then ' (SS,4/8/17) replaced LPaymentMethod = ptBankTransfer with IsPaymentBankTransfer(LPaymentMethod)
' LExtraMessage = LExtraMessage & "You have chosen to pay by bank transfer. Please make a full payment to the following account:" & NL & NL & GetBankTransferDetails
' (SS,19/12/14) replaced above with following
' (SS,9/8/17) replaced GetBankTransferDetails with GetBankTransferDetailsAsHTML
LEmailMessage = LEmailMessage & "You have chosen to pay by bank transfer. " & GetBankTransferPaymentLine & NL & NL & GetBankTransferDetailsAsHTML
End If
' (SS,13/12/18) added following to allow order to be cancelled by URL
If CancelOrderAllowed(AOrderNo) Then
LEmailMessage = LEmailMessage & NL & NL & "If you would like to cancel this order please click <a href=""" + GetCancelOrderURL(AOrderNo) + """>here</a>."
End If
End If
If LEmailMessage <> "" Then
LEmailMessage = ConvertNewlinesToHTML(LEmailMessage)
LEmailMessage = LStatusMessage & "<br><br>" & LEmailMessage
Else
LEmailMessage = LStatusMessage
End If
LEmailMessage = tr("Dear") & " " & AFullName & "," & BR & BR & ConvertNewlinesToHTML(LEmailMessage) & BR & BR
' (SS,16/2/11) if English then use the new improved message
' (SS,23/10/15) if not using message to customer for this or message is blank then assume the previous default
' (SS,30/10/15) moved here from inc-template-email-html.asp, also added Not LConfirmationEmailTemplateUsed, to only add if ConfirmationEmailTemplateUsed hasn't been used
If Not LConfirmationEmailTemplateUsed And (Not EmailUseMessageToCustomerForDespatch Or LStatusMessage = "") Then
Dim LEmailLink ' (SS,16/2/11) added because now in two places
LEmailLink = "<a href=""mailto:" + GetStoreEmail + """>" + GetStoreEmail + "</a>"
If IsEnglish Then
LEmailMessage = LEmailMessage & "If you have any queries please email us on " & LEmailLink & " quoting the order reference." & BR & BR
LEmailMessage = LEmailMessage & "We very much appreciate your custom and hope you are pleased with our products."
Else ' (SS,16/2/11) for non-English carry on using previous version so that it translates correctly
LEmailMessage = LEmailMessage & trx("If you have any queries in relation to the above order please visit our web site at <x>", "<a href=""" & GetStoreURL & """>" & GetStoreURL & "</a>")
End If
LEmailMessage = LEmailMessage & BR & BR
End If
LEmailMessage = LEmailMessage & Iif(IsEnglish, "Kindest regards", tr("Regards")) & "," & BR & BR & tr(GetStoreRegards)
' (SS,1/7/21) added following to try keep line length smaller than 1000 (limit for emails which some mail servers are strict about)
' does this by adding a NL after each BR (should have no cosmetic effect)
LEmailMessage = AddNewlinesToHTMLBreaks(LEmailMessage)
' (SS,28/6/19) added additional message for completed order emails (VDK)
If AStatus = ORDER_COMPLETED_STATUS Then
Dim LAdditionalMessage
LAdditionalMessage = GetSiteDetail("Other", "CompletedOrderEmailAdditionalInfo")
If LAdditionalMessage <> "" Then
LEmailMessage = LEmailMessage & BR & LAdditionalMessage
End If
End If
' (SS,15/10/20) added extra from new Extras field if applicable, calls custom routine if defined with AType "E" and passes on the Extras field value
If FunctionExists("CustomGetExtras") Then
LEmailMessage = LEmailMessage & BR & CustomGetExtras("E", GetFieldValue("Extras"))
End If
GetEmailBodyMessage = LEmailMessage ' (SS,7/1/15) value returned from this routine
End Function
' (SS,20/11/08)
' (SS,20/4/18) added header and footer to tidy up buttons, bank transfer appears higher up for HyperFlight
' (SS,17/2/21) for HF move Bank Transfer after 2nd payment type
' (SS,1/7/21) change for HyperFlight to show the two main payment types alternatively on odd/even days
' (SS,7/10/21) removed/commented out the alternating between first two payment types for HyperFlight
' (SS,23/6/22) now also called from ShowPaymentFailureAlert in inc-template-check.asp when payment fails or is cancelled
Sub SetUpPaymentButtons
ClearCreditCardPaymentProviderFailure ' (SS,24/6/22) clear to prevents buttons appearing again if payment was successful and a failure was flagged earlier
ShowCheckoutPaymentButtonHeader ' (SS,20/4/18)
' (SS,05/10/16) if local mode then show payment method combo and payment reference
If IsLocalMode Then
ShowCheckoutLocalModePayment
SetUpPaymentButton "LOCALMODE"
Else ' (SS,05/10/16) as before
' (SS,1/7/21) for HyperFlight alternate between the first two payment types on odd and even days
'If IsHyperFlight Then
' Response.Write "###Day of Month:" & DatePart("d", Date) & "###"
' if odd then as before, else if even then alternate
' If DatePart("d", Date) Mod 2 = 1 Then
' SetUpPaymentButton GetPaymentType
' SetUpPaymentButton GetPaymentType2
' Else
' SetUpPaymentButton GetPaymentType2
' SetUpPaymentButton GetPaymentType
' End If
'Else ' (SS,1/7/21) as before i.e. other than HyperFlight
' SetUpPaymentButton GetPaymentType
' SetUpPaymentButton GetPaymentType2
'End If
SetUpPaymentButton GetPaymentType
SetUpPaymentButton GetPaymentType2
' (SS,20/4/18) for HyperFlight show Bank Transfer before second method i.e. PayPal
' (SS,17/2/21) moved from before GetPaymentType2 to after it
If IsHyperFlight And AllowBankTransfers Then SetUpPaymentButton ptBankTransfer
SetUpPaymentButton GetPaymentType3 ' (SS,4/6/09)
' (SS,28/5/09) added following to allow cheque payments and bank transfers
' (SS,20/4/18) move cheque below bank transfer, added If Not IsHyperFlight to allow Bank Transfer to be shown earlier for HF
If Not IsHyperFlight And AllowBankTransfers Then SetUpPaymentButton ptBankTransfer
If AllowCheques Then SetUpPaymentButton ptCheque
End If
ShowCheckoutPaymentButtonFooter ' (SS,20/4/18)
End Sub
' (SS,20/11/14)
Sub SetUpPayPalExpressConfirmButton
SetUpPaymentButton ptPayPalExpress
End Sub
' (SS,8/9/06)
Function GetReturnFromPaymentURL
GetReturnFromPaymentURL = GetStoreURL + "/products.asp?cmd=checkout&stage=" & RETURN_FROM_THIRD_PARTY_PAYMENT
End Function
' (SS,20/4/18) used to show a normally disabled payment method if main credit card payment failed (i.e. Payzone for HF)
Sub SetCreditCardPaymentProviderFailure
Session("CreditCardPaymentProviderFailure") = True
End Sub
' (SS,20/6/22) this is a session variable so needs to be cleared before attempting a payment
Sub ClearCreditCardPaymentProviderFailure
Session("CreditCardPaymentProviderFailure") = False
End Sub
' (SS,20/4/18)
Function IsCreditCardPaymentProviderFailure
IsCreditCardPaymentProviderFailure = Session("CreditCardPaymentProviderFailure") = True
End Function
' (SS,20/11/08) new routine with code from SetUpPayment, now handles two payment types
' (SS,19/1/15) added extra parameter to ShowCheckoutPaymentButton for image, second parameter is now always the caption for the image
' (SS,28/3/18) added Payzone
' (SS,17/4/18) removed ptDirect and ptGoogleCheckout (now redundant)
' (SS,21/1/21) removed "preferred" text from PayZone button caption
' (SS,17/2/21) added "preferred" text back to PayZone button caption
' (SS,3/8/22) change to added PayPal Pay Later message
Sub SetUpPaymentButton(APaymentType)
Dim LPaymentLink
LPaymentLink = GetPaymentSubmitJavascriptLink(APaymentType)
' (SS,23/6/22) to highlight preferred if enabled
Dim LPaymentPreferred
If GetPaymentHighlightPreferred Then
LPaymentPreferred = "<br><small>Preferred :-)</small>"
Else
LPaymentPreferred = ""
End If
If IsLocalMode Then
' (SS,6/10/16) added local mode
ShowCheckoutPaymentButton LPaymentLink, "Make payment", ""
' (SS,28/5/09) added cheque payment
ElseIf APaymentType = ptCheque Then
' (SS,20/9/11) changed "images/pay-by-cheque.gif" to "Pay by Cheque", now using button instead of gif
' (SS,5/2/15) added images/make-payment-cheque.png
' (SS,20/4/18) removed image "images/make-payment-cheque.png"
' (SS,20/6/22) added new image, replaced "" with "images/make-payment-cheque.png"
ShowCheckoutPaymentButton LPaymentLink, "Pay by Cheque", "images/make-payment-cheque.png"
' (SS,28/5/09) added bank transfer payment
ElseIf APaymentType = ptBankTransfer Then
' *** (SS,20/7/17) added following for custom bank transfer dialog
If FunctionExists("CustomShowBankTransferModal") Then
CustomShowBankTransferModal(Session("Country")) ' (SS,29/9/17) modified to pass on the billing country
Else ' (SS,20/7/17) as before
' (SS,20/9/11) changed "images/pay-by-bank-transfer.gif" to "Pay by Bank Transfer", now using button instead of gif
' (SS,19/1/15) added images/make-payment-bacs.png image
' (SS,20/4/18) removed image "images/make-payment-bacs.png"
ShowCheckoutPaymentButton LPaymentLink, "Pay by Bank Transfer", ""
End If
ElseIf APaymentType = ptWorldPay Then
If GetWorldPayInstallID = "" Then
ShowCheckoutMakePaymentButton "javascript:alert('WorldPay facility not yet enabled')"
Else
'If AccountLoggedIn Then
' ShowCheckoutPayNowWithCreditCardButton LPaymentLink ' replaced "javascript:document.frmWorldPay.submit()" with GetPaymentSubmitJavascriptLink("frmWorldPay")
'Else
'End If
' (SS,16/6/09) removed the above, replaced with check for more than one payment type
If GetPaymentType1 = ptWorldPay And PaymentTypeCount = 1 Then
ShowCheckoutMakePaymentButton LPaymentLink ' replaced "javascript:document.frmWorldPay.submit()" with GetPaymentSubmitJavascriptLink("frmWorldPay")
Else ' because there's more than one payment type we need to show the world pay logo
' (SS,19/1/15) added "Pay by WorldPay" caption
' (SS,10/3/17) changed from .gif to .png
ShowCheckoutPaymentButton LPaymentLink, "Pay by WorldPay", "images/make-payment-worldpay.png"
End If
End If
' (SS,19/1/15) "Pay by PayPal" caption, and replaced make-payment-paypal.gif with make-payment-paypal.png
ElseIf APaymentType = ptPayPal Then
' (SS,9/4/18) added following "If" so that when GetPayPalUKOnlyCheckout is True then PayPal button only shown for UK
' on the normal checkout stage, for PayPal Express Checkout it's still available for all regions
' (SS,20/4/18) added IsCreditCardPaymentProviderFailure to show PayPal if main credit card option failed
If Not GetPayPalUKOnlyCheckout Or IsUK(GetInvoiceCountry) Or IsCreditCardPaymentProviderFailure Then
If GetPayPalBusiness = "" Then
ShowCheckoutPaymentButton "javascript:alert('PayPal facility not yet enabled')", "Pay by PayPal", "images/make-payment-paypal.gif"
Else
' (SS,8/6/18) added surcharge text if surcharge applicable
Dim LPayPalCaption
LPayPalCaption = "Pay by PayPal"
If IsPayPalSurcharge Then LPayPalCaption = LPayPalCaption & "<br><small>" & GetPayPalSurchargePercentage & "% surcharge</small>"
ShowCheckoutPaymentButton LPaymentLink, LPayPalCaption, "images/make-payment-paypal.png"
' (SS,3/8/22) added PayPal Pay Later message if enabled
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="<%=Session("PaymentAmount")%>"></div>
<%
End If
End If
End If
ElseIf APaymentType = ptEPDQ Then ' (SS,7/9/06)
' (SS,10/5/12) modified to work correctly
If GetEPDQClientID = "" Then
ShowCheckoutMakePaymentButton "javascript:alert('ePDQ facility not yet enabled')"
Else
' (SS,19/1/15) added "Pay by ePDQ" caption, later changed to "Pay by Credit or Debit Card"
ShowCheckoutPaymentButton LPaymentLink, "Pay by credit or debit card", "images/make-payment-epdq.png"
End If
' (SS,20/3/13) added Sage Pay
ElseIf APaymentType = ptSagePay Then
' (SS,22/3/13) enable SagePay for Sage themselves to test, if in test mode and if website was called using pptest=true
If Not IsSagePayTestMode Or IsPaymentProviderTestModeActivated Then
If GetSagePayVendorName = "" Then
' (SS,19/1/15) added "Pay by SagePay" caption
ShowCheckoutPaymentButton "javascript:alert('SagePay facility not yet enabled')", "Pay by SagePay", "images/make-payment-sage-pay.gif"
Else
' ShowCheckoutPaymentButton LPaymentLink, "images/make-payment-sage-pay.gif"
'ShowCheckoutMakePaymentButton LPaymentLink
' (SS,10/5/20) replaces above
ShowCheckoutPaymentButton LPaymentLink, "Pay by credit or debit card", "images/Payments-by-Sage-Pay-Horizontal-1.jpg"
End If
End If
' (SS,20/11/14)
ElseIf APaymentType = ptPayPalExpress Then
' (SS,6/2/15)
'ShowCheckoutMakePayPalPaymentText
' (SS,19/1/15) added "" for no image, new third parameter
'ShowCheckoutPaymentButton LPaymentLink, "Make PayPal Payment", ""
' (SS,19/4/18) following replaces ShowCheckoutMakePayPalPaymentText and ShowCheckoutPaymentButton above
ShowCheckoutMakePayPalPaymentButton LPaymentLink
' (SS,28/3/18) added Payzone
ElseIf APaymentType = ptPayzone Then
' (SS,5/4/18) added If GetPaymentAllowedIP for testing on our local IP address only
If GetPaymentAllowedIP Then
If GetPayzoneMerchantID = "" Then
ShowCheckoutMakePaymentButton "javascript:alert('Payzone facility not yet enabled')"
Else
'ShowCheckoutPaymentButton LPaymentLink, "Pay by credit or debit card", "images/make-payment-payzone.png"
' (SS,20/4/18) replaced above with following
' (SS,21/1/21) removed <br><small>Preferred :-)</small> due to NetPay being added and showing both this and NetPay
' (SS,17/2/21) added <small>Preferred :-)</small> back in, now moved to before bank transfer
' (SS,16/6/22) replaced make-payment-payzone.png with make-payment-takepayments.svg
' (SS,20/6/22) changed to make-payment-takepayments.png (less wide wallet only), max height in inc-template-checkout.asp for all changed from 70 to 26
' (SS,20/6/22) renamed MasterCard to Mastercard, slightly less wide
' (SS,23/6/22) replaced <br><small>Preferred :-)</small> with LPaymentPreferred
ShowCheckoutPaymentButton LPaymentLink, "Pay by Visa or Mastercard" + LPaymentPreferred, "images/make-payment-takepayments.png"
End If
End If
' (SS,17/9/20) added NetPay, also modified function itp_payment in javascript.js
ElseIf APaymentType = ptNetPay Then
' (SS,5/4/18) added If GetPaymentAllowedIP for testing on our local IP address only
If GetPaymentAllowedIP Then
If GetNetPayMerchantID = "" Then
ShowCheckoutMakePaymentButton "javascript:alert('NetPay facility not yet enabled')"
Else
' (SS,20/6/22) renamed MasterCard to Mastercard, slightly less wide
' (SS,23/6/22) replaced <br><small>Preferred :-)</small> with LPaymentPreferred
ShowCheckoutPaymentButton LPaymentLink, "Pay by Visa or Mastercard" + LPaymentPreferred, "images/make-payment-netpay.png"
End If
End If
' (SS,16/6/22)
ElseIf APaymentType = ptClover Then
If GetPaymentAllowedIP Then
If GetCloverStoreID = "" Then
ShowCheckoutMakePaymentButton "javascript:alert('Clover facility not yet enabled')"
Else
' (SS,20/6/22) renamed MasterCard to Mastercard, slightly less wide
' (SS,23/6/22) added "If GetCloverShowAll"
If GetCloverShowAll Then
' (SS,23/6/22) replaced <br><small>Preferred :-)</small> with LPaymentPreferred
ShowCheckoutPaymentButton LPaymentLink, "Pay by Visa or Mastercard" + LPaymentPreferred, "images/make-payment-clover.svg"
End If
' (SS,23/6/22) additional buttons for other payment methods if enabled
If GetCloverShowVisaMastercard Then
ShowCheckoutPaymentButton GetPaymentMethodSubmitJavascriptLink(APaymentType, cpmVisa), "Pay by Visa", "images/make-payment-visa.svg"
ShowCheckoutPaymentButton GetPaymentMethodSubmitJavascriptLink(APaymentType, cpmMastercard), "Pay by Mastercard", "images/make-payment-mastercard.svg"
End If
If GetCloverShowAppleGooglePay Then
If BrowserApplePayCompatible Then ShowCheckoutPaymentButton GetPaymentMethodSubmitJavascriptLink(APaymentType, cpmApplePay), "Pay by Apple Pay", "images/make-payment-apple-pay.svg"
ShowCheckoutPaymentButton GetPaymentMethodSubmitJavascriptLink(APaymentType, cpmGooglePay), "Pay by Google Pay", "images/make-payment-google-pay.svg"
End If
' (SS,21/6/22) include the page reload script which will refresh the page on back button and update with the latest transaction time and prevent error when going back to same provider
ScriptPageReloadOnBackButton
End If
End If
End If
' (SS,16/4/18) redirection payment stage/form (with 2 sec delay) now removed, the hidden payment form is shown here
' hidden and just below the button, by call to SetUpPayForm
SetUpPayForm APaymentType, GetOrderNo
End Sub
' (SS,24/6/22) simple check, if useragent has iPhone, iPad or Macintosh in it then assume it has Apple Pay (good enough for now)
Function BrowserApplePayCompatible
Dim LUserAgent
LUserAgent = Request.ServerVariables("HTTP_USER_AGENT")
BrowserApplePayCompatible = InStr(1, LUserAgent, "iPhone", vbTextCompare) > 0 Or InStr(1, LUserAgent, "iPad", vbTextCompare) > 0 Or InStr(1, LUserAgent, "Macintosh", vbTextCompare) > 0
End Function
' (SS,28/9/07) new routine with code from SetUpPayment, now handles two payment types
' (SS,20/11/08) button code moved to SetUpPaymentButtons
' (SS,28/3/18) added Payzone
' (SS,17/4/18) removed ptDirect, SetUpDirectPayForm and ptGoogleCheckout
' (SS,18/4/18) also removed ptPayPalExpress which is not necessary here
' (SS,19/4/18) added ptPayPalExpress back in, was required for final stage when using PayPal checkout button from basket page
Sub SetUpPayForm(APaymentType, AOrderNo)
' (SS,5/10/16) added SetUpLocalModePayForm for local mode
If IsLocalMode Then
SetUpLocalModePayForm(AOrderNo)
ElseIf APaymentType = ptWorldPay Then
SetUpWorldPayForm(AOrderNo)
ElseIf APaymentType = ptPayPal Then
' (SS,15/12/14) added If UsePayPalExpress (later GetPayPalExpressEnabled) to use PayPal Express instead
If GetPayPalExpressEnabled Then
'DoPayPalExpress True
' (SS,16/4/18) replaced above with following (i.e. added back in) because we're no longer redirectly for any payment form
' we're now setting up for every payment method in one page, so we can't call DoPayPalExpress
' when this routine is called, because it'll go to PayPal immediately
' (SS,19/4/18) renamed from SetUpPayPalExpressForm to SetUpPayPalExpressFormFromLaterStage
SetUpPayPalExpressFormFromLaterStage(AOrderNo)
Else
SetUpPayPalForm(AOrderNo)
End If
' (SS,10/12/14) added following for PayPalExpress
ElseIf APaymentType = ptPayPalExpress Then
SetUpPayPalExpressForm(AOrderNo) ' (SS,19/4/18) renamed from SetUpPayPalExpressPayForm to SetUpPayPalExpressForm
ElseIf APaymentType = ptEPDQ Then ' (SS,7/9/06)
SetUpEPDQForm(AOrderNo)
ElseIf APaymentType = ptSagePay Then ' (SS,20/3/13)
SetUpSagePayForm(AOrderNo)
' (SS,16/4/18) replaced SetUpChequeOrBankTransferPayForm with following separate cheque and bank transfer
ElseIf APaymentType = ptCheque Then
SetUpChequePayForm(AOrderNo)
ElseIf APaymentType = ptBankTransfer Then
SetUpBankTransferPayForm(AOrderNo)
' (SS,28/3/18) added Payzone
ElseIf APaymentType = ptPayzone Then
SetUpPayzoneForm(AOrderNo)
' (SS,17/9/20) added NetPay
ElseIf APaymentType = ptNetPay Then
SetUpNetPayForm(AOrderNo)
' (SS,8/6/22)
ElseIf APaymentType = ptClover Then
' (SS,23/6/22) modified to allow multiple buttons for different payment methods if enabled
If GetCloverShowAll Then SetUpCloverPayForm AOrderNo, cpmAll
If GetCloverShowVisaMastercard Then
SetUpCloverPayForm AOrderNo, cpmVisa
SetUpCloverPayForm AOrderNo, cpmMastercard
End If
If GetCloverShowAppleGooglePay Then
SetUpCloverPayForm AOrderNo, cpmApplePay
SetUpCloverPayForm AOrderNo, cpmGooglePay
End If
' SetUpCloverPayForm(AOrderNo)
End If
End Sub
' (SS,28/5/09)
' (SS,16/4/18) replaced SetUpChequeOrBankTransferPayForm with new separate SetUpChequePayForm and SetUpBankTransferPayForm
Sub SetUpChequePayForm(AOrderNo)
' (SS,21/2/14) replaced GetCheckoutLink with GetReturnFromPaymentURL, which is the same with stage=co at the end
' for unique URL for AdWord purposes (Clifton)
' (SS,21/7/17) added banktransferoption
%>
<form name="frmChequePay" action="<%=GetReturnFromPaymentURL%>" method="post" class="nospace">
<input type="hidden" name="stage" value="<%=CONFIRM_PAYMENT%>">
<input type="hidden" name="paymenttype" value="<%=ptCheque%>">
</form>
<%
End Sub
' (SS,16/4/18) replaced SetUpChequeOrBankTransferPayForm with new separate SetUpChequePayForm and SetUpBankTransferPayForm
Sub SetUpBankTransferPayForm(AOrderNo)
' (SS,21/2/14) replaced GetCheckoutLink with GetReturnFromPaymentURL, which is the same with stage=co at the end
' for unique URL for AdWord purposes (Clifton)
' (SS,21/7/17) added banktransferoption
%>
<form name="frmBankTransferPay" action="<%=GetReturnFromPaymentURL%>" method="post" class="nospace">
<input type="hidden" name="stage" value="<%=CONFIRM_PAYMENT%>">
<input type="hidden" name="paymenttype" value="<%=ptBankTransfer%>">
<input type="hidden" name="banktransferoption" value="<%=CleanRequestForm("banktransferoption")%>">
</form>
<%
End Sub
' (SS,5/10/16) used by local mode
Sub SetUpLocalModePayForm(AOrderNo)
%>
<form name="frmLocalModePay" action="<%=GetReturnFromPaymentURL%>" method="post" class="nospace">
<input type="hidden" name="stage" value="<%=CONFIRM_PAYMENT%>">
<input type="hidden" name="paymenttype" value="<%=GetChosenPaymentType%>">
<input type="hidden" name="paymentref" value="<%=GetLocalModePaymentReference%>">
</form>
<%
End Sub
' --------------------------
' Start of WorldPay routines
' --------------------------
' (SS,6/7/07) added HTMLEncode to some of the values to allow quotes etc
' (SS,30/4/10) added language
Sub SetUpWorldPayForm(AOrderNo)
Dim wpInstID, wpCartID, wpDesc, wpAmount, wpCurrency
Dim wpTestMode, wpName, wpAddress, wpPostcode, wpCountry, wpEmail, wpTel, wpLang
wpLang = GetWorldPayLanguageCode ' (SS,30/4/10)
wpInstID = GetWorldPayInstallID
wpCartID = AOrderNo
wpDesc = GetDescriptionForWorldPay
' (SS,14/11/12) added FormatNumber(x, 2) to ensure two decimal digits
' (SS,20/6/13) replaced FormatNumber(x, 2) with Format2dpnc(x) to remove commas, which was causing transactions above �1000 to fail
wpAmount = Format2dpnc(Session("PaymentAmount"))
wpCurrency = GetCurrencyCode ' (SS,19/9/06) was "GBP"
wpTestMode = GetWorldPayTestMode ' for normal mode this should be "0", test mode it should be "100"
wpName = GetNameForWorldPay
wpAddress = GetAddressForWorldPay
wpPostcode = GetPostcodeForWorldPay
wpCountry = GetCountryISOCode(GetCountryForWorldPay)
wpEmail = Session("Email")
wpTel = Session("Telephone")
' (SS,14/11/12) added MD5 for extra security to prevent sabotage of form values
Dim wpMD5SecretKey, wpSignature
wpMD5SecretKey = GetWorldPayMD5SecretKey ' (SS,14/11/12)
If wpMD5SecretKey = "" Then
wpSignature = ""
Else
' the following fields are used md5:amount:currency:cartId:testMode:instId
' the value set in WorldPay Signature fields is: amount:currency:cartId:testMode:instId (excluding the md5)
wpSignature = GetSQLValueAsString("SELECT CAST(MD5('" & wpMD5SecretKey & ":" & wpAmount & ":" & wpCurrency & ":" & wpCartID & ":" & wpTestMode & ":" & wpInstID & "') AS CHAR(32))")
End If
' (SS,27/01/10) replaced old URL which wasn't redirecting https://select.worldpay.com/wcc/purchase
' with new one https://secure.wp3.rbsworldpay.com/wcc/purchase
' (SS,11/08/11) replaced rbsworldpay URL with following:
' https://secure.worldpay.com/wcc/purchase
' as mentioned here:
' http://www.worldpay.com/media/index.php?page=archive&sub=worldpay-url-changes&c=WW
%>
<form name="frmWorldPay" action="https://secure.worldpay.com/wcc/purchase" method="post" class="nospace">
<input type="hidden" name="lang" value="<%=wpLang%>">
<%
' (SS,21/5/10) added following to hide currency selection
If GetPaymentHideCurrency Then
%>
<input type="hidden" name="hideCurrency" value="true">
<%
End If
%>
<input type="hidden" name="instId" value="<%=wpInstID%>">
<input type="hidden" name="cartId" value="<%=wpCartID%>">
<input type="hidden" name="desc" value="<%=HTMLEncode(wpDesc)%>">
<input type="hidden" name="amount" value="<%=wpAmount%>">
<input type="hidden" name="currency" value="<%=wpCurrency%>">
<input type="hidden" name="testMode" value="<%=wpTestMode%>">
<input type="hidden" name="name" value="<%=HTMLEncode(wpName)%>">
<input type="hidden" name="address" value="<%=HTMLEncode(wpAddress)%>">
<input type="hidden" name="postcode" value="<%=HTMLEncode(wpPostcode)%>">
<input type="hidden" name="country" value="<%=wpCountry%>">
<input type="hidden" name="email" value="<%=HTMLEncode(wpEmail)%>">
<input type="hidden" name="tel" value="<%=HTMLEncode(wpTel)%>">
<input type="hidden" name="M_OrderNo" value="<%=AOrderNo%>">
<input type="hidden" name="M_SessionID" value="<%=HTMLEncode(FSessionID)%>">
<input type="hidden" name="M_Name" value="<%=HTMLEncode(wpName)%>">
<input type="hidden" name="M_Email" value="<%=HTMLEncode(wpEmail)%>">
<input type="hidden" name="M_Desc" value="<%=HTMLEncode(wpDesc)%>">
<input type="hidden" name="fixContact" value="">
<%If wpSignature <> "" Then%><input type="hidden" name="signature" value="<%=wpSignature%>"><%End If%>
</form>
<%
' (SS,20/11/08) moved button from here to SetUpPaymentButton
End Sub
Function GetNameForWorldPay()
' (SS,13/8/05) removed If DeliveryAddressEntered, don't know why it was here, DeliveryName is relevant for WorldPay
'If DeliveryAddressEntered Then
' GetNameForWorldPay = Session("DeliveryName")
'Else
GetNameForWorldPay = GetFullName(Session("Title"), Session("FirstName"), Session("Surname"))
'End If
End Function
Function GetAddressForWorldPay()
Dim NL
NL = " " ' HTML line feed '
Dim LAddress
LAddress = LAddress + iif(Session("Address1") = "", "", Session("Address1") & NL)
LAddress = LAddress + iif(Session("Address2") = "", "", Session("Address2") & NL)
LAddress = LAddress + iif(Session("Town") = "", "", Session("Town") & NL)
LAddress = LAddress + iif(Session("County") = "", "", Session("County"))
GetAddressForWorldPay = Left(LAddress, 255) ' make sure its maximum of 255 characters '
End Function
Function GetPostcodeForWorldPay()
GetPostcodeForWorldPay = Session("Postcode")
End Function
Function GetCountryForWorldPay()
GetCountryForWorldPay = Session("Country")
End Function
Function GetDescriptionForWorldPay()
GetDescriptionForWorldPay = Left(Session("PaymentDescription"), 255) ' max of 255 chars '
End Function
' --------------------------
' End of WorldPay routines
' --------------------------
' --------------------------
' Start of PayPal routines
' --------------------------
' (SS,10/12/14)
' (SS,17/4/18) removed separate Sub SetUpPayPalExpressPayFormFromLaterStage, which was identical to this and not called anywhere
' (SS,17/4/18) replaced CONFIRM_PAYMENT with CS_PAYPAL_EXPRESS_CHECKOUT, and GetChosenPaymentType with ptPayPalExpress
' (SS,17/4/18) renamed from SetUpPayPalExpressPayForm to SetUpPayPalExpressForm, form name changed from "frmPayPalExpressPay" to "frmPayPal" so that it gets submitted by same PayPal button as normal PayPal
' (SS,18/4/18) replaced GetReturnFromPaymentURL with LURL i.e. products.asp?cmd=checkout&stage=" & CS_PAYPAL_EXPRESS_CHECKOUT
' Removed hidden stage and paymenttype form fields because it's in the querystring
' (SS,19/4/18) renamed this SetUpPayPalExpressForm to SetUpPayPalExpressFormFromLaterStage because had to have separate one for normal PayPal express checkout
Sub SetUpPayPalExpressFormFromLaterStage(AOrderNo)
Dim LURL
' xcmd=paypallaterstage indicates that we're using a later stage
LURL = "/products.asp?cmd=checkout&stage=" & CS_PAYPAL_EXPRESS_CHECKOUT & "&xcmd=paypallaterstage"
%>
<form name="frmPayPal" action="<%=LURL%>" method="post" class="nospace">
<input type="hidden" name="paymenttype" value="<%=ptPayPalExpress%>">
</form>
<%
End Sub
' (SS,10/12/14)
' (SS,19/4/18) This is for normal PayPal Express checkout from basket page (i.e. not from later stage)
' Form renamed from frmPayPalExpressPay to frmPayPalExpress, replaced GetChosenPaymentType with ptPayPalExpress
Sub SetUpPayPalExpressForm(AOrderNo)
%>
<form name="frmPayPalExpress" action="<%=GetReturnFromPaymentURL%>" method="post" class="nospace">
<input type="hidden" name="stage" value="<%=CONFIRM_PAYMENT%>">
<input type="hidden" name="paymenttype" value="<%=ptPayPalExpress%>">
</form>
<%
End Sub
' (SS,6/7/07) added HTMLEncode to some of the values to allow quotes etc
' (SS,16/6/09) make sure paypalcallbacks table exists in database
' (SS,10/9/14) added LCallbackURL i.e. notify_url, to allow more than one site to be used by the same PayPal account
Sub SetUpPayPalForm(AOrderNo)
Dim LBusiness, LReturnURL, LCallbackURL, LCancelURL, LDescription, LAmount, LCurrency, LShippingAddressFlag
Dim LEmail, LFirstName, LLastName, LAddress1, LAddress2, LCity, LCounty, LPostcode, LCountry
LBusiness = GetPayPalBusiness
LReturnURL = GetStoreURL + "/products.asp?cmd=checkout&stage=" & RETURN_FROM_THIRD_PARTY_PAYMENT
LCallbackURL = GetStoreURL + "/paypal-callback.asp" ' (SS,10/9/14)
LCancelURL = GetStoreURL + "/products.asp"
LDescription = GetDescriptionForPayPal
LAmount = Session("PaymentAmountGBP") ' (SS,17/2/12) replaced PaymentAmount with PaymentAmountGBP because we're paying using GBP even if another currency has been chosen
LCurrency = "GBP"
LShippingAddressFlag = GetPayPalShippingAddressFlag ' (SS,22/6/07) also changed "1" to =LShippingAddressFlag
LEmail = Left(Session("Email"), 127)
LFirstName = Left(Session("FirstName"), 32)
LLastName = Left(Session("Surname"), 64)
LAddress1 = Left(Session("Address1"), 100)
LAddress2 = Left(Session("Address2"), 100)
LCity = Left(Session("Town"), 40)
LCounty = Left(Session("County"), 32)
LPostcode = Left(Session("Postcode"), 32)
LCountry = GetCountryISOCode(Session("Country"))
' (SS,22/6/07) added following to pass delivery address instead to PayPal to allow printing of PayPal delivery slips
' this will end up being used as default for billing address, but user can override it. Neil preferred to have delivery address
' for printing of delivery labels with postage. This is only done when Shipping flag isn't "1"
' We can't use delivery name because PayPal uses separate FirstName and Surname, but it's most likely to be the same.
' (SS,2/7/13) removed the following because it was causing problems with PayPal for some customers with delivery address different to billing address
' PayPal delivery labels are not printed by Neil, haven't been for a very long time.
'If LShippingAddressFlag <> "1" And Not Session("DeliveryAddressSameAsInvoice") Then
' LAddress1 = Left(Session("DeliveryAddress1"), 100)
' LAddress2 = Left(Session("DeliveryAddress2"), 100)
' LCity = Left(Session("DeliveryTown"), 40)
' LCounty = Left(Session("DeliveryCounty"), 32)
' LPostcode = Left(Session("DeliveryPostcode"), 32)
' LCountry = GetCountryISOCode(Session("DeliveryCountry"))
'End If
Dim LActionURLPrefix
If GetPayPalTestMode Then
LActionURLPrefix = "https://www.sandbox.paypal.com"
Else
LActionURLPrefix = "https://www.paypal.com"
End If
%>
<form name="frmPayPal" action="<%=LActionURLPrefix%>/cgi-bin/webscr" method="post" class="nospace">
<input type="hidden" name="cmd" value="_xclick">
<input type="hidden" name="business" value="<%=LBusiness%>">
<input type="hidden" name="return" value="<%=LReturnURL%>">
<input type="hidden" name="notify_url" value="<%=LCallbackURL%>">
<input type="hidden" name="item_name" value="<%=HTMLEncode(LDescription)%>">
<input type="hidden" name="amount" value="<%=LAmount%>">
<input type="hidden" name="invoice" value="<%=AOrderNo%>">
<input type="hidden" name="custom" value="<%=HTMLEncode(FSessionID)%>">
<input type="hidden" name="currency_code" value="<%=LCurrency%>">
<input type="hidden" name="no_shipping" value="<%=LShippingAddressFlag%>">
<input type="hidden" name="cancel_return" value="<%=LCancelURL%>">
<input type="hidden" name="no_note" value="1">
<input type="hidden" name="rm" value="2">
<input type="hidden" name="email" value="<%=HTMLEncode(LEmail)%>">
<input type="hidden" name="first_name" value="<%=HTMLEncode(LFirstName)%>">
<input type="hidden" name="last_name" value="<%=HTMLEncode(LLastName)%>">
<input type="hidden" name="address1" value="<%=HTMLEncode(LAddress1)%>">
<input type="hidden" name="address2" value="<%=HTMLEncode(LAddress2)%>">
<input type="hidden" name="city" value="<%=HTMLEncode(LCity)%>">
<input type="hidden" name="state" value="<%=HTMLEncode(LCounty)%>">
<input type="hidden" name="zip" value="<%=HTMLEncode(LPostcode)%>">
<input type="hidden" name="country" value="<%=LCountry%>">
</form>
<%
' (SS,28/9/07) removed following, added PayPal image to form above
' (SS,10/11/08) went back to this method, image removed from above
' <input alt="" src="images/make-payment-paypal.gif" type="image"/>
' (SS,20/11/08) moved button from here to SetUpPaymentButton
End Sub
' (SS,24/11/14)
Function InPayPalExpress
InPayPalExpress = Session("PreviousCheckoutStage") = CS_PAYPAL_EXPRESS_RETURN
End Function
' (SS,18/11/14) following relies on <!-- #include file ="paypalfunctions.asp" -->
' (SS,15/12/14) added ALaterStage which is True if called from a later stage after user logged in or entered address details
' (SS,12/2/15) added Description to send to PayPal
Sub DoPayPalExpress(ALaterStage)
' (SS,18/11/14) added following to get it to work
' (SS,12/2/15) added LDescription
Dim LPaymentAmount, LDescription, LCurrencyCodeType, LPaymentType, LReturnURL, LCancelURL, LResArray, LAck
' ==================================
' PayPal Express Checkout Module
' ==================================
' (SS,18/11/14) removed following
' On Error Resume Next
'------------------------------------
' The paymentAmount is the total value of
' the shopping cart, that was set
' earlier in a session variable
' by the shopping cart page
'------------------------------------
' (SS,17/2/15) added "if" and move some code here
If ALaterStage Then
LPaymentAmount = Session("PaymentAmountGBP")
LDescription = GetDescriptionForPayPal ' (SS,12/2/15)
AddToPaymentLog "PayPal", "DoPayPalExpress called with ALaterStage = True" ' (SS,18/4/18)
Else
LPaymentAmount = GetBasketGrandTotal ' (SS,19/1/15) added GetBasketGrandTotal, replacing Session("Payment_Amount") or 1000 default
LDescription = GetBasketDescription ' (SS,17/2/15)
AddToPaymentLog "PayPal", "DoPayPalExpress called with ALaterStage = False" ' (SS,18/4/18)
End If
' (SS,8/6/18) apply PayPal surcharge if applicable
LPaymentAmount = PayPalAmountWithSurcharge(LPaymentAmount)
'------------------------------------
' The currencyCodeType and paymentType
' are set to the selections made on the Integration Assistant
'------------------------------------
LCurrencyCodeType = "GBP"
LPaymentType = "Sale"
'------------------------------------
' The returnURL is the location where buyers return to when a
' payment has been succesfully authorized.
'
' This is set to the value entered on the Integration Assistant
'------------------------------------
' returnURL = GetStoreURL & "/products.asp?cmd=checkout&xcmd=paypal_express_return"
'------------------------------------
' The cancelURL is the location buyers are sent to when they click the
' return to XXXX site where XXX is the merhcant store name
' during payment review on PayPal
'
' This is set to the value entered on the Integration Assistant
'------------------------------------
'cancelURL = GetStoreURL & "/products.asp?cmd=checkout&stage=" & CS_PAYPAL_EXPRESS_CANCEL
' (SS,11/12/14) replaced above with following because check out with PayPal is on the basket page
' (SS,16/12/14) added If ALaterStage and different URL to return to correct payment method selection / confirm order stage, i.e. not the basket
LReturnURL = GetStoreURL & "/products.asp?cmd=checkout&stage=" & CS_PAYPAL_EXPRESS_RETURN
If ALaterStage Then
' (SS,16/12/14) added following to return to a different URL if from a later stage, so that payment can be processed immediately
LReturnURL = LReturnURL & "&xcmd=paypallaterstage"
LCancelURL = GetStoreURL & "/" & GetCheckoutConfirmOrderURL
Else
LCancelURL = GetStoreURL & "/products.asp?cmd=basket&stage=" & CS_PAYPAL_EXPRESS_CANCEL
End If
'
'------------------------------------
' Calls the SetExpressCheckout API call
'
' The CallShortcutExpressCheckout function is defined in the file PayPalFunctions.asp,
' it is included at the top of this file.
'-------------------------------------------------
' (SS,15/12/14) added If Not
If Not ALaterStage Then
' (SS,12/2/15) added LDescription
Set LResArray = PP_CallShortcutExpressCheckout(LPaymentAmount, LDescription, LCurrencyCodeType, LPaymentType, LReturnURL, LCancelURL)
Else ' (SS,15/12/14)
Dim LShipToName, LShipToStreet, LShipToStreet2, LShipToCity, LShipToState, LShipToCountryCode, LShipToZip, LPhoneNum, LEmail
LShipToName = Left(Session("FirstName"), 32) + " " + Left(Session("Surname"), 64)
LShipToStreet = Left(Session("Address1"), 100)
LShipToStreet2 = Left(Session("Address2"), 100)
LShipToCity = Left(Session("Town"), 40)
LShipToState = Left(Session("County"), 32)
LShipToCountryCode = GetCountryISOCode(Session("Country"))
LShipToZip = Left(Session("Postcode"), 32)
LPhoneNum = Session("Telephone")
LEmail = Left(Session("Email"), 127)
'LShippingAddressFlag = GetPayPalShippingAddressFlag ' (SS,22/6/07) also changed "1" to =LShippingAddressFlag
'LFirstName = Left(Session("FirstName"), 32)
'LLastName = Left(Session("Surname"), 64)
'LAddress1 = Left(Session("Address1"), 100)
'LAddress2 = Left(Session("Address2"), 100)
'LCity = Left(Session("Town"), 40)
'LCounty = Left(Session("County"), 32)
'LPostcode = Left(Session("Postcode"), 32)
'LCountry = GetCountryISOCode(Session("Country"))
' (SS,12/2/15) added LDescription
' (SS,17/2/15) tidied variable names and moved LShipToStreet2 from before LPhoneNum to after LShipToStreet
Set LResArray = PP_CallMarkExpressCheckout(LPaymentAmount, LDescription, LCurrencyCodeType, LPaymentType, LReturnURL, LCancelURL, LShipToName, LShipToStreet, LShipToStreet2, LShipToCity, LShipToState, LShipToCountryCode, LShipToZip, LPhoneNum, LEmail)
End If
LAck = UCase(LResArray("ACK"))
If LAck = "SUCCESS" Then
' Redirect to paypal.com
PP_ReDirectURL LResArray("TOKEN"), ALaterStage ' (SS,16/12/14) added ALaterStage
Else
'Display a user friendly Error on the page using any of the following error information returned by PayPal
' (SS,3/2/15) replaced with ShowPayPalExpressError
ShowPayPalExpressError LResArray
End If
End Sub
' (SS,19/11/14), returns False if invalid, True if okay
Function GetDetailsFromPayPalExpress
Dim LToken
LToken = CleanRequest("token")
Session("PayPalExpressToken") = LToken ' (SS,24/11/14) save for next stage
If LToken = "" Then
GetDetailsFromPayPalExpress = False
Exit Function
End If
Dim LResultsDict
Set LResultsDict = PP_GetShippingDetails(LToken)
If UCase(LResultsDict("ACK")) <> "SUCCESS" Then
ShowPayPalExpressError LResultsDict
GetDetailsFromPayPalExpress = False
Exit Function
End If
' (SS,19/11/14) log all values to log file
Dim i, LKeys, LItems, LList
LKeys = LResultsDict.Keys
LItems = LResultsDict.Items
LList = NL
For i = 0 To LResultsDict.Count - 1
' Response.Write LKeys(i) & " = " & LItems(i) & "<BR>"
LList = LList & LKeys(i) & " = " & LItems(i) & NL
Next
' (SS,1/8/22) commented out following, it's been logging to files in d:\logs\asps\ since 26/1/2015, not necessary
' DebugLog -1, LList
' (SS,17/2/15)
' (SS,23/8/17) added "PayPal" and removed False
AddToPaymentLog "PayPal", "---GetDetailsFromPayPalExpress---" & NL & LList
GetDetailsFromPayPalExpress = True
Dim LCountry, LDeliveryCountry
Session("Title") = Left(LResultsDict("SALUTATION"), 15)
' middle name not used
' Session("FirstName") = Left(Proper(Trim(LResultsDict("FIRSTNAME") & " " & LResultsDict("MIDDLENAME"))), 100)
Session("FirstName") = Left(Proper(Trim(LResultsDict("FIRSTNAME"))), 100)
Session("Surname") = Left(Proper(Trim(LResultsDict("LASTNAME"))), 100)
Session("CompanyName") = Left(Proper(Trim(LResultsDict("BUSINESS"))), 100)
Session("Address1") = Left(Proper(Trim(LResultsDict("STREET"))), 100)
Session("Address2") = Left(Proper(Trim(LResultsDict("STREET2"))), 100)
Session("Town") = Left(Proper(Trim(LResultsDict("CITY"))), 100)
Session("County") = Left(Proper(Trim(LResultsDict("STATE"))), 100)
LCountry = GetCountryNameForCode(LResultsDict("COUNTRYCODE"))
Session("Postcode") = Left(CorrectPostcode(LResultsDict("ZIP"), LCountry), 20)
Session("Country") = LCountry
Session("Telephone") = Left(Trim(LResultsDict("PHONENUM")), 100)
' (SS,16/2/15) replace "+44 " with 0 (for UK, requested by Deborah)
If Left(Session("Telephone"), 4) = "+44 " Then Session("Telephone") = "0" + Mid(Session("Telephone"), 5)
'Session("Mobile") = Trim(CleanRequestForm("Mobile"))
Session("Email") = Left(Trim(LResultsDict("EMAIL")), 100)
'Session("Password") = Trim(CleanRequestForm("Password"))
'Session("Password2") = Trim(CleanRequestForm("Password2"))
' (SS,18/4/12) added "CollectionOnlyOrder Or" to following because disabled DeliveryWillCollect checkbox doesn't return "checked" when checkbox is disabled
Session("DeliveryWillCollect") = CollectionOnlyOrder Or (CleanRequestForm("DeliveryWillCollect") = "checked") ' (SS,14/11/07)
'Session("DeliveryAddressSameAsInvoice") = (CleanRequestForm("DeliveryAddressSameAsInvoice") = "checked")
' (SS,1/6/07)
'* Session("Subscribe") = (CleanRequestForm("Subscribe") = "checked")
'* Session("HearAboutUs") = CleanRequestForm("HearAboutUs")
' Session("DeliveryDate") = CleanRequestForm("DeliveryDate") ' (SS,17/4/09)
' Session("VoucherCode") = UCase(Trim(CleanRequestForm("VoucherCode"))) ' (SS,22/04/09)
' (SS,17/3/09) added following to ensure this value is set to true when DeliveryAddressSameAsInvoice checkbox isn't shown
' If Not AllowDifferentDeliveryAddress Then Session("DeliveryAddressSameAsInvoice") = True
' Session("PurchaseOrderNo") = CleanRequestForm("PurchaseOrderNo")
' (SS,21/8/12) added Left(.., GetMaxMessageLength) to limit length to x characters, currently 600, form also has this limit (using truncation prevents hackers/spammers from posting very long strings)
Session("Message") = Left(Proper(Trim(LResultsDict("PAYMENTREQUEST_0_NOTETEXT"))), GetMaxMessageLength)
Session("DeliveryName") = Left(Proper(Trim(LResultsDict("PAYMENTREQUEST_0_SHIPTONAME"))), 100)
Session("DeliveryCompanyName") = Left(Proper(Trim(LResultsDict("BUSINESS"))), 100)
Session("DeliveryAddress1") = Left(Proper(Trim(LResultsDict("PAYMENTREQUEST_0_SHIPTOSTREET"))), 100)
Session("DeliveryAddress2") = Left(Proper(Trim(LResultsDict("PAYMENTREQUEST_0_SHIPTOSTREET2"))), 100)
Session("DeliveryTown") = Left(Proper(Trim(LResultsDict("PAYMENTREQUEST_0_SHIPTOCITY"))), 100)
Session("DeliveryCounty") = Left(Proper(Trim(LResultsDict("PAYMENTREQUEST_0_SHIPTOSTATE"))), 100)
LDeliveryCountry = GetCountryNameForCode(LResultsDict("PAYMENTREQUEST_0_SHIPTOCOUNTRYCODE"))
Session("DeliveryPostcode") = Left(CorrectPostcode(LResultsDict("PAYMENTREQUEST_0_SHIPTOZIP"), LDeliveryCountry), 20)
Session("DeliveryCountry") = LDeliveryCountry
' (SS,22/1/15) compare addresses and set DeliveryAddressSameAsInvoice flag
If Session("FirstName") & " " & Session("Surname") = Session("DeliveryName") And Session("CompanyName") = Session("DeliveryCompanyName") And Session("Address1") = Session("DeliveryAddress1") And Session("Address2") = Session("DeliveryAddress2") And Session("Town") = Session("DeliveryTown") And Session("County") = Session("DeliveryCounty") And Session("Postcode") = Session("DeliveryPostcode") And Session("Country") = Session("DeliveryCountry") Then
Session("DeliveryAddressSameAsInvoice") = True
Else
Session("DeliveryAddressSameAsInvoice") = False
End If
' (SS,22/1/15) check countries, make sure they're in the list of allowed countries
If Not IsValidCountry(LDeliveryCountry) Then
GetDetailsFromPayPalExpress = False
SetAlertMessage "Sorry we don't ship to '" & LDeliveryCountry & "'"
ElseIf Not IsValidCountry(LCountry) Then
GetDetailsFromPayPalExpress = False
SetAlertMessage "Sorry we don't invoice to '" & LCountry & "'"
End If
'email = resArray("EMAIL") ' Email address of payer.
'* payerId = resArray("PAYERID") ' Unique PayPal customer account identification number.
'* payerStatus = resArray("PAYERSTATUS") ' Status of payer. Character length and limitations: 10 single-byte alphabetic characters.
'salutation = resArray("SALUTATION") ' Payer's salutation.
'firstName = resArray("FIRSTNAME") ' Payer's first name.
'middleName = resArray("MIDDLENAME") ' Payer's middle name.
'lastName = resArray("LASTNAME") ' Payer's last name.
'*suffix = resArray("SUFFIX") ' Payer's suffix.
'cntryCode = resArray("COUNTRYCODE") ' Payer's country of residence in the form of ISO standard 3166 two-character country codes.
'business = resArray("BUSINESS") ' Payer's business name.
'shipToName = resArray("PAYMENTREQUEST_0_SHIPTONAME") ' Person's name associated with this address.
'shipToStreet = resArray("PAYMENTREQUEST_0_SHIPTOSTREET") ' First street address.
'shipToStreet2 = resArray("PAYMENTREQUEST_0_SHIPTOSTREET2") ' Second street address.
'shipToCity = resArray("PAYMENTREQUEST_0_SHIPTOCITY") ' Name of city.
'shipToState = resArray("PAYMENTREQUEST_0_SHIPTOSTATE") ' State or province
'shipToCntryCode = resArray("PAYMENTREQUEST_0_SHIPTOCOUNTRYCODE") ' Country code.
'shipToZip = resArray("PAYMENTREQUEST_0_SHIPTOZIP") ' U.S. Zip code or other country-specific postal code.
'* addressStatus = resArray("ADDRESSSTATUS") ' Status of street address on file with PayPal
'* invoiceNumber = resArray("INVNUM") ' Your own invoice or tracking number, as set by you in the element of the same name in SetExpressCheckout request .
'phonNumber = resArray("PHONENUM") ' Payer's contact telephone number. Note: PayPal returns a contact telephone number only if your Merchant account profile settings require that the buyer enter one.
End Function
' (SS,24/11/14)
' (SS,10/12/14) returns True if successful
' (SS,20/1/15) added AOrderStatus, APaymentReference and APaymentInfo parameters
' (SS,8/6/18) added APaymentAmountReceived parameter, due to new surcharge feature
' (SS,25/6/18) added APaymentProviderSurcharge and APaymentProviderFee
' (SS,26/6/18) renamed APaymentAmountReceived to APaymentReceivedAmount, added APaymentReceivedCurrencyCode
Function PayPalExpressConfirmPayment(ByRef AOrderStatus, ByRef APaymentReference, ByRef APaymentInfo, ByRef APaymentReceivedAmount, ByRef APaymentReceivedCurrencyCode, ByRef APaymentProviderSurcharge, ByRef APaymentProviderFee)
' Response.Write "### PayPalExpressConfirmPayment 1 ###<br>"
Dim LToken, LFinalPaymentAmount
LToken = SESSION("PP_token") ' Session("PayPalExpressToken")
'------------------------------------
' The paymentAmount is the total value of
' the shopping cart, that was set
' earlier in a session variable
' by the shopping cart page
'------------------------------------
LFinalPaymentAmount = Session("PaymentAmountGBP") ' (SS,6/2/15) replaced PaymentAmount with PaymentAmountGBP
' (SS,8/6/18) apply PayPal surcharge if applicable
LFinalPaymentAmount = PayPalAmountWithSurcharge(LFinalPaymentAmount)
' (SS,25/6/18) calculate the extra charge added i.e. surcharge
APaymentProviderSurcharge = Round2dp(LFinalPaymentAmount - Session("PaymentAmountGBP"))
'------------------------------------
' Calls the GetExpressCheckoutDetails API call
'
' The GetShippingDetails function is defined in PayPalFunctions.asp
' included at the top of this file.
'-------------------------------------------------
'Response.Write "### Reached here: 10 (TOKEN:" & SESSION("PayPalExpressToken") & ")###<br>"
Dim LResultsDict, LErrorCode
'Response.Write "### Reached here: 11 (PP_PAYERID:" & SESSION("PP_PAYERID") & ")###<br>"
Set LResultsDict = PP_GetShippingDetails( LToken )
If UCase(LResultsDict("ACK")) <> "SUCCESS" Then
'Display a user friendly Error on the page using any of the following error information returned by PayPal
ShowPayPalExpressError LResultsDict
PayPalExpressConfirmPayment = False
Exit Function
End If
'Response.Write "### Reached here: 12 (PP_PAYERID:" & SESSION("PP_PAYERID") & ")###<br>"
Set LResultsDict = PP_ConfirmPayment( LFinalPaymentAmount )
'Response.Write "### Reached here: 13 (PP_PAYERID:" & SESSION("PP_PAYERID") & ")###<br>"
If UCase(LResultsDict("ACK")) <> "SUCCESS" Then
'Display a user friendly Error on the page using any of the following error information returned by PayPal
ShowPayPalExpressError LResultsDict
' (SS,17/2/15) if error code is 10486 then redirect back to PayPal as recommended by PayPal
LErrorCode = PP_URLDecode(LResultsDict("L_ERRORCODE0"))
If LErrorCode = "10486" Then
PP_ReDirectURL LToken, ReturnFromPayPalExpressLaterStage
End If
'Response.Write "###This point reached###" & BR
PayPalExpressConfirmPayment = False
Exit Function
End If
'Response.Write "### PayPalExpressConfirmPayment 2 ###<br>"
' '********************************************************************************************************************
' '
' ' THE PARTNER SHOULD SAVE THE KEY TRANSACTION RELATED INFORMATION LIKE
' ' transactionId & orderTime
' ' IN THEIR OWN DATABASE
' ' AND THE REST OF THE INFORMATION CAN BE USED TO UNDERSTAND THE STATUS OF THE PAYMENT
' '
' '********************************************************************************************************************
' token = resArray("TOKEN") ' The timestamped token value that was returned by SetExpressCheckout response and passed on GetExpressCheckoutDetails request.
' transactionId = resArray("PAYMENTINFO_0_TRANSACTIONID") ' Unique transaction ID of the payment. Note: If the PaymentAction of the request was Authorization or Order, this value is your AuthorizationID for use with the Authorization & Capture APIs.
' transactionType = resArray("PAYMENTINFO_0_TRANSACTIONTYPE") ' The type of transaction Possible values: l cart l express-checkout
' paymentType = resArray("PAYMENTINFO_0_PAYMENTTYPE") ' Indicates whether the payment is instant or delayed. Possible values: l none l echeck l instant
' orderTime = resArray("PAYMENTINFO_0_ORDERTIME") ' Time/date stamp of payment
' amt = resArray("PAYMENTINFO_0_AMT") ' The final amount charged, including any shipping and taxes from your Merchant Profile.
' currencyCode = resArray("PAYMENTINFO_0_CURRENCYCODE") ' A three-character currency code for one of the currencies listed in PayPay-Supported Transactional Currencies. Default: USD.
' 'feeAmt = resArray("PAYMENTINFO_0_FEEAMT") ' PayPal fee amount charged for the transaction
' 'settleAmt = resArray("PAYMENTINFO_0_SETTLEAMT") ' Amount deposited in your PayPal account after a currency conversion.
' taxAmt = resArray("PAYMENTINFO_0_TAXAMT") ' Tax charged on the transaction.
' 'exchangeRate = resArray("PAYMENTINFO_0_EXCHANGERATE") ' Exchange rate if a currency conversion occurred. Relevant only if your are billing in their non-primary currency. If the customer chooses to pay with a currency other than the non-primary currency, the conversion occurs in the customer�s account.
' ' Status of the payment:
' 'Completed: The payment has been completed, and the funds have been added successfully to your account balance.
' 'Pending: The payment is pending. See the PendingReason element for more information.
' paymentStatus = resArray("PAYMENTINFO_0_PAYMENTSTATUS")
' 'The reason the payment is pending:
' ' none: No pending reason
' ' address: The payment is pending because your customer did not include a confirmed shipping address and your Payment Receiving Preferences is set such that you want to manually accept or deny each of these payments. To change your preference, go to the Preferences section of your Profile.
' ' echeck: The payment is pending because it was made by an eCheck that has not yet cleared.
' ' intl: The payment is pending because you hold a non-U.S. account and do not have a withdrawal mechanism. You must manually accept or deny this payment from your Account Overview.
' ' multi-currency: You do not have a balance in the currency sent, and you do not have your Payment Receiving Preferences set to automatically convert and accept this payment. You must manually accept or deny this payment.
' ' verify: The payment is pending because you are not yet verified. You must verify your account before you can accept this payment.
' ' other: The payment is pending for a reason other than those listed above. For more information, contact PayPal customer service.
' pendingReason = resArray("PAYMENTINFO_0_PENDINGREASON")
' 'The reason for a reversal if TransactionType is reversal:
' ' none: No reason code
' ' chargeback: A reversal has occurred on this transaction due to a chargeback by your customer.
' ' guarantee: A reversal has occurred on this transaction due to your customer triggering a money-back guarantee.
' ' buyer-complaint: A reversal has occurred on this transaction due to a complaint about the transaction from your customer.
' ' refund: A reversal has occurred on this transaction because you have given the customer a refund.
' ' other: A reversal has occurred on this transaction due to a reason not listed above.
' reasonCode = resArray("PAYMENTINFO_0_REASONCODE")
Dim LOrderNo, LTransactionID, LTransactionType, LPaymentType, LOrderTime, LAmount, LCurrencyCode, LFeeAmount, LSettleAmount, LTaxAmount, LExchangeRate, LPaymentStatus, LPendingReason, LReasonCode
LOrderNo = Session("OrderNoPlaced")
LTransactionID = CleanSQLStr(LResultsDict("PAYMENTINFO_0_TRANSACTIONID"))
LTransactionType = CleanSQLStr(LResultsDict("PAYMENTINFO_0_TRANSACTIONTYPE"))
LPaymentType = CleanSQLStr(LResultsDict("PAYMENTINFO_0_PAYMENTTYPE"))
LOrderTime = CleanSQLStr(LResultsDict("PAYMENTINFO_0_ORDERTIME"))
LAmount = CleanSQLStr(LResultsDict("PAYMENTINFO_0_AMT"))
LCurrencyCode = CleanSQLStr(LResultsDict("PAYMENTINFO_0_CURRENCYCODE"))
LFeeAmount = CleanSQLStr(LResultsDict("PAYMENTINFO_0_FEEAMT"))
LSettleAmount = CleanSQLStr(LResultsDict("PAYMENTINFO_0_SETTLEAMT"))
LTaxAmount = CleanSQLStr(LResultsDict("PAYMENTINFO_0_TAXAMT"))
LExchangeRate = CleanSQLStr(LResultsDict("PAYMENTINFO_0_EXCHANGERATE"))
LPaymentStatus = CleanSQLStr(LResultsDict("PAYMENTINFO_0_PAYMENTSTATUS"))
LPendingReason = CleanSQLStr(LResultsDict("PAYMENTINFO_0_PENDINGREASON"))
LReasonCode = CleanSQLStr(LResultsDict("PAYMENTINFO_0_REASONCODE"))
' insert the record
Dim LSQL
LSQL = "INSERT INTO paypal_express_Log SET OrderNo=" & LOrderNo &_
", Token='" & CleanSQLStr(LToken) & "'" &_
", TransactionID='" & LTransactionID & "'" &_
", TransactionType='" & LTransactionType & "'" &_
", PaymentType='" & LPaymentType & "'" &_
", OrderTime='" & LOrderTime & "'" &_
", Amount='" & LAmount & "'" &_
", CurrencyCode='" & LCurrencyCode & "'" &_
", FeeAmount='" & LFeeAmount & "'" &_
", SettleAmount='" & LSettleAmount & "'" &_
", TaxAmount='" & LTaxAmount & "'" &_
", ExchangeRate='" & LExchangeRate & "'" &_
", PaymentStatus='" & LPaymentStatus & "'" &_
", PendingReason='" & LPendingReason & "'" &_
", ReasonCode='" & LReasonCode & "'"
ExecuteQuery(LSQL)
' (SS,20/1/14) set order status and payment reference
If UCase(LPaymentStatus) = "COMPLETED" Then
AOrderStatus = PAYMENT_RECEIVED_STATUS
Else ' i.e. Pending
AOrderStatus = AWAITING_PAYMENT_STATUS
End If
APaymentReference = LTransactionID
APaymentInfo = LTransactionType & " " & LPaymentType & " " & LPaymentStatus
APaymentReceivedAmount = LAmount ' (SS,8/6/18) amount is now passed back, could be higher than order amount due to possible surcharge
APaymentReceivedCurrencyCode = Left(Trim(LCurrencyCode), 3) ' (SS,26/6/18) currency code is also passed back
If IsChosenPaymentPayPalExpress Then APaymentInfo = APaymentInfo & NL & "Checkout with PayPal used" ' (SS,22/1/15) to indicate tha checkout was used from the basket page
PayPalExpressConfirmPayment = True
' Response.Write "### PayPalExpressConfirmPayment 3 ###<br>"
' (SS,25/6/18) returns the fee amount
APaymentProviderFee = ParseFloat(LFeeAmount)
End Function
' (SS,19/1/15) shows paypal error and adds to log
Sub ShowPayPalExpressError(AResultsDict)
Dim LErrorCode, LErrorShortMsg, LErrorLongMsg, LErrorSeverityCode
LErrorCode = PP_URLDecode(AResultsDict("L_ERRORCODE0"))
LErrorShortMsg = PP_URLDecode(AResultsDict("L_SHORTMESSAGE0"))
LErrorLongMsg = PP_URLDecode(AResultsDict("L_LONGMESSAGE0"))
LErrorSeverityCode = PP_URLDecode(AResultsDict("L_SEVERITYCODE0"))
' *** to be improved, perhaps log to file
Response.Write "<p style=""color: red; font-weight: bold"">"
Response.Write "ERROR!" & BR
Response.Write "Error Code: " & LErrorCode & BR
Response.Write "Error Short Msg: " & LErrorShortMsg & BR
Response.Write "Error Long Msg: " & LErrorLongMsg & BR
Response.Write "Error Severity Code: " & LErrorSeverityCode & BR
Response.Write "</p>"
' add to log and save
AppUtilsAddToPaymentLog "ERROR!", "Error Code: " & LErrorCode, "Error Short Msg: " & LErrorShortMsg & NL & "Error Long Msg: " & LErrorLongMsg & NL & "Error Severity Code: " & LErrorSeverityCode
' SavePaymentLog ' (SS,23/8/17) removed, no longer required
End Sub
' --------------------------
' End of PayPal routines
' --------------------------
' (SS,16/1/15) Session used because log is added before an order number is created
' called from paypalfunctions.asp Function PP_hash_call
' (SS,12/2/15) modified to call AddToPaymentLog
Sub AppUtilsAddToPaymentLog(AMethodName, ANvpStr, AResponseText)
'If Session("PaymentLog") <> "" Then Session("PaymentLog") = Session("PaymentLog") & NL ' extra newline for separation purposes
'Session("PaymentLog") = Session("PaymentLog") & AMethodName & NL & ANvpStr & NL & AResponseText & NL
' (SS,12/2/15) above replaced with following
' (SS,23/8/17) added "PayPal" removed last False parameter
AddToPaymentLog "PayPal", AMethodName & NL & ANvpStr & NL & AResponseText
End Sub
' (SS,12/2/15) called from AppUtilsAddToPaymentLog, added directly from AppUtils when adding to PaymentLog required e.g. Bank Transfer details
' (SS,31/7/17) added date/time (now)
' (SS,23/8/17) new version without AForceSave but with AType to separate types which can be VAT No Check, Bank Transfer details, PayPal etc.
' SavePaymentLog sub removed because AddToPaymentLog will save when it can i.e. Order record exists, otherwise add to session
' if AType is "" then nothing is added Session("PaymentLog") is saved to order if order exists ie. AddToPaymentLog "", ""
' (SS,26/1/21) modified to get order from callback if session was lost, also logs session ID change
Sub AddToPaymentLog(AType, AMessage)
Dim LNewMessage, LOrderNo, LCallbackOrderNo
LOrderNo = GetOrderNo ' (SS,26/1/21) moved here from below
LCallbackOrderNo = GetCallbackOrderNoForPaymentLog ' (SS,26/1/21)
If AType <> "" Then
LNewMessage = GetPaymentLogSeparator(AType, True) & NL
LNewMessage = LNewMessage & Now() & NL
' (SS,23/6/22) added IP address, Session ID, User agent, Referrer
LNewMessage = LNewMessage & "IPAddress = " & Request.ServerVariables("REMOTE_ADDR") & NL
LNewMessage = LNewMessage & "SessionID = " & Session.SessionID & NL
LNewMessage = LNewMessage & "UserAgent = " & Request.ServerVariables("HTTP_USER_AGENT") & NL
LNewMessage = LNewMessage & "Referer = " & Request.ServerVariables("HTTP_REFERER") & NL
LNewMessage = LNewMessage & TrimAll(AMessage) & NL ' (SS,23/6/22) added TrimAll to prevent empty lines at the end
' (SS,26/1/21) check if session was changed i.e. was lost due to payment callback (was happening for Payzone and payment log was sometimes not being updated)
If LOrderNo = "" And LCallbackOrderNo <> "" Then
LOrderNo = LCallbackOrderNo
Dim LThisSessionID, LOriginalSessionID
LThisSessionID = GetSessionID
LOriginalSessionID = GetOrderFieldValue(LOrderNo, "SessionID")
LNewMessage = LNewMessage & "!!! SessionID changed from " & LOriginalSessionID & " to " & LThisSessionID & NL
End If
LNewMessage = LNewMessage & GetPaymentLogSeparator(AType, False) & NL & NL
Else
LNewMessage = ""
End If
' save to session first
Session("PaymentLog") = Session("PaymentLog") & LNewMessage
' ### (SS,18/4/18) for debugging
' SendAlertEmail "Payment Log", "AddToPaymentLog called with Type: " & AType & ", Message: " & AMessage, False
' if order no exists then save from session to the order record and clear session
If LOrderNo <> "" And Session("PaymentLog") <> "" Then
ExecuteQuery("UPDATE orders SET PaymentLog = CONCAT(COALESCE(PaymentLog, ''), '" & CleanSQLStr(Session("PaymentLog")) & "') WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'")
Session("PaymentLog") = "" ' clear the paymentlog in session because we're now adding to the log and don't want to add the same message multiple times
End If
End Sub
' (SS,23/8/17) returns separator string used to separate messages in payment log field
Function GetPaymentLogSeparator(AType, AStart)
Dim Result
Result = "=== " + iif(AStart, "", "End of ") + AType + ": "
Result = Result + String(50 - Len(Result), "=")
GetPaymentLogSeparator = Result
End Function
' (SS,23/8/17) returns the most recent message section from given log
Function GetPaymentLogSection(APaymentLog, AType)
' put into array
' work backwards until end separater found
' continue until start found
Dim Result
Result = ""
If APaymentLog <> "" Then
Dim LLines, LLine, i, LStart, LEndSeparator, LStartSeparator
LLines = Split(APaymentLog, NL, -1, 0)
LStartSeparator = GetPaymentLogSeparator(AType, True)
LEndSeparator = GetPaymentLogSeparator(AType, False)
LStart = False
For i = UBound(LLines) to LBound(LLines) Step -1
LLine = LLines(i)
If Not LStart And LLine = LEndSeparator Then
LStart = True
End If
If LStart Then
Result = LLine & NL & Result
If LLine = LStartSeparator Then Exit For
End If
Next
End If
GetPaymentLogSection = Result
End Function
' (SS,21/3/13) certain payment provides e.g. SagePay, require a unique number, i.e. same order can be used again for same purchase,
' e.g. if buyer goes back to site and then back to SagePay then it'll complain, we get around this by added an extra number to the end to keep it unique
Function GetUniquePaymentProviderSuffix
If Session("PaymentProviderSuffix") = "" Then
Session("PaymentProviderSuffix") = 1
Else
Session("PaymentProviderSuffix") = Session("PaymentProviderSuffix") + 1
End If
GetUniquePaymentProviderSuffix = Session("PaymentProviderSuffix")
End Function
' --------------------------
' Start of Sage Pay routines
' --------------------------
' (SS,19/3/13) new SagePay payment method
' (SS,23/7/15) modified for v3.00 (migration from v2.23), version number changed from 2.23 to 3.00
Sub SetUpSagePayForm(AOrderNo)
Dim LVPSProtocol, LMode, LSagePayURL
' current version is 3.00, simulator said it wants 2.23
' (SS,23/7/15) changed from version 2.23 to 3.00
LVPSProtocol = "3.00"
LMode = GetSagePayMode ' can be LIVE, TEST or "SIM"
' set the URL to use depending on mode
If LMode = "LIVE" then
LSagePayURL = "https://live.sagepay.com/gateway/service/vspform-register.vsp"
ElseIf LMode = "TEST" then
LSagePayURL = "https://test.sagepay.com/gateway/service/vspform-register.vsp"
Else
LSagePayURL = "https://test.sagepay.com/simulator/vspformgateway.asp"
End If
' build the form Crypt field and encrypt it, &xx=yyy, first one without &
FSagePayCrypt = ""
AddToSagePayCrypt "VendorTxCode", AOrderNo & "-" & GetUniquePaymentProviderSuffix ' unique number, even for same session
AddToSagePayCrypt "Amount", Session("PaymentAmount")
AddToSagePayCrypt "Currency", GetCurrencyCode
AddToSagePayCrypt "Description", GetDescriptionForPaymentProvider(100) ' upto 100 chars
' (SS,23/3/13) added URLEncode around ptSagePay because SAGEPAY was changed to SAGE PAY, and can't have space
AddToSagePayCrypt "SuccessURL", GetReturnFromPaymentURL & "&pt=" & URLEncode(ptSagePay) & "&success=true" ' SagePay will send values back using &crypt
AddToSagePayCrypt "FailureURL", GetReturnFromPaymentURL & "&pt=" & URLEncode(ptSagePay) & "&success=false" ' SagePay will send values back using &crypt
AddToSagePayCrypt "CustomerName", Left(GetNameForPaymentProvider, 100) ' optional
AddToSagePayCrypt "CustomerEMail", Left(Session("Email"), 255) ' optional
AddToSagePayCrypt "VendorEMail", GetStoreEmail ' optional
AddToSagePayCrypt "SendEMail", 1 ' optional, 1 means send both customer and vendor emails
AddToSagePayCrypt "eMailMessage", "Thank you so very much for your order." ' optional
' billing address details
AddToSagePayCrypt "BillingFirstnames", Left(Session("FirstName"), 20)
AddToSagePayCrypt "BillingSurname", Left(Session("Surname"), 20)
AddToSagePayCrypt "BillingAddress1", Left(Session("Address1"), 100)
If Session("Address2") <> "" Then AddToSagePayCrypt "BillingAddress2", Left(Session("Address2"), 100)
AddToSagePayCrypt "BillingCity", Left(Session("Town"), 100)
AddToSagePayCrypt "BillingPostCode", Left(Session("Postcode"), 10)
AddToSagePayCrypt "BillingCountry", GetCountryISOCode(Session("Country"))
' AddToSagePayCrypt "BillingState, "") ' optional, US customers only, 2 letter state, which we don't have *** we could convert the county to a 2 letter state
' BillingPhone is also optional
' delivery address details
' We can't use delivery name because PayPal uses separate FirstName and Surname, but it's most likely to be the same.
If Session("DeliveryAddressSameAsInvoice") Then
AddToSagePayCrypt "DeliveryFirstNames", Left(Session("FirstName"), 20)
AddToSagePayCrypt "DeliverySurname", Left(Session("Surname"), 20)
AddToSagePayCrypt "DeliveryAddress1", Left(Session("Address1"), 100)
If Session("Address2") <> "" Then AddToSagePayCrypt "DeliveryAddress2", Left(Session("Address2"), 100)
AddToSagePayCrypt "DeliveryCity", Left(Session("Town"), 100)
AddToSagePayCrypt "DeliveryPostCode", Left(Session("Postcode"), 10)
AddToSagePayCrypt "DeliveryCountry", GetCountryISOCode(Session("Country"))
' AddToSagePayCrypt "DeliveryState, "") ' optional, US customers only, 2 letter state, which we don't have *** we could convert the county to a 2 letter state
' DeliveryPhone is also optional
Else ' i.e. different delivery address
' split the name across two fields because we don't have separate first and surnames for delivery name
Dim LDeliveryName, LDeliveryFirstName, LDeliverySurname, LPos
LDeliveryName = Trim(Session("DeliveryName"))
LPos = InStrRev(LDeliveryName, " ") ' in reverse, first space before the surname because there may be a title
If LPos > 0 Then
LDeliveryFirstName = Trim(Left(LDeliveryName, LPos - 1))
LDeliverySurname = Trim(Mid(LDeliveryName, LPos + 1))
ElseIf Len(LDeliveryFirstName) > 20 Then
LDeliveryFirstName = Left(LDeliveryName, 20)
LDeliverySurname = Mid(LDeliveryName, 21)
Else
LDeliveryFirstName = LDeliveryName
LDeliverySurname = ""
End If
AddToSagePayCrypt "DeliveryFirstNames", Left(LDeliveryFirstName, 20)
AddToSagePayCrypt "DeliverySurname", Left(LDeliverySurname, 20)
AddToSagePayCrypt "DeliveryAddress1", Left(Session("DeliveryAddress1"), 100)
If Session("DeliveryAddress2") <> "" Then AddToSagePayCrypt "DeliveryAddress2", Left(Session("DeliveryAddress2"), 100)
AddToSagePayCrypt "DeliveryCity", Left(Session("DeliveryTown"), 100)
AddToSagePayCrypt "DeliveryPostCode", Left(Session("DeliveryPostcode"), 10)
AddToSagePayCrypt "DeliveryCountry", GetCountryISOCode(Session("DeliveryCountry"))
' AddToSagePayCrypt "DeliveryState, "") ' optional, US customers only, 2 letter state, which we don't have *** we could convert the county to a 2 letter state
' DeliveryPhone is also optional
End If
' following is debug code, currently commented out
' If IsPaymentProviderTestModeActivated Then Response.Write "#" & FSagePayCrypt & "#<br>"
' encrypt the string before including in the hidden field
'Response.Write "#" & FSagePayCrypt & "#<br>"
'Dim LSQL
'LSQL = "SELECT HEX(AES_ENCRYPT('" & CleanSQLStr(FSagePayCrypt) & "', '" & CleanSQLStr(GetSagePayEncryptionKey) & "'))"
'FSagePayCrypt = "@" & GetSQLValueAsString(LSQL) ' @ indicates AES encryption used
' (SS,20/3/13) tried above using MySQL but Sage didn't like it, might be because MySQL uses 128bit encryption, used AESEncrypt instead provide by SagePay in rijndael.asp
FSagePayCrypt = "@" & AESEncrypt(FSagePayCrypt, GetSagePayEncryptionKey)
%>
<form name="frmSagePay" action="<%=LSagePayURL%>" method="post" class="nospace">
<input type="hidden" name="VPSProtocol" value="<%=LVPSProtocol%>">
<input type="hidden" name="TxType" value="PAYMENT">
<input type="hidden" name="Vendor" value="<%=GetSagePayVendorName%>">
<input type="hidden" name="Crypt" value="<%=FSagePayCrypt%>">
</form>
<%
End Sub
' (SS,20/3/13)
Sub AddToSagePayCrypt(AFieldName, AFieldValue)
If FSagePayCrypt <> "" Then FSagePayCrypt = FSagePayCrypt + "&"
FSagePayCrypt = FSagePayCrypt & AFieldName & "=" & AFieldValue ' need to URL or HTML encode AFieldValue HTMLEncode
End Sub
' (SS,21/3/13)
' not actually a direct call back like PayPal and WorldPay, but done via a return to the site via a special URL
' (SS,23/7/15) modified for v3.00 (migration from v2.23), 5 new fields added to sagepaycallbacks table
Sub ProcessSagePayCallback
Dim LCrypt, LDecoded
LCrypt = "@" & AESEncrypt(FSagePayCrypt, GetSagePayEncryptionKey)
LCrypt = Request.QueryString("Crypt")
If LCrypt <> "" Then
If Left(LCrypt, 1) = "@" Then
LDecoded = AESDecrypt(Mid(LCrypt, 2), GetSagePayEncryptionKey)
Else
Response.Write(BR & BR & "Incorrect data received from SagePay." & BR)
Exit Sub
End If
Else ' nothing passed back from Sage then we need to show a message to redirect to another part of the site
Response.Write(BR & BR & "Nothing received from Sage Pay." & BR)
Exit Sub
End If
' Response.Write("#" & LDecoded & "#<br>")
' get the decrypted values from crypt into separate variables
Dim LOrderNo, LPos
Dim LStatus, LStatusDetail, LVendorTxCode, LVPSTxId, LTxAuthNo, LAmount, LAVSCV2, LAddressResult, LPostCodeResult, LCV2Result
Dim LGiftAid, L3DSecureStatus, LCAVV, LCardType, LLast4Digits, LAddressStatus, LPayerStatus
Dim LExpiryDate, LBankAuthCode, LDeclineCode, LFraudResponse, LSurcharge ' (SS,23/7/15)
LStatus = CleanSQLStr(GetSagePayToken(LDecoded, "Status"))
LStatusDetail = CleanSQLStr(GetSagePayToken(LDecoded, "StatusDetail"))
LVendorTxCode = CleanSQLStr(GetSagePayToken(LDecoded, "VendorTxCode"))
LVPSTxId = CleanSQLStr(GetSagePayToken(LDecoded, "VPSTxId"))
LTxAuthNo = CleanSQLStr(GetSagePayToken(LDecoded, "TxAuthNo"))
LAmount = CleanSQLStr(GetSagePayToken(LDecoded, "Amount"))
LAVSCV2 = CleanSQLStr(GetSagePayToken(LDecoded, "AVSCV2"))
LAddressResult = CleanSQLStr(GetSagePayToken(LDecoded, "AddressResult"))
LPostCodeResult = CleanSQLStr(GetSagePayToken(LDecoded, "PostCodeResult"))
LCV2Result = CleanSQLStr(GetSagePayToken(LDecoded, "CV2Result"))
LGiftAid = CleanSQLStr(GetSagePayToken(LDecoded, "GiftAid"))
L3DSecureStatus = CleanSQLStr(GetSagePayToken(LDecoded, "3DSecureStatus"))
LCAVV = CleanSQLStr(GetSagePayToken(LDecoded, "CAVV"))
LCardType = CleanSQLStr(GetSagePayToken(LDecoded, "CardType"))
LLast4Digits = CleanSQLStr(GetSagePayToken(LDecoded, "Last4Digits"))
LAddressStatus = CleanSQLStr(GetSagePayToken(LDecoded, "AddressStatus")) '** PayPal transactions only
LPayerStatus = CleanSQLStr(GetSagePayToken(LDecoded, "PayerStatus")) '** PayPal transactions only
' (SS,23/7/15) added following fields for version 3.00
LExpiryDate = Left(CleanSQLStr(GetSagePayToken(LDecoded, "ExpiryDate")), 4)
LBankAuthCode = Left(CleanSQLStr(GetSagePayToken(LDecoded, "BankAuthCode")), 6)
LDeclineCode = Left(CleanSQLStr(GetSagePayToken(LDecoded, "DeclineCode")), 2)
LFraudResponse = Left(CleanSQLStr(GetSagePayToken(LDecoded, "FraudResponse")), 10)
LSurcharge = Left(CleanSQLStr(GetSagePayToken(LDecoded, "Surcharge")), 20)
' get the order number from LVendorTxCode before the "-" and proceed only if it exists
LPos = InStr(LVendorTxCode, "-")
LOrderNo = Left(LVendorTxCode, LPos - 1)
If LOrderNo = "" Then
Response.Write(BR & BR & "Order No must be specified." & BR)
Exit Sub
End If
' insert the record
' (SS,23/7/15) added ExpiryDate, BankAuthCode, DeclineCode, FraudResponse, Surcharge
Dim LSQL
LSQL = "INSERT INTO sagepaycallbacks SET OrderNo=" & LOrderNo &_
", SessionID='" & GetSessionID & "'" &_
", Status='" & LStatus & "'" &_
", DateTimeReceived=NOW()" &_
", StatusDetail='" & LStatusDetail & "'" &_
", VendorTxCode='" & LVendorTxCode & "'" &_
", VPSTxId='" & LVPSTxId & "'" &_
", TxAuthNo='" & LTxAuthNo & "'" &_
", Amount='" & LAmount & "'" &_
", AVSCV2='" & LAVSCV2 & "'" &_
", AddressResult='" & LAddressResult & "'" &_
", PostCodeResult='" & LPostCodeResult & "'" &_
", CV2Result='" & LCV2Result & "'" &_
", GiftAid='" & LGiftAid & "'" &_
", 3DSecureStatus='" & L3DSecureStatus & "'" &_
", CAVV='" & LCAVV & "'" &_
", CardType='" & LCardType & "'" &_
", Last4Digits='" & LLast4Digits & "'" &_
", AddressStatus='" & LAddressStatus & "'" &_
", PayerStatus='" & LPayerStatus & "'" &_
", ExpiryDate='" & LExpiryDate & "'" &_
", BankAuthCode='" & LBankAuthCode & "'" &_
", DeclineCode='" & LDeclineCode & "'" &_
", FraudResponse='" & LFraudResponse & "'" &_
", Surcharge='" & LSurcharge & "'"
ExecuteQuery(LSQL)
' if paid then mark the order as paid and send email
If LStatus = "OK" And LOrderNo <> "" Then
' following will update the status, send email and empty basket
' (SS,21/1/15) added "" parameter for PaymentInfo
' (SS,25/6/18) added new PaymentProviderFee parameter i.e. 0 to the end
' (SS,26/6/18) added three more parameters, PaymentReceivedAmount, PaymentReceivedCurrencyCode and PaymentProviderSurcharge
' only PaymentAmountReceived is set a value, i.e. ParseFloat(LAmount). The other two are 0. Currency Code is set to "GBP"
ProcessOrderThirdPartyPayment True, LOrderNo, GetSessionID, ptSagePay, LVPSTxId, PAYMENT_RECEIVED_STATUS, "", ParseFloat(LAmount), "GBP", 0, 0
Else
Response.Write("Payment not successful." & BR)
End If
End Sub
'------------------------------------------------------
' (SS,21/3/13) following is exact copy of function from Sage Pay to get value of given token
' I renamed it from getToken to GetSagePayToken
' (SS,23/7/15) changes for version 3.00 (from 2.23) added extra fields
'** The getToken function. **
'** NOTE: A function of convenience that extracts the value from the "name=value&name2=value2..." reply string **
'** Does not use the split function because returned values can contain & or =, so it looks for known names and **
'** removes those, leaving only the field selected **
public function GetSagePayToken(strList,strRequired)
dim strTokenValue, iIndex ' (SS,21/3/13) had to add this to prevent Variable is undefined error
dim arrTokens
' (SS,23/7/15) added for version 3.00 ExpiryDate, BankAuthCode, DeclineCode, FraudResponse, Surcharge
arrTokens = array("Status","StatusDetail","VendorTxCode","VPSTxId", _
"TxAuthNo","Amount","AVSCV2","AddressResult","PostCodeResult", _
"CV2Result","GiftAid","3DSecureStatus","CAVV","AddressStatus", _
"CardType","Last4Digits","PayerStatus", _
"ExpiryDate","BankAuthCode","DeclineCode", _
"FraudResponse","Surcharge")
'** If the toekn we're after isn't in the list, return nothing **
if instr(strList,strRequired+"=")=0 then
GetSagePayToken=""
exit function
else
'** The token is present, so ignore everything before it in the list **
strTokenValue=mid(strList,instr(strList,strRequired)+len(strRequired)+1)
'** Strip off all remaining tokens if they are present **
iIndex = LBound(arrTokens)
do while iIndex <= UBound(arrTokens)
if arrTokens(iIndex)<>strRequired then
if instr(strTokenValue,"&"+arrTokens(iIndex))<>0 then
strTokenValue=left(strTokenValue,instr(strTokenValue,"&"+arrTokens(iIndex))-1)
end if
end if
iIndex = iIndex + 1
loop
GetSagePayToken=strTokenValue
end if
end function
'------------------------------------------------------
' ------------------------
' End of Sage Pay routines
' ------------------------
' --------------------------
' Start of ePDQ routines
' --------------------------
' (SS,7/9/06)
' (SS,6/7/07) added HTMLEncode to some of the values to allow quotes etc
' (SS,2/10/14) added PARAMVAR to allow more than one site to use same account via virtual directory e.g. https://secure.itpartnership.com/<PARAMVAR>/epdq-callback.asp
' (SS,7/3/18) added hidden ACCEPTURL to redirect back to site automatically, but wasn't working
' (SS,26/4/18) replaced (this old migrated CPI service) with new version see Sub SetUpEPDQForm below
Sub SetUpEPDQFormOld(AOrderNo)
Dim LClientID, LPassphrase, LChargeType, LCurrencyCode, LTotal
Dim LePDQData, LReturnURL, LMerchantDisplayName
LClientID = GetEPDQClientID
LPassphrase = GetEPDQPassphrase
LChargeType = GetEPDQChargeType
LCurrencyCode = "826"
LTotal = Session("PaymentAmount")
' LReturnURL = GetReturnFromPaymentURL
' (SS,8/9/06) above doesn't work so following because the cmd and stage parameters are
' removed by ePDQ, replaced by oid, so used following instead to redirect
LReturnURL = GetStoreURL + "/epdq-return.asp"
LMerchantDisplayName = GetEPDQMerchantDisplayName ' (SS,10/5/12) was GetStoreURLNoHttp
LePDQData = GetEncryptedEPDQData(LClientID, AOrderNo, LPassphrase, LChargeType, LCurrencyCode, LTotal)
Dim Lbaddr1, Lbaddr2, Lbcity, Lbcountyprovince, Lbcountry, Lbpostalcode, Lbstate, Lbtelephonenumber, Lemail
Dim Lsaddr1, Lsaddr2, Lscity, Lscountyprovince, Lscountry, Lspostalcode, Lsstate, Lstelephonenumber
' extra fields
Lbaddr1 = Left(Session("Address1"), 60)
Lbaddr2 = Left(Session("Address2"), 60)
Lbcity = Left(Session("Town"), 25)
Lbcountyprovince = Left(Session("County"), 25)
Lbcountry = GetCountryISOCode(Session("Country"))
Lbpostalcode = Left(Session("Postcode"), 9)
' if USA then use first two letters of postcode/zip as two letter state code
If Lbcountry = "US" Then
Lbstate = Left(Trim(Lbpostalcode), 2)
Else
Lbstate = ""
End If
Lbtelephonenumber = Left(Session("Telephone"), 30)
Lemail = Left(Session("Email"), 64)
Lsaddr1 = Left(Session("DeliveryAddress1"), 60)
Lsaddr2 = Left(Session("DeliveryAddress2"), 60)
Lscity = Left(Session("DeliveryTown"), 25)
Lscountyprovince = Left(Session("DeliveryCounty"), 25)
Lscountry = GetCountryISOCode(Session("DeliveryCountry"))
Lspostalcode = Left(Session("DeliveryPostcode"), 9)
' if USA then use first two letters of postcode/zip as two letter state code
If Lscountry = "US" Then
Lsstate = Left(Trim(Lspostalcode), 2)
Else
Lsstate = ""
End If
Lstelephonenumber = Left(Session("Telephone"), 30)
' (SS,7/3/18) added hidden ACCEPTURL to return straight to website (to GetReturnFromPaymentURL) successful payment, so that conversion tracking is done without customer having to press a button to return
%>
<form name="frmEPDQ" action="https://secure2.epdq.co.uk/cgi-bin/CcxBarclaysEpdq.e" method="post" class="nospace">
<%=LePDQData%>
<input type="hidden" name="returnurl" value="<%=LReturnURL%>">
<input type="hidden" name="merchantdisplayname" value="<%=LMerchantDisplayName%>">
<input type="hidden" name="baddr1" value="<%=HTMLEncode(Lbaddr1)%>">
<input type="hidden" name="baddr2" value="<%=HTMLEncode(Lbaddr2)%>">
<input type="hidden" name="bcity" value="<%=HTMLEncode(Lbcity)%>">
<input type="hidden" name="bcountyprovince" value="<%=HTMLEncode(Lbcountyprovince)%>">
<input type="hidden" name="bcountry" value="<%=Lbcountry%>">
<input type="hidden" name="bpostalcode" value="<%=HTMLEncode(Lbpostalcode)%>">
<input type="hidden" name="bstate" value="<%=HTMLEncode(Lbstate)%>">
<input type="hidden" name="btelephonenumber" value="<%=HTMLEncode(Lbtelephonenumber)%>">
<input type="hidden" name="email" value="<%=HTMLEncode(Lemail)%>">
<input type="hidden" name="collectdeliveryaddress" value="0">
<input type="hidden" name="PARAMVAR" value="<%=HTMLEncode(GetEPDQPARAMVAR)%>">
<input type="hidden" name="ACCEPTURL" value="<%=HTMLEncode(GetReturnFromPaymentURL & "&accept=1")%>">
</form>
<%
' (SS,10/5/12) shipping address removed from above, also added hidden collectdeliveryaddress to notify ePDQ that delivery address not applicable
'<input type="hidden" name="saddr1" value="<~=HTMLEncode(Lsaddr1)~>">
'<input type="hidden" name="saddr2" value="<~=HTMLEncode(Lsaddr2)~>">
'<input type="hidden" name="scity" value="<~=HTMLEncode(Lscity)~>">
'<input type="hidden" name="scountyprovince" value="<~=HTMLEncode(Lscountyprovince)~>">
'<input type="hidden" name="scountry" value="<~=HTMLEncode(Lscountry)~>">
'<input type="hidden" name="spostalcode" value="<~=HTMLEncode(Lspostalcode)~>">
'<input type="hidden" name="sstate" value="<~=HTMLEncode(Lsstate)~>">
'<input type="hidden" name="stelephonenumber" value="<~=HTMLEncode(Lstelephonenumber)~>">
' removed following doesn't look nice, takes too much spaces
' <input type="hidden" name="cpi_logo" value="https://secure.itpartnership.com/period-products.jpg">
' (SS,20/11/08) moved button from here to SetUpPaymentButton
End Sub
' (SS,7/9/06) taken from ePDQ example, made into function
' uses ASPTear object that has to be installed
' (SS,25/4/18) modified to use GetWebPageViaPOST instead of SOFTWING.ASPtear
Function GetEncryptedEPDQData(AClientID, AOID, APassword, AChargeType, ACurrencyCode, ATotal)
Dim strEPDQ, LSite, LQuery
LSite = "https://secure2.epdq.co.uk/cgi-bin/CcxBarclaysEpdqEncTool.e"
' (SS,10/5/12) added "&mandatecsc=1" to force security code to be mandatory
LQuery = "clientid=" & AClientID & "&oid=" & AOID & "&password=" & APassword & "&chargetype=" & AChargeType & "¤cycode=" & ACurrencyCode & "&total=" & ATotal & "&mandatecsc=1"
' (SS,25/4/18) replaced Set objTear = CreateObject("SOFTWING.ASPtear") with GetWebPageViaPOST
strEPDQ = GetWebPageViaPOST(LSite & "?" & LQuery)
GetEncryptedEPDQData = strEPDQ
End Function
' (SS,26/4/18) new version
' (SS,16/2/24) renamed from SetUpEPDQForm to SetUpEPDQFormPrev while experimenting with changes (see below)
Sub SetUpEPDQFormPrev(AOrderNo)
' clear the hash string
ClearEPDQStringToHash
Dim LTotal, LISOCurrencyCode
' amount is always GBP
LISOCurrencyCode = "GBP" ' in ISO alpha (not numeric like Payzone)
LTotal = Session("PaymentAmountGBP") ' amount in GBP
LTotal = Round(CDbl(LTotal) * 100) ' x 100 because it's in pence
Dim LActionURL
If GetEPDQTestMode Then
LActionURL = "https://mdepayments.epdq.co.uk/ncol/test/orderstandard.asp"
Else
LActionURL = "https://payments.epdq.co.uk/ncol/prod/orderstandard.asp"
End If
%>
<form name="frmEPDQ" action="<%=LActionURL%>" method="post" class="nospace">
<%
Dim LCustomerName
LCustomerName = GetNameForPaymentProvider
' order has to be alphabetic on name for the hash string
AddEPDQField "ACCEPTURL", GetReturnFromPaymentURL & "&pt=" & ptEPDQ, 0, True
AddEPDQField "AMOUNT", LTotal, 0, True
AddEPDQField "CN", LCustomerName, 100, True
AddEPDQField "CURRENCY", LISOCurrencyCode, 0, True
AddEPDQField "EMAIL", Session("Email"), 64, True
' following logo needs to be uploaded, removed for now, perhaps use store name followed by .PNG
'AddEPDQField "LOGO", GetStoreURL & "/images/logo.png" , 64, True
AddEPDQField "ORDERID", AOrderNo, 50, True
AddEPDQField "OWNERADDRESS", Session("Address1"), 60, True
AddEPDQField "OWNERCTY", GetCountryISOCode(Session("Country")), 0, True
AddEPDQField "OWNERTELNO", Session("Telephone"), 30, True
AddEPDQField "OWNERTOWN", Session("Town"), 25, True
AddEPDQField "OWNERZIP", Session("Postcode"), 9, True
AddEPDQField "PSPID", GetEPDQClientID, 0, True
AddEPDQField "TITLE", GetStoreName, 0, True
' AddEPDQField "LANGUAGE", "en_GB", 0, True ' (SS,26/4/18) language of the customer not passed on for now
'AddEPDQField "OWNERADDRESS2", Session("Address2"), 60, True
'AddEPDQField "TITLE", GetEPDQMerchantDisplayName, 0, True
' AddEPDQField "PARAMVAR", GetEPDQPARAMVAR, 0, True
'AddPayzoneField "OrderDescription", GetDescriptionForPaymentProvider(256), 256, True
%><input type="hidden" name="SHASign" value="<%=GetEPDQHashDigest%>">
</form>
<%
End Sub
' (SS,26/4/18) new version
Sub SetUpEPDQForm(AOrderNo)
' clear the hash string
ClearEPDQStringToHash
Dim LTotal, LISOCurrencyCode
' amount is always GBP
LISOCurrencyCode = "GBP" ' in ISO alpha (not numeric like Payzone)
LTotal = Session("PaymentAmountGBP") ' amount in GBP
LTotal = Round(CDbl(LTotal) * 100) ' x 100 because it's in pence
Dim LActionURL
If GetEPDQTestMode Then
LActionURL = "https://mdepayments.epdq.co.uk/ncol/test/orderstandard.asp"
Else
LActionURL = "https://payments.epdq.co.uk/ncol/prod/orderstandard.asp"
End If
%>
<form name="frmEPDQ" action="<%=LActionURL%>" method="post" class="nospace">
<%
Dim LCustomerName
LCustomerName = GetNameForPaymentProvider
' order has to be alphabetic on name for the hash string
AddEPDQField "ACCEPTURL", GetReturnFromPaymentURL & "&pt=" & ptEPDQ, 0, True
AddEPDQField "AMOUNT", LTotal, 0, True
AddEPDQField "CN", LCustomerName, 100, True
AddEPDQField "CURRENCY", LISOCurrencyCode, 0, True
AddEPDQField "EMAIL", Session("Email"), 64, True
' following logo needs to be uploaded, removed for now, perhaps use store name followed by .PNG
'AddEPDQField "LOGO", GetStoreURL & "/images/logo.png", 64, True
' (SS,20/2/24) added logo, it's a reference to an uploaded file via the EPDQ file manager
'AddEPDQField "LOGO", "logo-circ.png", 64, True
'AddEPDQField "LOGO", "logocirc.png", 64, True
AddEPDQField "ORDERID", AOrderNo, 50, True
AddEPDQField "OWNERADDRESS", Session("Address1"), 60, True
AddEPDQField "OWNERCTY", GetCountryISOCode(Session("Country")), 0, True
AddEPDQField "OWNERTELNO", Session("Telephone"), 30, True
AddEPDQField "OWNERTOWN", Session("Town"), 25, True
AddEPDQField "OWNERZIP", Session("Postcode"), 9, True
AddEPDQField "PSPID", GetEPDQClientID, 0, True
AddEPDQField "TITLE", GetStoreName, 0, True
AddEPDQField "SHASign", GetEPDQHashDigest, 0, True ' (SS,29/2/24) replaces input type hidden at end
' AddEPDQField "LANGUAGE", "en_GB", 0, True ' (SS,26/4/18) language of the customer not passed on for now
'AddEPDQField "OWNERADDRESS2", Session("Address2"), 60, True
'AddEPDQField "TITLE", GetEPDQMerchantDisplayName, 0, True
' AddEPDQField "PARAMVAR", GetEPDQPARAMVAR, 0, True
'AddPayzoneField "OrderDescription", GetDescriptionForPaymentProvider(256), 256, True
%>
</form>
<%
End Sub
' (SS,26/4/18) outputs the input field and adds to FEPDQStringToHash (implementation similar to Payzone's)
' If AIncludeInForm is true then is including in both form and digest, if false then digest only
Sub AddEPDQField(AFieldName, AFieldValue, AMaxLength, AIncludeInForm)
Dim LFieldValue, LFieldValueEncoded
If AMaxLength = 0 Then
LFieldValue = AFieldValue
Else
LFieldValue = Left(AFieldValue, AMaxLength)
End If
' replace ampersand with + (their system currently can't handle special characters)
' not encoded yet, not sure if necessary
LFieldValueEncoded = LFieldValue
' add the hidden variable to form
If AIncludeInForm Then
Response.Write "<input type=""hidden"" name=""" & AFieldName & """ value=""" & LFieldValueEncoded & """>" & NL
End If
AddEPDQStringToHash AFieldName, LFieldValueEncoded
End Sub
' (SS,26/4/18)
Sub ClearEPDQStringToHash
' Global FEPDQStringToHash
FEPDQStringToHash = ""
End Sub
' (SS,26/4/18) notice it's different to Payzone, "&" not used to separate the values, and passphrase added to the end of each value
Sub AddEPDQStringToHash(AFieldName, AFieldValue)
FEPDQStringToHash = FEPDQStringToHash & AFieldName & "=" & AFieldValue & GetEPDQPassphrase
End Sub
' (SS,27/4/18) similar to AddEPDQStringToHash above, but gets value from form field and returns a value, calls AddEPDQStringToHash
Function GetEPDQFormFieldToHash(AFieldName)
Dim LFieldValue
LFieldValue = CleanRequestQueryString(AFieldName)
FEPDQStringToHash = FEPDQStringToHash & UCase(AFieldName) & "=" & LFieldValue & GetEPDQPassphrase ' NB. name has to be uppercase
GetEPDQFormFieldToHash = LFieldValue
End Function
' (SS,28/3/18)
Function GetEPDQHashDigest
Dim LResult
' use SHA1 function of MySQL to create the hash
' (SS,5/4/18) added CAST(AS CHAR) for MySQL server 5.1.x and old ODBC driver, otherwise it returns ????, fine in MySQL 5.7.x on test server
LResult = GetSQLValueAsString("SELECT CAST(SHA1(""" & CleanSQLStr(FEPDQStringToHash) & """) AS CHAR)")
GetEPDQHashDigest = LResult
End Function
' this routine gets called by epdq-callback.asp which is normally called by ePDQ callback when payment has been made
' (SS,27/4/18) old version, for new version see Sub ProcessEPDQRedirectCallback below
' Kept this to continue processing callbacks the old way as well
Sub ProcessEPDQCallback
' (SS,26/4/18) !!! debug
SendWebLogEmail "ProcessEPDQCallback"
Dim LSQL, LOrderNo
Dim Ltransactionstatus, Ltotal, LClientID, Lchargetype, Ldatetime, Lecistatus, Lcardprefix
' get values from query forms etc (passed on values) '
LOrderNo = CleanSQLStr(Trim(CleanRequest("oid")))
Ltransactionstatus = CleanSQLStr(CleanRequest("transactionstatus"))
Ltotal = CleanSQLStr(CleanRequest("total"))
LClientID = CleanSQLStr(CleanRequest("ClientID"))
Lchargetype = CleanSQLStr(CleanRequest("chargetype"))
Ldatetime = CleanSQLStr(CleanRequest("datetime"))
Lecistatus = CleanSQLStr(CleanRequest("ecistatus"))
Lcardprefix = CleanSQLStr(CleanRequest("cardprefix"))
If LOrderNo = "" Then
Response.Write("<br><br>Order No must be specified.<br>")
Exit Sub
End If
' insert the record '
LSQL = "INSERT INTO epdqcallbacks SET OrderNo=" & LOrderNo &_
", transactionstatus='" & Ltransactionstatus & "'" &_
", total='" & Ltotal & "'" &_
", ClientID='" & LClientID & "'" &_
", chargetype='" & Lchargetype & "'" &_
", datetime='" & Ldatetime & "'" &_
", ecistatus='" & Lecistatus & "'" &_
", cardprefix='" & Lcardprefix & "'"
ExecuteQuery(LSQL)
' if paid then mark the order as paid and send email
If UCase(Ltransactionstatus) = "SUCCESS" And LOrderNo <> "" Then
' we need to get SessionID because it's not passed on from ePDQ
Dim LSessionID
LSessionID = GetSessionIDForOrder(LOrderNo)
' following will update the status, send email and empty basket
' OrderNo is used as PaymentReference because ePDQ doesn't pass it's own ref back
' (SS,5/10/07) added ptEPDQ
' (SS,16/5/12) added PAYMENT_RECEIVED_STATUS
' (SS,21/1/15) added "" for new PaymentInfo parameter
' (SS,25/6/18) added new PaymentProviderFee parameter i.e. 0 to the end
' (SS,26/6/18) added two more parameters, PaymentAmountReceived and PaymentProviderSurcharge, only PaymentAmountReceived is sent a value, i.e. ParseFloat(LAmount). The other two are 0.
' (SS,26/6/18) also added PaymentReceivedCurrencyCode, set this to "GBP"
ProcessOrderThirdPartyPayment True, LOrderNo, LSessionID, ptEPDQ, LOrderNo, PAYMENT_RECEIVED_STATUS, "", ParseFloat(Ltotal), "GBP", 0, 0
End If
End Sub
' (SS,27/4/18) new version for callbacks via browser redirect
' (SS,11/8/20) improvements to log and prevent duplicate issue was occurs when page is left for a while and browser does a refresh later
Sub ProcessEPDQRedirectCallback
Dim LIPCTY, LECI, LCardNo, LPAYIDSUB, LOrderNo, LAmount, LCurrency, LED, LCCCTY
Dim LCVCCheck, LAAVCheck, LSHASIGN, LPM, LPAYID, LVC, LACCEPTANCE, LBRAND, LIP, LSTATUS, LNCERROR, LCN, LTRXDATE
Dim LSHASIGNCalculated
' (SS,26/4/18) !!! debug
'SendWebLogEmail "ProcessEPDQRedirectCallback"
ClearEPDQStringToHash
' following have to be in this alphabetical order
' (SS,30/4/18) removed BRAND and ED (Expiry Date) due to sensitive info that we don't wanted in address bar, even though most of card no is replaced with X's
' Also removed, AAVCheck, CCCTY, CVCCheck, ECI, ED, PAYIDSUB, VC
'LAAVCheck = GetEPDQFormFieldToHash("AAVCheck")
LACCEPTANCE = GetEPDQFormFieldToHash("ACCEPTANCE")
LAmount = GetEPDQFormFieldToHash("amount")
LBRAND = GetEPDQFormFieldToHash("BRAND")
'LCardNo = GetEPDQFormFieldToHash("CARDNO")
'LCCCTY = GetEPDQFormFieldToHash("CCCTY")
LCN = GetEPDQFormFieldToHash("CN")
LCurrency = GetEPDQFormFieldToHash("currency")
'LCVCCheck = GetEPDQFormFieldToHash("CVCCheck")
'LECI = GetEPDQFormFieldToHash("ECI")
'LED = GetEPDQFormFieldToHash("ED")
LIP = GetEPDQFormFieldToHash("IP")
'LIPCTY = GetEPDQFormFieldToHash("IPCTY")
LNCERROR = GetEPDQFormFieldToHash("NCERROR")
LOrderNo = GetEPDQFormFieldToHash("orderID")
LPAYID = GetEPDQFormFieldToHash("PAYID")
'LPAYIDSUB = GetEPDQFormFieldToHash("PAYIDSUB")
LPM = GetEPDQFormFieldToHash("PM")
LSTATUS = GetEPDQFormFieldToHash("STATUS")
LTRXDATE = GetEPDQFormFieldToHash("TRXDATE")
'LVC = GetEPDQFormFieldToHash("VC")
LSHASIGN = CleanRequestQueryString("SHASIGN")
' show message and abort if no order no specified
If LOrderNo = "" Then
Response.Write("Order No must be specified" & BR & NL)
Exit Sub
End If
LSHASIGNCalculated = UCase(GetEPDQHashDigest) ' UCase used because they return it in upper case
'Response.Write BR & BR & "SHASIGN Actual: " & LSHASIGN & BR
'Response.Write BR & BR & "SHASIGN Calculated: " & LSHASIGNCalculated & BR
'Response.Write BR & BR & "FEPDQStringToHash: " & HTMLEncode(FEPDQStringToHash) & BR
' (SS,11/8/20) added following to fix an issue where customers are keeping the final page open
' and refreshing it calls this routine as if a payment has been made and adding to this log
' and has also resulted in cancelled orders where payment was made and refunded in full, later being marked as payment received
' This is obviously a bug and has been corrected via change to Function CheckPaymentReceived
' Here we are detecting the subsequent refresh of page with same URL and marking it as such and redirecting to the home page to prevent refresh in future.
' In CIRC about 15% (VDK 13.5%) of logged entries were due to a refresh because customer still has the tab open, even many months after the original order.
' Modified epdq_redirect_callbacks to add new field called "InternalStatus" VARCHAR(20) and SHASIGN has an index due to search below
Dim LDuplicateDetected
LDuplicateDetected = GetSQLRecordExists("SELECT OrderNo FROM epdq_redirect_callbacks WHERE SHASIGN = '" & LSHASIGN & "'")
' add to new epdq_redirect_callbacks log
' !!! to be completed
Dim LSQL
LSQL = "INSERT INTO epdq_redirect_callbacks SET OrderNo=" & CleanSQLStr(LOrderNo) &_
", SessionID='" & CleanSQLStr(GetSessionID) & "'" &_
", DateTimeReceived=NOW()" &_
", Acceptance='" & CleanSQLStr(LACCEPTANCE) & "'" &_
", Amount='" & CleanSQLStr(LAmount) & "'" &_
", Brand='" & CleanSQLStr(LBRAND) & "'" &_
", CN='" & CleanSQLStr(LCN) & "'" &_
", Currency='" & CleanSQLStr(LCurrency) & "'" &_
", IP='" & CleanSQLStr(LIP) & "'" &_
", NCError='" & LNCERROR & "'" &_
", PayID='" & LPAYID & "'" &_
", PM='" & LPM & "'" &_
", Status='" & LSTATUS & "'" &_
", TRXDate='" & LTRXDATE & "'" &_
", SHASIGN='" & LSHASIGN & "'"
ExecuteQuery(LSQL)
' (SS,11/8/20) added following to update the new InternalStatus field later
Dim LLastInsertID
LLastInsertID = GetSQLLastInsertID
' (SS,11/8/20) if duplicate then, set the new internal status to "DUPLICATE" and redirect to home page to prevent this from occurring repeatedly
If LDuplicateDetected Then
EPDQUpdateInternalStatus LLastInsertID, "DUPLICATE"
SetPageRedirection GetStoreURL
Exit Sub
End If
' (SS,18/4/18)
' AddToPaymentLog "EPDQ", "Status = " & LSTATUS & NL & "NCERROR = " & LNCERROR & NL & "ACCEPTANCE = " & LACCEPTANCE
' (SS,22/6/22) replaced above with following to record all values and check for session ID change
Dim LPaymentLog, LName
LPaymentLog = ""
For Each LName in Request.QueryString
LPaymentLog = LPaymentLog & LName & " = " & Request.QueryString(LName) & NL
Next
SetCallbackOrderNoForPaymentLog LOrderNo ' added this to check for SessionID change in AddToPaymentLog
AddToPaymentLog "EPDQ", LPaymentLog
' (SS,11/8/20) debug code
'Response.Write BR & "###" & LSHASIGNCalculated & "###" & BR
' if paid then mark the order as paid and send email
' STATUS "5" means authorised
' (SS,1/5/18) replaced LSTATUS = "5" with EPDQSuccessfulPayment, because it can be 5 or 9
If LSHASIGN = LSHASIGNCalculated And EPDQSuccessfulPayment And LOrderNo <> "" Then
' following will update the status, send email and empty basket
' (SS,25/6/18) added new PaymentProviderFee parameter i.e. 0 to the end
' (SS,26/6/18) added two more parameters, PaymentAmountReceived and PaymentProviderSurcharge, only PaymentAmountReceived is sent a value, i.e. ParseFloat(LAmount). The other two are 0.
' (SS,26/6/18) also added PaymentReceivedCurrencyCode, set this to LCurrency
ProcessOrderThirdPartyPayment True, LOrderNo, GetSessionID, ptEPDQ, LPAYID, PAYMENT_RECEIVED_STATUS, "", ParseFloat(LAmount), LCurrency, 0, 0
Else
'Response.Write("Payment not successful" & BR & NL)
'Response.Write("Status Code is " & LStatusCode & BR & NL)
'If LSHASIGN = LSHASIGNCalculated Then
' Response.Write("SHASIGN mismatch" & BR & NL)
'End If
' (SS,11/8/20) added following to new InternalStatus field
If LSHASIGN <> LSHASIGNCalculated Then
EPDQUpdateInternalStatus LLastInsertID, "HASH MISMATCH"
Else
EPDQUpdateInternalStatus LLastInsertID, "FAILURE"
End If
' (SS,6/4/18) show error message and retry button
ShowPaymentFailureAlert ""
SetCreditCardPaymentProviderFailure ' (SS,20/4/18) flag the error
End If
End Sub
' (SS,11/8/20)
Sub EPDQUpdateInternalStatus(AID, AStatus)
ExecuteQuery("UPDATE epdq_redirect_callbacks SET InternalStatus = '" & CleanSQLStr(AStatus) & "' WHERE ID = '" & CleanSQLStr(AID) & "'")
End Sub
' (SS,30/4/18) used by conversion via IsSuccessfulReturnFromPaymentProviderPage to check for successful payment when returning from payment provider
Function EPDQSuccessfulPayment
' (SS,1/5/18) added CleanRequestQueryString("STATUS") = "9", 5 is for Authorised and 9 for Payment requested
EPDQSuccessfulPayment = CleanRequestQueryString("STATUS") = "5" Or CleanRequestQueryString("STATUS") = "9"
End Function
' --------------------------
' End of ePDQ routines
' --------------------------
Function GetDescriptionForPayPal()
GetDescriptionForPayPal = Left(Session("PaymentDescription"), 127) ' max of 127 chars '
End Function
' --------------------------
' Start of Payzone routines
' --------------------------
' (SS,23/3/18) is Payzone payment
Function IsPayzonePayment
IsPayzonePayment = GetPaymentType = ptPayzone
End Function
' (SS,26/3/18)
Function GetPayzoneMerchantID
GetPayzoneMerchantID = FPayzoneMerchantID
End Function
' (SS,26/3/18)
Function GetPayzoneGatewayAccountPassword
GetPayzoneGatewayAccountPassword = FPayzoneGatewayAccountPassword
End Function
' (SS,26/3/18)
Function GetPayzonePreSharedKey
GetPayzonePreSharedKey = FPayzonePreSharedKey
End Function
' (SS,5/4/18) for testing purposes, returns true if valid IP
Function GetPaymentAllowedIP
Const IP_ALLOWED = "ALL"
'Const IP_ALLOWED = "80.229.231.82,86.2.247.155"
Dim LClientIPAddress, LResult
LClientIPAddress = Request.ServerVariables("REMOTE_ADDR")
If IP_ALLOWED = "ALL" Then
LResult = True
Else
LResult = InStr("," & IP_ALLOWED & ",", "," & LClientIPAddress & ",") > 0
End If
GetPaymentAllowedIP = LResult
End Function
' (SS,23/3/18)
' (SS,17/4/18) renamed from SetUpPayzonePayForm to SetUpPayzoneForm
' (SS,19/12/18) added EmailAddress
' (SS,24/12/23) URL change to new one
Sub SetUpPayzoneForm(AOrderNo)
' (SS,28/3/18) clear globals used here
ClearPayzoneStringToHash
' (SS,6/4/18) added LISOCurrencyCode
Dim LTotal, LISOCurrencyCode
LTotal = Session("PaymentAmount") ' amount in selected currency
If IsCurrencyUSD Then
LISOCurrencyCode = "840"
ElseIf IsCurrencyEUR Then
LISOCurrencyCode = "978"
Else ' GBP or other
LISOCurrencyCode = "826"
LTotal = Session("PaymentAmountGBP") ' amount in GBP
End If
' (SS,6/4/18) USD and EUR not set up or working currently so adding the following to default all to GBP, need to comment out the following once USD and EUR working
LISOCurrencyCode = "826"
LTotal = Session("PaymentAmountGBP") ' amount in GBP
LTotal = Round(CDbl(LTotal) * 100) ' x 100 because it's in pence
' date time ordered in required UTC format, TIMEDIFF(NOW(), UTC_TIMESTAMP()) used to determine the difference to UTC
Dim LTransactionDateTimeUTC
'LTransactionDateTimeUTC = GetSQLValueAsString("SELECT CONCAT(DATE_FORMAT(DateTimeOrdered, '%Y-%m-%d %H:%i:%s'), ' +', LEFT(TIMEDIFF(NOW(), UTC_TIMESTAMP()), 5)) AS TransactionDateTimeUTC FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
' (SS,5/4/18) added CAST(AS CHAR) for MySQL server 5.1.x and old ODBC driver, otherwise it returns ????, fine in MySQL 5.7.x on test server
LTransactionDateTimeUTC = GetSQLValueAsString("SELECT CAST(CONCAT(DATE_FORMAT(DateTimeOrdered, '%Y-%m-%d %H:%i:%s'), ' +', LEFT(TIMEDIFF(NOW(), UTC_TIMESTAMP()), 5)) AS CHAR) AS TransactionDateTimeUTC FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
' *** to add CallbackURL, check encoding for OrderDescription, CustomerName and size check (before or after encode)
' better name for GetCountryForWorldPay e.g. GetCountryForPaymentProvider
' GetReturnFromPaymentURL
' (SS,24/12/23) changed URL from "mms.payzoneonlinepayments.com" (which had stopped working) to new "mms.tponlinepayments2.com"
%>
<form name="frmPayzone" action="https://mms.tponlinepayments2.com/Pages/PublicPages/PaymentForm.aspx" method="post" class="nospace">
<%
AddPayzoneField "PreSharedKey", GetPayzonePreSharedKey, 0, False
AddPayzoneField "MerchantID", GetPayzoneMerchantID, 0, True
AddPayzoneField "Password", GetPayzoneGatewayAccountPassword, 0, False
AddPayzoneField "Amount", LTotal, 0, True
AddPayzoneField "CurrencyCode", LISOCurrencyCode, 0, True
AddPayzoneField "OrderID", AOrderNo, 50, True
AddPayzoneField "TransactionType", "SALE", 0, True
AddPayzoneField "TransactionDateTime", LTransactionDateTimeUTC, 0, True
'AddPayzoneField "CallbackURL", GetStoreURL, 0, True
AddPayzoneField "CallbackURL", GetReturnFromPaymentURL & "&pt=" & ptPayzone, 0, True
'AddPayzoneField "CallbackURL", GetStoreURL & "/checkout/callback/payzone", 0, True
AddPayzoneField "OrderDescription", GetDescriptionForPaymentProvider(256), 256, True
' (SS,12/4/18) added IsPayzoneSafeString to ensure name has valid chars for Payzone, it doesn't like accented chars, or specials chars like &, ", ', <, >
' if not safe then a blank name is passed to Payzone
Dim LCustomerName
LCustomerName = GetNameForPaymentProvider
If Not IsPayzoneSafeString(LCustomerName) Then LCustomerName = ""
AddPayzoneField "CustomerName", LCustomerName, 100, True
AddPayzoneField "DisplayBillingAddress", False, 0, True
'AddPayzoneField "DisplayBillingAddress", True, 0, True
' (SS,12/4/18) removed address lines, kept postcode
'AddPayzoneField "Address1", Session("Address1"), 100, True
'AddPayzoneField "Address2", Session("Address2"), 50, True
'AddPayzoneField "Address3", "", 50, False
'AddPayzoneField "Address4", "", 50, False
'AddPayzoneField "City", Session("Town"), 50, True
'AddPayzoneField "State", Session("County"), 50, True
AddPayzoneField "Address1", "", 100, True
AddPayzoneField "Address2", "", 50, True
AddPayzoneField "Address3", "", 50, False
AddPayzoneField "Address4", "", 50, False
AddPayzoneField "City", "", 50, True
AddPayzoneField "State", "", 50, True
AddPayzoneField "PostCode", Session("Postcode"), 50, True
AddPayzoneField "CountryCode", GetCountryCodeNumeric(Session("Country")), 0, True
AddPayzoneField "EmailAddress", Session("Email"), 100, True ' (SS,19/12/18)
'AddToSagePayCrypt "SuccessURL", GetReturnFromPaymentURL & "&pt=" & URLEncode(ptSagePay) & "&success=true" ' SagePay will send values back using &crypt
'AddToSagePayCrypt "FailureURL", GetReturnFromPaymentURL & "&pt=" & URLEncode(ptSagePay) & "&success=false" ' SagePay will send values back using &crypt
'AddToSagePayCrypt "CustomerName", Left(GetNameForPaymentProvider, 100) ' optional
'AddToSagePayCrypt "CustomerEMail", Left(Session("Email"), 255) ' optional
AddPayzoneField "ResultDeliveryMethod", "POST", 0, True
%><input type="hidden" name="HashDigest" value="<%=GetPayzoneHashDigest%>">
</form>
<%
' Response.Write "###" & FPayzoneStringToHash & "###" & BR
End Sub
' (SS,12/4/18) returns true if string only contains following characters which we found safe to use in Payzone
Function IsPayzoneSafeString(AStr)
Dim LValid, i, LChar, LCharCode
' from https://www.w3schools.com/html/html_charset.asp
' only allow space, 0 to 9, A to Z, a to z
' also allow dash, comma and fullstop
LValid = True
For i = 1 To Len(AStr)
LChar = Mid(AStr, i, 1)
If LChar = "" Then
LCharCode = 0
Else
LCharCode = Asc(UCase(Left(LChar, 1)))
End If
LValid = (LCharCode >= 48 And LCharCode <= 57) Or (LCharCode >= 65 And LCharCode <= 90) Or LCharCode = 32 Or LCharCode = 44 Or LCharCode = 45 Or LCharCode = 46
If Not LValid Then Exit For
Next
IsPayzoneSafeString = LValid
End Function
' (SS,28/3/18) outputs the input field and adds to FPayzoneStringToHash
' If AIncludeInForm is true then is including in both form and digest, if false then digest only
Sub AddPayzoneField(AFieldName, AFieldValue, AMaxLength, AIncludeInForm)
Dim LFieldValue, LFieldValueEncoded
If AMaxLength = 0 Then
LFieldValue = AFieldValue
Else
LFieldValue = Left(AFieldValue, AMaxLength)
End If
' add to string to hash
'If AFieldName = "CallbackURL" Then
' LFieldValueEncoded = ReplaceStr(LFieldValue, "&", "%26")
'Else
' LFieldValueEncoded = HTMLEncode(LFieldValue)
'End If
' LFieldValueEncoded = HTMLEncode(AFieldValue) ' use this once their issue is resolved
' replace ampersand with + (their system currently can't handle special characters)
LFieldValueEncoded = LFieldValue
'LFieldValueEncoded = ReplaceStr(LFieldValue, "&", "+")
'LFieldValueEncoded = ReplaceStr(LFieldValueEncoded, "<", "")
'LFieldValueEncoded = ReplaceStr(LFieldValueEncoded, ">", "")
'LFieldValueEncoded = ReplaceStr(LFieldValueEncoded, """", "")
'LFieldValueEncoded = ReplaceStr(LFieldValueEncoded, "'", "")
' remove special HTML chars (until Payzone correct the issue)
'LFieldValueEncoded = ReplaceStr(LFieldValue, "&", "+")
'LFieldValueEncoded = HTMLEncode(LFieldValueEncoded)
'LFieldValueEncoded = ReplaceStr(LFieldValue, """", """)
'LFieldValueEncoded = AFieldValue
' add the hidden variable to form
If AIncludeInForm Then
Response.Write "<input type=""hidden"" name=""" & AFieldName & """ value=""" & LFieldValueEncoded & """>" & NL
End If
'AddPayzoneStringToHash AFieldName, HTMLEncode(LFieldValue)
AddPayzoneStringToHash AFieldName, LFieldValueEncoded
End Sub
' (4/4/18)
Sub ClearPayzoneStringToHash
' Global FPayzoneStringToHash
FPayzoneStringToHash = ""
End Sub
' (4/4/18)
Sub AddPayzoneStringToHash(AFieldName, AFieldValue)
FPayzoneStringToHash = FPayzoneStringToHash & IIf(FPayzoneStringToHash = "", "", "&") & AFieldName & "=" & AFieldValue
End Sub
' (SS,28/3/18)
Function GetPayzoneHashDigest
Dim LResult
' use SHA1 function of MySQL to create the hash
' (SS,5/4/18) added CAST(AS CHAR) for MySQL server 5.1.x and old ODBC driver, otherwise it returns ????, fine in MySQL 5.7.x on test server
LResult = GetSQLValueAsString("SELECT CAST(SHA1(""" & CleanSQLStr(FPayzoneStringToHash) & """) AS CHAR)")
GetPayzoneHashDigest = LResult
End Function
' (SS,19/12/18) added EmailAddress
Sub ProcessPayzoneCallback
ClearPayzoneStringToHash
Dim LStatusCode, LPreviousStatusCode, LMessage, LPreviousMessage, LCrossReference, LAmount, LCurrencyCode
Dim LOrderNo, LTransactionType, LTransactionDateTime, LOrderDescription
Dim LCustomerName, LAddress1, LAddress2, LAddress3, LAddress4, LCity, LState, LPostCode, LCountryCode, LEmailAddress
Dim LHashDigest, LHashDigestCalculated
LStatusCode = CleanRequestForm("StatusCode")
LMessage = CleanRequestForm("Message")
LPreviousStatusCode = CleanRequestForm("PreviousStatusCode")
LPreviousMessage = CleanRequestForm("PreviousMessage")
LCrossReference = CleanRequestForm("CrossReference")
LAmount = CleanRequestForm("Amount")
LCurrencyCode = CleanRequestForm("CurrencyCode")
LOrderNo = CleanRequestForm("OrderID")
LTransactionType = CleanRequestForm("TransactionType")
LTransactionDateTime = CleanRequestForm("TransactionDateTime")
LOrderDescription = CleanRequestForm("OrderDescription")
LCustomerName = CleanRequestForm("CustomerName")
LAddress1 = CleanRequestForm("Address1")
LAddress2 = CleanRequestForm("Address2")
LAddress3 = CleanRequestForm("Address3")
LAddress4 = CleanRequestForm("Address4")
LCity = CleanRequestForm("City")
LState = CleanRequestForm("State")
LPostCode = CleanRequestForm("PostCode")
LCountryCode = CleanRequestForm("CountryCode")
LEmailAddress = CleanRequestForm("EmailAddress") ' (SS,19/12/18)
LHashDigest = CleanRequestForm("HashDigest")
' show message and abort if no order no specified
If LOrderNo = "" Then
Response.Write("Order No must be specified" & BR & NL)
Exit Sub
End If
AddPayzoneStringToHash "PreSharedKey", GetPayzonePreSharedKey
AddPayzoneStringToHash "MerchantID", GetPayzoneMerchantID
AddPayzoneStringToHash "Password", GetPayzoneGatewayAccountPassword
AddPayzoneStringToHash "StatusCode", LStatusCode
AddPayzoneStringToHash "Message", LMessage
AddPayzoneStringToHash "PreviousStatusCode", LPreviousStatusCode
AddPayzoneStringToHash "PreviousMessage", LPreviousMessage
AddPayzoneStringToHash "CrossReference", LCrossReference
AddPayzoneStringToHash "Amount", LAmount
AddPayzoneStringToHash "CurrencyCode", LCurrencyCode
AddPayzoneStringToHash "OrderID", LOrderNo
AddPayzoneStringToHash "TransactionType", LTransactionType
AddPayzoneStringToHash "TransactionDateTime", LTransactionDateTime
AddPayzoneStringToHash "OrderDescription", LOrderDescription
AddPayzoneStringToHash "CustomerName", LCustomerName
AddPayzoneStringToHash "Address1", LAddress1
AddPayzoneStringToHash "Address2", LAddress2
AddPayzoneStringToHash "Address3", LAddress3
AddPayzoneStringToHash "Address4", LAddress4
AddPayzoneStringToHash "City", LCity
AddPayzoneStringToHash "State", LState
AddPayzoneStringToHash "PostCode", LPostCode
AddPayzoneStringToHash "CountryCode", LCountryCode
AddPayzoneStringToHash "EmailAddress", LEmailAddress ' (SS,19/12/18)
LHashDigestCalculated = GetPayzoneHashDigest
' Response.Write BR & BR & "HashDigest Calculated: " & LHashDigestCalculated & BR & NL
' add to payzonecallbacks log
Dim LSQL
LSQL = "INSERT INTO payzonecallbacks SET OrderNo=" & LOrderNo &_
", SessionID='" & GetSessionID & "'" &_
", DateTimeReceived=NOW()" &_
", StatusCode='" & LStatusCode & "'" &_
", Message='" & Left(CleanSQLStr(LMessage), 255) & "'" &_
", PreviousStatusCode='" & Left(CleanSQLStr(LPreviousStatusCode), 255) & "'" &_
", PreviousMessage='" & Left(CleanSQLStr(LPreviousMessage), 255) & "'" &_
", CrossReference='" & Left(CleanSQLStr(LCrossReference), 255) & "'" &_
", Amount='" & Left(CleanSQLStr(LAmount), 20) & "'" &_
", CurrencyCode='" & Left(CleanSQLStr(LCurrencyCode), 3) & "'" &_
", TransactionType='" & Left(CleanSQLStr(LTransactionType), 10) & "'" &_
", TransactionDateTime='" & Left(CleanSQLStr(LTransactionDateTime), 20) & "'" &_
", OrderDescription='" & Left(CleanSQLStr(LOrderDescription), 256) & "'" &_
", CustomerName='" & Left(CleanSQLStr(LCustomerName), 100) & "'" &_
", Address1='" & Left(CleanSQLStr(LAddress1), 100) & "'" &_
", Address2='" & Left(CleanSQLStr(LAddress2), 100) & "'" &_
", Address3='" & Left(CleanSQLStr(LAddress3), 100) & "'" &_
", Address4='" & Left(CleanSQLStr(LAddress4), 100) & "'" &_
", City='" & Left(CleanSQLStr(LCity), 100) & "'" &_
", State='" & Left(CleanSQLStr(LState), 100) & "'" &_
", PostCode='" & Left(CleanSQLStr(LPostCode), 100) & "'" &_
", CountryCode='" & Left(CleanSQLStr(LCountryCode), 3) & "'" &_
", HashDigestReturned='" & Left(CleanSQLStr(LHashDigest), 100) & "'" &_
", HashDigestCalculated='" & Left(CleanSQLStr(LHashDigestCalculated), 100) & "'"
ExecuteQuery(LSQL)
' (SS,18/4/18)
' AddToPaymentLog "Payzone", "Status = " & LStatusCode & NL & "Message = " & LMessage
' (SS,25/1/21) modified above to following to log extra values: SessionID, Amount, CurrencyCode
Dim LPaymentLog
LPaymentLog = "Status = " & LStatusCode & NL & "Message = " & LMessage & NL
LPaymentLog = LPaymentLog & "SessionID = " & GetSessionID & NL
LPaymentLog = LPaymentLog & "Amount = " & LAmount & NL & "CurrencyCode = " & LCurrencyCode
SetCallbackOrderNoForPaymentLog LOrderNo ' (SS,26/1/21) tells AddToPaymentLog to use OrderNo from callback in case session was lost (which it where it normally gets it from)
AddToPaymentLog "Payzone", LPaymentLog
' if paid then mark the order as paid and send email
If LHashDigest = LHashDigestCalculated And LStatusCode = "0" And LOrderNo <> "" Then
' following will update the status, send email and empty basket
' (SS,25/6/18) calculate the Fee on the amount, 1.25% + 5p
Dim LPaymentProviderFee
LAmount = Round2dp(ParseFloat(LAmount) / 100) ' (SS,26/6/18) amount is in pence, so divde by 100 to convert to pounds
LPaymentProviderFee = Round2dp(Round2dp(LAmount * 0.0125) + 0.05)
' (SS,25/6/18) added new LPaymentProviderFee parameter
' (SS,26/6/18) added two more parameters, PaymentAmountReceived and PaymentProviderSurcharge. PaymentAmountReceived is also sent a value, i.e. ParseFloat(LAmount). The other one (surcharge) is 0.
' (SS,26/6/18) also added PaymentReceivedCurrencyCode, set this to LCurrencyCode
If LCurrencyCode = "826" Then LCurrencyCode = "GBP" ' convert from code to alpha for GBP, note that amount is
ProcessOrderThirdPartyPayment True, LOrderNo, GetSessionID, ptPayzone, LCrossReference, PAYMENT_RECEIVED_STATUS, "", ParseFloat(LAmount), LCurrencyCode, 0, LPaymentProviderFee
Else
'Response.Write("Payment not successful" & BR & NL)
'Response.Write("Status Code is " & LStatusCode & BR & NL)
'If LHashDigest <> LHashDigestCalculated Then
' Response.Write("Hash Digest mismatch" & BR & NL)
'End If
' (SS,6/4/18) show error message and retry button
ShowPaymentFailureAlert ""
SetCreditCardPaymentProviderFailure ' (SS,20/4/18) flag the error
End If
End Sub
' (SS,30/4/18) used by conversion via IsSuccessfulReturnFromPaymentProviderPage to check for successful payment when returning from payment provider
Function PayzoneSuccessfulPayment
PayzoneSuccessfulPayment = CleanRequestForm("StatusCode") = "0"
End Function
' --------------------------
' End of Payzone routines
' --------------------------
' (SS,19/3/13) new for Sage Pay, similar to previous need to specify maximum length
Function GetDescriptionForPaymentProvider(AMaxLength)
GetDescriptionForPaymentProvider = Left(Session("PaymentDescription"), AMaxLength) ' max of x chars '
End Function
' (SS,19/3/13) same as GetNameForWorldPay, i.e. Title, First Name and Surname
Function GetNameForPaymentProvider
GetNameForPaymentProvider = GetNameForWorldPay
End Function
' (SS,15/5/10) rewritten using GetValueFromQuery (1 line of code instead of 6)
Function GetCountryISOCode(ACountry)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
GetCountryISOCode = NB(GetValueFromQuery("CodeA2", "SELECT * FROM countries WHERE Country = '" + CleanSQLStr(ACountry) + "'"))
End Function
' (SS,16/9/20)
Function GetCountryISOCodeA3(ACountry)
GetCountryISOCodeA3 = NB(GetValueFromQuery("CodeA3", "SELECT * FROM countries WHERE Country = '" + CleanSQLStr(ACountry) + "'"))
End Function
' (SS,28/3/18) returns country code in numeric e.g. "826" for UK
Function GetCountryCodeNumeric(ACountry)
GetCountryCodeNumeric = NB(GetValueFromQuery("CodeNumeric", "SELECT * FROM countries WHERE Country = '" + CleanSQLStr(ACountry) + "'"))
End Function
' (SS,16/1/15) returns True if country is UK, uses the ISO code from countries table to determine this
Function IsUK(ACountry)
IsUK = GetCountryISOCode(ACountry) = "GB"
End Function
' (SS,16/2/21) for EORI checking
Function IsEU(ACountry)
IsEU = GetPostalArea(ACountry) = "EU"
End Function
' (SS,12/2/21) added for Brexit, returns true if country is UK and postcode starts with BT
Function IsNorthernIreland(ACountry, APostcode)
If IsUK(ACountry) Then
IsNorthernIreland = UCase(Mid(Trim(APostcode), 1, 2)) = "BT"
Else
IsNorthernIreland = False
End If
End Function
' (SS,16/1/15) to use a setting, for now it returns True
Function UseDeliveryPostcodes
UseDeliveryPostcodes = FUseDeliveryPostcodes ' (SS,10/4/15) replaced True with FUseDeliveryPostcodes
End Function
' (SS,20/11/14) returns Country Name for given 2 letter ISO Code
Function GetCountryNameForCode(ACountryCode)
GetCountryNameForCode = NB(GetValueFromQuery("Country", "SELECT * FROM countries WHERE CodeA2 = '" + CleanSQLStr(ACountryCode) + "' ORDER BY SortOrder"))
End Function
' (SS,19/12/13) returns EU country code for VAT number checking purposes
' EU has two exception, Greece ISO "GR" is "EL", United Kingdom ISO "UK" is "GB"
Function GetEUCountryCode(ACountry)
Dim LISO
LISO = GetCountryISOCode(ACountry)
If LISO = "UK" Then
GetEUCountryCode = "GB"
ElseIf LISO = "GR" Then
GetEUCountryCode = "EL"
Else
GetEUCountryCode = LISO
End If
End Function
' (SS,15/5/10)
Function GetCountryVATNumberFormat(ACountry)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
GetCountryVATNumberFormat = NB(GetValueFromQuery("VATNumberFormat", "SELECT * FROM Countries WHERE Country = '" + CleanSQLStr(ACountry) + "'"))
End Function
' (SS,20/2/12) returns ChargeVAT flag from countries table for given country, True is returned if country not found
' (SS,3/2/23) added cache feature to reduce the number of queries, as much as 85 on HF, 20 on CIRC home pages
Function GetCountryChargeVATFlag(ACountry)
Dim LChargeVAT
If ACountry = "" Then
LChargeVAT = True
Else
' (SS,3/2/23) this routine i.e. SQL was being run multiple times (once per product?) for HF home page, this could be as much as 85 times
' 20 times for CIRC, for HF search with 120 (full page) results it was 251 times
' added the following "if" to cache the result for given country, only looked up if not done before or if country changes
' if country hasn't changed then return the previously looked up value, else lookup the vat from the countries
If FChargeVATFlagCountry = ACountry Then
LChargeVAT = FChargeVATFlag
Else ' (SS,3/2/23) as before, look up the VAT charge flag
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,3/2/23) change Countries to countries in following, we always use lower case for table names
LChargeVAT = GetValueFromQuery("ChargeVAT", "SELECT ChargeVAT FROM countries WHERE Country = '" + CleanSQLStr(ACountry) + "'")
' (SS,26/2/15) replaced LChargeVAT = Null with IsNull(LChargeVAT) to fix bug where country wasn't found and LChargeVAT = Null still returned false
If IsNull(LChargeVAT) Then
LChargeVAT = True
Else
LChargeVAT = IntToBool(LChargeVAT)
End If
' (SS,3/2/23) save for next time to avoid running above query multiple times per page
FChargeVATFlag = LChargeVAT
FChargeVATFlagCountry = ACountry
End If
End If
GetCountryChargeVATFlag = LChargeVAT
End Function
' (SS,15/5/10) validate VAT number according to http://customs.hmrc.gov.uk/channelsPortalWebApp/channelsPortalWebApp.portal?_nfpb=true&_pageLabel=pageVAT_RatesCodesTools&propertyType=document&columns=1&id=HMCE_CL_001721#P100_1122
' (SS,11/8/16) renamed from IsVATNumberValid to IsVATNumberFormatValid
Function IsVATNumberFormatValid(ACountry, ANumberToValidate)
Dim i, LLen, LChar, LCharFormat, LValid, LNumberToValidate, LCountryCode, LAllowedFormats
' (SS,11/11/10) if VAT Number validation is not enabled then assume valid
' (SS,20/12/13) added "Not IsIntraCommunitySupply" to not validate VAT number if not applicable, e.g. people in the UK may enter a VAT number which we don't want to validate
' (SS,16/10/14) added special VAT check bypass where "[NV]" is added to end if VAT number, because on rare occasions it might be valid by checking site says it isn't
' (SS,10/08/16) removed Or Not IsIntraCommunitySupply because this relies on DeliveryCountry which isn't set in CheckValidPersonalDetails when checking out, i.e. different delivery address
' therefore we need to force the VAT check no matter what the delivery country
If Not ValidateVATNumber Or Right(ANumberToValidate, 4) = "[NV]" Then
IsVATNumberFormatValid = True
Exit Function
End If
LCountryCode = GetEUCountryCode(ACountry) ' (SS,19/12/13) replaced GetCountryISOCode with GetEUCountryCode because Greece uses "EL" nor "GR" GetEUCountryCode does this correct
LAllowedFormats = GetCountryVATNumberFormat(ACountry)
If ACountry = "" Or LAllowedFormats = "" Then
IsVATNumberFormatValid = False
SetVATNumberExample "" ' (SS,25/5/10)
Exit Function
End If
LLen = Len(ANumberToValidate)
LNumberToValidate = Mid(ANumberToValidate, 3, LLen - 2)
LLen = LLen - 2 ' reduce by 2 because we're now ignoring country prefix
LValid = Mid(ANumberToValidate, 1, 2) = LCountryCode ' valid if first 2 characters match the country code
' Response.Write("<br>Formats: " & LAllowedFormats & "<br>")
Dim LVATFormats, LVATFormat
LVATFormats = Split(LAllowedFormats, ",")
If LValid Then
For Each LVATFormat In LVATFormats
LValid = LLen = Len(LVATFormat) ' default to True if length is the same
'Response.Write("<br>LNumberToValidate: " & LNumberToValidate & "<br>")
'Response.Write("<br>Format: " & LVATFormat & "<br>")
i = 1
Do While LValid And i <= LLen
LCharFormat = Mid(LVATFormat, i, 1)
LChar = Mid(LNumberToValidate, i, 1)
If LCharFormat = "X" Then ' any letter
LValid = IsCharAlpha(LChar)
ElseIf LCharFormat = "Y" Then ' any letter except O and I
LValid = IsCharAlpha(LChar) And LChar <> "O" And LChar <> "I"
ElseIf IsCharNumeric(LCharFormat) Then ' 0 to 9
LValid = IsCharNumeric(LChar)
Else ' i.e. any letter besides X and Y
LValid = LChar = LCharFormat
End If
i = i + 1
Loop
If LValid Then Exit For ' if valid here then it's valid so no need to compare any more
Next
End If
' (SS,25/5/10)
If Not LValid Then
' determine the examples to show in error message prefixed with country code
Dim LExampleVATFormats
LExampleVATFormats = ""
For Each LVATFormat In LVATFormats
LExampleVATFormats = LExampleVATFormats + iif(LExampleVATFormats = "", "", ", ") + LCountryCode + ReplaceStr(LVATFormat, "Y", "X") ' "Y" is also replaced with "X"
Next
SetVATNumberExample tr("e.g.") + " " + LExampleVATFormats
End If
IsVATNumberFormatValid = LValid
End Function
' (SS,25/5/10)
Sub SetVATNumberExample(AVATNumberExample)
FVATNumberExample = AVATNumberExample
End Sub
' (SS,25/5/10)
Function GetVATNumberExample
GetVATNumberExample = FVATNumberExample
End Function
' (SS,6/10/11) added a hidden field and message used for VAT validation in account and checkout forms
Sub AddVATNumberValidationHTML
If IsVATZeroForIntraCommunity And ValidateVATNumber Then
%>
<input name="VATNumberValidated" type="hidden" value="">
<script type="text/javaScript">
ITP_InvalidVATNoMessage = "<%=tr("Following VAT Number is not valid")%>"
</script>
<%
End If
End Sub
' delete all the products form basket for this session that have since been disabled '
Sub DeleteDisabledProductsFromBasket()
Dim LSQL
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "DELETE FROM shoppingbaskets USING shoppingbaskets, products "
LSQL = LSQL + "WHERE shoppingbaskets.SessionID = '" & CleanSQLStr(FSessionID) & "' AND shoppingbaskets.ProductCode = products.ProductCode AND products.ProductDisabled <> 0"
ExecuteQuery LSQL
End Sub
' returns true if basket is empty
' (SS,17/2/04) now calls IsBasketSessionEmpty
' (SS,5/6/07) now calls returns FIsBasketEmpty (whichs is set from initialise using GetIsBasketEmpty)
Function IsBasketEmpty
IsBasketEmpty = FIsBasketEmpty
End Function
' returns true if basket is empty '
' (SS,17/2/04) modified version of IsBasketEmpty with ASessionID as parameter '
' (SS,5/6/07) was IsBasketSessionEmpty, renamed to GetIsBasketEmpty and removed ASession parameter
Function GetIsBasketEmpty
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
GetIsBasketEmpty = NZ(GetValueFromQuery("Count", "SELECT Count(*) As Count FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(FSessionID) & "'")) = 0
End Function
' (SS,21/5/07) returns total number of items in basket
' (SS,12/5/18) added GetShoppingBasketFilter(False) to ignore subproducts (missed from before)
Function GetTotalItemsInBasket
' If IsEmpty used to ensure this query is run maximum of once per session
If IsEmpty(FTotalItemsInBasket) Then
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
FTotalItemsInBasket = NZL(GetValueFromQuery("Items", "SELECT SUM(Qty) As Items FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(FSessionID) & "'"& GetShoppingBasketFilter(False)))
End If
GetTotalItemsInBasket = FTotalItemsInBasket
End Function
' (SS,28/1/08) added following to count how many times a product name token is used, this can be used by customutils.asp to calc delivery
Function GetProductNameTokensInBasket(AToken)
' If IsEmpty used to ensure this query is run maximum of once per session
If IsEmpty(FProductNameTokensInBasket) Then
If AToken = "" Then
FProductNameTokensInBasket = 0
Else
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
FProductNameTokensInBasket = NZL(GetValueFromQuery("Tokens", "SELECT SUM(Qty) As Tokens FROM shoppingbaskets LEFT JOIN products ON shoppingbaskets.ProductCode = products.ProductCode WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND INSTR(products.ProductName, '" + CleanSQLStr(AToken) + "')"))
End If
End If
GetProductNameTokensInBasket = FProductNameTokensInBasket
End Function
' (SS,1/2/13) added following to count how many times a product code prefix is used, e.g. "RMP-" for ready made parcels this can be used by customutils.asp to calc delivery
Function GetProductCodePrefixesInBasket(APrefix)
' If IsEmpty used to ensure this query is run maximum of once per session, prevents running of same query more than once
If IsEmpty(FProductCodePrefixesInBasket) Or FProductCodePrefixesPrefix <> APrefix Then
FProductCodePrefixesPrefix = APrefix
If APrefix = "" Then
FProductCodePrefixesInBasket = 0
Else
FProductCodePrefixesInBasket = NZL(GetSQLValue("SELECT SUM(Qty) FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND LEFT(ProductCode, " & Len(APrefix) & ") = '" + CleanSQLStr(APrefix) + "'"))
End If
End If
GetProductCodePrefixesInBasket = FProductCodePrefixesInBasket
End Function
' (SS,30/10/08) added following to count number of flagged products in basket, this can be used by customutils.asp to calc delivery
' AFlagged should be True to count Flagged products, False to count Unflagged (i.e. the value of the CustomFlag field)
Function GetFlaggedItemsInBasket(AFlagged)
' (SS,18/3/15) added "If InGoogleShoppingDataFeedthis" to handle when doing this check for Google Shopping delivery costs, i.e. there is no basket
If InGoogleShoppingDataFeed Then
GetFlaggedItemsInBasket = NZL(GetValueFromQuery("Count", "SELECT COUNT(*) AS Count FROM products WHERE ProductID = " & GetGoogleShoppingDataFeedProductID & " AND CustomFlag = " + Iif(AFlagged, "TRUE", "FALSE")))
Else
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
GetFlaggedItemsInBasket = NZL(GetValueFromQuery("Count", "SELECT SUM(Qty) As Count FROM shoppingbaskets LEFT JOIN products ON shoppingbaskets.ProductCode = products.ProductCode WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND products.CustomFlag = " + Iif(AFlagged, "TRUE", "FALSE") + GetProductsFilter))
End If
End Function
' (SS,20/2/12)
Sub SetDeliveryCountryCookie
If CleanRequest("cmd") = "recalculate" Then
Dim LSelectedDeliveryCountry
LSelectedDeliveryCountry = CleanRequestForm("DeliveryCountry")
If LSelectedDeliveryCountry <> "" Then
SetCookie "DeliveryCountry", LSelectedDeliveryCountry
End If
End If
End Sub
' (SS,20/2/12) used to change the delivery and invoice country from basket form
' to show the correct delivery and also include/exclude VAT if country is vatable/not vatable
' this routine is also called from GetCurrencyExchangeRate
' invoice country is also changed if it had been the same as delivery country
' this saves user from having to re-enter in the checkout stage, also shows the correct prices inc/exc VAT depending on whether country is vatable
' (SS,28/6/18) added TrackedDeliverySelected
' (SS,29/6/18) minor change (see below)
Sub SetCountryFromBasketForm
If CleanRequest("cmd") = "recalculate" Then ' only do it in basket recalculate
Dim LDeliveryCountrySameAsInvoice, LSelectedDeliveryCountry
LDeliveryCountrySameAsInvoice = Session("Country") = Session("DeliveryCountry")
LSelectedDeliveryCountry = CleanRequestForm("DeliveryCountry")
If LSelectedDeliveryCountry <> "" Then
SetDeliveryCountry(LSelectedDeliveryCountry)
If LDeliveryCountrySameAsInvoice Then
SetInvoiceCountry(LSelectedDeliveryCountry)
End If
End If
' (SS,28/6/18) added following to also allow delivery option (tracking) to be selected
' (SS<29/6/18) changed from TrackedDeliverySelected to DeliveryMethod, and "checked" to "tracked"
If TrackedDeliveryOptionEnabled Then
SetTrackedDeliverySelected(CleanRequestForm("DeliveryMethod") = "tracked")
' (SS,22/4/21) added following foe new expedited delivery
SetExpeditedDeliverySelected(CleanRequestForm("DeliveryMethod") = "expedited")
End If
' (SS,12/2/21) added following for DeliveryWillCollect (Click & Collect) on basket page
If AllowCollection Then ' And AllowCollectionBasketPage Then
' *** To check
Session("DeliveryWillCollect") = CollectionOnlyOrder Or (CleanRequestForm("DeliveryWillCollect") = "checked")
End If
End If
End Sub
' (SS,27/5/07) replaced GetCurrencyCountry with GetDeliveryCountry
Function GetDeliveryCountry
Dim LCountry
If Session("DeliveryCountry") = "" Then
LCountry = Session("Country")
Else
LCountry = Session("DeliveryCountry")
End If
If LCountry = "" Then
LCountry = GetCookie("DeliveryCountry") ' (SS,20/2/12)
' (SS,19/1/15) if country from cookie is no longer valid then ignore it
If LCountry <> "" Then ' two separate ifs used due to ASP's limitation of always calling all condition sections if even previous ones are FALSE in an AND
If Not IsValidCountry(LCountry) Then
LCountry = ""
DeleteCookie "DeliveryCountry" ' (SS,26/2/15) delete invalid cookie, no point keeping it
End If
End If
End If
'If LCountry = "" Then LCountry = FCurrencyCountry
'If LCountry = "" Then LCountry = GetDefaultCountry ' (SS,16/2/12)
' (SS,8/2/21) replaced above with following
If LCountry = "" Then LCountry = GetCountryFromDefault
GetDeliveryCountry = LCountry
End Function
' (SS,19/1/15) Checks that country is valid (exists in countries table) need because countries may have changed e.g. CovDem/CIRC, UK (England) etc. were dropped, and cookie for existing
' customers may hold the old value which no longer exists in the countries table
' (SS,22/1/15) added Enabled = 'Yes'
Function IsValidCountry(ACountry)
IsValidCountry = GetSQLRecordExists("SELECT Country FROM countries WHERE Country = '" & CleanSQLStr(ACountry) & "' AND Enabled = 'Yes'")
End Function
' (SS,16/2/12) sets delivery country in session to given, used in basket page to allow user to calculate delivery for their region without going to checkout stage
Function SetDeliveryCountry(ADeliveryCountry)
If Session("Country") = "" Then Session("Country") = ADeliveryCountry ' default the invoice country as well if not already set
Session("DeliveryCountry") = ADeliveryCountry
End Function
' (SS,27/5/07) replaced GetCurrencyCountry with GetInvoiceCountry
Function GetInvoiceCountry
Dim LCountry
LCountry = Session("Country")
' (SS,2/11/12) added following
' (SS,26/2/15) replaced GetCookie("DeliveryCountry") in following with GetDeliveryCountry which may also call GetCookie("DeliveryCountry")
If LCountry = "" Then LCountry = GetDeliveryCountry
'If LCountry = "" Then LCountry = FCurrencyCountry
'If LCountry = "" Then LCountry = GetDefaultCountry ' (SS,20/2/12)
' (SS,8/2/21) replaced above with following
If LCountry = "" Then LCountry = GetCountryFromDefault
GetInvoiceCountry = LCountry
End Function
' (SS,28/10/22) used to decide whether to display cheque payment option
Function InvoiceCountryIsUK
Dim LInvoiceCountry
LInvoiceCountry = GetInvoiceCountry
If LInvoiceCountry = DEFAULT_CURRENCY_COUNTRY Or LInvoiceCountry = GetDefaultCountry Then
InvoiceCountryIsUK = True
Else
InvoiceCountryIsUK = False
End If
End Function
' (SS,8/2/21) added following to fix issue in Express Music who have UK Mainland as the default country
' called from GetDeliveryCountry and GetInvoiceCountry above
Function GetCountryFromDefault
Dim LCountry
If GetDefaultCountry <> DEFAULT_CURRENCY_COUNTRY Then ' i.e. Express Music ("UK Mainland" <> "United Kingdom")
LCountry = GetDefaultCountry
Else ' (SS,8/2/21) as before
LCountry = FCurrencyCountry
If LCountry = "" Then LCountry = GetDefaultCountry ' (SS,16/2/12)
End If
GetCountryFromDefault = LCountry
End Function
' (SS,20/2/12) sets invoice country in session to given, used in basket page to allow user to set invoice country if they change delivery country
' (SS,12/12/12) corrected to Sub from Function
Sub SetInvoiceCountry(AInvoiceCountry)
Session("Country") = AInvoiceCountry
End Sub
' (SS,9/6/14) get delivery country from session, cookie, GeoIP, save to cookie if necessary
Sub SetCurrencyAndDeliveryCountryCookieFromGeoIP
' don't do a Geo IP lookup if it's not the main products.asp script
' this prevents it running in order-details.asp and other scripts
If Not ScriptIsProducts Or Not GeoIPEnabled Then Exit Sub
Dim LGeoIPCountry, LIPFromQueryString
LGeoIPCountry = ""
LIPFromQueryString = CleanRequestQueryString("ip") ' used for testing purposes, to override the remote IP
' if currency code or delivery country cookie is not set then lookup from GeoIP and save to cookie
If Session("DeliveryCountry") = "" Or Session("CurrencyCode") = "" Then
If Session("DeliveryCountry") = "" Then
Session("DeliveryCountry") = GetCookie("DeliveryCountry")
' (SS,6/2/15) if country from cookie is no longer valid then ignore it
If Session("DeliveryCountry") <> "" Then ' two separate ifs used due to ASP's limitation of always calling all condition sections if even previous ones are FALSE in an AND
If Not IsValidCountry(Session("DeliveryCountry")) Then Session("DeliveryCountry") = ""
End If
If Session("DeliveryCountry") = "" Then
LGeoIPCountry = GetGeoIPCountry(LIPFromQueryString)
Session("DeliveryCountry") = LGeoIPCountry
SetCookie "DeliveryCountry", Session("DeliveryCountry")
End If
End If
If Session("CurrencyCode") = "" Then
Session("CurrencyCode") = GetCookie("CurrencyCode")
If Session("CurrencyCode") = "" Then
If LGeoIPCountry = "" Then LGeoIPCountry = GetGeoIPCountry(LIPFromQueryString) ' if not already looked up above
Session("CurrencyCode") = GetCurrencyCodeForCountry(LGeoIPCountry)
SetCookie "CurrencyCode", Session("CurrencyCode")
End If
End If
End If
End Sub
' (SS,5/6/14) returns country name using the remote IP address, looking up in geo_ip_country table
Function GetGeoIPCountry(AIPAddress)
Dim LIPAddress, LIPAddressInt, LCountryCode, LCountryName
' if IP supplied (used for testing) then use that else use the one from server variables
If AIPAddress = "" Then
LIPAddress = Request.ServerVariables("REMOTE_ADDR")
Else
LIPAddress = AIPAddress
End If
' lookup the country code in geo_ip_country table
LIPAddressInt = IPAddressToInt(LIPAddress)
LCountryCode = ""
If LIPAddressInt <> 0 Then
OpenDatabaseCommon
OpenQueryCommon("SELECT * FROM geo_ip_country WHERE IPStartInteger <= " & LIPAddressInt & " AND IPEndInteger >= " & LIPAddressInt)
If Not EndOfQueryCommon Then
LCountryCode = GetQueryValueCommon("CountryISOCode")
End If
CloseQueryCommon
CloseDatabaseCommon
End If
' lookup the country code in the countries table to get the country name, some codes may have more than one, in which case get the first (sorted by SortOrder)
' if country code is blank or not found then assume default country name
Dim LResult
If LCountryCode = "" Then
LResult = ""
Else
' SortOrderISOCode allows the preferred default to be set when there are more than one
LResult = GetSQLValueAsString("SELECT Country FROM countries WHERE CodeA2 = '" & CleanSQLStr(LCountryCode) & "' ORDER BY SortOrderISOCode, Country")
End If
If LResult = "" Then LResult = GetDefaultCountry
GetGeoIPCountry = LResult
End Function
' (SS,16/11/07)
Function GetVATNumberForIntraCommunity
GetVATNumberForIntraCommunity = Session("VATNumber")
End Function
' (SS,12/12/12) because order confirmation is called outside of session we need to put VAT Number into session for functions like CorrectCurrencyNV to work correctly
Sub SetVATNumberForIntraCommunity(AVATNumber)
Session("VATNumber") = AVATNumber
End Sub
' (SS,23/6/09) help message used to display on create/edit accounts form
Function GetVATNumberHelpMessage
If FunctionExists("CustomVATNumberHelpMessage") Then
GetVATNumberHelpMessage = CustomVATNumberHelpMessage
Else
GetVATNumberHelpMessage = ""
End If
End Function
' (SS,15/1/15) gets voucher from posted form and places in session variable
' added because voucher code on basket page
' (SS,16/2/15) added AVoucherCode parameter
Sub SetVoucherCode(AVoucherCode)
Session("VoucherCode") = AVoucherCode
End Sub
' (SS,15/1/15)
Function GetVoucherCode
GetVoucherCode = Session("VoucherCode")
End Function
' (SS,10/10/16)
Sub ClearVoucherCodeForLocalMode
If IsLocalMode And GetVoucherCode = DISCOUNT_OVERRIDE_VOUCHER_CODE Then
SetVoucherCode ""
End If
End Sub
' (SS,16/1/15) used to get delivery region using given UK postcode
' due to use of PayPal Express, only United Kingdom can be used for UK, no longer can use UK (England), UK (Mainland) etc.
' new table delivery_postcodes holds list of mappings
' returns blank if region couldn't be determined, or postcode is blank
' (SS,6/2/15) new improved version
' (SS,10/2/15) added new AGroupName parameter parameter, which can be blank for normal or main group
' (SS,16/3/15) modified to use OpenQuery2 instead of OpenQuery to prevent clash due to recursive use
' (SS,19/01/15) slight mod to allow 0, e.g. CR0 9DW, some areas can have a 0
' also modified to allow all postcodes, default to DEFAULT_DELIVERY_REGION_UK if not found, also send alert email if an invalid postcode is entered
' (SS,28/7/22) change to not send alert email if postcode not valid for UK on basket page
Function GetDeliveryRegionFromPostcode(APostcode, AGroupName)
' (SS,10/2/15) complete list of postcodes now including here to check if text "ALL" in PostcodeList
Dim LAllPostcodeAreas
LAllPostcodeAreas = "AL,CB,CM,CO,EN,IG,IP,LU,MK,NR,PE,RM,SG,SS,WD," &_
"B,CV,DE,DY,LE,NG,NN,ST,WS,WV," &_
"BD,DH,DL,DN,HD,HG,HU,HX,LN,LS,NE,S,SR,TS,WF,YO," &_
"BB,BL,CA,CW,FY,L,LA,M,OL,PR,SK,SY,TF,WA,WN,CH," &_
"E,EC,N,NW,SE,SW,W,WC," &_
"GU,HA,HP,OX,PO,RG,SL,SN,SO,SP,UB," &_
"BN,BR,CR,CT,DA,KT,ME,RH,SM,TN,TW,BA," &_
"BH,BS,DT,EX,GL,HR,PL,TA,TQ,TR,WR," &_
"CF,LD,LL,NP,SA," &_
"BT," &_
"AB,DD,DG,EH,FK,G,HS,IV,KA,KW,KY,ML,PA,PH,TD,ZE"
Dim LResult, LPostcode, LPrefix, LOutwardNo, LInwardNo, LSuffix
LResult = ""
LPostcode = CorrectPostcodeForUK(APostcode)
' (SS,18/2/15) added CorrectPostcodeForUK which removes extra spaces and hyphens
If SplitPostcode(LPostcode, LPrefix, LOutwardNo, LInwardNo, LSuffix) Then
Dim LPostcodeList, i, LPostcodeItem
Dim LPostcodeArea, LStart, LEnd, LPos, LWhere
' (SS,10/2/15) filter by new GroupName field
LWhere = " WHERE GroupName = '" & CleanSQLStr(AGroupName) & "'"
If AGroupName = "" Then
LWhere = LWhere & " OR GroupName IS NULL OR GroupName = 'Main'"
End If
OpenQuery2("SELECT * FROM delivery_postcodes" & LWhere & " ORDER BY SortOrder, ID")
Do While Not EndOfQuery2
' (SS,10/2/15) check for ALL and replace with full postcode list
LPostcodeList = Trim(GetQueryValue2("PostcodeList"))
If UCase(LPostcodeList) = "ALL" Then LPostcodeList = LAllPostcodeAreas
LPostcodeList = Split(LPostcodeList, ",")
' for each item in postcode list
For i = LBound(LPostcodeList) to UBound(LPostcodeList)
LPostcodeItem = Trim(UCase(LPostcodeList(i))) ' (SS,5/2/15) added Trim to remove spaces, and UCase to convert to uppercase
' determine start and end, assume 0 if no start or end
LStart = ParseFirstInt(LPostcodeItem)
LPos = InStr(LPostcodeItem, "-")
If LPos = 0 Then
LEnd = LStart
Else
LEnd = ParseInt(Mid(LPostcodeItem, LPos + 1))
End If
' (SS,19/1/15) removed following because some areas have 0 e.g. CR0 9DW
' If LStart = 0 Then LStart = 1 ' because 0 isn't a valid number
If LEnd = 0 Then LEnd = 99 ' if LEnd is 0 i.e. not specified then assume maximum
' determine postcode area which can be 1 or 2 letters
LPostcodeArea = ""
If IsCharAlpha(Mid(LPostcodeItem, 1, 1)) Then
LPostcodeArea = Mid(LPostcodeItem, 1, 1)
If IsCharAlpha(Mid(LPostcodeItem, 2, 1)) Then LPostcodeArea = LPostcodeArea + Mid(LPostcodeItem, 2, 1)
End If
' if postcode area matches then match the outward range, if within range then it's a match
' (SS,18/2/15) replaced CInt with ParseInt because LOutwardNo can contain a letter, e.g. EC2M 2RH, SW1W 0NY, E1W 1AB
If LPostcodeArea <> "" And LPostcodeArea = LPrefix Then
'Response.Write("OutwardNo 1:" & LOutwardNo & BR)
If ParseInt(LOutwardNo) >= LStart And ParseInt(LOutwardNo) <= LEnd Then
'Response.Write ("Start: " & LStart & ", End: " & LEnd & ", OutwardNo: " & ParseInt(LOutwardNo) & BR)
LResult = GetQueryValue2("DeliveryRegionCode")
Exit Do
End If
End If
Next
NextQueryRecord2
Loop
CloseQuery2
End If
' (SS,19/3/15) remove ElseIf LPostcode = "" from above and added this to default to the default region, if region not found in delivery postcodes
' if a postcode was entered then an alert email is sent, but customer is allowed to continue to place the order
If LResult = "" Then
LResult = DEFAULT_DELIVERY_REGION_UK
' (SS,28/7/22) added And Not IsBasketPage because this alert was being sent when postcode/zip from a different country entered at checkout stage and later user chooses "United Kingdom" on basket page
If LPostcode <> "" And Not InGoogleShoppingDataFeed And Not IsBasketPage Then ' don't send emails if doing Google Shopping Data Feed
Dim LBody
' added emailing of error message for alert purposes, together with session variables
LBody = LBody & "SessionID = " & GetSessionID
LBody = LBody & NL & "IPAddress = " & Request.ServerVariables("REMOTE_ADDR")
LBody = LBody & NL & "DateTime = " & Now
LBody = LBody & NL & SessionVarList("OrderNoPlaced,AccountID,Title,FirstName,Surname,CompanyName,Address1,Address2,Town,County,Postcode,Country,VATNumber,Telephone,Email,VoucherCode,Subscribe,HearAboutUs" &_
",Message,DeliveryDate,DeliveryWillCollect,DeliveryAddressSameAsInvoice,DeliveryName,DeliveryCompanyName,DeliveryAddress1,DeliveryAddress2,DeliveryTown,DeliveryCounty,DeliveryPostcode,DeliveryCountry")
SendAlertEmail "Invalid postcode entered. Default UK delivery region assumed.", LBody, False
End If
End If
GetDeliveryRegionFromPostcode = LResult
End Function
' (SS,13/9/06)
' (SS,22/10/08) renamed ARemaining parameter to AValue, we're now alerting the user instead of calculating delivery using multiples
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,16/3/15) modified to use Query2 to prevent recursive issue, i.e. OpenQuery replaced with OpenQuery2, GetQueryValue with GetQueryValue2 etc.
' (SS,5/5/21) modified to interpolate if enabled
' (SS,6/5/21) correction to interpolation to use RangeStart instead of Value field
' (SS,10/5/21) correction to interpolation when end reached not no high value found, it now returns the low value (i.e. highest value from last record)
Function GetDeliveryFromTable(ARegionCode, AIsSpecialRegion, AType, AValue)
GetDeliveryFromTable = 0 ' (SS,22/10/08) moved here from 2 different places below
Dim LSQL, LRegionNo
LSQL = "SELECT * FROM deliveryregions WHERE Type = '" + CleanSQLStr(AType) + "'"
If AIsSpecialRegion And Session("DeliveryRegion") <> "" Then
LSQL = LSQL + " AND RegionName = '" + CleanSQLStr(Session("DeliveryRegion")) + "'"
Else
LSQL = LSQL + " AND RegionCode = '" + CleanSQLStr(ARegionCode) + "'"
End If
OpenQuery2(LSQL)
If Not EndOfQuery2 Then
LRegionNo = GetQueryValue2("RegionNo")
Else
LRegionNo = ""
End If
CloseQuery2
' flag error and exit if LRegionNo is not found
If LRegionNo = "" Then
FDeliveryCalculationFailure = True
Exit Function
End If
Dim LRegionField
LRegionField = "Region" & LRegionNo
LSQL = "SELECT * FROM deliverycosts WHERE Type = '" + CleanSQLStr(AType) + "' AND " + LRegionField + " IS NOT NULL ORDER BY Value"
OpenQuery2(LSQL)
' flag error and exit if no records found
If EndOfQuery2 Then
FDeliveryCalculationFailure = True
CloseQuery2
Exit Function
End If
' (SS,22/10/08) added LFound
Dim LFound
LFound = False
' (SS,5/5/21) as before
If Not DeliveryInterpolationEnabled Then
Do While Not EndOfQuery2
If CDbl(GetQueryValue2("Value")) >= AValue Then
LFound = True ' (SS,22/10/08)
Exit Do
End If
NextQueryRecord2
Loop
' (SS,22/10/08) signal failure if not found
If LFound Then
GetDeliveryFromTable = CDbl(GetQueryValue2(LRegionField))
Else
FDeliveryCalculationFailure = True
End If
Else ' interpolated version if DeliveryInterpolationEnabled
Dim LLowValue, LHighValue, LLowCost, LHighCost
LLowValue = -1 ' used to detect if there was a previous value
Do While Not EndOfQuery2
If CDbl(GetQueryValue2("RangeStart")) > AValue Then
LFound = True
LHighValue = CDbl(GetQueryValue2("RangeStart"))
LHighCost = CDbl(GetQueryValue2(LRegionField))
Exit Do
Else ' i.e. previous values
LLowValue = CDbl(GetQueryValue2("RangeStart"))
LLowCost = CDbl(GetQueryValue2(LRegionField))
End If
NextQueryRecord2
Loop
' if found then use the next record as the high value
If LFound Then
' if end reached or outside of threshold then just use this low value (i.e. no interpolation)
If LLowValue = -1 Or LLowValue < DeliveryInterpolationStartThreshold Then
GetDeliveryFromTable = LLowCost ' (SS,6/5/21) fixed bug was LLowValue, should have been LLowCost
Else
LHighValue = CDbl(GetQueryValue2("RangeStart"))
LHighCost = CDbl(GetQueryValue2(LRegionField))
If LHighValue <= DeliveryInterpolationEndThreshold Then
Dim LValueDiff, LCostDiff, LWeightRatio
LValueDiff = LHighValue - LLowValue
LCostDiff = LHighCost - LLowCost
LWeightRatio = (AValue - LLowValue) / LValueDiff
GetDeliveryFromTable = Round2dp(LLowCost + (LCostDiff * LWeightRatio))
If False Then
' *** DEBUG CODE ***
Response.Write " *** DELIVERY INTERPOLATION ***" & BR
Response.Write " ARegionCode: " & ARegionCode & BR
Response.Write " AValue: " & AValue & BR
Response.Write " DeliveryInterpolationStartThreshold: " & DeliveryInterpolationStartThreshold & BR
Response.Write " DeliveryInterpolationEndThreshold: " & DeliveryInterpolationEndThreshold & BR
Response.Write " LLowValue: " & LLowValue & ", LHighValue: " & LHighValue & BR
Response.Write " LLowCost: " & LLowCost & ", LHighCost: " & LHighCost & BR
Response.Write " LValueDiff: " & LValueDiff & BR
Response.Write " LCostDiff: " & LCostDiff & BR
Response.Write " LWeightRatio: " & LWeightRatio & BR
Response.Write " Interpolated Delivery: " & Round2dp(LLowCost + (LCostDiff * LWeightRatio)) & BR
Response.Write " *** DELIVERY INTERPOLATION END ***" & BR
End If
Else ' as before, i.e. no interpolation
GetDeliveryFromTable = LHighCost
End If
End If
NextQueryRecord2
Else ' i.e. end point not found, high cost will not be set, so use LLowCost instead i.e. last valid value
' Response.Write "####GetDeliveryFromTable ***LLowCost**" & LLowCost & BR
' (SS,10/5/21) not found then flag failure to calling routine with -1
' but don't set FDeliveryCalculationFailure to True, because for HF this routine is called again with lower adjusted weight
' and we don't want a failure with higher total weight because adjusted weight (lower) may be okay
' FDeliveryCalculationFailure = True
' Had set to -1, later changed to LLowCost, for HF last range is allowed for UK, CustomGetDelivery can check for this
GetDeliveryFromTable = LLowCost
End If
End If
CloseQuery2
End Function
' (SS,5/5/21) nre delivery table interpolation, i.e. filling in the in-between values
Function DeliveryInterpolationEnabled
DeliveryInterpolationEnabled = FDeliveryInterpolationEnabled
End Function
Function DeliveryInterpolationStartThreshold
DeliveryInterpolationStartThreshold = FDeliveryInterpolationStartThreshold
End Function
Function DeliveryInterpolationEndThreshold
DeliveryInterpolationEndThreshold = FDeliveryInterpolationEndThreshold
End Function
' (SS,18/2/04) added application delivery values previously was hard code '
' (SS,4/11/04) modified to use GetPostalArea and GetDeliveryCostForPostalArea '
' also renamed from GetDeliveryCost to GetDeliveryCostForCountry
' (SS,12/9/06) added AWeightOfGoods
' (SS,27/5/07) was GetDeliveryCostForCountry, also removed ACountry parameter
' (SS,28/5/07) added AVATContent which is the VAT content of goods, if PricesEnteredIncludeVAT then ATotalPriceOfGoods includes VAT
' (SS,21/10/08) amendments for custom delivery to pass on postcode and to work in conjunction with normal by price/weight calculations
' (SS,22/10/08) added AFlaggedWeight and ANonFlaggedWeight, removed the looping facility where it was looping around if price/weight
' was too big, user is now alert if value/weight is too high
Function GetDeliveryCost(ATotalPriceOfGoods, APriceOfNonWeightedGoods, AWeightOfGoods, AFlaggedWeight, ANonFlaggedWeight, AVATContent)
ShowDebug "GetDeliveryCost" ' 12/5/22)
GetDeliveryCost = 0
' (SS,14/11/07) if collection allow and customer has chosen to collect then no delivery charge
' (SS,1/12/16) replaced AllowCollection And Session("DeliveryWillCollect") with GetDeliveryWillCollect
' (SS,31/3/17) added GetDeliveryAddToExistingOrder
' (SS,2/10/17) removed Or GetDeliveryAddToExistingOrder, move below to do a check to make sure customer has an existing order not yet completed
' (SS,15/5/22) discovered a bug which would result in 0 being displayed if user gets as far as the final checkit stage but then clicks
' to go to the basket page, it was showing (for HF) zero delivery cost due to this routine exiting below,
' fixed by adding basket page check using If Not IsBasketPage
' (SS,13/5/22) needs to work for Express Music who have Click & Collected on basket page, added Or AllowCollectionBasketPage to exit
If Not IsBasketPage Or AllowCollectionBasketPage Then
If GetDeliveryWillCollect Then Exit Function
' (SS,2/10/17)
If GetDeliveryAddToExistingOrder And Session("Email") <> "" Then
If CustomerHasExistingOrder(Session("Email")) Then
Exit Function ' i.e. free delivery
End If
End If
End If
Dim LCountry
LCountry = GetDeliveryCountry
'Response.Write ("###Total price:" & ATotalPriceOfGoods - GetVATAmount(ATotalPriceOfGoods) & "####<br>")
'Response.Write ("###Total priced goods:" & APriceOfNonWeightedGoods - GetVATAmount(APriceOfNonWeightedGoods) & "####<br>")
'Response.Write ("###Total weight:" & AWeightOfGoods & "####<br>")
FDeliveryCalculationFailure = False
Dim LDeliveryCost
LDeliveryCost = 0
' (SS,26/5/07) removed following this is now done in GetSettings in the initialisation process
' GetDeliverySettings
Dim LRegionCode
' (SS,5/6/07) modified to get new region code field, GetPostalArea is used if GetRegionCode returns blank
LRegionCode = GetRegionCode(LCountry)
If LRegionCode = "" Then LRegionCode = GetPostalArea(LCountry)
' (SS,16/1/15) moved following here from below, renamed from LPostcode to LDeliveryPostcode
Dim LDeliveryPostcode
LDeliveryPostcode = Session("DeliveryPostcode")
If LDeliveryPostcode = "" Then LDeliveryPostcode = Session("Postcode")
' (SS,16/1/15) if UseDeliveryPostcodes enabled in UK then we determine region from postcode
If UseDeliveryPostcodes And IsUK(LCountry) Then
LRegionCode = GetDeliveryRegionFromPostcode(LDeliveryPostcode, "")
If LRegionCode = "" Then
FDeliveryCalculationFailure = True
SetAlertMessage "Your postcode might be wrong. Please check."
End If
End If
' (SS,13/9/07) replaced IsNull(FDeliveryType) Or FDeliveryType = "" Or FDeliveryType = DT_ORIGINAL with GetDeliveryType
If GetDeliveryType = DT_ORIGINAL Then
GetDeliveryCost = GetDeliveryCostForPostalArea(LRegionCode, ATotalPriceOfGoods)
Exit Function
End If
Dim LByPriceDeliveryCost, LByWeightDeliveryCost
LByPriceDeliveryCost = 0
LByWeightDeliveryCost = 0
' (SS,25/11/08) fixed bug by adding APriceOfNonWeightedGoods > 0 because it was adding delivery when APriceOfNonWeightedGoods was 0
If FIsDeliveryByPrice And APriceOfNonWeightedGoods > 0 Then
' (SS,22/10/08) modified to no longer loop around to calculate using increments, if price too much then shopper is alerted
Dim LTotalPrice
LTotalPrice = APriceOfNonWeightedGoods
' (SS,27/5/07) remove the VATContent if prices include VAT because table contains prices excluding VAT
If PricesEnteredIncludeVAT Then LTotalPrice = LTotalPrice - AVATContent ' use the total price without VAT
' GetDeliveryFromTable will set FDeliveryCalculationFailure to True if it fails
LByPriceDeliveryCost = GetDeliveryFromTable(LRegionCode, FIsDeliverySpecialRegionByPrice, "P", LTotalPrice)
End If
If Not FDeliveryCalculationFailure Then
If FIsDeliveryByWeight Then
' (SS,22/10/08) modified to no longer loop around to calculate using increments, if weight too much then shopper is alerted
Dim LTotalWeight
If FIsDeliveryByWeightFlagged Then
LTotalWeight = AFlaggedWeight
ElseIf FIsDeliveryByWeightNonFlagged Then
LTotalWeight = ANonFlaggedWeight
Else
LTotalWeight = AWeightOfGoods
End If
' GetDeliveryFromTable will set FDeliveryCalculationFailure to True if it fails
' (SS,25/11/08) added "If LTotalWeight > 0 Then" to only do when LTotalWeight isn't zero
If LTotalWeight > 0 Then LByWeightDeliveryCost = GetDeliveryFromTable(LRegionCode, FIsDeliverySpecialRegionByWeight, "W", LTotalWeight)
End If
End If
If Not FDeliveryCalculationFailure Then
' (SS,21/10/08) fixed bug, i.e. 2nd FIsDeliveryByPrice changed to FIsDeliveryByWeight
If FIsDeliveryByPrice And FIsDeliveryByWeight Then
If GetDeliveryType = DT_HIGHEST Then
LDeliveryCost = Iif(LByPriceDeliveryCost > LByWeightDeliveryCost, LByPriceDeliveryCost, LByWeightDeliveryCost)
ElseIf GetDeliveryType = DT_LOWEST Then
LDeliveryCost = Iif(LByPriceDeliveryCost < LByWeightDeliveryCost, LByPriceDeliveryCost, LByWeightDeliveryCost)
Else ' i.e. GetDeliveryType = DT_TOTAL (also if customer delivery is enabled i.e. DT_CUSTOM)
LDeliveryCost = LByPriceDeliveryCost + LByWeightDeliveryCost
End If
ElseIf FIsDeliveryByPrice Then
LDeliveryCost = LByPriceDeliveryCost
Else ' i.e. FIsDeliveryByWeight
LDeliveryCost = LByWeightDeliveryCost
End If
End If
' (SS,22/10/08)
If FDeliveryCalculationFailure Then
SetAlertMessage "Delivery cost could not be determined, please contact us."
End If
' (SS,27/5/07) added following custom delivery code
' (SS,21/10/08) custom delivery calculation moved here from above, to still allow normal delivery by price or delivery by weight calculation to work if enabled
' (SS,21/10/08) modified to pass on postcode and delivery cost calculated above
If Not FDeliveryCalculationFailure And CustomDeliveryEnabled Then
ShowDebug "CustomGetDelivery" ' 12/5/22)
Dim LTotalItems
LTotalItems = GetTotalItemsInBasket
' (SS,21/10/08) added 2 more parameters, LPostcode and LDeliveryCost
' (SS,9/12/14) added LByPriceDeliveryCost, LByWeightDeliveryCost parameters to CustomGetDelivery
' (SS,16/1/15) move postcode code to above and replaced LPostcode with LDeliveryPostcode
LDeliveryCost = CustomGetDelivery(ATotalPriceOfGoods, APriceOfNonWeightedGoods, AWeightOfGoods, AVATContent, LTotalItems, LDeliveryCost, LByPriceDeliveryCost, LByWeightDeliveryCost, LDeliveryPostcode, LRegionCode, Session("DeliveryRegion"), LCountry)
' (SS,22/10/08) if CustomGetDelivery returns -1 then it means it's a delivery calculation failure, so flag it as such
' (SS,19/10/18) added Not IsLocalMode to allow such deliveries in local mode
' i.e. CIRC wanted to deliver to France using a VAT code to not pay VAT, this change allowed it,
' before it was giving a failure while processing error.
If Not IsLocalMode And LDeliveryCost = -1 Then FDeliveryCalculationFailure = True
End If
' (SS,18/10/06) changed GetVATAmount to GetVATAmountToAdd
' (SS,26/5/07) added If PricesEnteredIncludeVAT to only add VAT to delivery if PricesEnteredIncludeVAT
' (SS,20/2/12) replaced GetVATAmountToAdd with GetVATAmountToAddNC, because GetVATAmountToAdd only adds if country is VAT, here we always want to add if PricesEnteredIncludeVAT
' fixes bug which was causing delivery cost to be lower than it show be for RW orders where VAT isn't charged, here we want to add VAT to delivery because it's deducted later
If PricesEnteredIncludeVAT Then LDeliveryCost = LDeliveryCost + GetVATAmountToAddNC(LDeliveryCost)
' (SS,4/10/16) if overriden using local mode then set to overriding amount
If IsDeliveryCostOverride Then
LDeliveryCost = GetDeliveryCostOverride(LDeliveryCost) ' (SS,24/3/17) added LDeliveryCost to allow amount to be factored if applicable
End If
' (SS,21/2/12) added Round2dp to make sure it's rounded to 2 dp, had noticed some orders in clifton where it hadn't been rounded
GetDeliveryCost = Round2dp(LDeliveryCost)
' (SS,22/10/08) removed following asp error message, shopper is now alerted instead
'If FDeliveryCalculationFailure Then
' Err.Raise 8, "AppUtils", "Delivery Calculation Failure" ' raise a user-defined error
'End If
End Function
' (SS,14/9/06)
' (SS,07/6/07) to be removed, will no longer be used
Function ShowSpecialDeliveryRegion
ShowSpecialDeliveryRegion = False
Dim LHasDeliveryByPriceItems, LHasDeliveryByWeightItems
' determine whether by price or by weight items are in basket
' (SS,26/10/18) added False parameter to GetOrderItemsQuery to exclude subproducts
OpenQuery(GetOrderItemsQuery(Session.SessionID, False))
Do While Not EndOfQuery
If NZ(GetQueryValue("PostalWeight")) = 0 Then
LHasDeliveryByPriceItems = True
Else
LHasDeliveryByWeightItems = True
End If
NextQueryRecord
Loop
CloseQuery
If Not (FIsDeliverySpecialRegionByPrice Or FIsDeliverySpecialRegionByWeight) Then
Exit Function
End If
If (FIsDeliverySpecialRegionByPrice And LHasDeliveryByPriceItems) Or (FIsDeliverySpecialRegionByWeight And LHasDeliveryByWeightItems) Then
ShowSpecialDeliveryRegion = True
End If
End Function
' (SS,14/9/06)
Function GetCriteriaForDeliveryRegionCombo
If FIsDeliverySpecialRegionByPrice Then
GetCriteriaForDeliveryRegionCombo = "Type='P'"
Else
GetCriteriaForDeliveryRegionCombo = "Type='W'"
End If
End Function
' (SS,14/5/09) now calls GetDeliveryCostInfo, code from here to GetDeliveryCostInfo
Sub ShowDeliveryCostInfo()
Response.Write(GetDeliveryCostInfo)
End Sub
' (SS,4/11/04) for showing in customer info '
' (SS,24/6/05) improved by not showing duplicates if single charge, i.e. not below or above '
' (SS,6/7/05) added Iif(Application("UKText") etc to override the default country names '
' (SS,11/6/07) replaced Application variables with functions
' (SS,14/5/09) added this due to customerinfo being held in sitedetails to return as a string
' code taken from ShowDeliveryCostInfo, which now calls this
' Response.Write replaced with LResult = LResult &
' ShowDeliveryCostForArea replaced with LResult = LResult & GetDeliveryCostForArea, ShowDeliveryMatrix with GetDeliveryMatrix
Function GetDeliveryCostInfo()
Dim LResult
LResult = ""
If GetDeliveryType = DT_ORIGINAL Then
LResult = LResult & GetDeliveryCostForArea("UK", Iif(DeliveryUKText = "", "UK Mainland", DeliveryUKText))
LResult = LResult & GetDeliveryCostForArea("EU", Iif(DeliveryEUText = "", "Europe", DeliveryEUText))
LResult = LResult & GetDeliveryCostForArea("RW", Iif(DeliveryRWText = "", "Rest of the World", DeliveryRWText))
LResult = LResult & "<br>"
Else
If FIsDeliveryByPrice Then LResult = LResult & GetDeliveryMatrix("P", "", True, True)
If FIsDeliveryByWeight Then LResult = LResult & GetDeliveryMatrix("W", "", True, True)
End If
GetDeliveryCostInfo = LResult
End Function
' (SS,17/10/06)
' (SS,21/10/08) added "& NL" to end of table rows to make code more readable
' (SS,14/5/09) now calls GetDeliveryMatrix
Sub ShowDeliveryMatrix(AType, AValueHeading, AIncVat, AZeroAsFree)
Response.Write(GetDeliveryMatrix(AType, AValueHeading, AIncVat, AZeroAsFree))
End Sub
' (SS,14/5/09) added this due to customerinfo being held in sitedetails to return as a string
' code taken from ShowDeliveryMatrix, which now calls this
' Response.Write replaced with LResult = LResult &
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Function GetDeliveryMatrix(AType, AValueHeading, AIncVat, AZeroAsFree)
' show the region headings
Dim LResult, i, LRegionCount, LValue
OpenQuery("SELECT * FROM deliveryregions WHERE Type = '" + CleanSQLStr(AType) + "' ORDER BY Type, RegionNo")
If AValueHeading = "" Then
AValueHeading = Iif(AType="P" , "Total Price", "Total Weight")
End If
' (SS,10/9/14) added following to use single class for table in Bootstrap called "table"
' also replace td in heading row with th so that Bootstrap applies the correct style
' also added right align for row, and th cell because it was working for td but not th
Dim LTableClass, LTableRowHeadingClass, LTableRowClass
If IsRWD Then
LTableClass = " class=""table table-condensed"" style=""text-align: right"""
LTableRowHeadingClass = " style=""text-align: right"""
LTableRowClass = ""
Else
LTableClass = " class=""delivery_charge"""
LTableRowHeadingClass = " class=""delivery_charge_ttl"""
LTableRowClass = " class=""delivery_charge_row"""
End If
LResult = NL & "<table" & LTableClass & "><tr" & LTableRowHeadingClass & "><th style=""text-align:right"">" & AValueHeading & "</th>"
LRegionCount = 0
Do While Not EndOfQuery
LRegionCount = LRegionCount + 1
LResult = LResult & "<th style=""text-align:right"">" & GetQueryValue("RegionName") & "</th>"
NextQueryRecord
Loop
CloseQuery
LResult = LResult & "</tr>" & NL
' show the delivery costs
OpenQuery("SELECT * FROM deliverycosts WHERE Type = '" + CleanSQLStr(AType) + "' ORDER BY Value")
Do While Not EndOfQuery
LResult = LResult & "<tr" & LTableRowClass & "><td>"
LValue = GetQueryValue("ValueText")
If NB(LValue) <> "" Then
LResult = LResult & LValue
Else
LValue = GetQueryValue("Value")
If AType = "P" Then
If AIncVAT Then
LResult = LResult & CorrectCurrencyWV(LValue)
Else
LResult = LResult & CorrectCurrency(LValue)
End If
Else
LResult = LResult & LValue
End If
End If
LResult = LResult & "</td>"
For i = 1 To LRegionCount
LResult = LResult & "<td>"
LValue = GetQueryValue("Region" & i)
If NB(LValue) = "" Then
LResult = LResult & " "
ElseIf AZeroAsFree And CDbl(LValue) = 0 Then
LResult = LResult & "Free"
Else
If AIncVAT Then
LResult = LResult & CorrectCurrencyWV(LValue)
Else
LResult = LResult & CorrectCurrency(LValue)
End If
End If
LResult = LResult & "</td>"
Next
LResult = LResult & "</tr>" & NL
NextQueryRecord
Loop
CloseQuery
LResult = LResult & "</table>" & NL
LResult = LResult & "<br>" & NL
GetDeliveryMatrix = LResult
End Function
' (SS,24/6/05) '
' (SS,11/6/07) modified to use settings from table instead of Application values from global.asa
' (SS,14/5/09) now calls GetDeliveryCostForArea
Sub ShowDeliveryCostForArea(APostalArea, APostalDesc)
Response.Write(GetDeliveryCostForArea(APostalArea, APostalDesc))
End Sub
' (SS,14/5/09) added this due to customerinfo being held in sitedetails to return as a string
' code taken from ShowDeliveryCostForArea, which now calls this
Function GetDeliveryCostForArea(APostalArea, APostalDesc)
Dim LResult, LBelowDel, LAboveDel
LResult = ""
' NB. LBelowDel & LAboveDel contain Currency Symbol and 0 is set as "Free"
LBelowDel = GetDeliveryCostForInfo(APostalArea, 0)
Dim LLimit
If APostalArea = "UK" Then
LLimit = DeliveryUKLimit
ElseIf APostalArea = "EU" Then
LLimit = DeliveryEULimit
Else
LLimit = DeliveryRWLimit
End If
LAboveDel = GetDeliveryCostForInfo(APostalArea, LLimit)
If LBelowDel = LAboveDel Then
LResult = APostalDesc & ": " & LBelowDel & "<br>"
Else
LResult = APostalDesc & " orders below the value of " & CorrectCurrency(LLimit) & ": " & LBelowDel & "<br>"
LResult = LResult & APostalDesc & " orders above the value of " & CorrectCurrency(LLimit) & ": " & LAboveDel & "<br>"
End If
GetDeliveryCostForArea = LResult
End Function
' (SS,4/11/04) for showing in customer info '
' returns a string with pound sign, or "free" '
Function GetDeliveryCostForInfo(APostalArea, APriceOfGoods)
Dim LDeliveryCost
LDeliveryCost = GetDeliveryCostForPostalArea(APostalArea, APriceOfGoods)
If LDeliveryCost = 0 Then
GetDeliveryCostForInfo = "<strong>Free</strong>"
Else
GetDeliveryCostForInfo = "<strong>" & CorrectCurrency(LDeliveryCost) & "</strong>"
End If
End Function
' (SS,4/11/04) '
' (SS,11/6/07) no longer using Application variables
Function GetDeliveryCostForPostalArea(APostalArea, APriceOfGoods)
Dim LDelivery
If APostalArea = "UK" Or APostalArea = "" Then
If APriceOfGoods >= DeliveryUKLimit Then
LDelivery = DeliveryUKAbove
Else
LDelivery = DeliveryUKBelow
End If
ElseIf APostalArea = "EU" Then
If APriceOfGoods >= DeliveryEULimit Then
LDelivery = DeliveryEUAbove
Else
LDelivery = DeliveryEUBelow
End If
Else ' i.e. RW
If APriceOfGoods >= DeliveryRWLimit Then
LDelivery = DeliveryRWAbove
Else
LDelivery = DeliveryRWBelow
End If
End If
GetDeliveryCostForPostalArea = LDelivery
End Function
' get postal area, UK, EU or RW
Function GetPostalArea(ACountry)
Dim LPostalArea
If ACountry = "" Then
LPostalArea = "UK"
Else
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
'OpenQuery("SELECT PostalArea FROM countries WHERE Country = '" + CleanSQLStr(ACountry) + "'")
'If Not EndOfQuery Then
' LPostalArea = GetFieldValue("PostalArea")
'Else
' LPostalArea = ""
'End If
'CloseQuery
' (SS,16/11/12) replaced with following to prevent clash with main query oRS used by OpenQuery, "" is return if country not found
LPostalArea = GetSQLValueAsString("SELECT PostalArea FROM countries WHERE Country = '" + CleanSQLStr(ACountry) + "'")
If LPostalArea = "" Then LPostalArea = "UK"
End If
GetPostalArea = LPostalArea
End Function
' (SS,5/6/07) returns new RegionCode field from Countries table, blank is returned if not found
Function GetRegionCode(ACountry)
Dim LRegionCode
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
GetRegionCode = NB(GetValueFromQuery("RegionCode", "SELECT RegionCode FROM countries WHERE Country = '" + CleanSQLStr(ACountry) + "'"))
End Function
' (SS,13/3/06) get flag from country table, country is blank or not found then True is returned
' (SS,27/5/07) renamed from IsVATable to IsCountryVATable, also removed ACountry parameter, added LCountry = GetInvoiceCountry
' (SS,11/8/16) delivery country now used to decide whether VAT is charged
Function IsCountryVATable
Dim LCountry, LChargeVAT
' (SS,14/10/13) added If IsSalesPostalAreaInvoice to use delivery country if e.g. delivery to UK and invoice is RW
' most of the time invoice country is used, but on rare occasions e.g. billing address is RW and delivery is UK then we need to charge VAT
'
'If IsSalesPostalAreaInvoice Then
' LCountry = GetInvoiceCountry
'Else
' LCountry = GetDeliveryCountry
'End If
' (SS,11/8/16) replaced above with following, i.e. delivery country is used to decide whether VAT is charged, IsSalesPostalAreaInvoice no longer called
LCountry = GetDeliveryCountry
' if UseVATFlagFromCountries is true then use VAT flag from country else use the old from postal area method
If UseVATFlagFromCountries Then ' (SS,27/5/07) UseVATFlagFromCountries replaces LCase(GetAppSetting("Application", "UseVATFlagFromCountries") = "true")
'If LCountry = "" Then
' LChargeVAT = True
'Else
'OpenQuery("SELECT ChargeVAT FROM Countries WHERE Country = '" + LCountry + "'")
'If Not EndOfQuery Then
' LChargeVAT = GetFieldValue("ChargeVAT") = "Yes"
' (SS,11/5/09) replaced above with following, ChargeVAT field is now TINYINT(1) instead of CHAR(1)
' LChargeVAT = IntToBool(GetFieldValue("ChargeVAT"))
'Else
' LChargeVAT = True
' End If
' CloseQuery
'End If
' (SS,20/12/12) replaced above with new function GetCountryChargeVATFlag
LChargeVAT = GetCountryChargeVATFlag(LCountry)
Else
Dim LPostalArea
If LCountry = "" Then
LPostalArea = "UK"
Else
LPostalArea = GetPostalArea(LCountry)
End If
If Instr("," + VATABLE_REGIONCODES + ",", "," + LPostalArea + ",") = 0 Then
LChargeVAT = False
Else
LChargeVAT = True
End If
End If
IsCountryVATable = LChargeVAT
End Function
' (SS,30/11/07)
Function IsAllowedCountry(ACountry)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT Country FROM Countries WHERE Country = '" + CleanSQLStr(ACountry) + "' AND Enabled='Yes'")
If Not EndOfQuery Then
IsAllowedCountry = True
Else
IsAllowedCountry = False
End If
CloseQuery
End Function
' (SS,14/10/13) uses invoice and delivery country to lookup using the new sales_postal_area_lookup table
' decided in the end not to include the actual table because the logic is quite simple, and there's always an overhead when adding a new table
' INSERT INTO `sales_postal_area_lookup` (`InvoicePostalArea`, `DeliveryPostalArea`, `SalesPostalAreaIsInvoice`) VALUES
' ('UK', 'UK', 1),
' ('EU', 'EU', 1),
' ('RW', 'RW', 1),
' ('UK', 'EU', 1),
' ('EU', 'UK', 1),
' ('RW', 'UK', 0),
' ('RW', 'EU', 0),
' ('UK', 'RW', 1),
' ('EU', 'RW', 1);
' LResult = GetSQLValue("SELECT SalesPostalAreaIsInvoice FROM sales_postal_area_lookup WHERE InvoicePostalArea = '" + CleanSQLStr(LInvoicePostalArea) + "' AND DeliveryPostalArea = '" + CleanSQLStr(LDeliveryPostalArea) + "'")
' If LResult = Null Then
' LResult = 1
' End If
' IsSalesPostalAreaInvoice = IntToBool(LResult)
' (SS,11/8/16) modified to use new method where the delivery country decides whether vatable, see tables below from email of 5/8/16
'Invoice Country Delivery Country Charge VAT Current Charge VAT New
'UK UK Yes Y
'UK EU Yes Y
'UK RW Yes N
'EU EU Yes Y
'EU UK Yes Y
'EU RW Yes N
'RW RW No N
'RW UK Yes Y
'RW EU Yes Y
'When invoicing to EU and VAT No entered:
'Invoice Country Delivery Country VAT No Entered Charge VAT Current Charge VAT New
'EU EU No Yes Y
'EU UK No Yes Y
'EU RW No Yes N
'EU EU Yes No N
'EU UK Yes Yes Y
'EU RW Yes Yes N
' (SS,11/8/16) routine no longer used, VAT is decided by delivery country, routine now redundant, not called
Function IsSalesPostalAreaInvoice
Dim LInvoicePostalArea, LDeliveryPostalArea, LResult
LInvoicePostalArea = GetPostalArea(GetInvoiceCountry)
LDeliveryPostalArea = GetPostalArea(GetDeliveryCountry)
If LInvoicePostalArea = "RW" And (LDeliveryPostalArea = "UK" Or LDeliveryPostalArea = "EU") Then
IsSalesPostalAreaInvoice = False
Else
IsSalesPostalAreaInvoice = True
End If
End Function
' (SS,28/5/07)
Function IsVATRegistered
IsVATRegistered = FVATRegistered
End Function
' (SS,16/11/07)
Function IsVATZeroForIntraCommunity
IsVATZeroForIntraCommunity = FVATZeroForIntraCommunity
End Function
' (SS,17/11/07)
Function GetVATIntraCommunityCountries
GetVATIntraCommunityCountries = FVATIntraCommunityCountries
End Function
' (SS,11/11/10)
Function ValidateVATNumber
ValidateVATNumber = FValidateVATNumber
End Function
' (SS,12/12/12)
Function VATIntraCommunityEmailAlertEnabled
VATIntraCommunityEmailAlertEnabled = FVATIntraCommunityEmailAlertEnabled
End Function
' this VAT rate figure is used when VATBands aren't enabled, or it's used for Delivery Cost if VAT bands are enabled
Function GetVATRate
If FVATRegistered Then
GetVATRate = FVATRate ' (SS,26/5/07) was GetAppSetting("Application", "VATRate")
Else
GetVATRate = 0
End If
End Function
' uses VATRate in settings table to calculate the VAT '
' (SS,16/9/04) discovered error in calculation '
' Price of Goods contains VAT already '
' This requires a different calculation '
Function GetVATAmount(APrice)
' GetVATAmount = CDbl(FormatNumber(APriceOfGoods * GetVATRate, 2)) '
' (SS,16/9/04) above replaced with following '
' (SS,28/5/07) replaced CDbl(FormatNumber..., 2) with Round2dp
GetVATAmount = Round2dp(APrice * (1 - (1 / (1 + GetVATRate))))
End Function
' (SS,17/10/06) similar to GetVATAmount above but adds VAT onto price that
' does not have VAT, (GetVATAmount returns the amount of VAT where given price already includes VAT)
Function GetVATAmountToAdd(APrice)
' (SS,28/5/07) replaced CDbl(FormatNumber..., 2) with Round2dp
GetVATAmountToAdd = Round2dp(GetVATAmountToAddNR(APrice))
End Function
' (SS,22/6/10) added this to do the same as GetVATAmountToAdd with no country check
Function GetVATAmountToAddNC(APrice)
GetVATAmountToAddNC = Round2dp(APrice * GetVATRate)
End Function
' (SS,28/5/07) non rounding version of GetVATAmountToAdd also called from GetVATAmountToAdd
' (SS,22/6/10) now takes IsCountryVATable and IsIntraCommunitySupply into account (mainly to show correct total values on showbasket page when country is not VATable)
Function GetVATAmountToAddNR(APrice)
' GetVATAmountToAddNR = APrice * GetVATRate
' (SS,22/6/10) replaced above with following
If IsCountryVATable And Not IsIntraCommunitySupply Then
GetVATAmountToAddNR = APrice * GetVATRate
Else
GetVATAmountToAddNR = 0
End If
End Function
' (SS,27/5/07) removed ACountry parameter, calls GetInvoiceCountry to get country
' (SS,28/5/07) replaced APriceOfGoods with AVATAmount
' (SS,16/11/07) added Intra Community not VAT feature
Function GetVATIncludedAmount(AVATAmount)
Dim LVATIncludedAmount
If IsCountryVATable Then
LVATIncludedAmount = AVATAmount ' (SS,28/5/07) was GetVATAmount(APriceOfGoods)
' (SS,16/11/07) no VAT if IsVATZeroForIntraCommunity enabled, country is in VATIntraCommunityCountries list and VATNumber has been provided
If IsIntraCommunitySupply Then
LVATIncludedAmount = 0
End If
Else
LVATIncludedAmount = 0
End If
GetVATIncludedAmount = LVATIncludedAmount
End Function
' (SS,16/11/07) returns true if IsVATZeroForIntraCommunity enabled, country is in VATIntraCommunityCountries list and VATNumber has been provided
Function IsIntraCommunitySupply
IsIntraCommunitySupply = False
If IsVATZeroForIntraCommunity And GetVATNumberForIntraCommunity <> "" Then
' (SS,30/10/08) modified to use countries table if GetVATIntraCommunityCountries is "USE TABLE"
If GetVATIntraCommunityCountries = "USE TABLE" Then
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
If IntToBool(GetValueFromQuery("IntraCommunitySupply", "SELECT IntraCommunitySupply FROM countries WHERE Country = '" & CleanSQLStr(GetDeliveryCountry) & "'")) Then
IsIntraCommunitySupply = True
End If
ElseIf InStr("," + GetVATIntraCommunityCountries + ",", "," + GetDeliveryCountry + ",") > 0 Then
IsIntraCommunitySupply = True
End If
End If
End Function
' (SS,27/5/07) removed ACountry parameter, calls GetInvoiceCountry to get country
' (SS,28/5/07) replaced APriceOfGoods with AVATAmount
' (SS,12/12/12) correction to deduct VAT for intracommunity supply for sites where prices include VAT
Function GetVATDeductedAmount(AVATAmount)
Dim LVATDeductedAmount
' (SS,12/12/12) added "And Not IsIntraCommunitySupply" so that VAT is deducted for EU sales where VAT Number is entered for sites that have Prices Entered Inc VAT e.g. HyperFlight
If IsCountryVATable And Not IsIntraCommunitySupply Then
LVATDeductedAmount = 0
Else
LVATDeductedAmount = AVATAmount ' (SS,28/5/07) was GetVATAmount(APriceOfGoods)
End If
GetVATDeductedAmount = LVATDeductedAmount
End Function
' (SS,26/5/07)
Sub GetVATBands
If VATBandsEnabled Then
OpenQuery("SELECT * FROM vatbands ORDER BY SortOrder, VATBand")
FVATBandCount = 0
Do While Not EndOfQuery
FVATBandCount = FVATBandCount + 1
FVATBands(FVATBandCount, 0) = GetQueryValue("VATBand")
FVATBands(FVATBandCount, 1) = NZ(GetQueryValue("VATRate"))
NextQueryRecord
Loop
CloseQuery
End If
End Sub
' (SS,26/5/07) returns the VAT rate for product, takes VAT Bands into account if enabled
' assumes VATBand is in FVATBand
Function GetVATRateForProduct
Dim i, LVATRate
LVATRate = 0
If FVATRegistered Then
If VATBandsEnabled Then
Dim LFound
LFound = False
For i = 1 To FVATBandCount
If FVATBands(i, 0) = FVATBand Then
LVATRate = FVATBands(i, 1)
LFound = True
Exit For
End If
Next
If Not LFound Then SetAlertMessage("VAT Band " + FVATBand + " not found") ' if not found alert user with message
Else
LVATRate = GetVATRate
End If
End If
GetVATRateForProduct = LVATRate
End Function
' (SS,27/5/07) calls GetVATRateForProduct to take VAT Band into account
Function GetVATForProduct(AValue)
Dim LVATRate
LVATRate = GetVATRateForProduct
If PricesEnteredIncludeVAT Then
GetVATForProduct = AValue * (1 - (1 / (1 + LVATRate)))
Else
GetVATForProduct = LVATRate * AValue
End If
End Function
' (SS,23/6/14) adds VAT to given price that excludes VAT
' Used by Galleon, 4 price bands to show inc VAT prices because Google Shopping requires it
Function GetPriceIncVAT(AValue)
GetPriceIncVAT = AValue + GetVATForProduct(AValue)
End Function
' (SS,28/5/07)
Function GetVATLabel
GetVATLabel = FVATLabel
End Function
' (SS,28/5/07)
Sub SetVATLabel(AIsVATDeducted)
If AIsVATDeducted Then
FVATLabel = "VAT Deducted"
ElseIf PricesEnteredIncludeVAT Then
FVATLabel = "VAT Included"
Else
FVATLabel = "VAT"
End If
FVATLabel = tr(FVATLabel) ' (SS,19/3/10) for translation
End Sub
' (SS,19/2/04)
Sub EmptyBasket(ASessionID)
' empty the basket for the session
' (SS,28/12/14) modified to now also delete options missed from before (noticed shopping_basket_options records weren't being deleted, should have been added in 6/7/11)
If ProductOptionsEnabled Then
ExecuteQuery("DELETE t1, t2 FROM shoppingbaskets t1, shopping_basket_options t2 WHERE t1.ItemID = t2.ItemID AND t1.SessionID = '" & CleanSQLStr(ASessionID) & "'")
End If
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
ExecuteQuery("DELETE FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(ASessionID) & "'")
' (SS,6/11/20) calls a custom routine if set to clear extra settings that are applicable to the basket
If FunctionExists("CustomClearExtras") Then CustomClearExtras
End Sub
' (SS,15/6/04) returns true if item is in stock '
' depends on ANumInStock value and AllowProductOrderIfNoStock '
' if AllowProductOrderIfNoStock is True then this function '
' always returns true '
' (SS,24/2/05) if AllowProductOrderIfNoStock is false
' the ANumInStock value when blank is treated is if AllowProductOrderIfNoStock
' is false, i.e. there is always stock.
' (SS,24/3/20) added call to OrderingSuspended
Function InStock(ANumInStock)
If OrderingSuspended Then ' (SS,24/3/20)
InStock = False
Else
' (SS,19/7/10) replaced AllowProductOrderIfNoStock with GetAllowOutOfStockOrdering
If GetAllowOutOfStockOrdering Then
InStock = True
Else
If IsNull(ANumInStock) Then
InStock = True ' (SS,24/2/05) changed to True from False, if blank then instock is assumed '
Else
InStock = (CLng(ANumInStock) > 0)
End If
End If
End If
End Function
' (SS,26/11/20) same as InStock above but also check to make sure the given qty is in stock, added for calculator in GSC
Function InStockQty(ANumInStock, AQty)
If OrderingSuspended Then
InStockQty = False
Else
If GetAllowOutOfStockOrdering Then
InStockQty = True
Else
If IsNull(ANumInStock) Then
InStockQty = True
Else
InStockQty = (CLng(ANumInStock) >= AQty)
End If
End If
End If
End Function
' (SS,20/4/10) similar to InStock but doesn't return True if item out of stock and can be ordered
Function ReallyInStock(ANumInStock)
If IsNull(ANumInStock) Then
ReallyInStock = True
Else
ReallyInStock = (CLng(ANumInStock) > 0)
End If
End Function
' (SS,19/7/10)
Function SetAllowOutOfStockOrdering(AAllowOutOfStockOrdering)
FAllowOutOfStockOrdering = AAllowOutOfStockOrdering
End Function
' (SS,19/7/10)
Function GetAllowOutOfStockOrdering
GetAllowOutOfStockOrdering = FAllowOutOfStockOrdering
End Function
' (SS,16/5/11) called from SetStockInfo, saves NumInStock into global for use by template routines to which NumInStock parameter isn't passed
Sub SetNumInStock(ANumInStock)
FNumInStock = ANumInStock
End Sub
' (SS,16/5/11) gets NumInStock from new global for use by template routines to which NumInStock parameter isn't passed
Function GetNumInStock
GetNumInStock = FNumInStock
End Function
' (SS,16/11/07) used to pass stock info to inc-template-product-detail.asp (rather than adding new parameter)
' (SS,24/3/20) added called to OrderingSuspended and setting appropriate message
Sub SetStockInfo(ANumInStock, ADateStockDue)
SetNumInStock ANumInStock ' (SS,16/5/11) sets NumInStock to be used by routines to which the NumInStock parameter isn't passed
If OrderingSuspended Then
' (SS,24/3/20)
FStockInfo = tr("Ordering temporarily suspended")
ElseIf IsNull(ANumInStock) Then
' always in stock so just say in stock
FStockInfo = tr("In stock")
Else
If Not ShowStockInfo Then
If ANumInStock = 0 Then ' (SS,21/1/09) corrected was LNumInStock
FStockInfo = tr(GetOutOfStockMessage) ' the original out of stock message
Else
FStockInfo = ""
End If
Else
Dim LNumInStock
LNumInStock = CLng(ANumInStock)
If LNumInStock > 0 Then
' (SS,25/6/10) added If ShowStockAmount and Else FStockInfo = tr("In stock")
If ShowStockAmount Then
' (SS,5/12/11) added StockAmountInfoSpec
If StockAmountInfoSpec <> "" Then
FStockInfo = GetStockAmountInfo(LNumInStock, StockAmountInfoSpec)
If FStockInfo = "" Then
FStockInfo = tr("In stock")
Else
FStockInfo = FStockInfo + " " + tr("in stock")
End If
Else
FStockInfo = Iif(LNumInStock > 9, "10+", LNumInStock) & " " & tr("in stock")
End If
Else
FStockInfo = tr("In stock")
End If
Else ' i.e. 0 zero stock
' (SS,23/6/10) set stock availability, i.e. Available in 2 to 3 days,
Dim LStockAvailabilityInfo
LStockAvailabilityInfo = GetStockAvailability
' (SS,20/7/10) if custom stock info enabled then call the custom routine
If CustomStockInfoEnabled Then
FStockInfo = CustomGetStockInfo(ADateStockDue, GetAllowOutOfStockOrdering, LStockAvailabilityInfo)
Else
' (SS,10/5/12) added following for Under Offer attribute added to covdem
If ProductAttributeExists(GetProductIDForProductCode(GetProductCode), "Under Offer") Then
FStockInfo = "Currently under offer"
Else
' (SS,26/7/11) shortened "Currently out of stock" to "Out of stock" due to limited space in related product section
FStockInfo = tr("Out of stock") + ", "
' if date is null or before today then show "soon", else show the date
' (SS,26/5/10) added tr and slight changes to FStockInfo to help with translation
If IsNull(ADateStockDue) Then
' FStockInfo = FStockInfo + tr("more due soon")
' (SS,1/2/16) replaced above "more due soon" with following as requested by Express Music
FStockInfo = FStockInfo + GetPleaseContactForAvailabilityInfo
If LStockAvailabilityInfo <> "" Then FStockInfo = LStockAvailabilityInfo ' (SS,24/6/10) override with stock availability info
Else
If ADateStockDue < Date Then
FStockInfo = FStockInfo + GetPleaseContactForAvailabilityInfo ' (SS,2/1/16) replaced [tr("more due soon")] with GetPleaseContactForAvailabilityInfo
If LStockAvailabilityInfo <> "" Then FStockInfo = LStockAvailabilityInfo ' (SS,24/6/10) override with stock availability info
ElseIf ADateStockDue = Date Then
FStockInfo = FStockInfo + tr("more due today")
Else
' (SS,26/7/11) shortened "more due on" to "more due" due to limited space in related product section
FStockInfo = FStockInfo + tr("more due") & " " & ADateStockDue
End If
End If
' (SS,12/1/11) if Preorder then replaced "Out of stock, more " with "Preorder, ", a bit messy and not multi-language friendly, but quickest and easiest way
If LStockAvailabilityInfo = "Preorder" then FStockInfo = ReplaceStr(FStockInfo, "Out of stock, more ", "Preorder, ")
End If
End If
' (SS,10/6/09) added a red font and bold to make it stand out
' (SS,26/5/10) removed the font stuff
' FStockInfo = "<font color=red><b>" & FStockInfo & "</b></font>"
End If
End If
End If
End Sub
' (SS,2/1/16) added as separate routine because it may also be called from CustomUtils (i.e. CustomGetStockInfo)
Function GetPleaseContactForAvailabilityInfo
GetPleaseContactForAvailabilityInfo = "<a href=""products.asp?page=contact&enquiry=" & URLEncode("Availability of " & GetProductNameNoHTMLEncode(GetProductCode) & " (" & GetProductCode & ")") & """ rel=""nofollow"">contact us</a> for availability"
End Function
' (SS,5/12/11) returns customisable stock range, blank string is returned if stock is 0 or less
' ANoInStock is the amount in stock
' AStockAmountInfoSpec is the specification in format x-y:sss, x-y:sss: x+:sss etc.
' e.g. 1-3:1-3, 3-9:3-9, 10+:10+
' this can be written: 1-3, 3-9, 10+
' GetStockAmountInfo(3, "1-3, 3-9, 10+") will return "3-9"
Function GetStockAmountInfo(ANoInStock, AStockAmountInfoSpec)
GetStockAmountInfo = ""
If AStockAmountInfoSpec = "" Or IsNull(ANoInStock) Or ANoInStock = "" Then Exit Function
If NZ(ANoInStock) <= 0 Then Exit Function ' would fail if ANoInStock was "" and added as Or to above
Dim LPairs, i, LSections, LLeft, LRight, LRange, LStart, LEnd
' separate into pairs using comma
LPairs = Split(AStockAmountInfoSpec, ",")
For i = LBound(LPairs) To UBound(LPairs)
' separate each pair from colon into two sections, hold start-end on the left, and the actual string to show on right
LSections = Split(LPairs(i), ":")
LLeft = Trim(LSections(0))
If UBound(LSections) > 0 Then
LRight = Trim(LSections(1))
Else
LRight = LLeft
End If
' split left to get start and end separated by dash
LRange = Split(LLeft, "-")
LStart = ParseInt(Trim(LRange(0))) ' also removes the + if it was there
If UBound(LRange) > 0 Then
LEnd = ParseInt(Trim(LRange(1)))
Else
LEnd = 0
End If
' if in range, or end is 0 then match found
If LEnd = 0 Or (ANoInStock >= LStart And ANoInStock <= LEnd) Then
GetStockAmountInfo = CStr(LRight)
Exit For
End If
Next
End Function
' (SS,16/11/07) used to pass stock info to inc-template-product-detail.asp (rather than adding new parameter)
Function GetStockInfo
GetStockInfo = FStockInfo
End Function
' (SS,23/6/10) returns true if StockAvailability feature enabled and StockAvailability is not blank, i.e. stock is available to order even if not in stock
' (SS,19/7/10) added GetAllowOutOfStockOrdering which is set per product
Function IsStockAvailable
' (SS,3/8/10) fixed bug which wasn't allowing ordering because they don't have stock availability feature enabled (replaced And with Or)
IsStockAvailable = GetAllowOutOfStockOrdering Or (StockAvailabilityEnabled And GetStockAvailability <> "")
End Function
' (SS,23/6/10)
Function StockAvailabilityEnabled
StockAvailabilityEnabled = FStockAvailabilityEnabled
End Function
' (SS,24/3/20) same as ProductOrderingSuspended but without AProductID, i.e. calls ProductOrderingSuspended with GetProductID
Function OrderingSuspended
OrderingSuspended = ProductOrderingSuspended(GetProductID)
End Function
' (SS,2/10/20) called from checkout stage to fix loophole when items already in basket
Function ProductsInBasketOrderingSuspended
ProductsInBasketOrderingSuspended = ProductOrderingSuspended(0) ' calls ProductOrderingSuspended with 0, special case
End Function
' (SS,6/4/20) new version of OrderingSuspended with AProductID specified, OrderingSuspended above now calls this
Function ProductOrderingSuspended(AProductID)
Dim LResult
If FOrderingSuspended Then
' if flag indicates that ordering is suspended then also do an extra check which allows ordering of particular products to be suspended
If FunctionExists("CustomOrderingSuspended") Then
LResult = CustomOrderingSuspended(AProductID) ' (SS,6/4/20) added AProductID parameter
Else
LResult = True
End If
Else
LResult = False
End If
ProductOrderingSuspended = LResult
End Function
' (SS,5/6/22)
Function AppStatsEnabled
AppStatsEnabled = FAppStatsEnabled
End Function
' (SS,25/6/10) returns list of stock availability fields to use from products and supplier tables
' called from several places, minimises repetitive code
' (SS,20/7/10) added products.AllowOutOfStockOrdering
Function GetStockAvailabilityFieldList
GetStockAvailabilityFieldList = "products.AvailabilityDaysFrom, products.AvailabilityDaysTo, suppliers.AvailabilityDaysFrom AS SupplierAvailabilityDaysFrom, suppliers.AvailabilityDaysTo AS SupplierAvailabilityDaysTo, products.AllowOutOfStockOrdering"
End Function
' (SS,25/6/10) calls SetStockAvailability using the 4 availability fields, minimises repetitive code
Sub SetStockAvailabilityFromFields
SetAllowOutOfStockOrdering IntToBool(GetFieldValue("AllowOutOfStockOrdering")) ' (SS,20/7/10)
SetStockAvailability GetFieldValue("AvailabilityDaysFrom"), GetFieldValue("AvailabilityDaysTo"), GetFieldValue("SupplierAvailabilityDaysFrom"), GetFieldValue("SupplierAvailabilityDaysTo")
End Sub
' (SS,23/6/10) if StockAvailability featured enabled then this sets the availability string
' Product takes priority over supplier over global
Sub SetStockAvailability(AProductAvailabilityDaysFrom, AProductAvailabilityDaysTo, ASupplierAvailabilityDaysFrom, ASupplierAvailabilityDaysTo)
FStockAvailability = "" ' i.e. not available
If Not StockAvailabilityEnabled Then Exit Sub
Dim LDaysFrom, LDaysTo
' get from global
LDaysFrom = FStockAvailableDaysFrom
LDaysTo = FStockAvailableDaysTo
' get from supplier if defined
If NB(ASupplierAvailabilityDaysFrom) <> "" Then
LDaysFrom = CStr(ASupplierAvailabilityDaysFrom)
If NB(ASupplierAvailabilityDaysTo) = "" Then
LDaysTo = ""
Else
LDaysTo = CStr(ASupplierAvailabilityDaysTo)
End If
End If
' get from product if defined
If NB(AProductAvailabilityDaysFrom) <> "" Then
LDaysFrom = CStr(AProductAvailabilityDaysFrom)
If NB(AProductAvailabilityDaysTo) = "" Then
LDaysTo = ""
Else
LDaysTo = CStr(AProductAvailabilityDaysTo)
End If
End If
If LDaysFrom <> "" And LDaysFrom <> "0" Then
' (SS,28/6/10) replaced tr("Available in") with tr("Delivery") as requested by clifton
FStockAvailability = tr("Delivery") & " " & LDaysFrom
If LDaysTo <> "" Then
FStockAvailability = FStockAvailability & " " & tr("to") & " " & LDaysTo
End If
If CInt(LDaysFrom) = 1 And LDaysTo = "" Then
FStockAvailability = FStockAvailability & " " & tr("day")
ElseIf CInt(LDaysFrom) <= -1 Then ' (SS,12/1/11) added preorder if days from is negative
FStockAvailability = "Preorder"
Else
FStockAvailability = FStockAvailability & " " & tr("days")
End If
End If
' DebugLog "###StockAvailability###: From: " & LDaysFrom & " to: " & LDaysTo & " str: " & FStockAvailability
End Sub
' (SS,23/6/10)
Function GetStockAvailability
GetStockAvailability = FStockAvailability
End Function
' (SS,17/2/16)
Function GetStockAvailabilityMicrodata(AProductCode, AProductName, ANumInStock)
' (SS,26/9/17) moved code from here to GetStockAvailabilityForMicrodata below, result LResult with call to new GetProductAvailabilityForMicrodata
GetStockAvailabilityMicrodata = "<link itemprop=""availability"" href=""http://schema.org/" + GetProductAvailabilityForMicrodata(AProductCode, AProductName, ANumInStock) + """ />"
End Function
' (SS,26/9/17) similar to GetStockAvailabilityMicrodata but returns just the value, GetStockAvailabilityMicrodata now calls this to get the value
Function GetProductAvailabilityForMicrodata(AProductCode, AProductName, ANumInStock)
Dim LResult
If ProductDiscontinued(AProductCode, AProductName) Then
LResult = "Discontinued"
Else
If ReallyInStock(ANumInStock) Then
LResult = "InStock"
Else
If IsStockAvailable Then
LResult = "PreOrder"
Else
LResult = "OutOfStock"
End If
End If
End If
GetProductAvailabilityForMicrodata = LResult
End Function
' (SS,15/11/07) returns true if product is discontinued, i.e. if ProductName contains '*discontinued*'
' buy button, out of stock and other stock won't be shown
' ProductCode also passed here for future use, in case another method is used to detect discontinued product
' (SS,16/11/07) added DISCONTINUED_TEXT2 to also do the same for *special order*
Function ProductDiscontinued(AProductCode, AProductName)
ProductDiscontinued = InStr(1, AProductName, DISCONTINUED_TEXT, vbTextCompare) > 0 Or InStr(1, AProductName, DISCONTINUED_TEXT2, vbTextCompare) > 0
End Function
' (SS,2/10/20) returns true if given product has been discontinued, i.e. contains " discontinued" in product name
' slightly different version to above ProductDiscontinued, only requires product code and looks for just " discontinued"
Function ProductIsDiscontinued(AProductCode)
Dim LProductName
LProductName = GetProductNameNoHTMLEncode(AProductCode)
ProductIsDiscontinued = InStr(1, LProductName, " discontinued", vbTextCompare) > 0
End Function
' (SS,18/4/12) stored in session because disabled checked doesn't return a value
Function SetCollectionOnlyOrder(AValue)
Session("CollectionOnlyOrder") = AValue
End Function
' (SS,18/4/12) Session("CollectionOnlyOrder") will be "" when this session variable hasn't been assigned that's why we check for True
Function CollectionOnlyOrder
CollectionOnlyOrder = (Session("CollectionOnlyOrder") = True)
End Function
' this routine gets called by worldpay-callback.asp which is normally requested '
' by worldpay callback when payment has been made or cancelled '
' (SS,16/7/04) added setting of PaymentMethod and PaymentReference fields in Orders table
' (SS,12/8/08) replaced all Request.Form with Request, allowing the query string to be pasted into URL to manually perform a failed callback
' (SS,20/9/12) change to prevent payments when test callback received while in live mode
' (SS,3/3/14) modified to call ProcessOrderThirdPartyPayment
Sub ProcessWorldPayCallback
Dim LSQL, LOrderNo, LSessionID, LStatus, LName, LEmail, LDesc
Dim LtransID, LfuturePayID, LtransStatus, LtransTime, LauthAmount, LauthCurrency
Dim LauthAmountString, LrawAuthMessage, LrawAuthCode, LcallbackPW, LcardType, LcountryMatch, LAVS
' get values from query forms etc (passed on values) '
LOrderNo = CleanSQLStr(CleanRequest("M_OrderNo"))
LSessionID = CleanSQLStr(CleanRequest("M_SessionID"))
LName = CleanSQLStr(CleanRequest("M_Name"))
LEmail = CleanSQLStr(CleanRequest("M_Email"))
LDesc = CleanSQLStr(CleanRequest("M_Desc"))
If LOrderNo = "" Or LSessionID = "" Then
Response.Write("<br><br>Both Order No and Session ID must be specified.<br>")
Exit Sub
End If
' worldpay values '
LtransID = CleanSQLStr(CleanRequest("transID"))
LfuturePayID = CleanSQLStr(CleanRequest("futurePayID"))
LtransStatus = CleanSQLStr(CleanRequest("transStatus"))
LtransTime = CleanSQLStr(CleanRequest("transTime"))
LauthAmount = CleanSQLStr(CleanRequest("authAmount"))
LauthCurrency = CleanSQLStr(CleanRequest("authCurrency"))
LauthAmountString = CleanSQLStr(CleanRequest("authAmountString"))
LrawAuthMessage = CleanSQLStr(CleanRequest("rawAuthMessage"))
LrawAuthCode = CleanSQLStr(CleanRequest("rawAuthCode"))
LcallbackPW = CleanSQLStr(CleanRequest("callbackPW"))
LcardType = CleanSQLStr(CleanRequest("cardType"))
LcountryMatch = CleanSQLStr(CleanRequest("countryMatch"))
LAVS = CleanSQLStr(CleanRequest("AVS"))
' insert the record '
LSQL = "INSERT INTO worldpaycallbacks SET OrderNo=" & LOrderNo &_
", SessionID='" & LSessionID & "'" &_
", Name='" & LName & "'" &_
", Email='" & LEmail & "'" &_
", Description='" & LDesc & "'" &_
", transID='" & LtransID & "'" &_
", futurePayID='" & LfuturePayID & "'" &_
", transStatus='" & LtransStatus & "'" &_
", transTime='" & LtransTime & "'" &_
", authAmount='" & LauthAmount & "'" &_
", authCurrency='" & LauthCurrency & "'" &_
", authAmountString='" & LauthAmountString & "'" &_
", rawAuthMessage='" & LrawAuthMessage & "'" &_
", rawAuthCode='" & LrawAuthCode & "'" &_
", callbackPW='" & LcallbackPW & "'" &_
", cardType='" & LcardType & "'" &_
", countryMatch='" & LcountryMatch & "'" &_
", AVS='" & LAVS & "'"
ExecuteQuery(LSQL)
' if paid then mark the order as paid, if cancelled then mark as cancel '
Dim LPaymentMethod, LPaymentReference
LPaymentMethod = ""
LPaymentReference = ""
If LtransStatus = "Y" Then
' (SS,20/9/12) if in live mode then don't allow test transactions, i.e. only allow rawAuthMessage of cardbe.msg.authorised or paypal.msg.authorised
' this is to prevent potential hacking of test mode in order to receive goods, because Galleon aren't checking payment receipts from WorldPay
Dim LTestTransactionInLiveMode
If GetWorldPayTestMode = "0" Then
If LCase(Trim(LrawAuthMessage)) = "cardbe.msg.authorised" Or LCase(Trim(LrawAuthMessage)) = "paypal.msg.authorised" Then
LTestTransactionInLiveMode = False
Else
LTestTransactionInLiveMode = True
End If
Else ' i.e. site is in worldpay test mode, so treat as normal, send email and mark as paid
LTestTransactionInLiveMode = False
End If
' (SS,20/9/12) added "if" so that payment is ignored if test payment made in live mode
If LTestTransactionInLiveMode Then
LStatus = ""
Else
LStatus = PAYMENT_RECEIVED_STATUS
LPaymentMethod = "WORLDPAY"
LPaymentReference = CleanSQLStr(LtransID)
End If
ElseIf LtransStatus = "C" Then
LStatus = ORDER_CANCELLED_STATUS
Else
LStatus = ""
End If
' set the status and date on the order record (only if it's ORDER PLACED or cancelled or awaiting payment, this prevents a second callback from overwriting the same record, in case user goes back and makes another payment)
If LStatus <> "" Then ' (SS,3/3/14) removed [And LOrderNo <> ""] not necessary
'UpdateOrderStatusForOrderPlaced LOrderNo, LStatus, LPaymentMethod, LPaymentReference
' (SS,3/3/14) replacing above with following (to make consistent with other payment methods, aftering noticing that CustomerID was being set for WorldPay payments in Clifton
' (SS,21/1/15) added "" parameter for PaymentInfo
' (SS,25/6/18) added new PaymentProviderFee parameter i.e. 0 to the end
' (SS,26/6/18) added two more parameters, PaymentAmountReceived and PaymentProviderSurcharge. PaymentAmountReceived is also sent a value, i.e. ParseFloat(LAmount). The other two are 0.
' (SS,26/6/18) also added PaymentReceivedCurrencyCode, set this to LauthCurrency
' (SS,28/6/18) corrected LAmount to LauthAmount
ProcessOrderThirdPartyPayment True, LOrderNo, LSessionID, ptWorldPay, LPaymentReference, LStatus, "", ParseFloat(LauthAmount), LauthCurrency, 0, 0
End If
' email the order if paid '
' (SS,21/9/12) added LStatus <> ""
' (SS,3/3/14) following 3 lines replaced by ProcessOrderThirdPartyPayment above
'If LStatus <> "" And LtransStatus = "Y" Then
' EmailOrder(LOrderNo)
'End If
' empty the basket for the session '
' (SS,3/3/14) following replaced by ProcessOrderThirdPartyPayment above
' EmptyBasket(LSessionID)
End Sub
' this routine gets called by paypal-callback.asp which is normally call '
' by PayPal callback when payment has been made '
' (SS,20/1/15) slight improvement to mark payment as awaiting if status is pending, previously it only did this for echecks
Sub ProcessPayPalCallback
Dim LSQL, LOrderNo, LSessionID, Lbusiness, Lfirst_name, Llast_name
Dim Lpayment_date, Lpayment_gross, Lpayment_type, Lpayment_status, Lpayment_fee, Litem_name
Dim Litem_number, Ltest_ipn, Lquantity, Lmc_currency, Lmc_gross, Lmc_fee, Lshipping
Dim Ltax, Lpayer_status, Lpayer_email, Lpayer_id, Lreceiver_id, Lreceiver_email
Dim Ltxn_type, Ltxn_id, Lverify_sign, Lcharset, Lnotify_version
' get values from query forms etc (passed on values) '
LOrderNo = CleanSQLStr(CleanRequestForm("invoice"))
LSessionID = CleanSQLStr(CleanRequestForm("custom"))
If LOrderNo = "" Or LSessionID = "" Then
Response.Write("<br><br>Both Order No and Session ID must be specified.<br>")
Exit Sub
End If
' PayPal values '
Lbusiness = CleanSQLStr(CleanRequestForm("business"))
Lfirst_name = CleanSQLStr(CleanRequestForm("first_name"))
Llast_name = CleanSQLStr(CleanRequestForm("last_name"))
Lpayment_date = CleanSQLStr(CleanRequestForm("payment_date"))
Lpayment_gross = CleanSQLStr(CleanRequestForm("payment_gross"))
Lpayment_type = CleanSQLStr(CleanRequestForm("payment_type"))
Lpayment_status = CleanSQLStr(CleanRequestForm("payment_status"))
Lpayment_fee = CleanSQLStr(CleanRequestForm("payment_fee"))
Litem_name = CleanSQLStr(CleanRequestForm("item_name"))
Litem_number = CleanSQLStr(CleanRequestForm("item_number"))
Ltest_ipn = CleanSQLStr(CleanRequestForm("test_ipn"))
Lquantity = CleanSQLStr(CleanRequestForm("quantity"))
Lmc_currency = CleanSQLStr(CleanRequestForm("mc_currency"))
Lmc_gross = CleanSQLStr(CleanRequestForm("mc_gross"))
Lmc_fee = CleanSQLStr(CleanRequestForm("mc_fee"))
Lshipping = CleanSQLStr(CleanRequestForm("shipping"))
Ltax = CleanSQLStr(CleanRequestForm("tax"))
Lpayer_status = CleanSQLStr(CleanRequestForm("payer_status"))
Lpayer_email = CleanSQLStr(CleanRequestForm("payer_email"))
Lpayer_id = CleanSQLStr(CleanRequestForm("payer_id"))
Lreceiver_id = CleanSQLStr(CleanRequestForm("receiver_id"))
Lreceiver_email = CleanSQLStr(CleanRequestForm("receiver_email"))
Ltxn_type = CleanSQLStr(CleanRequestForm("txn_type"))
Ltxn_id = CleanSQLStr(CleanRequestForm("txn_id"))
Lverify_sign = CleanSQLStr(CleanRequestForm("verify_sign"))
Lcharset = CleanSQLStr(CleanRequestForm("charset"))
Lnotify_version = CleanSQLStr(CleanRequestForm("notify_version"))
' insert the record '
LSQL = "INSERT INTO paypalcallbacks SET OrderNo=" & LOrderNo &_
", SessionID='" & LSessionID & "'" &_
", business='" & Lbusiness & "'" &_
", first_name='" & Lfirst_name & "'" &_
", last_name='" & Llast_name & "'" &_
", payment_date='" & Lpayment_date & "'" &_
", payment_gross='" & Lpayment_gross & "'" &_
", payment_type='" & Lpayment_type & "'" &_
", payment_status='" & Lpayment_status & "'" &_
", payment_fee='" & Lpayment_fee & "'" &_
", item_name='" & Litem_name & "'" &_
", item_number='" & Litem_number & "'" &_
", test_ipn='" & Ltest_ipn & "'" &_
", quantity='" & Lquantity & "'" &_
", mc_currency='" & Lmc_currency & "'" &_
", mc_gross='" & Lmc_gross & "'" &_
", mc_fee='" & Lmc_fee & "'" &_
", shipping='" & Lshipping & "'" &_
", tax='" & Ltax & "'" &_
", payer_status='" & Lpayer_status & "'" &_
", payer_email='" & Lpayer_email & "'" &_
", payer_id='" & Lpayer_id & "'" &_
", receiver_id='" & Lreceiver_id & "'" &_
", receiver_email='" & Lreceiver_email & "'" &_
", txn_type='" & Ltxn_type & "'" &_
", txn_id='" & Ltxn_id & "'" &_
", verify_sign='" & Lverify_sign & "'" &_
", charset='" & Lcharset & "'" &_
", notify_version='" & Lnotify_version & "'"
ExecuteQuery(LSQL)
' if paid then mark the order as paid and send email
' (SS,19/2/08) added "Or ((Lpayment_type = "echeck") And (Lpayment_status = "Pending"))" for echeck payments
'If ((Lpayment_status = "Completed") Or ((Lpayment_type = "echeck") And (Lpayment_status = "Pending"))) And LOrderNo <> "" Then
' (SS,20/1/15) replaced above with following to prevent pending PayPal order from being cancelled, and mark order as AWAITING_PAYMENT
If (Lpayment_status = "Completed" Or Lpayment_status = "Pending") And LOrderNo <> "" Then
' (SS,19/2/08) added following to make payment as echeck in payment reference field
Dim LStatus
' (SS,16/5/12) added following to set status to awaiting payment if echeck and pending
' (SS,20/1/15) now set to payment received when completed, otherwise awaiting payment
If Lpayment_status = "Completed" Then
LStatus = PAYMENT_RECEIVED_STATUS
Else ' i.e. "Pending"
LStatus = AWAITING_PAYMENT_STATUS
End If
' (SS,21/1/15) removed following for echeck, because it's now saved in new PaymentInfo field below
'If Lpayment_type = "echeck" Then
' Ltxn_id = "echeck " + Ltxn_id
'End If
' following will update the status, send email and empty basket
' (SS,5/10/07) added ptPayPal
' (SS,16/5/12) added LStatus
' (SS,21/1/15) added Lpayment_type + Lpayment_status for new PaymentInfo parameter
' (SS,25/6/18) added new PaymentProviderFee parameter i.e. Lmc_fee to the end (ParseFloat(Lmc_fee))
' (SS,26/6/18) added three more parameters: PaymentReceivedAmount, PaymentReceivedCurrencyCode and PaymentProviderSurcharge.
' PaymentAmountReceived is also set a value, i.e. ParseFloat(Lmc_gross). PaymentReceivedCurrencyCode is set to Lmc_currency and surcharge to 0.
ProcessOrderThirdPartyPayment True, LOrderNo, LSessionID, ptPayPal, Ltxn_id, LStatus, Lpayment_type + " " + Lpayment_status, ParseFloat(Lmc_gross), Lmc_currency, 0, ParseFloat(Lmc_fee)
End If
End Sub
' (SS,20/9/17) process TransferWise bank transfer payments from email. Called from EventHandlers.vbs (Sub ProcessTransferWisePayment) from rule in hMailServer matched to emails from TransferWise
' (SS,21/10/20) change to log passed on Reference value
' (SS,10/8/22) change made to Sub UpdateOrderStatusForOrderPlaced called via ProcessOrderThirdPartyPayment, to fix value too long for PaymentInfo
' Also made a change to EventHandlers.vbs for hMailServer to correct value for Reference, added CleanSQLStrMax to values passed here
Sub ProcessTransferWiseCallback
Dim LInsertSQL, LOrderNo
Dim LAmount, LCurrency, LPayerName, LTransferNumber, LReference
' get values from query forms etc (passed on values)
' (SS,10/8/22) replaced all CleanSQLStr with CleanSQLStrMax to prevent value too long for field errors
LAmount = CleanSQLStrMax(Trim(CleanRequest("Amount")), 100)
LCurrency = CleanSQLStrMax(CleanRequest("Currency"), 20)
LPayerName = CleanSQLStrMax(CleanRequest("PayerName"), 100)
LTransferNumber = CleanSQLStrMax(CleanRequest("TransferNumber"), 100)
LReference = CleanSQLStrMax(CleanRequest("Reference"), 255) ' (SS,21/10/20) added this
If LAmount = "" Then
Response.Write("Amount must be specified")
Exit Sub
End If
Dim LPaymentMethod
If LCurrency = "EUR" Then
LPaymentMethod = ptBankTransferEUR
ElseIf LCurrency = "USD" Then
LPaymentMethod = ptBankTransferUSD
ElseIf LCurrency = "GBP" Then
LPaymentMethod = ptBankTransferGBP ' (SS,29/9/17) renamed ptBankTransfer to ptBankTransferGBP
Else
Response.Write("Currency must be EUR, USD or GBP")
Exit Sub
End If
' insert the record
' (SS,21/10/20) added new reference field (VARCHAR(255)
LInsertSQL = "INSERT INTO transferwise_payment_log SET LogDateTime=NOW()" &_
", Amount='" & LAmount & "'" &_
", CurrencyCode='" & LCurrency & "'" &_
", PayerName='" & LPayerName & "'" &_
", Reference='" & Left(LReference, 255) & "'" &_
", TransferNumber='" & LTransferNumber & "'"
' (SS,29/9/17) removed following, don't know why it was here
'If LOrderNo <> "" Then LSQL = LSQL & ", OrderNo='" & LOrderNo & "'"
' find order number in awaiting payment status, no more than one matching order, and exact same value in same currency
Dim LSQLWhere, LMatchingOrders
' (SS,29/9/17) removed " AND PaymentMethod = '" & LPaymentMethod & "'", no longer checks for matching payment method, no need, e.g. for GBP it could "BANK TRANSFER" for HSBC "BANK TRANSFER - GBP" for TransferWise
LSQLWhere = "WHERE Status = '" & AWAITING_PAYMENT_STATUS & "'" &_
" AND DefaultPaymentCurrencyCode = '" & LCurrency & "' AND ROUND(GrandTotal * DefaultPaymentCurrencyRate, 2) = '" & LAmount & "'"
LMatchingOrders = GetSQLValue("SELECT COUNT(*) FROM orders " + LSQLWhere)
If LMatchingOrders = 1 Then
LOrderNo = GetSQLValueAsString("SELECT OrderNo FROM orders " + LSQLWhere)
Else ' abort if 0 or more than 1 matching orders found
' insert to log without order no
ExecuteQuery(LInsertSQL)
Response.Write("Matching orders found: " & LMatchingOrders)
Exit Sub
End If
' insert to log with order no
LInsertSQL = LInsertSQL & ", OrderNo='" & LOrderNo & "'"
ExecuteQuery(LInsertSQL)
' mark the order as paid and send email
If LOrderNo <> "" Then
' we need to get SessionID because it's not passed on from ePDQ
Dim LSessionID
LSessionID = GetSessionIDForOrder(LOrderNo)
' following will update the status, send email and empty basket
' TransferNumber is used as PaymentReference
Dim LPaymentInfo
LPaymentInfo = "Auto-entry via email" & NL
LPaymentInfo = LPaymentInfo & "Date/Time: " & Now & NL
LPaymentInfo = LPaymentInfo & "Amount: " & LAmount & NL
LPaymentInfo = LPaymentInfo & "Currency: " & LCurrency & NL
LPaymentInfo = LPaymentInfo & "From: " & LPayerName & NL
LPaymentInfo = LPaymentInfo & "Reference: " & LReference & NL ' (SS,21/10/20)
LPaymentInfo = LPaymentInfo & "Transfer No: " & LTransferNumber
' (SS,25/6/18) added new PaymentProviderFee parameter i.e. 0 to the end
' (SS,26/6/18) added three more parameters: PaymentReceivedAmount, PaymentReceivedCurrencyCode and PaymentProviderSurcharge.
' PaymentAmountReceived is to ParseFloat(LAmount). PaymentReceivedCurrencyCode is set to LCurrency and surcharge to 0.
ProcessOrderThirdPartyPayment True, LOrderNo, LSessionID, LPaymentMethod, LTransferNumber, PAYMENT_RECEIVED_STATUS, LPaymentInfo, ParseFloat(LAmount), LCurrency, 0, 0
Response.Write("Payment succesfully applied to order " & LOrderNo & NL)
' send payment received email
Dim LURL, LIPAddress
LIPAddress = GetOrderFieldValue(LOrderNo, "IPAddress")
LURL = GetStoreURL & "/payment-received-email.asp?orderno=" & LOrderNo & "&sid=" & LSessionID & "&ip=" & LIPAddress & "&cmd=email"
GetWebPage(LURL)
Response.Write("Payment Received email sent")
End If
End Sub
' (SS,24/11/11) send payment mismatch email,
' (SS,17/4/18) was used by ProcessGoogleCheckoutCallback, not used anymore, perhaps add to other payment methods in future
Sub SendPaymentMismatchEmail(APaymentProvider, AOrderNo, AOrderTotal, APaymentReceived)
Dim LSubject, LBody
LSubject = "PAYMENT MISMATCH ALERT!!! " + APaymentProvider + " for " + GetStoreName
LBody =_
"Order No : " & AOrderNo & NL &_
"Order Total : " & AOrderTotal & NL &_
"Payment Received: " & APaymentReceived
SendEmail FEmailOrderConfirmationBcc1, FEmailOrderConfirmationBcc2, "", FEmailOrderConfirmationFrom, LSubject, LBody, False
End Sub
' (SS,8/9/06)
Function GetSessionIDForOrder(AOrderNo)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT SessionID FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
If Not EndOfQuery Then
GetSessionIDForOrder = GetQueryValue("SessionID")
Else
GetSessionIDForOrder = ""
End If
CloseQuery
End Function
' (SS,5/8/04)
Sub ProcessOrderOnAccount(AOrderNo, ASessionID)
' (SS,21/1/15) added "" for APaymentInfo parameter
' (SS,8/6/18) added 0 to the end, new APaymentReceivedAmount parameter
' (SS,25/6/18) added 0, 0 to the end for new APaymentProviderSurcharge, APaymentProviderFee parameters
' (SS,26/6/18) added "GBP" for new APaymentReceovedCurrencyCode parameter
UpdateOrderStatusForOrderPlaced AOrderNo, PAYMENT_ON_ACCOUNT_STATUS, "ON ACCOUNT", "", 0, "GBP", 0, 0
ProcessOrderFinalise AOrderNo, ASessionID
End Sub
' (SS,28/5/09)
' (SS,6/10/16) renamed from ProcessOrderChequeOrBankTransferPayment to ProcessOrderChequeOrBankTransferOrLocalModePayment
' also changed to set correct status and payment reference
Sub ProcessOrderChequeOrBankTransferOrLocalModePayment(AOrderNo, ASessionID)
' (SS,4/8/17) added following to allow payment method to be overridden with special one e.g "BANK TRANSFER - EUR" or "BANK TRANSFER - USD"
Dim LChosenPaymentType
LChosenPaymentType = GetChosenPaymentType
' (SS,21/6/17) check if bank transfer option chosen i.e. which Bank, UK, EU or USA, if not blank then use this to update the default currency code and rate and get the correct bank details
If IsChosenPaymentBankTransfer Then
Dim LBankTransferOption
LBankTransferOption = CleanRequestForm("banktransferoption")
' Response.Write("##LBankTransferOption" & ":" & LBankTransferOption & "##" & BR)
If LBankTransferOption <> "" Then
Dim LDefaultPaymentCurrencyCode
If LBankTransferOption = "USA" Then
LDefaultPaymentCurrencyCode = "USD"
LChosenPaymentType = ptBankTransferUSD ' (SS,4/8/17)
ElseIf LBankTransferOption = "EU" Then
LDefaultPaymentCurrencyCode = "EUR"
LChosenPaymentType = ptBankTransferEUR ' (SS,4/8/17)
Else ' i.e. UK
LDefaultPaymentCurrencyCode = "GBP"
End If
UpdateOrderDefaultPaymentCurrency AOrderNo, LDefaultPaymentCurrencyCode
UpdateBankTransferDetails(AOrderNo)
End If
End If
' (SS,12/2/15) log the bank transfer details if bank transfer to PaymentLog
' (SS,23/8/17) removed True and added "Bank Transfer Details" to call to AddToPaymentLog
' (SS,18/4/18) added payment log for cheque
If IsChosenPaymentBankTransfer Then
If Session("BankTransferDetails") <> "" Then
AddToPaymentLog "Bank Transfer Details", Session("BankTransferPaymentLine") & NL & Session("BankTransferDetails")
End If
' (SS,18/4/18)
ElseIf IsChosenPaymentCheque Then
AddToPaymentLog "Cheque", ""
End If
' (SS,6/10/16) added following to set awaiting payment for bank transfer or cheque, received for others, also get payment reference from session
Dim LStatus, LPaymentReference
If IsChosenPaymentBankTransfer Or IsChosenPaymentCheque Then
LStatus = AWAITING_PAYMENT_STATUS
Else
LStatus = PAYMENT_RECEIVED_STATUS
End If
If IsLocalMode Then
LPaymentReference = GetLocalModePaymentReference
Else
LPaymentReference = ""
End If
' (SS,21/1/15) added "" for APaymentInfo parameter
' (SS,6/10/16) replaced AWAITING_PAYMENT_STATUS with LStatus and "" with LPaymentReference
' (SS,4/8/17) replaced GetChosenPaymentType with LChosenPaymentType
' (SS,8/6/18) added 0 to the end, new APaymentReceivedAmount parameter, *** may need to change 0 to actual amount
' (SS,25/6/18) added 0, 0 to the end for new APaymentProviderSurcharge, APaymentProviderFee parameters
' (SS,26/6/18) added "GBP" to new APaymentReceivedCurrencyCode parameter
UpdateOrderStatusForOrderPlaced AOrderNo, LStatus, LChosenPaymentType, LPaymentReference, "", 0, "GBP", 0, 0
ProcessOrderFinalise AOrderNo, ASessionID
End Sub
' (SS,10/12/14)
Sub ProcessOrderPayPalExpressPayment(AOrderNo, ASessionID)
' Response.Write "### ProcessOrderPayPalExpressPayment 1 ###<br>"
' (SS,20/1/14) improved to pass back AOrderStatus, APaymentReference, APaymentInfo
' (SS,26/6/18) changed A prefix to L, added LPaymentReceivedAmount, LPaymentReceivedCurrencyCode, LPaymentProviderSurcharge, LPaymentProviderFee
Dim LOrderStatus, LPaymentReference, LPaymentInfo, LPaymentReceivedAmount, LPaymentReceivedCurrencyCode, LPaymentProviderSurcharge, LPaymentProviderFee
' (SS,8/6/18) added new APaymentAmountReceived parameter to PayPalExpressConfirmPayment, and Dim above
' (SS,25/6/18) added new APaymentProviderSurcharge and APaymentProviderFee, and to Dim above
' (SS,26/6/18) renamed APaymentAmountReceived to APaymentReceivedAmount, added APaymentReceivedCurrencyCode, then corrected to use L prefix instead of A
If PayPalExpressConfirmPayment(LOrderStatus, LPaymentReference, LPaymentInfo, LPaymentReceivedAmount, LPaymentReceivedCurrencyCode, LPaymentProviderSurcharge, LPaymentProviderFee) Then
' (SS,10/12/14) NB. marked as PayPal rather than PayPal Express, APaymentReference holds text to indicate express
' (SS,8/6/18) added APaymentAmountReceived to the end, which is the actual amount received
' (SS,25/6/18) added APaymentProviderSurcharge, APaymentProviderFee
' (SS,26/6/18) renamed to use L prefixed instead of A and added LPaymentReceivedCurrencyCode
UpdateOrderStatusForOrderPlaced AOrderNo, LOrderStatus, ptPayPal, LPaymentReference, LPaymentInfo, LPaymentReceivedAmount, LPaymentReceivedCurrencyCode, LPaymentProviderSurcharge, LPaymentProviderFee
ProcessOrderFinalise AOrderNo, ASessionID
' (SS,16/12/14) added following to redirect to final page
If ReturnFromPayPalExpressLaterStage Then SetPageRedirection GetReturnFromPaymentURL
End If
End Sub
' (SS,28/5/09) moved repeated code from ProcessOrderOnAccount, ProcessOrderDirectPayment & ProcessOrderChequeOrBankTransferPayment here
Sub ProcessOrderFinalise(AOrderNo, ASessionID)
UpdateCustomerRecord(AOrderNo) ' (SS,19/12/12) (SS,22/2/13) added to update or add a customer record
EmailOrder(AOrderNo)
EmptyBasket(ASessionID)
Session("AccountID") = "" ' clear the account ID ready for next order '
ShowOrderThankYou AOrderNo, GetStoreName
' (SS,18/4/16) noticed that same was order no was being used if customer places another order and order being overwritten, added following to clear the order and prevent this from happening
' (SS,20/4/16) renamed from ClearOrderNo to StopOrderNoReuse, which clears a flag to prevent order no reuse, allows same order no reuse until new order needs to be created
StopOrderNoReuse
' (SS,6/10/16) clear local mode settings
If IsLocalMode Then ClearLocalModeSettings
' (SS,6/10/16) clear voucher code
Session("VoucherCode") = ""
End Sub
' (SS,14/8/05) called from PayPal auto return browser link and PayPal IPN callback
' (SS,8/9/06) also called from ePDQ
' (SS,5/10/07) added APaymentType
' (SS,16/5/12) added AStatus, which can be AWAITING PAYMENT or PAYMENT RECEIVED, this allows pending paypal echeck to set as AWAITING PAYMENT, completed as PAYMENT RECEIVED
' (SS,21/3/13) modified to cope with SagePay where the callback is only done via browser return
' (SS,21/1/15) added APaymentInfo parameter
' (SS,26/6/18) added new APaymentReceivedAmount, APaymentReceivedCurrencyCode, APaymentProviderSurcharge, APaymentProviderFee parameters
' (SS,22/11/23) fix to same order no being reused by customer bug for payment methods implement here
Sub ProcessOrderThirdPartyPayment(AFromCallback, AOrderNo, ASessionID, APaymentType, APaymentRef, AStatus, APaymentInfo, APaymentReceivedAmount, APaymentReceivedCurrencyCode, APaymentProviderSurcharge, APaymentProviderFee)
If AOrderNo <> "" Then
' if payment hasn't already been processed
If Not CheckPaymentReceived(AOrderNo) Then
' (SS,17/4/18) replaced IsPayPalPayment with APaymentType = ptPayPal because IsPayPalPayment not accurate and was removed
If AFromCallback Or APaymentType = ptPayPal Then
' mark as payment received and send email
Dim LPaymentRef
LPaymentRef = APaymentRef
' if no payment ref defined then create one
If LPaymentRef = "" Then LPaymentRef = "BRWRTN-" & ASessionID ' BRWRTN stands for browser return
' (SS,16/5/12) replaced PAYMENT_RECEIVED_STATUS with AStatus
' (SS,21/1/15) added APaymentInfo
' (SS,8/6/18) added 0 to the end, new APaymentAmountReceived parameter
' (SS,25/6/18) added 0 to the end for new APaymentProviderSurcharge and added new APaymentProviderFee parameter now passed to this routine
' (SS,26/6/18) replaced the 0's with parameter now passed to this routine i.e. APaymentReceivedAmount, APaymentProviderSurcharge
UpdateOrderStatusForOrderPlaced AOrderNo, AStatus, APaymentType, LPaymentRef, APaymentInfo, APaymentReceivedAmount, APaymentReceivedCurrencyCode, APaymentProviderSurcharge, APaymentProviderFee
' (SS,3/3/14) added If to following to only update/add customer record if payment received or awaiting payment status, now called from WorldPay which can have cancelled status
If AStatus = PAYMENT_RECEIVED_STATUS Or AStatus = AWAITING_PAYMENT_STATUS Then
UpdateCustomerRecord(AOrderNo) ' (SS,19/12/12) (SS,22/2/12) added to update or add a customer record
EmailOrder(AOrderNo)
End If
End If
EmptyBasket(ASessionID)
Session("AccountID") = "" ' clear the account ID ready for next order '
End If
' show thank you if from customer's browser (not callback from ThirdParty payment server)
' (SS,21/3/13) Added APaymentType = ptSagePay because SagePay is a special case where callback is done with the browser return
' (SS,5/4/18) added Payzone (ptPayzone) which works like SagePay, i.e. callback done via browser
' (SS,27/4/18) added ptEPDQ which now works the same way (latest account type, not CPI migrated)
' (SS,17/9/20) added ptNetPay
' (SS,20/6/22) added ptClover
' (SS,22/11/23) Neil, HF, bug where customer placed an order, paid via Clover, order was cancelled by NS, but order no got reused and overwrote the original paid for order
' - this was caused by missing call to StopOrderNoReuse (it's in ProcessOrderFinalise above, but was called for following payment methods, ideally it would be efficient to call ProcessOrderFinalise
' - kept the change simple by adding StopOrderNoReuse, Session("AccountID") = "" and Session("VoucherCode") = "" here (no need for EmptyBasket because it would have been called already above via server to server call back)
If Not AFromCallback Or APaymentType = ptSagePay Or APaymentType = ptPayzone Or APaymentType = ptEPDQ Or APaymentType = ptNetPay Or APaymentType = ptClover Then
' (SS,22/11/23) added following 3 lines for orderno reuse bugfix
StopOrderNoReuse ' stops this order no from being reused by this session
Session("AccountID") = "" ' clear the account ID ready for next order
Session("VoucherCode") = "" ' clear the voucher code
ShowOrderThankYou AOrderNo, GetStoreName
End If
End If
End Sub
' (SS,14/8/05) returns true if payment already made for given order, or order completed
' (SS,11/8/20) bug fix to prevent cancelled order reactivation via EPDQ payment browser refresh, by adding check for PaymentReceived
Function CheckPaymentReceived(AOrderNo)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' OpenQuery("SELECT COUNT(*) AS RecCount FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "' AND (Status = '" & PAYMENT_RECEIVED_STATUS & "' OR Status = '" & ORDER_COMPLETED_STATUS & "')")
' CheckPaymentReceived = GetQueryValue("RecCount") > 0
' CloseQuery
' (SS,11/8/20) replaced above with following to fix bug where order is refunded in full and cancelled and was later being paid for when a very old browser session was refreshed
' was happening for CIRC in EPDQ where URL return from EPDQ was a get string with all the values being reposted.
' checking for the PaymentReceived flag being set fixes the issue, i.e. added: "PaymentReceived OR "
CheckPaymentReceived = GetSQLRecordExists("SELECT OrderNo FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "' AND (PaymentReceived OR Status = '" & PAYMENT_RECEIVED_STATUS & "' OR Status = '" & ORDER_COMPLETED_STATUS & "')")
End Function
' (SS,27/6/16) returns true if given order is in given status
Function CheckOrderInStatus(AOrderNo, AStatus)
'Response.Write "###CheckOrderInStatus called with " & AOrderNo & ", " & AStatus & BR
CheckOrderInStatus = GetSQLRecordExists("SELECT OrderNo FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "' AND Status = '" & AStatus & "'")
End Function
' (SS,5/8/04)
' (SS,11/4/12) modified update query to set new PaymentReceived field
' (SS,21/1/15) added APaymentInfo field
' (SS,8/6/18) added new APaymentAmountReceived parameter, new field PaymentAmountReceived was also added to orders
' (SS,25/6/18) added new APaymentProviderSurcharge, APaymentProviderFee
' (SS,26/6/18) renamed APaymentAmountReceived to APaymentReceivedAmount, added APaymentReceivedCurrencyCode
' (SS,10/8/22) added CleanSQLStrMax(255) to PaymentInfo and PaymentReference
Sub UpdateOrderStatusForOrderPlaced(AOrderNo, AStatus, APaymentMethod, APaymentReference, APaymentInfo, APaymentReceivedAmount, APaymentReceivedCurrencyCode, APaymentProviderSurcharge, APaymentProviderFee)
' set the status and date on the order record (only if it's ORDER PLACED, this prevents a second callback from overwriting the same record, in case user goes back and makes another payment)
' (SS,28/5/09) added ORDER_CANCELLED_STATUS in case order become cancelled because customer took too long to pay, I think this may have occurred with Clifton
' (SS,29/5/09) added code to not set DatTimePaid when status is payment on account or awaiting payment
Dim LDateTimePaid
If AStatus = PAYMENT_ON_ACCOUNT_STATUS Or AStatus = AWAITING_PAYMENT_STATUS Then
LDateTimePaid = ""
Else
LDateTimePaid = "DateTimePaid=NOW(), "
End If
' (SS,23/11/09) setting of NewCustomer flag is there is a customer record for this order and customer hasn't ordered before
Dim LNewCustomer
LNewCustomer = False
' if payment received, awaiting payment or payment on account then check if first customer order and flag it as such
If AStatus = PAYMENT_RECEIVED_STATUS Or AStatus = AWAITING_PAYMENT_STATUS Or AStatus = PAYMENT_ON_ACCOUNT_STATUS Then
Dim LCustomerID
LCustomerID = NB(GetValueFromQuery("CustomerID", "SELECT CustomerID FROM orders WHERE OrderNo = " & AOrderNo))
' if there is a customer id then count how many orders placed so far by customer which are not cancelled, order placed not including this one
' if there are zero then set LNewCustomer to true
If LCustomerID <> "" Then
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
If NZD(GetValueFromQuery("OrderCount", "SELECT COUNT(*) AS OrderCount FROM orders WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "' AND Status <> '" & ORDER_CANCELLED_STATUS & "' AND Status <> '" & ORDER_PLACED_STATUS & "' AND OrderNo <> '" & CleanSQLStr(AOrderNo) & "'")) = 0 Then
LNewCustomer = True
End If
End If
End If
' (SS,23/11/09) added
' (SS,11/4/12) added setting PaymentReceived to TRUE or FALSE depending on AStatus
' (SS,8/6/18) added LPaymentAmountReceived
' (SS,26/6/18) renamed LPaymentAmountReceived to LPaymentReceivedAmount
Dim LPaymentReceived, LPaymentReceivedAmount
If AStatus = PAYMENT_RECEIVED_STATUS Then
LPaymentReceived = True
LPaymentReceivedAmount = APaymentReceivedAmount
Else
LPaymentReceived = False
LPaymentReceivedAmount = 0
End If
' (SS,27/11/12) check for cancelled status because items would have been taken out of stock, send alert email
If GetSQLValueAsString("SELECT OrderNo FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "' AND Status = '" & ORDER_CANCELLED_STATUS & "'") <> "" Then
Dim LBody
LBody =_
"Order No: " & AOrderNo & NL &_
"Status: " & AStatus & NL &_
"Payment Method: " & APaymentMethod & NL &_
"Payment Reference: " & APaymentReference
' SendAlertEmail "Cancelled order paid for. Stock may need to be decreased.", LBody
' (SS,18/4/16) added following to automatically decrease stock, and modified alert message
TakeProductsFromStock AOrderNo, True
' (SS,24/8/17) removed following alert email. Perhaps add the above body to PaymentLog in future, replaced with AddToPaymentLog
' SendAlertEmail "Cancelled order paid for. Stock automatically decreased.", LBody, False
AddToPaymentLog "Cancelled order paid for", "Stock automatically decreased" & NL & LBody ' (SS,24/8/17) replaces alert email above
End If
' (SS,25/5/12) added "OR Status = '" & AWAITING_PAYMENT_STATUS & " so that PayPal echeck's that have cleared and were awaiting payment can be set to payment received
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,21/1/14) added new PaymentInfo field
' (SS,8/6/18) added ", PaymentAmountReceived = '" & CleanSQLStr(LPaymentAmountReceived) &
' (SS,25/6/18) added "', PaymentProviderSurcharge = '" & CleanSQLStr(APaymentProviderSurcharge) & "', PaymentProviderFee = '" & CleanSQLStr(APaymentProviderFee) & "'"
' (SS,26/6/18) renamed PaymentAmountReceived to PaymentReceivedAmount, added PaymentReceivedCurrencyCode, split across multiple lines
' (SS,10/8/22) added CleanSQLStrMax(255) to PaymentInfo to prevent value too long which has occurred for TransferWise, also added CleanSQLStrMax(255) to PaymentReference
ExecuteQuery("UPDATE orders SET Status = '" & CleanSQLStr(AStatus) & "', " & LDateTimePaid & "PaymentMethod = '" + CleanSQLStr(APaymentMethod) + "'" &_
", PaymentReference = '" + CleanSQLStr(APaymentReference) + "'" &_
", PaymentInfo = '" + CleanSQLStrMax(APaymentInfo, 255) & "'" &_
", PaymentReceived = " & BoolToInt(LPaymentReceived) &_
", PaymentReceivedAmount = '" & CleanSQLStr(LPaymentReceivedAmount) & "'" &_
", PaymentReceivedCurrencyCode = '" & CleanSQLStr(Left(Trim(APaymentReceivedCurrencyCode), 3)) & "'" &_
", PaymentProviderSurcharge = '" & CleanSQLStr(APaymentProviderSurcharge) & "'" &_
", PaymentProviderFee = '" & CleanSQLStr(APaymentProviderFee) & "'" &_
", NewCustomer = " & BoolToInt(LNewCustomer) &_
" WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "' AND (Status = '" & ORDER_PLACED_STATUS & "' OR Status = '" & ORDER_CANCELLED_STATUS & "' OR Status = '" & AWAITING_PAYMENT_STATUS & "')")
End Sub
' (SS,11/8/05)
Sub UpdateOrderCardDetails(AOrderNo)
Dim LSQL
' (SS,12/6/12) added CleanSQLStr before AOrderNo to prevent SQL injection
LSQL = "UPDATE orders SET CardType='" & CleanSQLStr(Session("CardType")) & "'" &_
", CardNumber=AES_ENCRYPT('" & CleanSQLStr(SimpleEncryptString(Session("CardNumber"))) & "', 'itp123')" &_
", CardHoldersName='" & CleanSQLStr(Session("CardHoldersName")) & "'" &_
", CardSecurityCode='" & CleanSQLStr(Session("CardSecurityCode")) & "'" &_
", CardIssueNumber='" & CleanSQLStr(Session("CardIssueNumber")) & "'" &_
", CardValidFrom='" & CleanSQLStr(Session("CardValidFromMonth") + "/" + Session("CardValidFromYear")) & "'" &_
", CardExpiryDate='" & CleanSQLStr(Session("CardExpiryMonth") + "/" + Session("CardExpiryYear")) & "'" &_
" WHERE OrderNo='" & CleanSQLStr(AOrderNo) & "'"
ExecuteQuery(LSQL)
End Sub
' (SS,17/11/04) sets javascript alert message call "onload" of body '
' can be called more than once, each new message is separated by newline
' (SS,4/6/09) added check for "", only adds if AMessage <> ""
' (SS,22/7/10) noticed that the alert wasn't appearing when message contained double quote
' escaped using \ to fix this for single and double quotes
Sub SetAlertMessage(AMessage)
If AMessage <> "" Then
If gsITP_ErrorMessage <> "" Then
gsITP_ErrorMessage = gsITP_ErrorMessage + "\n" ' i.e. newline in javascript '
End If
Dim LMessage
LMessage = Replace(AMessage, BR, "\n") ' (SS,1/6/07) replace <br> with "\n" ' (SS,7/6/11) replaced <br> with BR constant
LMessage = Replace(LMessage, "'", "\'") ' (SS,22/7/10) escape single quotes
LMessage = Replace(LMessage, """", "\""") ' (SS,22/7/10) escape double quotes
LMessage = Replace(LMessage, " ", " ") ' (SS,19/4/16) replaced non-breaking space (HTML) to normal space
gsITP_ErrorMessage = gsITP_ErrorMessage + Replace(LMessage, "<br>", "\n")
End If
End Sub
' (SS,15/4/16) returns True of alert message already contains given text
Function AlertMessageContains(AContains)
AlertMessageContains = InStr(1, gsITP_ErrorMessage, AContains, vbTextCompare) > 0
End Function
' (SS,19/4/16) add a line to separate message if already a message
Function AddAlertMessageSection
If gsITP_ErrorMessage <> "" Then
gsITP_ErrorMessage = gsITP_ErrorMessage + "\n" ' i.e. newline in javascript '
End If
End Function
' (SS,28/5/07) moved here from SetAlertMessage, so it can be run from finalise at the end of the page
Sub ShowAlertMessage
If gsITP_ErrorMessage <> "" Then
%>
<script language="JavaScript" type="text/JavaScript">
<!--
ITP_ErrorMessage = "<%=gsITP_ErrorMessage%>";
//-->
</script>
<%
End If
End Sub
' (SS,7/6/11)
Sub SetConfirmDialog(AMessage, AFunction)
%>
<script language="JavaScript" type="text/JavaScript">
ITP_ConfirmMessage = "<%=AMessage%>"
ITP_ConfirmFunction = "<%=AFunction%>"
</script>
<%
End Sub
' (SS,20/2/14) redirect to basket, show a pop-up alert or neither depending on setting
Sub SetAddToBasketAlert(AQty, AProductCode)
If FAddToBasketAlertType = "Redirect" Then
SetPageRedirection GetBasketPageURL
ElseIf FAddToBasketAlertType = "PopUp" Then
SetPopUpMessage AQty & " x " & GetProductName(AProductCode) & " added to basket"
End If
End Sub
' (SS,20/2/14)
' (SS,15/4/16) changed to append to existing message rather than overwrite
Sub SetPopUpMessage(AMessage)
FPopUpMessage = FPopUpMessage & IIf(FPopUpMessage = "", "", BR) & AMessage
End Sub
' (SS,20/2/14)
Sub ShowPopUpMessage
If FPopUpMessage <> "" Then
%>
<div id="popupmessage" style="display: none; position: absolute; top: 0px; right: 0px; background-color: #FFF; text-align: center; width: 394px; padding: 25px; border: 2px solid red;">
<p><%=FPopUpMessage%></p>
</div>
<script language="JavaScript" type="text/JavaScript">
$("#popupmessage").show();
/* (SS,11/6/14) added following to position below the shopping status */
l_top = $("#shopping-status").offset().top + $("#shopping-status").height() + 5;
l_left = $("#shopping-status").offset().left + $("#shopping-status").width() - $("#popupmessage").outerWidth() + 3;
$("#popupmessage").css({top: l_top, left: l_left});
$("#popupmessage").fadeOut(4000);
</script>
<%
End If
End Sub
' ----------------------------------- '
' Start of Currency Exchange Routines '
' ----------------------------------- '
' (SS,15/9/06) Currency routines
' (SS,9/6/14) removed routines GetLatestExchangeRatesIfNeeded, GetWorldPayExchangeRates and UpdateExchangeRate, not called here
' sets the currency code using users selection, cookie
' code must be called before sending HTML tag because of cookie
' (SS,28/10/09) added ACurrencyCode parameter, also called from GetEmailBody, added to fix incorrect currency symbol appearing in HTML emails
' ACurrencyCode is "" else called from GetEmailBody
' (SS,10/6/14) minor improvements
Sub SetCurrencyCode(ACurrencyCode)
Dim LCurrencyCode
If CleanRequestQueryString("xcmd") = "currency" Then
LCurrencyCode = CleanRequestQueryString("xcode")
If IsAllowedCurrency(LCurrencyCode) Then
Session("CurrencyCode") = LCurrencyCode
' set cookie to hold selected currency
' (SS,20/2/12) cookie code moved to separate Sub SetCookie
SetCookie "CurrencyCode", LCurrencyCode
Else
Session("CurrencyCode") = FCurrencyDefaultCode ' (SS,10/6/14) change from "" to FCurrencyDefaultCode
End If
' (SS,10/6/14) combined into one if/else and removed If Session("CurrencyCode") = "" Then
Else
' (SS,28/10/09) added following if
If ACurrencyCode <> "" Then ' (SS,28/10/09)
LCurrencyCode = ACurrencyCode ' (SS,28/10/09)
Else ' (SS,28/10/09)
' try getting from cookie
LCurrencyCode = GetCookie("CurrencyCode") ' (SS,20/2/12) replaced Request.Cookies with GetCookie
End If ' (SS,28/10/09)
If IsAllowedCurrency(LCurrencyCode) Then
Session("CurrencyCode") = LCurrencyCode
Else
Session("CurrencyCode") = ""
End If
' set default if it's still blank
If Session("CurrencyCode") = "" Then Session("CurrencyCode") = FCurrencyDefaultCode ' (SS,14/11/07) was DEFAULT_CURRENCY_CODE
End If
End Sub
' (SS,19/3/15)
Function GetDefaultCurrencyCode
GetDefaultCurrencyCode = FCurrencyDefaultCode
End Function
' (SS,6/6/14)
Function GetCurrencyCodeForCountry(ACountry)
Dim LPostalArea, LCurrencyCode
If GetSQL2Values("SELECT PostalArea, COALESCE(Currency, '') FROM countries WHERE Country = '" & CleanSQLStr(ACountry) & "'", LPostalArea, LCurrencyCode) Then
' determine currency code from postal area, UK = GBP, EU = EUR, RW = USD
If LCurrencyCode = "" Then
Select Case LPostalArea
Case "EU": LCurrencyCode = "EUR"
Case "RW": LCurrencyCode = "USD"
Case Else: LCurrencyCode = "GBP"
End Select
End If
Else ' use default if not found
LCurrencyCode = "GBP"
End If
GetCurrencyCodeForCountry = LCurrencyCode
End Function
' (SS,18/9/04) this is called once in the initialise routine
' gets various currency values from the exchange rates table
' (SS,5/6/14) changes to add new local table currencies used to hold exchange rates
Sub GetCurrencyExchangeRate
FCurrencyCode = Session("CurrencyCode")
If FCurrencyCode = FCurrencyDefaultCode Or Not IsMulticurrency Then ' (SS,14/11/07) replaced DEFAULT_CURRENCY_CODE with FCurrencyDefaultCode
SetCurrencyDefaults ' (SS,6/6/14) moved code from here to new routine
Else
' (SS,5/6/14) added "If" to separate original from new local table method
If IsMulticurrencyMethodOriginal Then
OpenDatabaseCommon
' (SS,26/5/07) modified to use OpenQueryCommon instead of OpenQuery
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQueryCommon("SELECT * FROM exchangerates WHERE Source = 'WP' AND CurrencyCode = '" + CleanSQLStr(FCurrencyCode) + "'")
' (SS,28/10/09) in following lines replaced EndOfQuery with EndOfQueryCommon and GetQueryValue with GetQueryValueCommon
If Not EndOfQueryCommon Then
FCurrencyRate = CDbl(GetQueryValueCommon("ExchangeRate"))
FCurrencySymbol = GetQueryValueCommon("SymbolHTML") ' (SS,28/10/09) replaced Symbol with SymbolHTML
' (SS,20/2/12) removed following because we're now looking up this from the countries table below
' FCurrencyShowVAT = IntToBool(GetQueryValueCommon("ShowVAT"))
FCurrencyCountry = GetQueryValueCommon("DefaultCountry") ' used to work out approx delivery when showing basket
' (SS,20/2/12) currency country is fine as a default, but if user has already set country in basket or checkout then we need to use that instead
SetCountryFromBasketForm ' if user has changed country in basket form then we need to use the newly selected country
If Session("Country") <> "" Then
FCurrencyCountry = Session("Country")
ElseIf Session("DeliveryCountry") <> "" Then
FCurrencyCountry = Session("DeliveryCountry")
End If
' we need to use the VAT setting in the countries table to decide whether to show vat, not "ShowVAT" from the exchangerates rate
' because it can vary from site to site, hyperflight currently uses flat rate and charges VAT to RW unlike clifton
FCurrencyShowVAT = GetCountryChargeVATFlag(FCurrencyCountry)
Else ' (SS,6/6/14) set defaults if not found
SetCurrencyDefaults
End If
' (SS,26/5/07) modified to use CloseQueryCommon instead of CloseQuery and CloseDatabaseCommon instead of CloseDatabase
CloseQueryCommon
CloseDatabaseCommon
Else ' (SS,5/6/14) new code to use local currencies table i.e. hyperflight
' (SS,18/12/14) some code moved to new GetCurrencyExchangeRateAdjusted
If GetCurrencyExchangeRateAdjusted(FCurrencyCode, FCurrencyRate, FCurrencySymbol) Then
FCurrencyCountry = GetDeliveryCountry
FCurrencyShowVAT = GetCountryChargeVATFlag(FCurrencyCountry)
Else ' (SS,6/6/14) set defaults if not found
SetCurrencyDefaults
End If
CloseQuery
End If
End If
' (SS,8/6/07) replaced "�" with HTML code, mainly because � shows as # in HTML emails
' (SS,28/10/09) removed following SymbolHTML field above now returns the correct HMTL symbol
'If FCurrencySymbol = "�" Then FCurrencySymbol = "£"
'If FCurrencySymbol = "�" Then FCurrencySymbol = "€" ' (SS,29/11/07)
End Sub
' (SS,6/6/14) called when currency code not found or applicable
Sub SetCurrencyDefaults
FCurrencyRate = FCurrencyDefaultRate ' (SS,14/11/07) was DEFAULT_CURRENCY_RATE
FCurrencySymbol = FCurrencyDefaultSymbol ' (SS,14/11/07) was DEFAULT_CURRENCY_SYMBOL
FCurrencyShowVAT = FCurrencyDefaultShowVAT ' (SS,14/11/07) was DEFAULT_CURRENCY_SHOW_VAT
FCurrencyCountry = FCurrencyDefaultCountry ' (SS,14/11/07) was DEFAULT_CURRENCY_COUNTRY
End Sub
' (SS,28/10/09) called from GetEmailBody
Sub SetCurrencySymbol(ACurrencyCode)
Dim LCurrencyCode
LCurrencyCode = ACurrencyCode
If LCurrencyCode = "" Then LCurrencyCode = FCurrencyCode
' (SS,5/6/14) added If because exchange rate can be in two different tables
If IsMulticurrencyMethodOriginal Then
OpenDatabaseCommon
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQueryCommon("SELECT * FROM exchangerates WHERE Source = 'WP' AND CurrencyCode = '" + CleanSQLStr(LCurrencyCode) + "'")
If Not EndOfQueryCommon Then
FCurrencySymbol = GetQueryValueCommon("SymbolHTML")
End If
CloseQueryCommon
CloseDatabaseCommon
Else ' (SS,5/6/14) use local currencies table i.e. hyperflight
FCurrencySymbol = GetSQLValueAsString("SELECT SymbolHTML FROM currencies WHERE Currency = '" + CleanSQLStr(LCurrencyCode) + "'")
End If
End Sub
' (SS,19/9/06) set the currency code, rate, symbols for calls to CorrectCurrencyNV etc to work correctly
' (SS,1/8/17) moved code to this separate SetCurrencyForOrder routine, originally in GetEmailBodyOrderDetails
' now also called from ShowOrderDetailsMaster, ShowPreviousOrders
Sub SetCurrencyForOrder(ACurrencyCode, AExchangeRate)
SetCurrencyRate(CDbl(AExchangeRate))
SetCurrencyCode(ACurrencyCode) ' (SS,28/10/09) added this to correct pound symbol incorrectly appearing in HTML emails when non UK currency
SetCurrencySymbol(ACurrencyCode) ' (SS,28/10/09) sets the currency symbol
End Sub
Function IsMulticurrency
IsMulticurrency = FMulticurrencyEnabled ' (SS,13/9/07) replaced Application("Multicurrency") = True with FMulticurrencyEnabled
End Function
' (SS,5/6/14)
Function IsMulticurrencyMethodOriginal
IsMulticurrencyMethodOriginal = Not IsMulticurrencyMethodLocalTable
End Function
' (SS,5/6/14)
Function IsMulticurrencyMethodLocalTable
IsMulticurrencyMethodLocalTable = FMulticurrencyMethod = "LocalTable"
End Function
' (SS,13/9/07) replaced Application("AllowedCurrencies") with FAllowedCurrencies
' (SS,5/6/14) added code for new local currencies table
Function IsAllowedCurrency(ACurrencyCode)
If FAllowedCurrencies = "" Then
IsAllowedCurrency = False
Exit Function
End If
' (SS,5/6/14) added If
If IsMulticurrencyMethodOriginal Then
IsAllowedCurrency = InStr("," & FAllowedCurrencies & ",", "," & ACurrencyCode & ",") > 0
Else ' (SS,5/6/14) check if currency exists in the currencies table
IsAllowedCurrency = GetSQLRecordExists("SELECT * FROM currencies WHERE Currency = '" + CleanSQLStr(ACurrencyCode) + "'")
End If
End Function
' (SS,18/12/14)
Function IsMainCurrency(ACurrencyCode)
IsMainCurrency = InStr("," & MAIN_CURRENCIES & ",", "," & ACurrencyCode & ",") > 0
End Function
' (SS,5/6/14)
' (SS,18/12/14) complete rewrite, added ACurrencyCode because there are now two ratios, one for main currencies e.g. EUR & USD, and another for other
' also changed to work with two different ratios, existing ratio renamed to FExchangeRateAdjustmentRatioMain, new FExchangeRateAdjustmentRatioOther added
Function GetExchangeRateAdjustmentRatio(ACurrencyCode)
If IsMainCurrency(ACurrencyCode) And ACurrencyCode <> DEFAULT_CURRENCY_CODE And FExchangeRateAdjustmentRatioMain <> "" Then
GetExchangeRateAdjustmentRatio = CDbl(FExchangeRateAdjustmentRatioMain)
ElseIf Not IsMainCurrency(ACurrencyCode) And FExchangeRateAdjustmentRatioOther <> "" Then
GetExchangeRateAdjustmentRatio = CDbl(FExchangeRateAdjustmentRatioOther)
Else
GetExchangeRateAdjustmentRatio = 1
End If
End Function
' (SS,18/12/14) new routine which returns currency rate and symbol for given currency adjusted by the exchange rate adjustment ratio, returns false if currency not found
Function GetCurrencyExchangeRateAdjusted(ACurrencyCode, ByRef ACurrencyRate, ByRef ACurrencySymbol)
If GetSQL2Values("SELECT ExchangeRate, SymbolHTML FROM currencies WHERE Currency = '" + CleanSQLStr(ACurrencyCode) + "'", ACurrencyRate, ACurrencySymbol) Then
ACurrencyRate = CDbl(ACurrencyRate) * GetExchangeRateAdjustmentRatio(ACurrencyCode)
GetCurrencyExchangeRateAdjusted = True
Else
GetCurrencyExchangeRateAdjusted = False
End If
End Function
' (SS,18/12/14) get the default payment currency from currencies table where applicable, mainly to determine amount to show for bank transfers
' called from TryProcessOrder
Sub GetDefaultPaymentCurrency(ACurrencyCode, ByRef ADefaultPaymentCurrencyCode, ByRef ADefaultPaymentCurrencyRate)
ADefaultPaymentCurrencyCode = DEFAULT_CURRENCY_CODE
ADefaultPaymentCurrencyRate = DEFAULT_CURRENCY_RATE
If IsMulticurrency And Not IsMulticurrencyMethodOriginal Then
Dim LPaymentCurrencyCode
LPaymentCurrencyCode = GetSQLValueAsString("SELECT DefaultPaymentCurrency FROM currencies WHERE Currency = '" & CleanSQLStr(GetCurrencyCode) & "'")
If LPaymentCurrencyCode <> "" Then
Dim LCurrencySymbol ' this is ignored, required by GetCurrencyExchangeRateAdjusted
If GetCurrencyExchangeRateAdjusted(LPaymentCurrencyCode, ADefaultPaymentCurrencyRate, LCurrencySymbol) Then
ADefaultPaymentCurrencyCode = LPaymentCurrencyCode
End If
End If
End If
End Sub
' (SS,18/9/06) returns true if currency is vatable (i.e. the default for currency)
' when checking out the country will be used to get the VAT Falg
' (SS,16/1/13) this routine may now be redundant, IsCountryVATable is now used instead
Function IsCurrencyVATable
IsCurrencyVATable = FCurrencyShowVAT
End Function
Function GetCurrencyCode
GetCurrencyCode = Session("CurrencyCode")
End Function
' (SS,17/2/12)
Function IsCurrencyGBP
IsCurrencyGBP = GetCurrencyCode = "GBP"
End Function
' (SS,7/11/12)
Function IsCurrencyUSD
IsCurrencyUSD = GetCurrencyCode = "USD"
End Function
' (SS,7/11/12)
Function IsCurrencyEUR
IsCurrencyEUR = GetCurrencyCode = "EUR"
End Function
Function GetCurrencyRate
GetCurrencyRate = FCurrencyRate
End Function
Function SetCurrencyRate(ACurrentRate)
FCurrencyRate = ACurrentRate
End Function
Function GetCurrencySymbol
GetCurrencySymbol = FCurrencySymbol
End Function
Function GetCurrencyPostalArea
GetCurrencyPostalArea = GetPostalArea(GetDeliveryCountry) ' (SS,28/5/07) replaced GetCurrencyCountry with GetInvoiceCountry
End Function
' (SS,27/01/10) gets the correct region/area to show in basket footer to indicate which region the delivery has been calculated for
' in hyperflight it would show RW if customer had selected United States, changed to show the delivery region code if not blank, this would show USA
Function GetRegionCodeOrPostalArea
Dim LDeliveryCountry, LRegionCode
LDeliveryCountry = GetDeliveryCountry
LRegionCode = GetRegionCode(LDeliveryCountry)
If LRegionCode = "" Then LRegionCode = GetPostalArea(LDeliveryCountry)
GetRegionCodeOrPostalArea = LRegionCode
End Function
' returns value with currency symbols, commas, 2 dp
Function CorrectCurrency(APrice)
CorrectCurrency = CorrectCurrencyActual(APrice, True)
End Function
' returns correct currency with no format
Function CorrectCurrencyNF(APrice)
CorrectCurrencyNF = CorrectCurrencyActual(APrice, False)
End Function
' returns currency with VAT removed if currency has ShowVAT flag set to false
' (SS,20/10/08) changed to take PricesEnteredIncludeVAT into account, if false then VAT is not deducted because prices don't already include VAT
' had to do this because price in CovDem product pages and shopping status was deducting VAT when it shouldn't because entered prices don't include VAT
Function CorrectCurrencyNV(APrice)
If IsNull(APrice) Or APrice = "" Then
CorrectCurrencyNV = APrice
Else
Dim LPrice
LPrice = CDbl(APrice)
' (SS,20/10/08) added PricesEnteredIncludeVAT
' (SS,2/11/12) replaced IsCurrencyVATable with IsCountryVATable so that VAT can also be removed from GBP
' (SS,12/12/12) added "Or IsIntraCommunitySupply" so that VAT is deducted for EU sales where VAT Number is entered for sites that have Prices Entered Inc VAT e.g. HyperFlight
If PricesEnteredIncludeVAT And (Not IsCountryVATable Or IsIntraCommunitySupply) Then LPrice = LPrice - GetVATAmount(LPrice)
CorrectCurrencyNV = CorrectCurrencyActual(LPrice, True)
End If
End Function
' (SS,17/10/06) returns currency with VAT added to given price if currency has ShowVAT flag set to true
Function CorrectCurrencyWV(APrice)
If IsNull(APrice) Or APrice = "" Then
CorrectCurrencyWV = APrice
Else
Dim LPrice
LPrice = CDbl(APrice)
' (SS,22/6/10) modified GetVATAmountToAdd to GetVATAmountToAddNC because GetVATAmountToAdd was changed to use IsCountryVATable which we don't want to do
' (SS,2/11/12) replaced IsCurrencyVATable with IsCountryVATable so that VAT can also be removed from GBP
If IsCountryVATable Then LPrice = LPrice + GetVATAmountToAddNC(LPrice)
Dim LResult ' (SS,26/2/15)
LResult = CorrectCurrencyActual(LPrice, True)
' (SS,26/2/15) added logging to help find issue where inc VAT prices showing same as exc VAT sometimes for CIRC
' comment out after fixing bug
' TempDebugLog "SessionID = " & GetSessionID & ", CorrectCurrencyWV(" & APrice & "), Result = " & LResult & ", IsCountryVATable = " & IsCountryVATable & ", APrice = " & APrice & ", LPrice = " & LPrice & ", UseVATFlagFromCountries = " & UseVATFlagFromCountries & ", GetInvoiceCountry = """ & GetInvoiceCountry & """, GetInvoiceCountry = """ & GetDeliveryCountry & """, GetCookie(""DeliveryCountry"") = """ & GetCookie("DeliveryCountry") & """"
CorrectCurrencyWV = LResult
End If
End Function
Function CorrectCurrencyActual(APrice, AIsFormatted)
If IsNull(APrice) Or APrice = "" Then
CorrectCurrencyActual = APrice
Else
Dim LPrice
LPrice = CDbl(APrice) ' needs to be as double so we can do calculations on it
LPrice = LPrice * FCurrencyRate
If AIsFormatted Then
' (SS,12/5/10) replaced "GetCurrencySymbol &" with AddCurrencySymbol and added SwapCommasAndDP
CorrectCurrencyActual = AddCurrencySymbol(CorrectCommasAndDP(FormatNumber(LPrice, 2)))
Else
CorrectCurrencyActual = LPrice
End If
End If
End Function
' (SS,12/5/10) for French and German swap commas and decimal point
' (SS,21/6/10) renamed SwapCommasAndDP to CorrectCommasAndDP
Function CorrectCommasAndDP(AFormattedValue)
If GetTranslationLanguage = "French" Or GetTranslationLanguage = "German" Then
Dim LResult
LResult = ReplaceStr(AFormattedValue, ",", "@")
LResult = ReplaceStr(LResult, ".", ",")
If GetTranslationLanguage = "French" Then
CorrectCommasAndDP = ReplaceStr(LResult, "@", " ") ' France using space as thousands separator
Else
CorrectCommasAndDP = ReplaceStr(LResult, "@", ".")
End If
Else ' no change if English
CorrectCommasAndDP = AFormattedValue
End If
End Function
' (SS,12/5/10)
Function AddCurrencySymbol(AFormattedAmount)
If GetTranslationLanguage = "French" Or GetTranslationLanguage = "German" Then
AddCurrencySymbol = AFormattedAmount & " " & GetCurrencySymbol' e.g. X,XX �
Else ' e.g. �X.XX
AddCurrencySymbol = GetCurrencySymbol & AFormattedAmount
End If
End Function
' (SS,16/2/16) removes the currency symbol added using AddCurrencySymbol
Function RemoveCurrencySymbol(AFormattedAmount)
RemoveCurrencySymbol = ReplaceStr(AFormattedAmount, GetCurrencySymbol, "")
End Function
' (SS,3/8/22) used for PayPal Pay Later, removes currency symbol and commas e.g. �1,234.00 = 1234.00
Function RemoveCurrencyAndCommas(AFormattedAmount)
RemoveCurrencyAndCommas = ReplaceStr(RemoveCurrencySymbol(AFormattedAmount), ",", "")
End Function
' (SS,13/11/07) converts given price (in non GBP currency) back to internal GBP currency
' used in custom delivery to ensure delivery is in fixed in EURO or other currency
Function ConvertCurrencyInternal(APrice)
If IsNull(APrice) Or APrice = "" Then
ConvertCurrencyInternal = APrice
Else
ConvertCurrencyInternal = CDbl(APrice) / FCurrencyRate
End If
End Function
' (SS,12/5/10) returns MySQL date format for DATE_FORMAT with time if AWithTime is True, to return correct date format for language
Function GetLanguageDateFormat(AWithTime)
Dim LResult
If GetTranslationLanguage = "French" Then
LResult = "%d/%m/%Y"
ElseIf GetTranslationLanguage = "German" Then
LResult = "%d.%m.%Y"
Else ' i.e. English
LResult = "%d/%m/%Y"
End If
If AWithTime Then LResult = LResult + " %H:%i"
GetLanguageDateFormat = LResult
End Function
' (SS,19/12/14) new routine used to show a default payment currency value in bank transfers
Function GetCurrencyFormattedValue(ACurrencyCode, ACurrencyRate, AValue)
' look up the currency symbol from currencies table
Dim LCurrencySymbol, LConvertedValue
LCurrencySymbol = GetSQLValueAsString("SELECT SymbolHTML FROM currencies WHERE Currency = '" & CleanSQLStr(ACurrencyCode) & "'")
If LCurrencySymbol = "" And ACurrencyCode = "GBP" Then LCurrencySymbol = "£" ' (SS,4/4/17) use pound symbol if nothing found and code is GBP i.e. currencies table not populated
GetCurrencyFormattedValue = LCurrencySymbol & CorrectCommasAndDP(FormatNumber(CDbl(ACurrencyRate) * CDbl(AValue), 2))
End Function
' (SS,19/12/14) used in both email and web page, orders table is open with access to fields using GetFieldValue()
' (SS,4/4/17) minor text changes as requested for CIRC, now can get customised message from GetMessage function
Function GetBankTransferPaymentLine
Dim LBankTransferText
' LBankTransferText = "Please make a payment to the following account for "
' (SS,4/4/17) replaced above with following
' (SS,4/8/17) moved following to below
' LBankTransferText = "Please make payment of "
' (SS,4/8/17) added following to simplify the code and work correctly for HF to only show one option for new BANK TRANSFER - EUR or BANK TRANSFER - USD
Dim LPaymentAmountText
LPaymentAmountText = ""
' if applicable and if default payment currency code is different to the one chosen in the website then also determine the amount to show in the default payment currency
' (SS,4/8/17) replaced LBankTransferText with LPaymentAmountText, and moved " or " below
If IsMulticurrency And IsMulticurrencyMethodLocalTable And GetFieldValue("CurrencyCode") <> GetFieldValue("DefaultPaymentCurrencyCode") Then
LPaymentAmountText = "<b>" & GetCurrencyFormattedValue(GetFieldValue("DefaultPaymentCurrencyCode"), GetFieldValue("DefaultPaymentCurrencyRate"), GetFieldValue("GrandTotal")) & "</b>"
End If
' (SS,4/8/17) include following if LPaymentAmountText not set above i.e. is "", also changed LBankTransferText to LPaymentAmountText
' (SS,12/9/17) removed ' Or GetFieldValue("DefaultPaymentCurrencyCode") = "GBP" to only show one option for GBP (not "or" selected currency) due to high costs with HSBC
If LPaymentAmountText = "" Then
' (SS,12/9/17) removed following, no longer applicable due to removable of "Or GetFieldValue("DefaultPaymentCurrencyCode") = "GBP"" from If condition above
' If LPaymentAmountText <> "" Then LPaymentAmountText = LPaymentAmountText & " or "
LPaymentAmountText = LPaymentAmountText & "<b>" & GetCurrencyFormattedValue(GetFieldValue("CurrencyCode"), GetFieldValue("ExchangeRate"), GetFieldValue("GrandTotal")) & "</b>"
End If
' (SS,4/4/17) added following, above line replaced
' (SS,4/8/17) adjusted to use new LPaymentAmountText
LBankTransferText = "Please make payment of " & LPaymentAmountText & " to the following account," ' (SS,4/4/17)
LBankTransferText = LBankTransferText & " entering <b>" & GetFieldValue("OrderNo") & "</b> in the bank's reference field." ' (SS,4/8/17) removed the & BR after LBankTransferText added space before "entering"
' (SS,5/4/17) following allows default text which is now "Failure to pay immediately will result in your order being delayed." to be overridden
' (SS,6/4/17) removed the default, now just adds extra text if defined
Dim LAdditionalText
LAdditionalText = GetMessage("BankTransferExtra")
If LAdditionalText <> "" Then
LBankTransferText = LBankTransferText & BR & LAdditionalText
End If
GetBankTransferPaymentLine = LBankTransferText
End Function
' --------------------------------- '
' End of Currency Exchange Routines '
' --------------------------------- '
' (SS,17/9/08) added following to allow the page to be default to a specific category
' without having to use a query string, routine called from the main page
' for galleon web promotion to allow doorway domains/pages to show content from the database
' new global variable FDefaultCategory used
Sub SetDefaultCategory(ACategory)
FDefaultCategory = ACategory
End Sub
// (SS,17/9/08) returns the default category if set
Function GetDefaultCategory
GetDefaultCategory = FDefaultCategory
End Function
' (SS,17/9/08) returns true if default category page has been set, used by inc-pages.asp
Function HasDefaultCategory
HasDefaultCategory = GetDefaultCategory <> ""
End Function
' (SS,17/5/11)
Function GetGroup
GetGroup = CleanRequestQueryString("grp")
End Function
' (SS,25/7/11)
Function GetSearch
GetSearch = CleanRequestQueryString("search")
End Function
' (SS,25/7/11)
Function IsSpecialOfferSearch
IsSpecialOfferSearch = LCase(GetSearch) = SPECIAL_OFFERS_SEARCH_TEXT
End Function
' (SS,27/7/11) returns true if a group / category / subcategory has been specified, product code also means it's specified because product belongs to a category
Function CategoryOrProductSpecified
CategoryOrProductSpecified = Not ((GetProductCodeQS = "") and (CleanRequestQueryString("grp") = "") and (CleanRequestQueryString("cat") = "") and (CleanRequestQueryString("subcat") = ""))
End Function
' (SS,28/7/11) returns true if only group is specified
Function GroupOnlySpecified
GroupOnlySpecified = GetGroup <> "" And GetCategory = "" And GetSubcategory = "" And GetProductCode = ""
End Function
' (SS,17/9/08) returns category from query string or the default setting
' *** all CleanRequestQueryString("cat") to be replaced by GetCategory in future
Function GetCategory
If HasDefaultCategory Then
GetCategory = GetDefaultCategory
Else
GetCategory = CleanRequestQueryString("cat")
End If
End Function
' (SS,12/4/11) returns subcategory from query string
Function GetSubcategory
GetSubcategory = CleanRequestQueryString("subcat")
End Function
' (SS,27/10/20) returns true if given category is a special one where hidden/disabled products are used in a special way e.g. Case Studies for GSC
' call made to function CustomIsSpecialCategory in customutils.asp if it exists
Function IsSpecialCategory(ACategory)
Dim Result
If FunctionExists("CustomIsSpecialCategory") Then
Result = CustomIsSpecialCategory(ACategory)
Else
Result = False
End If
IsSpecialCategory = Result
End Function
' (SS,27/10/20) returns true if given product code belongs in a special category (also see IsSpecialCategory above)
Function IsProductSpecialCategory(AProductCode)
Dim LGroup, LCategory, LSubcategory
GetFirstCatSubcatForProduct AProductCode, LGroup, LCategory, LSubcategory
IsProductSpecialCategory = IsSpecialCategory(LCategory)
End Function
' (SS,15/2/12) called from ShowSingleProduct, to overcome issue when we go directly to a product due to single product found in search
' and query string doesn't contain the code
Sub SetProductCode(AProductCode)
FProductCode = AProductCode
End Sub
' (SS,12/4/11)
' (SS,15/2/12) modified to use FProductCode if CleanRequestQueryString("code") is blank
Function GetProductCode
If GetProductCodeQS = "" Then ' (SS,7/11/18) replaced CleanRequestQueryString("code") with GetProductCodeQS
GetProductCode = FProductCode
Else
GetProductCode = GetProductCodeQS ' (SS,12/9/12) replaced CleanRequestQueryString("code") with GetProductCodeQS
End If
End Function
' (SS,12/9/12) get product code from query string
Function GetProductCodeQS
' (SS,7/11/18) added UCase to force uppercase, because items were ending up in basket with lowercase product codes
GetProductCodeQS = UCase(CleanRequestQueryString("code"))
End Function
' (SS,25/8/17) similar to GetProductCode except it always returns the value set using SetProductCode, instead of looking at the query string "code"
' returns the product code used by product list, related product, or product code, whichever is the most applicable
' fixes the bug in related products where link was incorrectly using the main product code from the product page for "notify me when back in stock" link
' via call in Function CustomGetStockInfo for HyperFlight, using this new GetActiveProductCode instead of GetProductCode (was which getting code from the query string when not blank) fixes this problem
Function GetActiveProductCode
GetActiveProductCode = FProductCode
End Function
' (SS,22/8/14)
Function GetProductID
GetProductID = FProductID
End Function
' (SS,18/7/11)
Function GetPageName
GetPageName = LCase(CleanRequestQueryString("page"))
End Function
' (SS,18/7/11) returns true is current page is in given comma separated list
Function IsPageName(AList)
Dim LPageName, LResult
LPageName = GetPageName
If LPageName <> "" And InStr(1, "," + AList + ",", "," + LPageName + ",", 1) > 0 Then
LResult = True
Else
LResult = False
End If
IsPageName = LResult
End Function
' (SS,9/9/14)
Function GetCmd
GetCmd = LCase(CleanRequest("cmd"))
End Function
' (SS,9/9/14)
Function IsCmd(AList)
Dim LCmd, LResult
LCmd = GetCmd
If LCmd <> "" And InStr(1, "," + AList + ",", "," + LCmd + ",", 1) > 0 Then
LResult = True
Else
LResult = False
End If
IsCmd = LResult
End Function
' (SS,9/9/14)
Function IsPageNameOrCmd(AList)
IsPageNameOrCmd = IsPageName(AList) Or IsCmd(AList)
End Function
' (SS,17/9/08) used to prefix given link with full store URL when default category used
Function AddStoreURL(ALink)
If HasDefaultCategory Then
AddStoreURL = GetStoreURL + "/" + ALink
Else
AddStoreURL = ALink ' no prefix
End If
End Function
' (SS,10/11/08) AFormName could be frmWorldPay, frmPayPal
' (SS,20/11/08) replaced AFormName with APaymentType
Function GetPaymentSubmitJavascriptLink(APaymentType)
' Dim Result
' Result = ""
' If FGoogleAnalyticsWebPropertyID <> "" And FEcommerceTrackingEnabled Then
' Result = "pageTracker._trackTrans();" + Result
' End If
' If FAdwordsConversionTrackingID <> "" And FAdWordsPurchaseConversionActivated Then
' Result = "itp_gawct();" + Result
' End If
' Result = "javascript:" + Result + "document." + AFormName + ".submit()"
' GetPaymentSubmitJavascriptLink = Result
' (SS,20/11/08) replaced above with following, also added javascript function itp_payment to javascript.js
GetPaymentSubmitJavascriptLink = "javascript:itp_payment('" + APaymentType + "')"
End Function
' (SS,23/6/22) special version of GetPaymentSubmitJavascriptLink with payment method added for Clover
' call to itp_payment in javascript.js also changed to handle this optional second parameter
Function GetPaymentMethodSubmitJavascriptLink(APaymentType, APaymentMethod)
GetPaymentMethodSubmitJavascriptLink = "javascript:itp_payment('" + APaymentType + "', '" + APaymentMethod + "')"
End Function
' (SS,21/7/17) new payment with bank transfer link where customer can choose which bank to pay into
Function GetPaymentBankTranferOptionSubmitLink(ABankTransferOption)
GetPaymentBankTranferOptionSubmitLink = "javascript:itp_payment_banktransfer('" + ABankTransferOption + "')"
End Function
' -------------------------------------------
' Start of web analytics routines
' -------------------------------------------
' (SS,11/10/23) Google Tag Manager Enabled
Function GTMEnabled
GTMEnabled = FGoogleTagManagerContainerID <> ""
End Function
' (SS,6/3/18) routine called from HTMLHeadEnd to take care of the analytics i.e. Google Analytics and Facebook Pixel
' (SS,20/6/23) added call to DoCookieConsent
' (SS,3/8/23) added DoOptinMonster
Sub DoWebAnalytics
' only do Google Analytics and Facebook Pixel it it's a product page i.e. products.asp
If ScriptIsProducts Then
IncrementPageViewCount
' (SS,15/1/24) add the initial Backona script if applicable before the other GTM and analytic scripts
If FBackonaAnalyticsEnabled Then DoBackonaAnalytics
' (SS,5/10/23) added following for Google Tag Manager, we can only do one or the other, !!! to change to if else with DoGoogleAnalytics
If GTMEnabled Then
DoGoogleTagManager
Else
DoGoogleAnalytics
End If
DoFacebookPixel
' (SS,19/10/23) only if GTM not enabled
If Not GTMEnabled Then
' (SS,3/8/23) new for CIRC, now includes conversion value
DoOptinMonster
End If
' (SS,20/6/23) added following to handle cookie consent
' (SS,19/10/23) only do CookieConsent if GTM not enabled because it uses gtag
If Not GTMEnabled Then
DoCookieConsent
End If
' if purchasing conversion was necessary then mark as done, so that it's not repeated for same order
If TrackPurchaseConversion Then
' SendWebLogEmail "###TrackPurchaseConversion###"
TrackPurchaseConversionAddToLog ' add to log
TrackPurchaseConversionDone ' mark as done, to ensure it's not repeated for same order no
End If
End If
End Sub
' (SS,6/3/18) do what needs going at the of the page for web analytics e.g. update the the conversion_tracking_log with payment method
' (SS,25/10/23) modified to only do GTM if oGTM is set, to fix error occuring in redirects
Sub FinaliseWebAnalytics
TrackPurchaseConversionUpdateLog
' (SS,25/10/23) added following If to fix issue which might be happening in a redirect or similar causing Object required: 'oGTM' error, now checking for oGTM first
' https://dev.castironradiatorcentre.co.uk/products.asp?code=CDC-460-13-ES&name=clearance-traditional-victorian-4-column-460mm-cast-iron-radiator-13-sections
If GTMEnabled And IsObject(oGTM) Then
DoGoogleTagManagerNoScript ' (SS,5/10/23)
' (SS,13/10/23) do GTM ecommerce event if applicable and free the Google Tag Manager object
' (SS,23/10/23) change from DoEcommerceEvents to DoEvents
' oGTM.DoEvents
' (SS,25/10/23) reverted back to DoEcommerceEvents for now, may go back to DoEvents in a future version
oGTM.DoEcommerceEvents
Set oGTM = Nothing
End If
End Sub
' (SS,5/10/23) Google Tag Manager, also added noscript code to HTMLBodyEnd
Sub DoGoogleTagManager
'If Not GTMEnabled Then Exit Sub
' (SS,13/10/23) replaced above and GTM script below with following
oGTM.DoGoogleTagManagerScript
' if purchase conversion applicable then get the conversion amount
' (SS,19/10/23) not sure if following is required
'Dim LTrackPurchaseConversion, LConversionValue
'LTrackPurchaseConversion = TrackPurchaseConversion And FAdwordsConversionTrackingID <> "" And FAdWordsConversionLabelPurchase <> ""
'If LTrackPurchaseConversion Then
' LConversionValue = GetConversionValue(Session("OrderNoPlaced"))
'End If
If IsNewSearch Then
oGTM.EventSearch(GetSearch)
End If
If IsStartOfCheckout Then
oGTM.EventBeginCheckout
GTMAddBasket
ElseIf IsCheckoutFilled Then
oGTM.EventAddShippingInfo
GTMAddOrder
ElseIf TrackPurchaseConversion Then
oGTM.EventPurchase
GTMAddOrder
' (SS,25/10/23) removed for now, to add back later
GTMAddEnhancedConversionData
End If
End Sub
' (SS,5/10/23) following called from HTMLBodyEnd adds recommended <noscript> GTM script for Javascript being disabled the Tag Assistant recommends it (otherwise I wouldn't have added it)
Sub DoGoogleTagManagerNoScript
'If FGoogleTagManagerContainerID = "" Then Exit Sub
' (SS,13/10/23) replaced above and noscript code with following
oGTM.DoGoogleTagManagerNoScript
End Sub
' (SS,10/11/08)
' (SS,27/11/13) asynchronous version of Google Analytics script, placed in header of inc-template-main.asp
' (SS,27/11/13) added AAsync parameter which can be true or false, and modified to do asynchronous as well
' (SS,12/2/15) modified to allow different DoubleClick.Net URL depending on setting
' (SS,3/3/16) modified to use the latest analytics.js for ASync method also added cross domain tracking
' (SS,1/3/18) modified extensively to use new Global Site Tag (gtag.js), removed AAsync parameter, now redundant
' also no longer calls DoGoogleAdWordsConversionTracking which it did when AAsync i.e. when called from Finalise
' now called from HTMLHeadEnd instead of head section in inc-template-main.asp
' Now does both Analytics and AdWords conversion tracking
' (SS,25/5/21) added remarketing 'event' tags (similar to the ones used for Facebook)
' (SS,17/9/21) added enhanced conversions
' (SS,1/8/22) changes to enhanced conversion data to remove phone and added postcode, country, county and city
' (SS,10/8/22) changes to enhanced conversion data to fix issue, now using gtag('set', 'user_data')
' (SS,15/6/23) change to enhanced conversion data to follow Google support team's recommendation i.e. first_name and last_name moved outside of address, and address renamed to home_address
' (SS,20/6/23) modified enhanced conversion to use new FGoogleEnhancedConversionsType to allow either official type with "address" to the Support Teams undocumented type of "home_address"
Sub DoGoogleAnalytics
' immediately exit if no analytics web property ID
If FGoogleAnalyticsWebPropertyID = "" Then Exit Sub
' if purchase conversion applicable then get the conversion amount
Dim LTrackPurchaseConversion, LConversionValue
LTrackPurchaseConversion = TrackPurchaseConversion And FAdwordsConversionTrackingID <> "" And FAdWordsConversionLabelPurchase <> ""
If LTrackPurchaseConversion Then
LConversionValue = GetConversionValue(Session("OrderNoPlaced"))
End If
' track new account conversion, only if label name specified, new account conversion activated and not already done
Dim LTrackNewAccountConversion
LTrackNewAccountConversion = FAdwordsConversionTrackingID <> "" And FAdWordsConversionLabelNewAccount <> "" And FAdWordsNewAccountConversionActivated And Session("AdWordsNewAccountConversionTrackingDone") <> True
' (SS,7/3/18) for AdWords conversion, replaced gtag('event', 'purchase' with gtag('event', 'conversion'
%><!-- Global Site Tag (gtag.js) - Google Analytics and AdWords -->
<script async src="https://www.googletagmanager.com/gtag/js?id=<%=FGoogleAnalyticsWebPropertyID%>"></script>
<script>
window.dataLayer = window.dataLayer || [];
function gtag(){dataLayer.push(arguments);}
gtag('js', new Date());
gtag('config', '<%=FGoogleAnalyticsWebPropertyID%>');
<%If FAdwordsConversionTrackingID <> "" Then
Dim LEnchancedConversionsSetting
If LTrackPurchaseConversion And FGoogleEnhancedConversionsEnabled Then
LEnchancedConversionsSetting = ", {'allow_enhanced_conversions':true}"
Else
LEnchancedConversionsSetting = ""
End If
%> gtag('config', 'AW-<%=FAdwordsConversionTrackingID%>'<%=LEnchancedConversionsSetting%>);
<%End If
If LTrackPurchaseConversion Then
If FGoogleEnhancedConversionsEnabled Then
' (SS,1/8/22) added LPostcode, LCountryCode, LTown, LCounty
Dim LEmailAddress, LTelephone, LFirstName, LSurname, LPostcode, LCountryCode, LTown, LCounty
If GetEnhancedConversionValues(Session("OrderNoPlaced"), LEmailAddress, LTelephone, LFirstName, LSurname, LPostcode, LCountryCode, LTown, LCounty) Then
' (SS,1/8/22) removed phone_number (no required and they want the country code which makes it complicated)
' (SS,1/8/22) "address." prefix to first_name and last_name, added city, region, postal_code and country with "address." prefix
' (SS,9/8/22) modified to new version using gtag('set', 'user_data')
' see https://support.google.com/google-ads/answer/9888145
' (SS,15/6/23) Google support team, recommends different names even though they are not documented see https://jsfiddle.net/08qLzowe/
' replacing following with below i.e. home_address replaced address and first_name and last_name moved outside of address
' their example mentions phone_number and street which we don't have or use currently
' (SS,20/6/23) added new setting via FGoogleEnhancedConversionsType that allows old or new "home_address" method which is not officially documented
If FGoogleEnhancedConversionsType = "HA" Then
%>
gtag('set', 'user_data', {
"email": '<%=JavaScriptStrEscape(LEmailAddress)%>',
"first_name": '<%=JavaScriptStrEscape(LFirstName)%>',
"last_name": '<%=JavaScriptStrEscape(LSurname)%>',
"home_address": {
"city": '<%=JavaScriptStrEscape(LTown)%>',
"region": '<%=JavaScriptStrEscape(LCounty)%>',
"postal_code": '<%=JavaScriptStrEscape(LPostcode)%>',
"country": '<%=JavaScriptStrEscape(LCountryCode)%>'
}
});
<%
Else ' (SS,20/6/23) i.e. "" or "A" original type with normal address
%>
gtag('set', 'user_data', {
"email": '<%=JavaScriptStrEscape(LEmailAddress)%>',
"address": {
"first_name": '<%=JavaScriptStrEscape(LFirstName)%>',
"last_name": '<%=JavaScriptStrEscape(LSurname)%>',
"city": '<%=JavaScriptStrEscape(LTown)%>',
"region": '<%=JavaScriptStrEscape(LCounty)%>',
"postal_code": '<%=JavaScriptStrEscape(LPostcode)%>',
"country": '<%=JavaScriptStrEscape(LCountryCode)%>'
}
});
<%
End If
End If
End If
%>
gtag('event', 'conversion', {
'send_to': 'AW-<%=FAdwordsConversionTrackingID%>/<%=FAdWordsConversionLabelPurchase%>',
'value': <%=LConversionValue%>,
'currency': 'GBP',
'transaction_id': '<%=Session("OrderNoPlaced")%>'
});
<%
End If
' (SS,5/3/18) removed True (AAsync) parameter
' (SS,10/4/10) renamed DoGoogleAnalyticsEcommerce to DoTrackPurchaseEvent and added ttGoogle (this now works for Facebook too)
DoTrackPurchaseEvent ttGoogle
' (SS,5/3/18) following does a new account conversion if label for this is defined
If LTrackNewAccountConversion Then%>
gtag('event', 'sign_up', {
'account_type': 'basic',
'send_to': 'AW-<%=FAdwordsConversionTrackingID%>/<%=FAdWordsConversionLabelNewAccount%>'
});
<% Session("AdWordsNewAccountConversionTrackingDone") = True ' make sure new account conversion is only done once per session
End If
' (SS,25/5/21) new remarketing tags
' (SS,17/9/21) added Not IsAddToBasketPage to prevent both view and add to cart event at the same time
' also change GetProductCode in add_to_cart event to GetBasketProductCode
If IsProductDetailsPage And Not IsAddToBasketPage Then%>
gtag('event', 'view_item', {
"items": [{id: "<%=GetProductCode%>"}]
});
<%End If%>
<%If IsAddToBasketPage Then%>
gtag('event', 'add_to_cart', {
"items": [{id: "<%=GetBasketProductCode%>"}]
});
<%End If%>
<%If IsNewSearch Then%>
gtag('event', 'search', {
"search_term": '<%=JavaScriptStrEscape(GetSearch)%>'
});
<%End If%>
<%If IsStartOfCheckout Then%>
gtag('event', 'begin_checkout');
<%End If%>
<%If IsCheckoutFilled Then%>
gtag('event', 'set_checkout_option', {
"checkout_step": 2,
"checkout_option": "select payment method",
"value": 2
});
<%End If%>
</script>
<!-- End Global Site Tag -->
<%
End Sub
' (SS,9/10/17) Facebook pixel tracking, called from Finalise
' (SS,10/10/17) !!! perhaps in future we need to do the conversion value when returning from payment provider (IsReturnFromPaymentProviderPage)
' this will ensure page is loaded for longer (i.e. not redirecting) and conversion only counted when payment actually made
' (SS,3/11/17) removed the noscript tag, causing missing alt tag error in W3C validator
' (SS,9/4/19) added Facebook event code for tracking ViewContent (i.e. product page view) and AddToCart (i.e. add to basket)
' (SS,10/4/19) added to content_type and content_ids to ViewContent and AddToCart. Also added content_type and contents to Purchase
' For purchase tracking added call to DoTrackPurchaseEvent which handles Facebook as well as Google
' (SS,11/4/19) removed the additional (not necessary I think) <noscript><img> tracking because it was interfering with the Facebook Pixel Helper add-on
' (SS,12/4/19) added events Search, InitiateCheckout, InitiateCheckout, AddPaymentInfo
' (SS,20/6/23) added consent feature via fbq('consent', 'revoke'); and fbq('consent', 'grant') added to DoCookieConsent
' (SS,02/7/23) consent version had stopped pixel from working correctly, conversions stopped being tracked, reverted back to original, consent version
' renamed to Sub DoFacebookPixel_ConsentVersion_removed (see below)
' (SS,15/1/24) added Backona version, also moved the events to separate DoFacebookPixelEvents
Sub DoFacebookPixel
' exit if not the product.asp page or Pixel ID not set
' (SS,2/3/18) removed Not ScriptIsProducts Or because this is now done in calling routine i.e. HTMLHeadEnd
If FFacebookPixelID = "" Then Exit Sub
' if purchase conversion activated then get the conversion amount
Dim LTrackConversion, LConversionValue
LTrackConversion = TrackPurchaseConversion ' (SS,2/3/18) TrackPurchaseConversion replaces previous if conditions
If LTrackConversion Then
' (SS,2/3/18) removed following, no longer necessary
' Session("FacebookPurchaseConversionTrackingDone") = True ' so that we only it do it once per session
LConversionValue = GetConversionValue(Session("OrderNoPlaced"))
End If
' (SS,15/1/24) added separate Backona version
If Not FBackonaAnalyticsEnabled Then
' standard version as before
%>
<!-- Facebook Pixel Code -->
<script>
!function(f,b,e,v,n,t,s){if(f.fbq)return;n=f.fbq=function(){n.callMethod?
n.callMethod.apply(n,arguments):n.queue.push(arguments)};if(!f._fbq)f._fbq=n;
n.push=n;n.loaded=!0;n.version='2.0';n.queue=[];t=b.createElement(e);t.async=!0;
t.src=v;s=b.getElementsByTagName(e)[0];s.parentNode.insertBefore(t,s)}(window, document,'script','//connect.facebook.net/en_US/fbevents.js');
<%
DoFacebookPixelEvents LTrackConversion
%>
</script>
<!-- End Facebook Pixel Code -->
<%
Else
' (SS,15/1/24) special Backona version
' (SS,16/1/24) added missing quote from end of fi=, also added !function(){ to the outside
%>
<!-- Facebook Pixel Code - Backona version -->
<script>
!function(){
//Alternative analytics subdomain
var sd="<%=FBackonaAnalyticsDomain%>";
//Facebook Pixel id
var fi="<%=FFacebookPixelID%>";
//Facebok Pixel Setup
function fb(f,b,e,v,n,t,s) {
if(f.fbq)return;
n=f.fbq=function(){
n.callMethod ? n.callMethod.apply(n,arguments) : n.queue.push(arguments)
};
if(!f._fbq)f._fbq=n;
n.push=n;
n.loaded=!0;
n.version='2.0';
n.queue=[];
t=b.createElement(e);
t.async=!0;
t.src=v;
s=b.getElementsByTagName(e)[0];
s.parentNode.insertBefore(t,s)
};
if (window.alx === false) {
fetch('https://connect.facebook.net/en_US/fbevents.js', {mode: 'no-cors', credentials: 'same-origin'})
.then(function(){
fb(window, document,'script','https://connect.facebook.net/en_US/fbevents.js');
})
.catch(function(){
window.alx = true;
fb(window, document,'script',"https://"+sd+"/fpx");
})
.finally(function(){
<%DoFacebookPixelEvents LTrackConversion%>
})
} else {
fb(window, document,'script',"https://"+sd+"/fpx");
<%DoFacebookPixelEvents LTrackConversion%>
}
}();
</script>
<!-- End Facebook Pixel Code - Backona version -->
<%
End If
' (SS,3/11/17) removed the noscript version because it was causing W3C validator to give error message, replaced < with [, and > with ] to avoid script compile error
'<noscript><img height="1" width="1" style="display:none" src="https://www.facebook.com/tr?id=[%=FFacebookPixelID%]&ev=PageView&noscript=1" /></noscript>
End Sub
' (SS,15/1/24) separated from above due to being called more than once because of adding the Backona version
' (SS,16/1/24) added fbq('trackCustom', 'PView') for Backona (will appear in standard as well), adjusted indent to look better for Backona
Sub DoFacebookPixelEvents(ATrackConversion)
%> fbq('init', '<%=FFacebookPixelID%>');
fbq('track', 'PageView');
fbq('trackCustom', 'PView');
<%If IsProductDetailsPage Then%>
fbq('track', 'ViewContent', {
content_ids: ['<%=GetProductCode%>'],
content_type: 'product'
});
<%End If%>
<%If IsAddToBasketPage Then%>
fbq('track', 'AddToCart', {
content_ids: ['<%=GetBasketProductCode%>'],
content_type: 'product'
});
<%End If%>
<%If IsNewSearch Then%>
fbq('track', 'Search', {
search_string: '<%=JavaScriptStrEscape(GetSearch)%>'
});
<%End If%>
<%If IsStartOfCheckout Then%>
fbq('track', 'InitiateCheckout', {
num_items: <%=GetTotalItemsInBasket%>
});
<%End If%>
<%If IsCheckoutFilled Then%>
fbq('track', 'AddPaymentInfo');
<%End If%>
<%If ATrackConversion Then%>
<%DoTrackPurchaseEvent ttFacebook%>
<%End If%>
<%
End Sub
' (SS,3/8/23)
Sub DoOptinMonster
' exit if OptinMonster not enabled
' for CIRC the IDs are 273285,291005
If FOptinMonsterAccountID = "" Or FOptinMonsterUserID = "" Then Exit Sub
%>
<!-- OptinMonster-->
<script>(function(d,u,ac){var s=d.createElement('script');s.type='text/javascript';s.src='https://a.omappapi.com/app/js/api.min.js';s.async=true;s.dataset.user=u;s.dataset.account=ac;d.getElementsByTagName('head')[0].appendChild(s);})(document,<%=FOptinMonsterUserID%>,<%=FOptinMonsterAccountID%>);</script>
<%
' if purchase conversion activated then get the conversion amount
Dim LTrackConversion, LConversionValue
LTrackConversion = TrackPurchaseConversion
If LTrackConversion Then
LConversionValue = GetConversionValue(Session("OrderNoPlaced"))
%>
<script>
!function(o,a){var n;((n=window)._omq=n._omq||[]).push([o,a])}(
'sale',
{
value: '<%=LConversionValue%>',
currency: 'GBP',
transaction_id: '<%=Session("OrderNoPlaced")%>',
test: false
});
</script>
<%
End If
%><!-- End of OptinMonster -->
<%
End Sub
' (SS,15/1/24)
Sub DoBackonaAnalytics
' e.g. https://track-fb-pixel-appanalytics-googleanalytics.backona.com/gtag.js?dl=app.castironradiatorcentre.co.uk"
%>
<!-- Backona -->
<script src="https://track-fb-pixel-appanalytics-googleanalytics.backona.com/gtag.js?dl=<%=FBackonaAnalyticsDomain%>">
</script>
<!-- End Backona -->
<%
End Sub
' (SS,2/7/23) following removed for now, due to conversions not being tracked since change made
Sub DoFacebookPixel_ConsentVersion_removed
' exit if not the product.asp page or Pixel ID not set
' (SS,2/3/18) removed Not ScriptIsProducts Or because this is now done in calling routine i.e. HTMLHeadEnd
If FFacebookPixelID = "" Then Exit Sub
' if purchase conversion activated then get the conversion amount
Dim LTrackConversion, LConversionValue
LTrackConversion = TrackPurchaseConversion ' (SS,2/3/18) TrackPurchaseConversion replaces previous if conditions
If LTrackConversion Then
' (SS,2/3/18) removed following, no longer necessary
' Session("FacebookPurchaseConversionTrackingDone") = True ' so that we only it do it once per session
LConversionValue = GetConversionValue(Session("OrderNoPlaced"))
End If
' (SS,20/6/23) added fbq('consent', 'revoke');
' as mentioned here https://developers.facebook.com/docs/meta-pixel/implementation/gdpr/
%>
<!-- Facebook Pixel Code -->
<script>
!function(f,b,e,v,n,t,s){if(f.fbq)return;n=f.fbq=function(){n.callMethod?
n.callMethod.apply(n,arguments):n.queue.push(arguments)};if(!f._fbq)f._fbq=n;
n.push=n;n.loaded=!0;n.version='2.0';n.queue=[];t=b.createElement(e);t.async=!0;
t.src=v;s=b.getElementsByTagName(e)[0];s.parentNode.insertBefore(t,s)}(window, document,'script','//connect.facebook.net/en_US/fbevents.js');
fbq('consent', 'revoke');
fbq('init', '<%=FFacebookPixelID%>');
fbq('track', 'PageView');
<%If IsProductDetailsPage Then%>
fbq('track', 'ViewContent', {
content_ids: ['<%=GetProductCode%>'],
content_type: 'product'
});
<%End If%>
<%If IsAddToBasketPage Then%>
fbq('track', 'AddToCart', {
content_ids: ['<%=GetBasketProductCode%>'],
content_type: 'product'
});
<%End If%>
<%If IsNewSearch Then%>
fbq('track', 'Search', {
search_string: '<%=JavaScriptStrEscape(GetSearch)%>'
});
<%End If%>
<%If IsStartOfCheckout Then%>
fbq('track', 'InitiateCheckout', {
num_items: <%=GetTotalItemsInBasket%>
});
<%End If%>
<%If IsCheckoutFilled Then%>
fbq('track', 'AddPaymentInfo');
<%End If%>
<%If LTrackConversion Then%>
<%DoTrackPurchaseEvent ttFacebook%>
<%End If%>
</script>
<!-- End Facebook Pixel Code -->
<%
' (SS,3/11/17) removed the noscript version because it was causing W3C validator to give error message, replaced < with [, and > with ] to avoid script compile error
'<noscript><img height="1" width="1" style="display:none" src="https://www.facebook.com/tr?id=[%=FFacebookPixelID%]&ev=PageView&noscript=1" /></noscript>
End Sub
' *** to be continued, cookie bar stuff
' (SS,20/6/23) cookie consent routine called from cookie bar OK button
' cb-enabled: blank default consent, denied
' cb-enabled: enabled or accepted then granted
' if user clicks "ok" then update "granted" i.e. itp_CookieConsent called
' see https://developers.google.com/tag-platform/devguides/consent?sjid=11941127019246313036-EU
' for facebook see https://developers.facebook.com/docs/meta-pixel/implementation/gdpr/
Sub DoCookieConsent
Dim LCookieResponse, LCookieConsented
LCookieResponse = GetCookie("cb-enabled")
LCookieConsented = LCookieResponse = "enabled" Or LCookieResponse = "accepted"
%>
<!--- cookie consent -->
<script><%
' Google Analytics and Ads
If FGoogleAnalyticsWebPropertyID <> "" Then
If LCookieConsented Then%>
gtag('consent', 'default', {
'ad_storage': 'granted',
'analytics_storage': 'granted'
});
<% Else%>
gtag('consent', 'default', {
'ad_storage': 'denied',
'analytics_storage': 'denied'
});
<% End If
End If
' Facebook Pixel
If FFacebookPixelID <> "" Then
If LCookieConsented Then%>
fbq('consent', 'grant');
<% End If
End If
' javascript code called from cookie bar "OK" button
%>
function itp_CookieConsent(){
<%If FGoogleAnalyticsWebPropertyID <> "" Then%>
gtag('consent', 'update', {
'ad_storage': 'granted',
'analytics_storage': 'granted'
});
<%End If
If FFacebookPixelID <> "" Then%>
fbq('consent', 'grant');
<%End If%>
}
</script>
<%
End Sub
' (SS,27/11/13) added AAsync parameter which can be true or false, and modified to do asynchronous
' (SS,11/04/16) had stopped working when changed over from ga.js to analytics.js on 3/3/16
' was due to not adding ga('require', 'ecommerce'); ga('ecommerce:addTransaction',
' mentioned here https://developers.google.com/analytics/devguides/collection/upgrade/reference/gajs-analyticsjs#snippet
' (SS,31/7/17) added order no existence check to prevent error when no session
' (SS,5/3/18) removed AAsync parameter, converted to use gtag, added Discount line, also corrected value by removing discount from it
' (SS,10/4/19) renamed DoGoogleAnalyticsEcommerce to DoTrackPurchaseEvent to also work for Facebook
' added ATrackType parameter which can be ttGoogle for Google or ttFacebook for Facebook
' (SS,11/4/19) added JavaScriptStrEscape to GetStoreName
' (SS,16/1/24) indented Facebook script a bit further to look tidier when Backona enabled
Sub DoTrackPurchaseEvent(ATrackType)
If Not FEcommerceTrackingEnabled Or Not TrackPurchaseConversion Then Exit Sub ' (SS,5/3/18) replaced FEcommerceTrackingActivated with TrackPurchaseConversion
Dim LOrderNo
LOrderNo = Session("OrderNoPlaced")
' main transaction details
OpenQuery("SELECT o.*, v.VoucherCode FROM orders o LEFT JOIN vouchers v ON v.VoucherID = o.VoucherID WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'")
Dim LSubtotal, LDelivery, LVATIncluded, LVATDeducted, LTax, LDiscount, LVoucherCode
LSubtotal = GetFieldValue("Subtotal")
LDelivery = GetFieldValue("Delivery")
LDiscount = GetFieldValue("Discount") ' (SS,5/3/18) discount held as a negative
LVATIncluded = GetFieldValue("VATIncluded")
LVATDeducted = GetFieldValue("VATDeducted")
LTax = LVATIncluded
LVoucherCode = NB(GetFieldValue("VoucherCode"))
' if prices include VAT then deduct VAT from LSubTotal and LDelivery
If PricesEnteredIncludeVAT Then
LSubtotal = LSubtotal - GetVATAmount(LSubtotal)
LDelivery = LDelivery - GetVATAmount(LDelivery)
LDiscount = LDiscount - GetVATAmount(LDiscount) ' (SS,5/3/18)
End If
LSubtotal = LSubtotal + LDiscount ' (SS,5/3/18) i.e. minus because discount negative
' Format2dpnc makes sure that there are always 2 dp e.g. 10.1 will be 10.10, 5 will be 5.00, also there are no commas for thousands
If ATrackType = ttGoogle Then
%>
gtag('event', 'purchase', {
"transaction_id": "<%=LOrderNo%>",
"affiliation": "<%=JavaScriptStrEscape(GetStoreName)%>",
"value": <%=Format2dpnc(LSubTotal)%>,
"currency": "GBP",
"tax": <%=Format2dpnc(LVATIncluded)%>,
"shipping": <%=Format2dpnc(LDelivery)%>,
"items": [<%
Else ' ttFacebook
%>
fbq('track', 'Purchase', {
content_type: 'product',
value: <%=Format2dpnc(LSubTotal)%>,
currency: 'GBP',
contents: [<%
End If
CloseQuery
' individual item details
' (SS,31/10/18) added GetOrderDetailsFilter to filter out subproducts
OpenQuery("SELECT * FROM orderdetails WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'" & GetOrderDetailsFilter & " ORDER BY OrderDetailID")
Dim LCount, LProductCode, LCategory, LGroup, LSubcategory, LPriceEach
' (SS,5/3/18) removed following, no longer used or applicable here
' ClearRemarketingTagProductIDs ' (SS,28/11/13)
LCount = 0
Do While Not EndOfQuery
LCount = LCount + 1
LProductCode = GetFieldValue("ProductCode")
' (SS,5/3/18) removed following, no longer used or applicable here
'AddRemarketingTagProductID(LProductCode) ' (SS,28/11/13)
LPriceEach = GetFieldValue("PriceEach")
' if prices already include VAT then deduct the VAT
If PricesEnteredIncludeVAT Then
LPriceEach = LPriceEach - GetVATAmount(LPriceEach)
End If
' lookup the first category for this product
GetFirstCatSubcatForProduct LProductCode, LGroup, LCategory, LSubcategory
LCategory = Trim(LSubcategory & " - " & LCategory) ' NB. subcategory first because we don't want it to be chopped, don't mind category being chopped
If LCategory = "-" Then LCategory = ""
' (SS,11/4/16) replaced above with following, new Universal Analytics version
' (SS,5/3/18) replaced with new gtag version (Global Site Tag), implemented in GoogleAnalyticsEcommerceAddItem
' (SS,10/4/19) replaced GoogleAnalyticsEcommerceAddItem with TrackPurchaseEventAddItem which also works for Facebook, added ATypeType parameter
TrackPurchaseEventAddItem ATrackType, LCount, LProductCode, GetFieldValue("ProductName"), LCategory, GetFieldValue("Qty"), LPriceEach
NextQueryRecord
Loop
CloseQuery
' (SS,5/3/18) added discount line
If LDiscount <> 0 Then
' (SS,10/4/19) renamed GoogleAnalyticsEcommerceAddItem to TrackPurchaseEventAddItem, added ATrackType so that it also works for Facebook
TrackPurchaseEventAddItem ATrackType, LCount + 1, "DISCOUNT", "Discount Voucher Code: " & LVoucherCode, "Discount", 1, LDiscount
End If
' (SS,5/3/18) close the gtag (or fbq (10/4/19))
%>
]
});
<%
End Sub
' (SS,5/3/18) add ecommerce item to Google Analytics gtag
' (SS,10/4/19) renamed GoogleAnalyticsEcommerceAddItem to TrackPurchaseEventAddItem, added ATrackType to also work for Facebook
' (SS,11/4/19) replaced 2 x SingleQuotedJavascriptString with JavaScriptStrEscape because product name may contain a double quote
' (SS,25/5/21) added 'google_business_vertical': 'retail'
Sub TrackPurchaseEventAddItem(ATrackType, ACount, AProductCode, AProductName, ACategory, AQuantity, APriceEach)
' add a comma as a separator if not first item
If ACount > 1 Then
Response.Write(",")
End If
If ATrackType = ttGoogle Then%>
{
"id": "<%=AProductCode%>",
"name": "<%=JavaScriptStrEscape(AProductName)%>",
"category": "<%=JavaScriptStrEscape(ACategory)%>",
"quantity": <%=AQuantity%>,
"price": "<%=Format2dpnc(APriceEach)%>",
"google_business_vertical": "retail"
}<%
Else%>
{
id: '<%=AProductCode%>',
quantity: <%=AQuantity%>,
item_price: <%=Format2dpnc(APriceEach)%>
}<%
End If
End Sub
' (SS,12/11/08)
Sub ActivateGoogleAdWordsNewAccountConversion
FAdWordsNewAccountConversionActivated = True
End Sub
' (SS,10/10/17) returns conversion value used for Google AdWords and Facebook Pixel
' value returned is the subtotal with discount applied and VAT removed (delivery is ignored)
Function GetConversionValue(AOrderNo)
Dim LResult, LSQL, LSubtotal, LDiscount, LVATIncluded
LResult = "0.00"
LSQL = "SELECT Subtotal, Discount, VATIncluded FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'"
If GetSQL3Values(LSQL, LSubtotal, LDiscount, LVATIncluded) Then
LResult = LSubtotal + LDiscount ' discount is negative so we add
' if prices include VAT and VAT was charged (will not be charged for RW orders)
If PricesEnteredIncludeVAT And LVATIncluded > 0 Then LResult = LResult - GetVATAmount(LResult)
LResult = Format2dpnc(LResult) ' convert to sign to 2dp and no commas
End If
GetConversionValue = LResult
End Function
' (SS,17/9/21) returns additional values for enhanced conversion
' (SS,1/8/22) added postcode, country, city and county via second GetSQL4Values
' see https://support.google.com/google-ads/answer/10172785?hl=en#zippy=%2Cidentify-and-define-your-enhanced-conversions-variables
Function GetEnhancedConversionValues(AOrderNo, ByRef AEmailAddress, ByRef ATelephone, ByRef AFirstName, ByRef ASurname, ByRef APostcode, ByRef ACountryCode, ByRef ATown, ByRef ACounty)
Dim LResult, LSQL
LSQL = "SELECT EmailAddress, Telephone, FirstName, Surname FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'"
If GetSQL4Values(LSQL, AEmailAddress, ATelephone, AFirstName, ASurname) Then
LResult = True
LSQL = "SELECT Postcode, countries.CodeA2, Town, County FROM orders LEFT JOIN countries ON orders.Country = countries.Country WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'"
If GetSQL4Values(LSQL, APostcode, ACountryCode, ATown, ACounty) Then
LResult = True
Else
LResult = False
End If
Else
LResult = False
End If
GetEnhancedConversionValues = LResult
End Function
' (SS,5/3/18) keeps a count of the number of main page views
Sub IncrementPageViewCount
If Session("PageViewCount") = "" Then Session("PageViewCount") = 0
Session("PageViewCount") = Session("PageViewCount") + 1
End Sub
' (SS,5/3/18) returns page view count from session variable (also see Sub IncrementPageViewCount)
Function GetPageViewCount
GetPageViewCount = IIf(Session("PageViewCount") = "", 0, Session("PageViewCount"))
End Function
' (SS,2/3/18) returns true if conversion tracking needs to be done
' i.e. when return from payment provider, and order no exists and same order number not done before in this session
Function TrackPurchaseConversion
' (SS,30/4/18) replaced IsReturnFromPaymentProviderPage with IsSuccessfulReturnFromPaymentProviderPage which checks to make sure certain payment providers return successful status i.e. Payzone and EPDQ
' (SS,4/10/20) noticed IsReturnFromPaymentProviderPage hadn't been changed to IsSuccessfulReturnFromPaymentProviderPage, change it now
TrackPurchaseConversion = IsSuccessfulReturnFromPaymentProviderPage And Session("OrderNoPlaced") <> "" And Session("PurchaseConversionTrackedOrderNo") <> Session("OrderNoPlaced")
End Function
' (SS,2/3/18) marks in session the order no for which conversion tracking has been done so that it's not done again for same order no
Sub TrackPurchaseConversionDone
Session("PurchaseConversionTrackedOrderNo") = Session("OrderNoPlaced")
End Sub
' (SS,5/3/18) logs the purchase conversion tracking to conversion_tracking_log table
Sub TrackPurchaseConversionAddToLog
Const MAX_SIZE = 255
Dim LOrderNo, LURL, LQueryString, LReferrer, LUserAgent, LCookie, LSQL
LOrderNo = Session("OrderNoPlaced")
LURL = Left(Request.ServerVariables("URL"), MAX_SIZE)
LQueryString = Left(Request.ServerVariables("QUERY_STRING"), MAX_SIZE)
LReferrer = Left(Request.ServerVariables("HTTP_REFERER"), MAX_SIZE)
LUserAgent = Left(Request.ServerVariables("HTTP_USER_AGENT"), MAX_SIZE)
LCookie = Request.ServerVariables("HTTP_COOKIE")
' NB. PaymentMethod can't be set here due to it not being set yet in the order record, this is updated in Sub TrackPurchaseConversionUpdateLog later
LSQL = "INSERT INTO conversion_tracking_log SET DateTimeLogged = NOW()" &_
", OrderNo = '" & CleanSQLStr(LOrderNo) & "'" &_
", ConversionValue = '" & GetConversionValue(LOrderNo) & "'" &_
", GrandTotal = '" & CleanSQLStr(GetOrderFieldValue(LOrderNo, "GrandTotal")) & "'" &_
", PageViews = '" & GetPageViewCount & "'" &_
", SessionID = '" & Session.SessionID & "'" &_
", IPAddress = '" & CleanSQLStr(Request.ServerVariables("REMOTE_ADDR")) & "'" &_
", URL = '" & CleanSQLStr(LURL) & "'" &_
", QueryString = '" & CleanSQLStr(LQueryString) & "'" &_
", Referrer = '" & CleanSQLStr(LReferrer) & "'" &_
", UserAgent = '" & CleanSQLStr(LUserAgent) & "'" &_
", Cookie = '" & CleanSQLStr(LCookie) & "'"
ExecuteQuery LSQL
' get the newly inserted ID to use for updating later, i.e. PaymentMethod is added in TrackPurchaseConversionUpdateLog
Session("ConversionTrackingLogID") = GetSQLLastInsertID
End Sub
' (SS,6/3/18) called from Sub Finalise, sets the PaymentMethod which can't be set earlier in TrackPurchaseConversionAddToLog
Sub TrackPurchaseConversionUpdateLog
' if record inserted earlier then update the PaymentMethod
If Session("ConversionTrackingLogID") <> "" Then
ExecuteQuery "UPDATE conversion_tracking_log SET PaymentMethod = '" & CleanSQLStr(GetOrderFieldValue(Session("OrderNoPlaced"), "PaymentMethod")) & "' WHERE ID = " & Session("ConversionTrackingLogID")
Session("ConversionTrackingLogID") = "" ' clear it so that it's not done again unless requested
End If
End Sub
' (SS,28/5/21) returns Google Ads ID prefixed with AW-
Function GetGoogleAdsConversionID
Dim LResult
LResult = FAdwordsConversionTrackingID
If LResult <> "" Then
If Left(LResult, 3) <> "AW-" Then
LResult = "AW-" & LResult
End If
End If
GetGoogleAdsConversionID = LResult
End Function
' -------------------------------------------
' End of web analytics routines
' -------------------------------------------
' ----------------------------------- '
' Start of Voucher Code Routines '
' ----------------------------------- '
' (SS,15/5/09) check voucher, return true if valid and discount <> 0, else false with error message in AErrorMessage
' (SS,12/5/20) removed check for discount of 0, because 0 is valid when there's free delivery
Function CheckVoucherCode(AVoucherCode, ByRef AErrorMessage)
CheckVoucherCode = False
AErrorMessage = ""
If AVoucherCode = "" Then Exit Function
If Not IsVoucherCodeValid(AVoucherCode, AErrorMessage) Then Exit Function
' determine the LSubtotal for current basket items, other variables are required by GetOrderTotalsForBasket
Dim LSubtotal, LDiscount, LTotalWeight, LNonWeightPrice, LVATTotal, LDelivery, LGrandTotal, LVATIncluded, LVATDeducted, LItems
' (SS,21/2/24) added LItems parameter
GetOrderTotalsForBasket FSessionID, LSubtotal, LDiscount, LDelivery, LGrandTotal, LVATIncluded, LVATDeducted, LTotalWeight, LItems
' GetDiscountUsingVoucherCode is called by GetOrderTotalsForBasket to return LDiscount
' (SS,12/5/20) removed following discount of 0 check because there can now a voucher can give free delivery without a discount value be set
'
'If LDiscount = 0 Then
' AErrorMessage = tr("Voucher code") & " '" & AVoucherCode & "' " & tr("results in no discount") ' (SS,12/5/10) removed " for this order"
'Else
' CheckVoucherCode = True
'End If
' (SS,12/5/20) following replaces above
CheckVoucherCode = True
End Function
' (SS,22/4/09) checks if given voucher code is valid
' also makes sure if single use voucher and usage count is 0 or 1 and used by this order only
' (SS,13/5/09) single usage now checks single usage per customer
' (SS,14/5/09) single usage replaced with voucher type, which can be
' "S" for Single Use, "SC" Single Use for Customer or "M" Multiple Use
' (SS,15/5/09) added ByRef AErrorMessage to return error message when voucher code is invalid
' improved to return useful message
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,16/2/15) voucher type can now be "A" for Auto which is also multiple
' (SS,17/2/15) voucher type can now also be "MC" for multiple use per customer
' (SS,12/5/20) removed "AND Discount <> 0" from check in "SC" and "MC" because discount of 0 is now valid when free delivery used
Function IsVoucherCodeValid(AVoucherCode, ByRef AErrorMessage)
IsVoucherCodeValid = False
AErrorMessage = ""
If AVoucherCode = "" Then Exit Function
If IsNull(GetValueFromQuery("VoucherCode", "SELECT * FROM vouchers WHERE VoucherCode = '" & CleanSQLStr(AVoucherCode) & "'")) Then
AErrorMessage = tr("Voucher code") & " '" & AVoucherCode & "' " & tr("is not valid")
Exit Function
End If
Dim LResult, LVoucherType
LResult = False
LVoucherType = GetValueFromQuery("VoucherType", "SELECT * FROM vouchers WHERE VoucherCode = '" & CleanSQLStr(AVoucherCode) & "' AND CURDATE() >= ValidFromDate AND CURDATE() <= ExpiryDate")
If IsNull(LVoucherType) Then
AErrorMessage = tr("Voucher code") & " '" & AVoucherCode & "' " & tr("has expired")
Exit Function
End If
' (SS,17/2/15) moved voucher ID lookup code here from below and added If LVoucherType <> "M"
Dim LVoucherID
If LVoucherType <> "M" Then LVoucherID = GetVoucherIDForVoucherCode(AVoucherCode)
' if voucher found then make sure it's only been used once
If LVoucherType = "S" Or LVoucherType = "SC" Then
' (SS,13/5/09) check single usage for this customer (by CustomerID or email address)
Dim LSQL, LOrderCount, LLastOrderNo
' (SS,12/5/20) removed "AND Discount <> 0" because discount can be zero when voucher is a free delivery type
LSQL = "SELECT COUNT(*) AS OrderCount, MAX(OrderNo) AS LastOrderNo FROM orders WHERE VoucherID = " & LVoucherID & " AND Status <> '" & ORDER_CANCELLED_STATUS & "'"
If LVoucherType = "SC" Then
' (SS,17/2/15) added CleanSQLStr to following two lines to prevent SQL injection, missed from before
LSQL = LSQL + " AND (EmailAddress = '" & CleanSQLStr(Session("Email")) & "'"
If Session("AccountID") <> "" Then LSQL = LSQL + " OR CustomerID = '" & CleanSQLStr(Session("AccountID")) & "'"
LSQL = LSQL & ")" ' close the bracket
End If
OpenQuery2(LSQL)
LOrderCount = GetQueryValue2("OrderCount")
LLastOrderNo = GetQueryValue2("LastOrderNo")
CloseQuery2
If LOrderCount = 1 Then ' used only by current order
LResult = Session("OrderNoPlaced") = LLastOrderNo
ElseIf LOrderCount > 1 Then ' used more than once already
LResult = False
Else ' i.e. not used so far
LResult = True
End If
' (SS,17/2/15) multiple use per customer
ElseIf LVoucherType = "MC" Then
' allow it if email not currently entered, i.e. at basket page
If Session("Email") = "" Then
LResult = True
Else
' set to True if not used by another customer
' (SS,12/5/20) removed "AND Discount <> 0" because discount can be zero when voucher is a free delivery type
LResult = GetSQLValue("SELECT COUNT(*) FROM orders WHERE VoucherID = " & LVoucherID & " AND Status <> '" & ORDER_CANCELLED_STATUS & "' AND EmailAddress <> '" & CleanSQLStr(Session("Email")) & "'") = 0
End If
Else ' i.e. "M" multiple
LResult = True
End If
If LResult = False Then
AErrorMessage = "Voucher code '" & AVoucherCode & "' has already been used"
If LVoucherType = "SC" Then
AErrorMessage = AErrorMessage & " by you"
' (SS,17/2/15)
ElseIf LVoucherType = "MC" Then
AErrorMessage = AErrorMessage & " by another customer"
End If
End If
IsVoucherCodeValid = LResult
End Function
' (SS,16/2/15) returns True if given voucher code is an Auto one
' used to decide whether to apply auto voucher, is existing one isn't auto and is valid then auto voucher code isn't applied
Function IsVoucherCodeAuto(AVoucherCode)
Dim LResult
If AVoucherCode = "" Then
LResult = False
Else
LResult = Not IsNull(GetValueFromQuery("VoucherCode", "SELECT * FROM vouchers WHERE VoucherCode = '" & CleanSQLStr(AVoucherCode) & "' AND VoucherType = 'A'"))
End If
IsVoucherCodeAuto = LResult
End Function
' (SS,16/2/15)
' (SS,19/3/20) added ADelivery and ByRef AFreeDelivery to allow free delivery value to be passed back
' (SS,28/7/23) change to set the correct Discount Info
Function GetDiscountUsingAutoVoucherCode(ABasketSessionID, ASubtotal, ADelivery, ByRef AFreeDelivery)
Dim LVoucherCodes, LVoucherCodeCount
ReDim LVoucherCodes(-1)
LVoucherCodeCount = 0
' find all auto voucher codes still valid
OpenQuery("SELECT * FROM vouchers WHERE VoucherType = 'A' AND CURDATE() >= ValidFromDate AND CURDATE() <= ExpiryDate")
Do While Not EndOfQuery
ReDim Preserve LVoucherCodes(UBound(LVoucherCodes) + 1)
LVoucherCodes(LVoucherCodeCount) = GetQueryValue("VoucherCode")
LVoucherCodeCount = LVoucherCodeCount + 1
NextQueryRecord
Loop
CloseQuery
' determine the voucher code with maximum discount
Dim i, LDiscount, LMaxDiscount, LMaxDiscountVoucherCode
LMaxDiscount = 0
LMaxDiscountVoucherCode = ""
For i = 0 To UBound(LVoucherCodes)
LDiscount = GetDiscountUsingVoucherCode(LVoucherCodes(i), ABasketSessionID, ASubtotal, ADelivery, AFreeDelivery) ' (SS,19/3/20) added ADelivery, AFreeDelivery
If LDiscount < LMaxDiscount Then ' discount is negative
LMaxDiscount = LDiscount
LMaxDiscountVoucherCode = LVoucherCodes(i)
End If
'Response.Write "Auto voucher code: " & LVoucherCodes(i) & ", Discount: " & LDiscount & BR
Next
'Response.Write "Max auto voucher code: " & LMaxDiscountVoucherCode & ", Max discount: " & LMaxDiscount & BR
SetVoucherCode LMaxDiscountVoucherCode ' save the voucher code or clear it
' (SS,28/7/23) Discount Info is now being set by GetDiscountUsingVoucherCode, this could be lost due to different voucher codes being applied above and correct info not being preserved
' fixed by calling GetDiscountUsingVoucherCode again to get the correct discount info for the voucher being applied
If LMaxDiscountVoucherCode <> "" Then
LMaxDiscount = GetDiscountUsingVoucherCode(LMaxDiscountVoucherCode, ABasketSessionID, ASubtotal, ADelivery, AFreeDelivery)
End If
GetDiscountUsingAutoVoucherCode = LMaxDiscount
End Function
' (SS,23/4/09) must be called with valid VoucherCode
' (SS,19/12/18) modified to handle new MinimumQty field
' (SS,19/3/20) modified to add Free Delivery feature, and also additional range, added ADelivery and ByRef AFreeDelivery parameter
' (SS,20/7/23) modified to not apply discountable total to second discount and to sum the discount if free delivery not used for CIRC (25OFF discount that provides �25 for ads and 5% for all if �2000+)
' (SS,28/7/23) modified to set Discount Info via calls to new ClearDiscountInfo AddDiscountInfo
Function GetDiscountUsingVoucherCode(AVoucherCode, ABasketSessionID, ASubtotal, ADelivery, ByRef AFreeDelivery)
' default to zero discount
GetDiscountUsingVoucherCode = 0
AFreeDelivery = False ' (SS,19/3/20) default to no free delivery
ClearDiscountInfo ' (SS,28/7/23)
' get the voucher values
Dim LMinimumSpend, LMinimumQty, LDiscountAmount, LDiscountPercentage, LCategory, LSubcategory
LDiscountAmount = 0
LDiscountPercentage = 0
' (SS,19/3/20)
Dim LFreeDelivery, LMinimumSpend2, LMinimumQty2, LDiscountAmount2, LDiscountPercentage2, LFreeDelivery2
LFreeDelivery = False
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT * FROM vouchers WHERE VoucherCode = '" + CleanSQLStr(AVoucherCode) + "'")
If Not EndOfQuery Then
' NZD used because fields are DECIMAL (not FLOAT) and convert to string causing Type Mismatch error
LMinimumSpend = NZD(GetQueryValue("MinimumSpend"))
LMinimumQty = NZL(GetQueryValue("MinimumQty")) ' (SS,19/12/18) MinimumQty is an integer so NZL used instead of NZD
LDiscountAmount = NZD(GetQueryValue("DiscountAmount"))
LDiscountPercentage = NZD(GetQueryValue("DiscountPercentage"))
' (SS,19/3/20)
LFreeDelivery = IntToBool(GetQueryValue("FreeDelivery"))
LMinimumSpend2 = NZD(GetQueryValue("MinimumSpend2"))
LMinimumQty2 = NZL(GetQueryValue("MinimumQty2"))
LDiscountAmount2 = NZD(GetQueryValue("DiscountAmount2"))
LDiscountPercentage2 = NZD(GetQueryValue("DiscountPercentage2"))
LFreeDelivery2 = IntToBool(GetQueryValue("FreeDelivery2"))
LCategory = NB(GetQueryValue("Category"))
LSubcategory = NB(GetQueryValue("Subcategory"))
End If
CloseQuery
' exit with 0 if discount amount and percentage are both zero
' (SS,19/3/20) added LFreeDelivery = False, and also second set of values
If LDiscountAmount = 0 And LDiscountPercentage = 0 And LFreeDelivery = False And LDiscountAmount2 = 0 And LDiscountPercentage2 = 0 And LFreeDelivery2 = False Then Exit Function
' (13/5/09) if list of product codes this voucher is valid for
Dim LProductCodeList
LProductCodeList = VoucherProductCodeList(AVoucherCode)
If LProductCodeList <> "" Then LProductCodeList = "," + LProductCodeList + ","
' determine total value of order, if category specified then only total value for products belonging to this category/subcategory
' (SS,19/12/18) added LDiscountableQty
Dim LProductCode, LInclude, LPriceEach, LQty, LDiscountableTotal, LDiscountableQty
LDiscountableTotal = 0
LDiscountableQty = 0 ' (SS,19/12/18)
' (SS,26/10/18) added False parameter to GetOrderItemsQuery to exclude subproducts
OpenQuery(GetOrderItemsQuery(ABasketSessionID, False))
Do While Not EndOfQuery
LProductCode = GetQueryValue("ProductCode")
If InStr(LProductCodeList, "," + LProductCode + ",") > 0 Then ' (SS,13/5/09)
LInclude = True
ElseIf LSubcategory <> "" Then
LInclude = IsProductInSubcategory(LProductCode, LCategory, LSubcategory)
ElseIf LCategory <> "" Then
LInclude = IsProductInCategory(LProductCode, LCategory)
ElseIf LProductCodeList = "" Then ' (SS,13/5/09)
LInclude = True
Else
LInclude = False
End If
If LInclude Then
LQty = GetQueryValue("Qty")
LDiscountableQty = LDiscountableQty + LQty ' (SS,19/12/18)
' (SS,6/7/11) removed LQty parameter, added True, to look up options price
GetPricingFromProductRecord(True)
LPriceEach = GetProductPrice
LDiscountableTotal = LDiscountableTotal + (LPriceEach * LQty)
End If
NextQueryRecord
Loop
CloseQuery
' (SS,19/3/20) code above moved to separate GetDiscountForRange
Dim LDiscountApplied, LDoDiscountAmount, LDoFreeDelivery
LDiscountApplied = GetDiscountForRange(ASubtotal, LDiscountableTotal, LDiscountableQty, LMinimumSpend, LMinimumQty, LDiscountAmount, LDiscountPercentage, LFreeDelivery, LDoDiscountAmount, LDoFreeDelivery)
Dim LDiscountApplied2, LDoDiscountAmount2, LDoFreeDelivery2
' (SS,20/7/23) for CIRC, only apply the LDiscountableTotal i.e. for category/product for first discount (above), second discount is applied to the whole subtotal,
' this allows �25 off for radiators plus 5% off whole order, implemented by changing 2nd parameter from LDiscountableTotal to ASubtotal
LDiscountApplied2 = GetDiscountForRange(ASubtotal, ASubtotal, LDiscountableQty, LMinimumSpend2, LMinimumQty2, LDiscountAmount2, LDiscountPercentage2, LFreeDelivery2, LDoDiscountAmount2, LDoFreeDelivery2)
' apply whichever is the greater discount, default to nothing first
Dim LDiscount
LDiscount = 0
AFreeDelivery = False
If LDiscountApplied And Not LDiscountApplied2 Then
LDiscount = LDoDiscountAmount
AFreeDelivery = LDoFreeDelivery
ElseIf Not LDiscountApplied And LDiscountApplied2 Then
LDiscount = LDoDiscountAmount2
AFreeDelivery = LDoFreeDelivery2
ElseIf LDiscountApplied And LDiscountApplied2 Then
' work out which is of the two is the highest taking into account the delivery saved if free delivery and use that
If LDoFreeDelivery Or LDoFreeDelivery2 Then
' (SS,20/7/23) as before if free delivery used
Dim LDoDiscountAmountIncDelivery, LDoDiscountAmountIncDelivery2
If LDoFreeDelivery Then
LDoDiscountAmountIncDelivery = LDoDiscountAmount + ADelivery
Else
LDoDiscountAmountIncDelivery = LDoDiscountAmount
End If
If LDoFreeDelivery2 Then
LDoDiscountAmountIncDelivery2 = LDoDiscountAmount2 + ADelivery
Else
LDoDiscountAmountIncDelivery2 = LDoDiscountAmount2
End If
If LDoDiscountAmountIncDelivery >= LDoDiscountAmountIncDelivery2 Then
LDiscount = LDoDiscountAmount
AFreeDelivery = LDoFreeDelivery
Else
LDiscount = LDoDiscountAmount2
AFreeDelivery = LDoFreeDelivery2
End if
Else ' (SS,20/7/23) if no free delivery then add the two together (for CIRC)
LDiscount = Round2dp(LDoDiscountAmount + LDoDiscountAmount2)
LDiscount = Min(ASubtotal, LDiscount) ' make sure discount is never more than the subtotal
End If
End If
' (SS,28/7/23)
If AFreeDelivery Then
AddDiscountInfo "free delivery"
ElseIf LDiscount = 0 Then ' if not discount and free delivery then clear the discount info
ClearDiscountInfo
End If
GetDiscountUsingVoucherCode = -LDiscount ' return discount as a negative number
End Function
' (SS,19/3/20) moved code here from GetDiscountUsingVoucherCode, can now be called twice to 2 different ranges
' (SS,20/7/23) fixed bug where ADiscountAmount was incorrectly being applied when category/product chosen, due to a previous change to use ASubtotal instead of ADiscountableTotal for AMinimumSpend
' (SS,28/7/23) changed to add discount info via callls to AddDiscountInfo
' (SS,4/8/23) correction to discount info to remove VAT where applicable and in selected currency
Function GetDiscountForRange(ASubtotal, ADiscountableTotal, ADiscountableQty, AMinimumSpend, AMinimumQty, ADiscountAmount, ADiscountPercentage, AFreeDelivery, ByRef ADoDiscountAmount, ByRef ADoFreeDelivery)
GetDiscountForRange = False ' default to false, i.e. not applied
ADoDiscountAmount = 0 ' default to zero amount
ADoFreeDelivery = False ' default to not free delivery
' if nothing set then exit without setting anything
If ADiscountAmount = 0 And ADiscountPercentage = 0 And AFreeDelivery = False Then Exit Function
' (SS,27/01/2010) corrected ">" to ">="
' (SS,19/12/18) added LDiscountableQty >= LMinimumQty
' (SS,19/6/20) replaced ADiscountableTotal with ASubtotal, i.e. overall total is checked for minimum spend, requested by Neil
If ASubtotal >= AMinimumSpend And ADiscountableQty >= AMinimumQty Then
Dim LDiscount
LDiscount = Round2dp(ADiscountAmount + (ADiscountableTotal * ADiscountPercentage / 100))
If LDiscount < 0 Then
LDiscount = 0 ' make sure it never goes below zero
ElseIf LDiscount > ASubtotal Then
LDiscount = ASubtotal ' make sure discount is never above the subtotal of order
End If
' (SS,20/7/23) added following to fix bug where ADiscountAmount wasn't taking ADiscountableTotal into account i.e. when limiting discount to a category or product
If LDiscount > ADiscountableTotal Then LDiscount = ADiscountableTotal
' (SS,28/7/23) set the discount info
If LDiscount > 0 Then
If ADiscountAmount > 0 Then
' AddDiscountInfo "�" & ADiscountAmount
' (SS,4/8/23) replaced above with following to work correctly with HF i.e. remove VAT where applicable and in selected currency
AddDiscountInfo CorrectCurrencyNV(ADiscountAmount)
End If
If ADiscountPercentage > 0 And ADiscountableTotal > 0 Then
AddDiscountInfo ADiscountPercentage & "%"
End If
End If
ADoDiscountAmount = LDiscount ' return the discount
' (SS,19/3/20) if free delivery then set free delivery
If AFreeDelivery Then
ADoFreeDelivery = True
End If
GetDiscountForRange = True ' set to True to indicate it's been applied due to matching range
End If
' *** debug info
'Response.Write "###" & "MinimumSpend: " & AMinimumSpend & ", DiscountPercentage: " & ADiscountPercentage & ", FreeDelivery: " & AFreeDelivery & ", DoDiscountAmount: " & ADoDiscountAmount & ", DoFreeDelivery: " & ADoFreeDelivery & "###" & BR
End Function
' (SS,13/5/09) comma separated list of product codes for given voucher ID(AVoucherCode)
Function VoucherProductCodeList(AVoucherCode)
Dim LResult, LVoucherID
LResult = ""
LVoucherID = GetVoucherIDForVoucherCode(AVoucherCode)
OpenQuery2("SELECT * FROM voucherproducts WHERE VoucherID = " & LVoucherID)
Do While Not EndOfQuery2
LResult = LResult + iif(LResult = "", "", ",") + GetQueryValue2("ProductCode")
NextQueryRecord2
Loop
CloseQuery2
VoucherProductCodeList = LResult
End Function
' (SS,23/4/09) return VoucherID for VoucherCode, used to store VoucherID in orders table
' (SS,21/2/15) GetValueFromQuery was returning Null when voucher code not found, modified to convert this to NULL as a string
' this was occurring when invalid voucher code entered e.g. 'RAD-5' containing actual quotes, when PayPal Express Checkout Used
' which allows an invalid voucher code get past the order creation stage
Function GetVoucherIDForVoucherCode(AVoucherCode)
Dim LResult
If AVoucherCode = "" Then
LResult = Null
Else
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LResult = GetValueFromQuery("VoucherID", "SELECT VoucherID FROM vouchers WHERE VoucherCode = '" + CleanSQLStr(AVoucherCode) + "'")
End If
' (SS,21/2/15) NB #LResult = Null' doesn't work, have to use IsNull(LResult) function to detect Null
If IsNull(LResult) Then LResult = "NULL" ' convert to null as a string for MySQL use
GetVoucherIDForVoucherCode = LResult
End Function
' (SS,19/6/09) returns VoucherCode for VoucherID used for direct payments to restore Voucher in the new secure session
Function GetVoucherCodeForVoucherID(AVoucherID)
If NB(AVoucherID) = "" Then
GetVoucherCodeForVoucherID = ""
Else
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
GetVoucherCodeForVoucherID = GetValueFromQuery("VoucherCode", "SELECT VoucherCode FROM vouchers WHERE VoucherID = '" & CleanSQLStr(AVoucherID) & "'")
End If
End Function
' (SS,28/7/23)
Sub ClearDiscountInfo
Session("DiscountInfo") = ""
End Sub
' (SS,28/7/23)
Sub AddDiscountInfo(AInfo)
If AInfo <> "" Then
If Session("DiscountInfo") <> "" Then Session("DiscountInfo") = Session("DiscountInfo") & " + "
Session("DiscountInfo") = Session("DiscountInfo") & AInfo
End If
End Sub
' (SS,28/7/23)
Function GetDiscountInfo
GetDiscountInfo = Session("DiscountInfo")
End Function
' (SS,22/4/09) returns true if given product code is in given category, used in voucher code discount calculation
Function IsProductInCategory(AProductCode, ACategory)
IsProductInCategory = GetValueFromQuery("RecordCount", "SELECT COUNT(*) AS RecordCount FROM productcategories WHERE ProductCode = '" + CleanSQLStr(AProductCode) + "' AND Category = '" + CleanSQLStr(ACategory) + "'") > 0
End Function
' (SS,22/4/09) returns true if given product code is in given category & subcategory, used in voucher code discount calculation
Function IsProductInSubcategory(AProductCode, ACategory, ASubcategory)
IsProductInSubcategory = GetValueFromQuery("RecordCount", "SELECT COUNT(*) AS RecordCount FROM productcategories WHERE ProductCode = '" + CleanSQLStr(AProductCode) + "' AND Category = '" + CleanSQLStr(ACategory) + "' AND Subcategory = '" + CleanSQLStr(ASubcategory) + "'") > 0
End Function
' --------------------------------- '
' End of Voucher Code Routines '
' --------------------------------- '
' (SS,18/5/09) call to ShowProductDetail now goes through here
' this allows other sections to be shown at the end or instead
' (SS,30/6/11) added AProductID
' (SS,10/10/23) added ABrandName, AProductName no longer HTML encoded due to being passed onto DoGTMEventViewItem, added HTMLEncode to parameter to ShowProductDetail
Sub ShowTheProductDetail(AProductID, AProductCode, AProductName, AProductDesc, ABrandName, ADimensions, ASalePrice, AStdPrice, ANumInStock, ANew, ACategory, ASubcategory, AShowLarge, ALargePicWidth, ALargePicHeight)
Dim LShowDescription
LShowDescription = InProductDescription
' (SS,17/6/11) added And Not ProductPageTabs, to ensure that reviews only show in ShowProductDetail when product page tabs are enabled
If InShowReviews And Not ProductPageTabs Then
ShowReviews(AProductCode)
ElseIf InWriteReview And Not ProductPageTabs Then
WriteReview(AProductCode)
ElseIf InStockNotify Then
StockNotify(AProductCode)
Else
' (SS,6/3/18) removed following due to migration to gtag.js (Global Site Tag)
'SetRemarketingTagTotalValue GetProductPrice ' (SS,28/11/13)
' (SS,10/10/23) added following for passing the view_item event to Google Tag Manager
'DoGTMEventViewItem AProductCode, AProductName, ABrandName, GetProductPrice, ACategory, ASubcategory
' (SS,13/10/23) replaced above with following
' (SS,17/10/23) add event item to GTM
oGTM.EventViewItem
oGTM.AddItem AProductCode, AProductName, "", GetProductPrice, 1, ABrandName, ACategory, ASubcategory
' (SS,30/6/11) added AProductID, HTMLEncode to AProductName
ShowProductDetail AProductID, AProductCode, HTMLEncode(AProductName), AProductDesc, ADimensions, ASalePrice, AStdPrice, ANumInStock, ANew, ACategory, ASubcategory, AShowLarge, ALargePicWidth, ALargePicHeight, LShowDescription
ShowRelatedProducts(AProductCode) ' (SS,13/5/11) NB will return without doing anything if already called from without the product detail template
End If
' (SS,8/5/09) only show if in product description (i.e. not review)
' (SS,13/5/11) NB will return without doing anything if already called from product detail template
If InProductDescription Then ShowViewOtherProducts(AProductCode)
End Sub
' (SS,13/5/11) code moved here from ShowTheProductDetail, may also be called from inc-template-product-detail.asp
' (SS,14/3/12) added code to show related category if set in product attribute, allows miscellaneous link to be added to categories without listing related products
Sub ShowViewOtherProducts(AProductCode)
' (SS,13/5/11) prevent it from being called twice
If FViewOtherProductsCalled Then Exit Sub
FViewOtherProductsCalled = True
' list all the categories this product belongs to '
ShowProductDetailViewOtherProductsHeader
OpenQuery(GetCategoryListSQL(AProductCode))
Do While Not EndOfQuery
ShowProductDetailViewOtherProductsItem GetFieldValue("GroupName"), GetFieldValue("Category"), GetFieldValue("Subcategory")
NextQueryRecord
Loop
CloseQuery
' (SS,14/3/12) added following for related category held in product attributes
Dim LAttributeValue
LAttributeValue = GetProductAttributeByName(GetProductIDForProductCode(AProductCode), "Related Category/Subcategory")
If LAttributeValue <> "" Then
Dim LPos, LGroup, LCategory, LSubcategory
' (SS,15/3/12) changed separated from forwardslash to backslash and added guillemet (forward arrow)
LPos = InStr(LAttributeValue, "\")
If LPos = 0 Then LPos = InStr(LAttributeValue, "�")
If LPos > 0 Then
LCategory = Trim(Left(LAttributeValue, LPos - 1))
LSubcategory = Trim(Mid(LAttributeValue, LPos + 1, Len(LAttributeValue)))
Else
LCategory = Trim(LAttributeValue)
LSubcategory = ""
End If
LGroup = GetGroupForCategory(LCategory)
ShowProductDetailViewOtherProductsItem LGroup, LCategory, LSubcategory
End If
ShowProductDetailViewOtherProductsFooter
End Sub
' (SS,17/2/16) returns Brand and MPN for given product, False is returns if not found with values set to blank
Function GetBrandAndMPN(AProductID, AProductCode, ByRef ABrand, ByRef AMPN)
Dim LResult
LResult = GetSQL2Values("SELECT BrandName, MPN FROM products LEFT JOIN brands ON brands.BrandID = products.BrandID WHERE ProductID = '" & CleanSQLStr(AProductID) & "'", ABrand, AMPN)
If LResult Then
' use product code for MPN if blank
If AMPN = "" Then
AMPN = AProductCode
End If
Else
ABrand = ""
AMPN = ""
End If
GetBrandAndMPN = LResult
End Function
' --------------------------------- '
' Start of Product Review Routines '
' --------------------------------- '
' (SS,1/5/09) returns 0 if no reviews, else number containing 1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5 or 5 depending on rating
' (SS,22/1/19) now rounds to 1 dp
Function GetReviewRatingAndCount(AProductCode, ByRef AReviewCount)
Dim LSQL, LRating ' (SS,22/1/19) removed LFraction
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,22/1/19) added ROUND( ,1) to round to 1 dp
LSQL = "SELECT ROUND(AVG(ProductRating), 1) AS AverageRating, COUNT(*) AS ReviewCount FROM productreviews WHERE ProductCode = '" & CleanSQLStr(AProductCode) & "' AND ShowOnSite = True"
'if product just has comment it shows
'"1 review" and no image on product listing, on product detail it has image with "NOT YET RATED"
'e.g. http://www.ebuyer.com/store/Components/cat/Graphics-Cards-Nvidia
'http://www.ebuyer.com/product/160628
OpenQuery2(LSQL)
LRating = NZD(GetQueryValue2("AverageRating"))
AReviewCount = GetQueryValue2("ReviewCount")
CloseQuery2
' round to nearest 0.5
' e.g. >= 0.75 becomes 1, >= 0.25 becomes 0.5, else 0
' (SS,22/1/19) removed following, now rounded in SQL to 1 dp
'LFraction = LRating - Int(LRating)
'LRating = Int(LRating)
'If LFraction >= 0.75 Then
' LRating = LRating + 1
'ElseIf LFraction >= 0.25 Then
' LRating = LRating + 0.5
'End If
GetReviewRatingAndCount = LRating
End Function
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
Function GetShowReviewsLink(AProductCode)
' (SS,19/7/17) added #reviews to the end to go to the correct position (i.e. anchor)
GetShowReviewsLink = AddStoreURL(GetScriptName + "?code=" + AProductCode + "&cmd=showreviews#reviews")
End Function
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
Function GetWriteReviewLink(AProductCode)
GetWriteReviewLink = AddStoreURL(GetScriptName + "?code=" + AProductCode + "&cmd=writereview")
End Function
' (SS,28/9/12) used in review request emails
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
Function GetWriteReviewFullLink(AProductCode)
GetWriteReviewFullLink = GetStoreURL + "/" + "products.asp?code=" + AProductCode + "&cmd=writereview"
End Function
Function InProductDescription
InProductDescription = Not (InShowReviews Or InWriteReview Or InStockNotify)
End Function
Function InShowReviews
InShowReviews = CleanRequestQueryString("cmd") = "showreviews"
End Function
Function InWriteReview
InWriteReview = CleanRequestQueryString("cmd") = "writereview"
End Function
' (SS,17/6/11) returns given class suffixed by "-active" when second parameter is True, else trues class with "-active"
Function GetActiveClass(AClass, AActive)
Dim LResult
If AActive Then
LResult = AClass + "-active"
Else
LResult = AClass
End If
GetActiveClass = LResult
End Function
' (SS,17/6/11) returns given text with href added if ADoAdd True
Function AddHRefIfTrue(AText, AHRef, ADoAdd)
Dim LResult
If ADoAdd Then
LResult = "<a href=""" & AHRef & """>" & AText & "</a>"
Else
LResult = AText
End If
AddHRefIfTrue = LResult
End Function
' (SS,13/9/14) replaced ReplaceNewLinesWithBR with ParagraphiseText
Sub ShowReviews(AProductCode)
Dim LRecordCount, LCount, LHeaderShown, LReviewText, LReviewerName, LProductName, LProductURL
LProductName = GetProductName(AProductCode)
LProductURL = GetProductLink(AProductCode)
' (SS,12/5/10) replaced '%D %b %Y, %l:%i %p' with GetLanguageDateFormat(True)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT *, DATE_FORMAT(ReviewDateTime, '" & GetLanguageDateFormat(True) & "') AS FormattedDateTime FROM productreviews WHERE ProductCode = '" + CleanSQLStr(AProductCode) + "' AND ShowOnSite = 1 ORDER BY ReviewDateTime DESC")
LRecordCount = GetQueryRecordCount
LHeaderShown = False
LCount = 0
Do While Not EndOfQuery
LCount = LCount + 1
SetAtFirstOrLastProduct LCount, LRecordCount
If Not LHeaderShown Then
ShowReviewHeader AProductCode, LProductName, LProductURL
LHeaderShown = True
End If
LReviewerName = GetQueryValue("ReviewerName")
If LReviewerName = "" Then LReviewerName = "Anonymous" ' (SS,15/5/09)
'LReviewText = ReplaceNewLinesWithBR(GetQueryValue("ReviewText"))
' (SS,13/9/14) replaced above with following, does a much better jobs using paragraphs, with more compact spacing (i.e. <p>'s instead of <br>'s and removing of starting and trailing newlines
LReviewText = ParagraphiseText(GetQueryValue("ReviewText"))
ShowReviewItem GetQueryValue("ReviewType"), GetQueryValue("FormattedDateTime"), GetQueryValue("ReviewTitle"), GetQueryValue("ProductRating"), LReviewText, LReviewerName
NextQueryRecord
Loop
CloseQuery
' (SS,19/7/17) if not shown i.e. no reviews we still need to show to show the write review button
If Not LHeaderShown Then
ShowReviewHeader AProductCode, LProductName, LProductURL
LHeaderShown = True
End If
If LHeaderShown Then ShowReviewFooter AProductCode, LProductName, LProductURL
End Sub
' (SS,15/5/09) added review email
Sub WriteReview(AProductCode)
Dim LSubmitting, LShowForm, LProductName, LProductURL
LSubmitting = CleanRequestForm("Submit") <> ""
LShowForm = True
LProductName = GetProductName(AProductCode)
LProductURL = GetProductLink(AProductCode)
' if submitting
If LSubmitting Then
Session("ReviewType") = CleanRequestForm("ReviewType")
If Session("ReviewType") = tr("-SELECT-") Then Session("ReviewType") = ""
Session("ReviewTitle") = Trim(CleanRequestForm("ReviewTitle"))
Session("ProductRating") = CleanRequestForm("ProductRating")
If Session("ProductRating") = tr("-SELECT-") Then Session("ProductRating") = ""
Session("ReviewerName") = Trim(CleanRequestForm("ReviewerName"))
Session("ReviewerEmail") = Trim(CleanRequestForm("ReviewerEmail"))
Session("ReviewText") = Trim(CleanRequestForm("ReviewText"))
Else ' default values
Session("ReviewType") = tr("Review")
Session("ReviewTitle") = ""
Session("ProductRating") = "5 " + tr("stars")
Session("ReviewerName") = ""
Session("ReviewerEmail") = ""
Session("ReviewText") = ""
End If
If LSubmitting Then
If CheckReviewDetails Then ' here because we don't want it called when LSubmitting is False
SaveReview(AProductCode)
SendReviewReceivedEmail(AProductCode) ' (SS,15/5/09)
ShowReviewThankYou AProductCode, LProductName, LProductURL
LShowForm = False
End If
End If
If LShowForm Then ShowReviewEntryForm gsErrorMessage, GetWriteReviewLink(AProductCode), AProductCode, LProductName, LProductURL
End Sub
Function CheckReviewDetails
Dim LError
LError = ""
If Session("ReviewType") = "" Then LError = LError + IIf(LError = "", "", ", ") + "Review Type" ' (SS,13/5/10) this will never occur
If Session("ReviewType") = tr("Review") And Session("ProductRating") = "" Then LError = LError + IIf(LError = "", "", ", ") + tr("Product Rating")
If Session("ReviewText") = "" Then LError = LError + IIf(LError = "", "", ", ") + tr("Review")
' (SS,23/3/12) added following, email now has to be entered
If Session("ReviewerEmail") = "" Then LError = LError + IIf(LError = "", "", ", ") + tr("Email Address")
If LError <> "" Then LError = tr("Following fields must be filled in") + ": " + LError + "."
' If Session("ReviewerEmail") <> "" And Not IsValidEmailAddress(Session("ReviewerEmail")) Then LError = LError + IIf(LError = "", "", "<br>") + tr("Valid Email address must be entered") + "."
' (SS,23/3/12) removed above, replaced with following which does a check to see if email address has placed an order
If Session("ReviewerEmail") <> "" Then
If Not EmailAddressHasOrdered(Session("ReviewerEmail")) Then LError = LError + IIf(LError = "", "", "<br>") + tr("No completed order found for the email address entered") + "."
End If
' (SS,23/3/12) following removed because it's no longer prevented spam, even after further distorting the image
' hoping that above method checking for completed order with email address does a better job
' If Not SecurityOK(False) Then LError = LError + IIf(LError = "", "", "<br>") + tr("Security Code is incorrect, please retype") + "."
gsErrorMessage = LError
CheckReviewDetails = (LError = "")
End Function
Sub SaveReview(AProductCode)
Dim LReviewType, LProductRating
If Session("ReviewType") = tr("Review") Then
LReviewType = "R"
LProductRating = Left(Session("ProductRating"), 1) ' i.e. ignore the "star(s)" word
Else
LReviewType = "C"
LProductRating = "Null"
End If
' (SS,12/6/12) added CleanSQLStr before AProductCode to prevent SQL injection
' (SS,10/6/14) replaced ShowOnSite=0 with "ShowOnSite=" & BoolToInt(ProductsShowReviewsImmediately)
ExecuteQuery("INSERT INTO productreviews SET ReviewDateTime=NOW(), ProductCode='" & CleanSQLStr(AProductCode) & "', ReviewType='" & LReviewType & "', ReviewTitle='" & CleanSQLStr(Session("ReviewTitle")) & "', ReviewerName='" & CleanSQLStr(Session("ReviewerName")) & "', ReviewerEmail='" & CleanSQLStr(Session("ReviewerEmail")) & "', ReviewText='" & CleanSQLStr(Session("ReviewText")) & "', ProductRating=" & LProductRating & ", ShowOnSite=" & BoolToInt(ProductsShowReviewsImmediately))
End Sub
' (SS,15/5/09)
' (SS,19/3/10) no need to translate this because it's only sent to the store
' (SS,17/3/20) changed from email from FEmailContactFrom to reviewer's email address
Sub SendReviewReceivedEmail(AProductCode)
Dim LSubject, LBody
LSubject = "Review received by " + GetStoreName
LBody =_
"Review Type : " & Session("ReviewType")& NL &_
"Product Code : " & AProductCode & NL &_
"Review Title : " & Session("ReviewTitle") & NL &_
"Product Rating : " & Session("ProductRating") & NL &_
"Reviewer Name : " & Session("ReviewerName") & NL &_
"Reviewer Email : " & Session("ReviewerEmail") & NL &_
"Review Text :" & NL & Session("ReviewText")
'SendEmail FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, False
' (SS,17/3/20) replaced FEmailContactFrom with Session("ReviewerEmail") to make it easier to reply to a reviewer's email (requested by Neil)
SendEmail FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, Session("ReviewerEmail"), LSubject, LBody, False
End Sub
' (SS,13/5/10)
Function GetReviewCombo
GetReviewCombo = GetListCombo("ReviewType", tr("-SELECT-") & NL & tr("Review") & NL & tr("Comment"), Session("ReviewType"), False)
End Function
' (SS,15/9/17) added following for short reviews in product description
Sub ShowProductReviewsInDesc(AProductCode, AMaxReviews)
Dim LRecordCount, LReviewText, LReviewerName
OpenQuery("SELECT *, DATE_FORMAT(ReviewDateTime, '%e %M %Y') AS FormattedDateTime FROM productreviews WHERE ProductCode = '" + CleanSQLStr(AProductCode) + "' AND ShowOnSite = 1 AND ReviewType = 'R' ORDER BY ReviewDateTime DESC LIMIT " & AMaxReviews)
LRecordCount = GetQueryRecordCount
If LRecordCount > 0 Then ShowProductReviewsInDescHeader
Do While Not EndOfQuery
LReviewerName = GetQueryValue("ReviewerName")
If LReviewerName = "" Then LReviewerName = "Anonymous"
LReviewText = ParagraphiseText(GetQueryValue("ReviewText"))
ShowProductReviewsInDescItem GetQueryValue("FormattedDateTime"), GetQueryValue("ReviewTitle"), GetQueryValue("ProductRating"), LReviewText, LReviewerName
NextQueryRecord
Loop
CloseQuery
If LRecordCount > 0 Then ShowProductReviewsInDescFooter
End Sub
' (SS,24/10/19) returns overall review count and average rating from all reviews including disabled products, only from those chosen to show on site
Function GetReviewAggregateRating(ByRef AReviewCount, ByRef AAverageRating)
Dim LResult, LSQL
LSQL = "SELECT COUNT(*) AS ReviewCount, ROUND(AVG(ProductRating), 2) AS AverageRating" &_
" FROM productreviews pr" &_
" INNER JOIN products p ON p.ProductCode = pr.ProductCode" &_
" WHERE ShowOnSite AND ReviewType = 'R'"
GetReviewAggregateRating = GetSQL2Values(LSQL, AReviewCount, AAverageRating)
End Function
' --------------------------------- '
' End of Product Review Routines '
' --------------------------------- '
' ------------------------------------ '
' Start of Stock Notification Routines '
' ------------------------------------ '
' (SS,15/5/09)
Function GetStockNotificationLink(AProductCode)
GetStockNotificationLink = AddStoreURL(GetScriptName + "?code=" + AProductCode + "&cmd=stocknotify")
' for example see http://www.sweetwater.com/store/detail/Mboxto003RFact/notify
End Function
' (SS,14/2/12) special version of GetStockNotificationLink with option added
Function GetStockNotificationWithOptionLink(AProductCode, AOption)
GetStockNotificationWithOptionLink = AddStoreURL(GetScriptName + "?code=" + AProductCode + "&option=" + URLEncode(AOption) + "&cmd=stocknotify")
End Function
Function InStockNotify
InStockNotify = CleanRequestQueryString("cmd") = "stocknotify"
End Function
' (SS,14/2/12) added Option, to be notified when particular option comes into stock
' (SS,2/10/20) modified to redirect product page if item is in stock and the referrer was from outside of the website
Sub StockNotify(AProductCode)
Dim LSubmitting, LShowForm, LProductName, LProductURL, LOption
LSubmitting = CleanRequestForm("Submit") <> ""
LShowForm = True
' if submitting
If LSubmitting Then
Session("StockNotifyName") = Trim(CleanRequestForm("StockNotifyName"))
Session("StockNotifyEmail") = Trim(CleanRequestForm("StockNotifyEmail"))
Else ' default values
Session("StockNotifyName") = ""
Session("StockNotifyEmail") = ""
End If
LProductName = GetProductName(AProductCode)
LProductURL = GetProductLink(AProductCode)
' (SS,14/2/12)
LOption = Trim(CleanRequest("option"))
If LOption <> "" Then LProductName = LProductName + " (" + LOption + ")"
If LSubmitting Then
If CheckStockNotifyDetails Then ' here because we don't want it called when LSubmitting is False
SaveStockNotification AProductCode, LOption ' (SS,14/2/12) added LOption
SendStockNotificationReceivedEmail AProductCode, LOption ' (SS,14/2/12) added LOption
ShowStockNotificationThankYou AProductCode, LProductName, LProductURL
LShowForm = False
End If
End If
If LShowForm Then
' (SS,2/10/20) if referrer is from outside of the website then redirect to the product page, in case product is in stock, no need to check for stock
If InStr(1, Request.ServerVariables("HTTP_REFERER"), GetStoreURL, vbTextCompare) = 0 Then
SingleProductRedirect AProductCode
End If
' (SS,14/2/12) modified to handle LOption
Dim LStockNotificationLink
If LOption = "" Then
LStockNotificationLink = GetStockNotificationLink(AProductCode)
Else
LStockNotificationLink = GetStockNotificationWithOptionLink(AProductCode, LOption)
End If
ShowStockNotificationForm gsErrorMessage, LStockNotificationLink, AProductCode, LProductName, LProductURL
End If
End Sub
Function CheckStockNotifyDetails
Dim LError
LError = ""
If Session("StockNotifyName") = "" Then LError = LError + IIf(LError = "", "", ", ") + "Name"
If Session("StockNotifyEmail") = "" Then LError = LError + IIf(LError = "", "", ", ") + "Email"
If LError <> "" Then LError = tr("Following fields must be filled in") + ": " + LError + "."
If Session("StockNotifyEmail") <> "" And Not IsValidEmailAddress(Session("StockNotifyEmail")) Then LError = LError + IIf(LError = "", "", "<br>") + "Valid Email address must be entered."
If Not SecurityOK(False) Then LError = LError + IIf(LError = "", "", "<br>") + tr("Security Code is incorrect, please retype") + "."
gsErrorMessage = LError
CheckStockNotifyDetails = (LError = "")
End Function
' (SS,14/2/12) added AOption parameter and modified query to save Option
' (SS,18/3/19) added size limit for 50 for name and 100 for email using Left function prevent "Data too long for column 'Name'" MySQL error
Sub SaveStockNotification(AProductCode, AOption)
' (SS,12/6/12) added CleanSQLStr before AProductCode to prevent SQL injection
ExecuteQuery("INSERT INTO stocknotifications SET ProductCode='" & CleanSQLStr(AProductCode) & "', ProductOption='" & CleanSQLStr(AOption) & "', Name='" & Left(CleanSQLStr(Session("StockNotifyName")), 50) & "', Email='" & Left(CleanSQLStr(Session("StockNotifyEmail")), 100) & "', DateTimeAdded=NOW()")
End Sub
' (SS,19/3/10) no need to translate this because it's only sent to the store
' (SS,14/2/12) added AOption parameter, Option shown if not blank
' (SS,24/8/17) added Num in Stock to help debug an issue, also changed to HTML to make it look tidier
Sub SendStockNotificationReceivedEmail(AProductCode, AOption)
Dim LSubject, LBody
LSubject = "Stock Notification Request received by " + GetStoreName & " - " & GetSQLLastInsertID ' (SS,14/2/12) added GetSQLLastInsertID
' (SS,13/1/11) replaced GetProductName with GetProductNameNoHTMLEncode, to prevent "&" encoding as "&"
LBody =_
"Product Code: " & AProductCode & NL &_
"Product Name: " & GetProductNameNoHTMLEncode(AProductCode) & NL
If AOption <> "" Then LBody = LBody & "Option : " & AOption & NL ' (SS,14/2/12)
LBody = LBody & "Num in Stock: " & GetFieldForProduct(AProductCode, "NumInStock") & NL ' (SS,24/8/17) added for debugging purpose after noticing some buyers were sending notification requests when in stock for HF
LBody = LBody &_
"Name : " & Session("StockNotifyName") & NL &_
"Email : " & Session("StockNotifyEmail")
' (SS,24/8/17)
LBody = LBody & NL & "Referrer: " & CleanRequestForm("Referrer")
LBody = LBody & NL & "URL: " & Request.ServerVariables("HTTP_REFERER")
' (SS,24/8/17) converted above to a HTML table
LBody = GetTextAsHTMLTable(LBody, ": ", True, True, "right")
SendEmail FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, True ' (SS,24/8/17) changed last para False to True to make it HTML
End Sub
' (SS,19/3/10) added translations using tr and trx
' (SS,14/2/12) added Option
' (SS,14/3/12) modified to work in staggered mode, so that the maximum notifications sent match the amount in stock
' the rest are delayed until the next day
' (SS,12/11/20) modified (for CIRC) to assume null (or blank) for NumInStock is 1 or more i.e. in stock
' also modified to exclude if product is disabled
Sub SendStockNotificationEmails
Dim LStaggered, LStaggerDelayHours, LSQL, LWhereStaggered, LHTML
' (SS,27/4/12) delete duplicates, keeping the oldest
StockNotificationsRemoveDuplicates
' (SS,14/3/12) staggered mode enabled if greater than 0, normally it'll be 23 hours
LStaggerDelayHours = FBackInStockNotificationsStaggeredDelay
LStaggered = LStaggerDelayHours > 0
If LStaggered Then
LWhereStaggered = "AND (DelayUntil IS NULL OR DelayUntil <= NOW()) "
Else
LWhereStaggered = ""
End If
If Not ProductOptionsEnabled Then
' (SS,14/3/12) added NumInStock and LWhereStaggered
' (SS,12/11/20) added NOT ProductDisabled and changed "NumInStock > 0" to COALESCE(NumInStock, 1) > 0
LSQL = "SELECT stocknotifications.*, NumInStock FROM stocknotifications " +_
"INNER JOIN products ON products.ProductCode = stocknotifications.ProductCode " +_
"WHERE DateTimeNotified IS NULL AND NOT ProductDisabled AND COALESCE(NumInStock, 1) > 0 " + LWhereStaggered +_
"ORDER BY ProductCode, DateTimeAdded"
Else ' (SS,14/2/12) following does the selection for sites where ProductOption is used, above is how it used to be
' (SS,14/3/12) added ProductOption to order by, also added LWhereStaggered, NumInStock and pov.NumInStock
' (SS,27/4/12) added LWhereStaggered which I had missed from the first query before the UNION ALL
' (SS,12/11/20) added NOT ProductDisabled and changed "NumInStock > 0" to COALESCE(NumInStock, 1) > 0, also for the second union i.e. pov.NumInStock
LSQL = "SELECT sn.*, NumInStock FROM stocknotifications sn " +_
"INNER JOIN products ON products.ProductCode = sn.ProductCode " +_
"WHERE DateTimeNotified IS NULL AND NOT ProductDisabled AND COALESCE(NumInStock, 1) > 0 AND ProductOption = '' " + LWhereStaggered +_
"UNION ALL " + _
"SELECT sn.*, pov.NumInStock FROM stocknotifications sn " +_
"INNER JOIN products p ON p.ProductCode = sn.ProductCode " +_
"INNER JOIN product_option_values pov ON pov.ProductID = p.ProductID AND pov.OptionValue = sn.ProductOption " +_
"WHERE DateTimeNotified IS NULL AND NOT ProductDisabled AND COALESCE(pov.NumInStock, 1) > 0 AND ProductOption <> '' " + LWhereStaggered +_
"ORDER BY ProductCode, ProductOption, DateTimeAdded"
End If
OpenQuery(LSQL)
LHTML = StockNotificationHeader ' (SS,14/3/12) code moved to new routine
Dim LCount, LID, LProductCode, LOption, LNotificationCount ' (SS,14/3/12) LCount renamed to LNotificationCount
Dim LPrevProductCode, LPrevOption, LProductOptionCount, LWhere, LMaximumReached ' (SS,14/3/12)
LCount = 0
LNotificationCount = 0
LPrevProductCode = ""
LPrevOption = ""
Do While Not EndOfQuery
LCount = LCount + 1 ' (SS,14/3/12)
LID = GetQueryValue("ID")
LProductCode = GetQueryValue("ProductCode")
' (SS,14/2/12)
If ProductOptionsEnabled Then
LOption = GetQueryValue("ProductOption")
Else
LOption = ""
End If
' (SS,14/3/12)
If (LPrevProductCode <> LProductCode) Or (LPrevOption <> LOption) Then
LProductOptionCount = 0
LMaximumReached = False
End If
LProductOptionCount = LProductOptionCount + 1
If LStaggered Then
' if no notifications sent for this product/option exceeds number in stock then don't send any more notifications for this product/option
' (SS,27/4/12) added "* FBackInStockNotificationsStockMultiplier" to allow multiple emails to be sent per stock item, default is 1
If LProductOptionCount > (GetQueryValue("NumInStock") * FBackInStockNotificationsStockMultiplier) Then
LMaximumReached = True
' delay all the notifications that haven't yet been sent for product/option
If ProductOptionsEnabled Then
LWhere = " AND ProductOption = '" + CleanSQLStr(LOption) + "'"'
Else
LWhere = ""
End If
LSQL = "UPDATE stocknotifications SET DelayUntil = NOW() + INTERVAL " & LStaggerDelayHours & " HOUR WHERE DateTimeNotified IS NULL AND ProductCode = '" & CleanSQLStr(LProductCode) + "'" + LWhere
ExecuteQuery(LSQL)
End If
End If
LHTML = LHTML & StockNotificationRow(LCount, LID, LProductCode, LOption, LProductOptionCount, IIf(LMaximumReached, "Delayed " & LStaggerDelayHours & " hours", "Sent"))
' (SS,14/3/12) only send if maximum hasn't been reached
If Not LMaximumReached Then
' (SS,14/3/12) code below moved to new routine, following sends the email and marks it as send
SendStockNotificationEmail LID, LProductCode, LOption
LNotificationCount = LNotificationCount + 1
End If
LPrevProductCode = LProductCode
LPrevOption = LOption
NextQueryRecord
Loop
CloseQuery
LHTML = LHTML & StockNotificationFooter(LNotificationCount) ' (SS,14/3/12) code moved to new routine
' (SS,14/3/12) email the results of this process, i.e. the table show on screen
EmailSendStockNotificationEmailsResult LHTML
End Sub
' (SS,27/4/12) remove duplicate notifications, keeping the oldest
Sub StockNotificationsRemoveDuplicates
Dim LSQL, LSQL2
LSQL = "SELECT Email, ProductCode, ProductOption, COUNT(*) AS NotificationCount, MIN(ID) AS LowestID FROM stocknotifications " +_
"WHERE DateTimeNotified IS NULL " +_
"GROUP BY Email, ProductCode, ProductOption " +_
"HAVING NotificationCount > 1"
OpenQuery LSQL
Do While Not EndOfQuery
LSQL2 = "DELETE FROM stocknotifications WHERE Email = '" & CleanSQLStr(GetQueryValue("Email")) & "' AND ProductCode = '" & CleanSQLStr(GetQueryValue("ProductCode")) & "' AND ProductOption = '" & CleanSQLStr(GetQueryValue("ProductOption")) & "' AND ID > " & GetQueryValue("LowestID")
ExecuteQuery LSQL2
NextQueryRecord
Loop
CloseQuery
End Sub
' (SS,14/3/12) email the results of the send notifications emails process
Sub EmailSendStockNotificationEmailsResult(ABody)
Dim LSubject
LSubject = "Back in Stock Notification Emails Result for " + GetStoreName + " on " & Now
SendEmail FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, ABody, True
End Sub
' (SS,14/3/12) from SendStockNotificationEmails above, returns the HTML as well as outputting using Response.Write
' added extra columns for No, No in Stock, Product Count, Result
' (SS,15/3/12) added NL to end of each HTML line because emailer is added a space after 1000 characters
Function StockNotificationHeader
Dim LResult
LResult = "<table border=1 cellspacing=0>" & NL
LResult = LResult & "<tr><td colspan=""" & IIf(ProductOptionsEnabled, 9, 8) & """>" & "Back in Stock Notifications" & "</td></tr>" & NL ' (SS,14/3/12) replaced 4 with IIf(ProductOptionsEnabled(9, 8)
LResult = LResult & "<tr>" & NL
LResult = LResult & "<td>No</td>" & NL
LResult = LResult & "<td>ID</td>" & NL
LResult = LResult & "<td>Product Code</td>" & NL
If ProductOptionsEnabled Then LResult = LResult & "<td>Option</td>" & NL ' (SS,14/2/12)
LResult = LResult & "<td>Email</td>" & NL
LResult = LResult & "<td>Product Name</td>" & NL
LResult = LResult & "<td>No in Stock</td>" & NL
LResult = LResult & "<td>Count</td>" & NL
LResult = LResult & "<td>Result</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
StockNotificationHeader = LResult
End Function
' (SS,14/3/12) from SendStockNotificationEmails above, returns the HTML as well as outputting using Response.Write
Function StockNotificationFooter(ACount)
Dim LResult
' (SS,14/2/12) colspan increased from 4 to 5 if ProductOptionsEnabled
' (SS,14/3/12) colspan increased to 9 and 8
LResult = "<tr><td colspan=""" & IIf(ProductOptionsEnabled, "9", "8") & """>Total of " & PluralString(ACount, "email", "emails") & " sent" & "</td></tr>" & NL
LResult = LResult & "</table>" & NL
Response.Write LResult
StockNotificationFooter = LResult
End Function
Function StockNotificationRow(ANo, AID, AProductCode, AOption, AProductCount, AResult)
Dim LResult
LResult = "<tr>" & NL
LResult = LResult & "<td align=center>" & ANo & "</td>" & NL
LResult = LResult & "<td>" & AID & "</td>" & NL
LResult = LResult & "<td>" & AProductCode & "</td>" & NL
If ProductOptionsEnabled Then LResult = LResult & "<td>" & AOption & " </td>" & NL ' (SS,14/2/12)
LResult = LResult & "<td>" & GetQueryValue("Email") & "</td>" & NL
LResult = LResult & "<td>" & GetProductName(AProductCode) & "</td>" & NL
LResult = LResult & "<td align=center>" & GetQueryValue("NumInStock") & "</td>" & NL
LResult = LResult & "<td align=center>" & AProductCount & "</td>" & NL
LResult = LResult & "<td>" & AResult & "</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
StockNotificationRow = LResult
End Function
' (SS,14/3/12) created from code in SendStockNotificationEmails above, to make it easier to read, also returns the output HTML
Sub SendStockNotificationEmail(AID, AProductCode, AOption)
Dim LSubject, LName, LEmail, LBody, LProductNameWithOptionForEmail
LSubject = trx("Back in Stock Notification from <x>", GetStoreName)
LName = GetQueryValue("Name")
LEmail = GetQueryValue("Email")
' (SS,14/2/12)
LProductNameWithOptionForEmail = GetProductNameNoHTMLEncode(AProductCode)
If AOption <> "" Then LProductNameWithOptionForEmail = LProductNameWithOptionForEmail + " (" + AOption + ")"
' (SS,13/1/12) replaced LProductName with GetProductNameNoHTMLEncode(AProductCode) to sort "&" appearing as "&" in the plain text emails
' (SS,14/2/12) later replaced with LProductNameWithOptionForEmail
LBody =_
tr("Dear") & " " & LName & "," & NL & NL &_
trx("The <x> is now back in stock", LProductNameWithOptionForEmail) & "." & NL & NL &_
tr("Please click the link below to visit the product page") & "." & NL &_
GetFullProductLink(AProductCode) & NL & NL
' (SS,6/4/20) add additional text if defined
Dim LAdditionalText
LAdditionalText = TrimAll(GetSiteDetail("Other", "StockNotificationEmailAdditional"))
If LAdditionalText <> "" Then
LBody = LBody & LAdditionalText & NL & NL
End If
LBody = LBody &_
tr("Thank you for your interest") & "." & NL & NL &_
tr("Kind regards") & "," & NL & NL & GetStoreName
' send the email
SendEmail LEmail, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, False
' mark as email sent
'&&& removed for debug purposes
ExecuteQuery("UPDATE stocknotifications SET DateTimeNotified=NOW() WHERE ID = " & AID)
End Sub
' ---------------------------------- '
' End of Stock Notification Routines '
' ---------------------------------- '
' Change to AddToRecentlyViewed and ShowRecentlyViewed to filter out currently shown product.
' ------------------------------- '
' Start of Recently View Routines '
' ------------------------------- '
' (SS,4/6/09)
' (SS,16/5/11) modified to use GetMaxRecentlyUsed instead of MAX_RECENTLY_VIEWED
Sub AddToRecentlyViewed(AProductCode)
Dim i, LFound, LMaxRecentlyViewed
LMaxRecentlyViewed = GetMaxRecentlyViewed + 1 ' (SS,5/9/12) added 1 to filter out current product, in ShowRecentlyViewed currently product isn't shown
' find if product code already added
LFound = 0
For i = 1 TO LMaxRecentlyViewed
If Session("RecentlyViewedProductCode" & i) = AProductCode Then
LFound = i
Exit For
End If
Next
' if found then shift all product codes below it up one effectively deleting AProductCode
If LFound > 0 Then
For i = LFound + 1 TO LMaxRecentlyViewed
Session("RecentlyViewedProductCode" & (i - 1)) = Session("RecentlyViewedProductCode" & i)
Session("RecentlyViewedProductName" & (i - 1)) = Session("RecentlyViewedProductName" & i)
If Session("RecentlyViewedProductCode" & i) = "" Then Exit For
Next
If i <= LMaxRecentlyViewed Then Session("RecentlyViewedProductCode" & i) = ""
End If
' shift everything down one making space for new
For i = LMaxRecentlyViewed TO 2 STEP -1
Session("RecentlyViewedProductCode" & i) = Session("RecentlyViewedProductCode" & (i - 1))
Session("RecentlyViewedProductName" & i) = Session("RecentlyViewedProductName" & (i - 1))
Next
' place new one at the top
Session("RecentlyViewedProductCode1") = AProductCode
Session("RecentlyViewedProductName1") = GetProductName(AProductCode)
End Sub
' (SS,4/6/09)
' (SS,16/5/11) MAX_RECENTLY_VIEWED replaced with GetMaxRecentlyViewed
' (SS,5/9/12) improved to not show current product if in product details page
' (SS,12/9/12) further improvements
Sub ShowRecentlyViewed
Dim LCurrentProductCode
LCurrentProductCode = GetProductCodeQS ' (SS,5/9/12), (SS,12/9/12) replaced GetProductCode with GetProductCodeQS
If Session("RecentlyViewedProductCode1") = "" Or GetRecentlyViewedCount(LCurrentProductCode) = 0 Then ' if nothing to show (SS,12/9/12) added GetRecentlyViewedCount
ShowRecentlyViewedEmpty
Else
ShowRecentlyViewedHeader
Dim i, LMaxRecentlyViewed, LLeftToShow
LLeftToShow = GetMaxRecentlyViewed ' (SS,5/9/12)
LMaxRecentlyViewed = GetMaxRecentlyViewed + 1 ' (SS,5/9/12) added + 1 because current product code is filtered out
For i = 1 TO LMaxRecentlyViewed
If Session("RecentlyViewedProductCode" & i) <> "" Then
If LCurrentProductCode <> Session("RecentlyViewedProductCode" & i) Then
ShowRecentlyViewedItem i, Session("RecentlyViewedProductCode" & i), Session("RecentlyViewedProductName" & i)
LLeftToShow = LLeftToShow - 1 ' (SS,5/9/12)
If LLeftToShow = 0 Then Exit For ' (SS,5/9/12)
End If
End If
Next
ShowRecentlyViewedFooter
End If
End Sub
' (SS,12/9/12) returns count, excluding given product code
Function GetRecentlyViewedCount(AProductCode)
Dim LResult, i, LMaxRecentlyViewed
LResult = 0
LMaxRecentlyViewed = GetMaxRecentlyViewed + 1 ' (SS,5/9/12) added + 1 because current product code is filtered out
For i = 1 TO LMaxRecentlyViewed
If Session("RecentlyViewedProductCode" & i) <> "" Then
If AProductCode <> Session("RecentlyViewedProductCode" & i) Then
LResult = LResult + 1
End If
End If
Next
GetRecentlyViewedCount = LResult
End Function
' ------------------------------- '
' End of Recently Viewed Routines '
' ------------------------------- '
' (SS,5/6/09)
Sub AddGoogleSitemapURL(AURL, APriority)
Const IDENT1 = " "
Const IDENT2 = " "
Response.Write(IDENT1 & "<url>" & NL)
' HTMLEncode will convert & to & as required by Google
Response.Write(IDENT2 & "<loc>" & HTMLEncode(AURL) & "</loc>" & NL)
Response.Write(IDENT2 & "<changefreq>" & "weekly" & "</changefreq>" & NL)
Response.Write(IDENT2 & "<priority>" & APriority & "</priority>" & NL)
Response.Write(IDENT1 & "</url>" & NL)
End Sub
' (SS,5/6/09) NB. URLEncode only used on separate fields to convert + and - to correct values (not on complete URL)
' (SS,20/2/13) replaced "&" with "&" for proper entity escape
' (SS,2/3/15) added SEO friendly product name
' (SS,28/10/19) change to 2nd querystring parameter to use "&" instead of "&" investigate issue in Google Search Console
Sub AddGoogleSitemapLevel(APage, ASQL, APriority, AFieldName1, AQueryStringFieldName1, AFieldName2, AQueryStringFieldName2)
Dim LURL, LPage
If APage = "" Then
LPage = "products.asp"
Else
LPage = APage
End If
OpenQuery(ASQL)
Do While Not EndOfQuery
LURL = AQueryStringFieldName1 & "=" & URLEncode(GetFieldValue(AFieldName1))
If AFieldName2 <> "" Then
' (SS,20/2/13) replaced "&" with "&"
' (SS,28/10/19) replaced "&" with "&"
LURL = LURL & "&" & AQueryStringFieldName2 & "="
' (SS,2/3/15) added ProductName SEO friendlym previously it was just code, now both code and name used
If AFieldName2 = "ProductName" Then
LURL = LURL & URLEncode(SEOFriendlyStr(GetFieldValue(AFieldName2)))
Else
LURL = LURL & URLEncode(GetFieldValue(AFieldName2))
End If
End If
AddGoogleSitemapURL GetStoreURL & "/" & LPage & "?" & LURL, APriority
NextQueryRecord
Loop
CloseQuery
End Sub
' (SS,5/6/09) called from google-sitemap.asp
' (SS,2/3/15) added ProductName
Sub DoGoogleSitemap
Response.ContentType = "text/xml" ' tells browses that it's an XML document
' add the main links held in site details
Dim LList, LLine, LStart, LEndReached, LPos
LList = GetSiteDetail("Other", "GoogleSitemapList")
LStart = 1
LEndReached = False
Do
LPos = InStr(LStart, LList, NL)
If LPos = 0 Then
LPos = Len(LList) + 1 ' go to end + 1
LEndReached = True
End If
LLine = Mid(LList, LStart, LPos - LStart)
LStart = LPos + 2 ' move beyond the new line
AddGoogleSitemapURL GetStoreURL & "/" & LLine, "1.0"
Loop Until LEndReached
Dim LSQL
' (SS,23/6/09) add the site pages if there are any (e.g. CovDem has them using index.asp)
LSQL = "SELECT Name FROM sitedetails WHERE Type = 'Pages' AND CheckBoxField = True ORDER BY SortOrder, Name"
OpenQuery(LSQL)
Do While Not EndOfQuery
AddGoogleSitemapURL GetStoreURL & "/index.asp" & "?page=" & CleanPageName(GetFieldValue("Name")), "1.0"
NextQueryRecord
Loop
CloseQuery
If GroupsEnabled Then
' add the group level links if groups enabled, only groups that contain enabled products
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
LSQL = "SELECT GroupName, COUNT(*) AS Products FROM productcategories" &_
" INNER JOIN categories ON categories.Category = productcategories.Category" &_
" INNER JOIN products ON products.ProductCode = productcategories.ProductCode" &_
" WHERE ProductDisabled = False" & GetProductsFilter &_
" GROUP BY GroupName"
AddGoogleSitemapLevel "", LSQL, "0.3", "GroupName", "grp", "", ""
End If
' add the category level links for the ones that contain products
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
LSQL = "SELECT productcategories.Category, COUNT(*) AS Products FROM productcategories" &_
" INNER JOIN products ON products.ProductCode = productcategories.ProductCode" &_
" WHERE ProductDisabled = False" & GetProductsFilter &_
" GROUP BY Category"
AddGoogleSitemapLevel "", LSQL, "0.4", "Category", "cat", "", ""
' add the subcategory level links for the ones that contain products
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
LSQL = "SELECT productcategories.Category, productcategories.Subcategory, COUNT(*) AS Products FROM productcategories" &_
" INNER JOIN products ON products.ProductCode = productcategories.ProductCode" &_
" WHERE ProductDisabled = False" & GetProductsFilter &_
" GROUP BY Category, Subcategory"
AddGoogleSitemapLevel "", LSQL, "0.5", "Category", "cat", "Subcategory", "subcat"
' add the product level links for products that are not disabled
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
LSQL = "SELECT ProductCode, ProductName FROM products" &_
" WHERE ProductDisabled = False" + GetProductsFilter + " ORDER BY ProductCode"
' (SS,2/1/5) added ProductName and name
AddGoogleSitemapLevel "", LSQL, "1.0", "ProductCode", "code", "ProductName", "name"
' add the product level links for products2.asp, uses same query as above
' (SS,16/11/12) removed links for products2.asphy
'AddGoogleSitemapLevel "products2.asp", LSQL, "1.0", "ProductName", "name", "ProductCode", "code"
' (SS,19/2/13) call GetCustomXMLSitemap routine if it exists in customutils.asp to add extra sitemap items
If FunctionExists("GetCustomXMLSitemap") Then GetCustomXMLSitemap
' CloseDatabase used instead of Finalise in google-sitemap.asp, because Finalise adds google analytics stuff
CloseDatabase
End Sub
' (SS,12/6/09) these are defined in
' show the banners on the ride hand side, shuffle randomly or shifted up or down
' AShiftMethod can be "R" for random, "U" to shift up "D" for down, blank for not change
Sub ShowCustomBanners(AShiftMethod)
Dim i, LSwap, LFirstTime, LBannerCount
' make sure the session variables have the default values and determine the count
If Session("CustomBannerCount") = "" Then
LFirstTime = True ' used to show in default order for first time when down is shift up/down
Session("CustomBannerCount") = 0
i = 1
Do While FunctionExists("CustomBanner" & i)
Session("CustomBanner" & i) = i
Session("CustomBannerCount") = i
i = i + 1
Loop
Else
LFirstTime = False
End If
LBannerCount = Session("CustomBannerCount")
' shift up/down or shuffle randomly
If AShiftMethod = "R" Then
' randomly swap
Dim LIndex1, LIndex2
For i = 1 To 20
LIndex1 = RandomInteger(1, LBannerCount)
LIndex2 = RandomInteger(1, LBannerCount)
LSwap = Session("CustomBanner" & LIndex1)
Session("CustomBanner" & LIndex1) = Session("CustomBanner" & LIndex2)
Session("CustomBanner" & LIndex2) = LSwap
Next
ElseIf AShiftMethod = "U" And Not LFirstTime Then
' shift up
LSwap = Session("CustomBanner1")
For i = 1 To LBannerCount - 1
Session("CustomBanner" & i) = Session("CustomBanner" & i + 1)
Next
Session("CustomBanner" & LBannerCount) = LSwap
ElseIf AShiftMethod = "D" And Not LFirstTime Then
' shift down
LSwap = Session("CustomBanner" & LBannerCount)
For i = LBannerCount TO 2 STEP -1
Session("CustomBanner" & i) = Session("CustomBanner" & i - 1)
Next
Session("CustomBanner1") = LSwap
End If ' if
' show the banners in new order
For i = 1 To LBannerCount
Eval("CustomBanner" & Session("CustomBanner" & i))
Next
End Sub
' -------------------------------------- '
' Start of Language Translation Routines '
' -------------------------------------- '
' (SS,17/3/10) this is called once in the initialise routine
' if translation is enabled it reads the contents of the common translation table into arrays
' the two arrays are used by the tr function
Sub SetUpTranslation
If Not FTranslationEnabled Or FTranslationLanguage = "" Then Exit Sub ' exit if translation not enabled
Dim i, LTotalLines
OpenDatabaseCommon
' count total lines for setting size of array
OpenQueryCommon("SELECT COUNT(*) AS TotalLines FROM translation")
LTotalLines = CInt(GetQueryValueCommon("TotalLines"))
CloseQueryCommon
' set size of array and read the lines into the array
ReDim FTransArrayEnglish(LTotalLines - 1), FTransArrayLanguage(LTotalLines - 1)
OpenQueryCommon("SELECT * FROM translation ORDER BY English")
i = 0
Do While Not EndOfQueryCommon
FTransArrayEnglish(i) = GetQueryValueCommon("English")
FTransArrayLanguage(i) = GetQueryValueCommon(FTranslationLanguage)
NextQueryRecordCommon
i = i + 1
Loop
CloseQueryCommon
CloseDatabaseCommon
End Sub
' (SS,17/3/10) looks up and returns the text for given English
Function tr(AText)
' exit with same string if translation not enabled
If Not FTranslationEnabled Then
tr = AText
Exit Function
End If
' lookup the equivalent text from array
Dim i, Result
Result = ""
For i = 0 To UBound(FTransArrayEnglish)
' do a case insensitive compare
If StrComp(FTransArrayEnglish(i), AText, 1) = 0 Then
Result = NB(FTransArrayLanguage(i))
Exit For
End If
Next
If Result = "" Then Result = AText
tr = Result
End Function
' (SS,18/3/10) calls tr and converts to lowercase
Function trl(AText)
trl = LCase(tr(AText))
End Function
' (SS,19/3/10) calls tr to get translation, replaces the token <x> with the text in AReplaceWith
Function trx(AText, AReplaceWith)
Dim Result
Result = tr(AText)
trx = ReplaceStr(Result, "<x>", AReplaceWith)
End Function
' (SS,19/3/10) calls tr to get translation, replaces <x> with AReplaceWith1, and </x> with AReplaceWith2 useful for adding a href in part of text
Function trx2(AText, AReplaceWith1, AReplaceWith2)
Dim Result
Result = tr(AText)
Result = ReplaceStr(Result, "<x>", AReplaceWith1)
trx2 = ReplaceStr(Result, "</x>", AReplaceWith2)
End Function
' ------------------------------------ '
' End of Language Translation Routines '
' ------------------------------------ '
' ---------------------------- '
' Start of New Button Routines '
' ---------------------------- '
' (SS,6/5/10) caption changed from "add to basket" to "Buy"
Function GetButtonBuy(AProductCode)
GetButtonBuy = GetButton(GetBuyBLink(AProductCode), "images/add.gif", "Buy", "")
End Function
' list version, gets link using GetBuyLLink instead of GetBuyBLink, caption changed from "add to basket" to "Buy"
Function GetButtonBuyL(AProductCode)
GetButtonBuyL = GetButton(GetBuyLLink(AProductCode), "images/add.gif", "Buy", "")
End Function
Function GetButtonSearch
GetButtonSearch = GetButton("javascript:itp_search()", "images/bt-go.gif", "Go", "")
End Function
Function GetButtonPreviousPage(AHRef)
GetButtonPreviousPage = GetButton(AHRef, "images/previous.gif", "Previous page", "")
End Function
Function GetButtonNextPage(AHRef)
GetButtonNextPage = GetButton(AHRef, "images/next.gif", "Next page", "")
End Function
Function GetButtonLogin
GetButtonLogin= GetButton("javascript:document.frmAccountLoginMain.submit()", "images/login.gif", "Log in", "") ' (SS,15/6/11) changed "Login" to "Log in" because it's a verb in this case not a noun
End Function
' login in first checkout page
' (SS,7/10/19) removed 2nd parameter "images/login.gif" redundant since use of RWD.
' For Bootstrap 4, added "form" to last (options) parameter
' because it uses "<button>" instead of "<a>" tag to post the form (due to new Bootstrap 4 validation)
' first parameter (GetCheckoutSubmitLink) can be blank, kept for compatibility with Bootstrap 3
' (SS,30/9/20) modified to work with Bootstrap 3 also
Function GetButtonLoginInCheckout
' original had align="absbottom" in img src, may need to add later
' (SS,15/6/11) changed "Login" to "Log in" because it's a verb in this case not a noun
' (SS,30/9/20) replaced "GetCheckoutSubmitLink" in following with "javascript:document.frmCheckoutLogin.submit()"
' due to different form being used for login in Bootstrap 4 which is now being used for Bootstrap 3 also (i.e. we're now using a combined Bootstrap 3 and 4 version)
'GetButtonLoginInCheckout = GetButton("javascript:document.frmCheckoutLogin.submit()", "", "Log in", "form")
' (SS,21/6/22) replaced above with following i.e. added itp_preserve_checkout_login_values()
GetButtonLoginInCheckout = GetButton("javascript:itp_preserve_checkout_login_values(); document.frmCheckoutLogin.submit()", "", "Log in", "form")
End Function
' was also login, but changed to My Account because it has same function as "My Account"
' (SS,13/9/12) renamed from GetButtonMyAccount to GetButtonYourAccount, caption "My Account" changed to "Your Account"
Function GetButtonYourAccount
GetButtonYourAccount = GetButton("products.asp?page=account", "images/login.gif", "Your Account", "")
End Function
' (SS,1/3/15) replaced & with &
Function GetButtonLogOut
GetButtonLogOut = GetButton("products.asp?page=account&cmd=logout", "images/logout.gif", "Log out", "")
End Function
' (SS,1/3/15) replaced & with &
Function GetButtonCreateAccount
GetButtonCreateAccount = GetButton("products.asp?page=account&cmd=create", "images/create-account.gif", "Create account", "")
End Function
' (SS,1/3/15) replaced & with &
Function GetButtonEditAccount
GetButtonEditAccount = GetButton("products.asp?page=account&cmd=update", "images/edit-details.gif", "Edit account details", "")
End Function
Function GetButtonSubmitForgotPassword
GetButtonSubmitForgotPassword = GetButton("javascript:document.frmForgotPassword.submit()", "images/submit.gif", "Submit", "")
End Function
' (SS,18/6/12)
Function GetButtonSubmitResetPassword
GetButtonSubmitResetPassword = GetButton("javascript:document.frmResetPassword.submit()", "images/submit.gif", "Submit", "")
End Function
' used to create account and edit account
' (SS,6/10/11) changed for VAT number validation, added id="accountsubmit"
' (SS,9/9/14) changed to show different button caption for create account or edit account
Function GetButtonSubmitCreateAccount
' (SS,9/9/14) added following
Dim LCaption
If AccountLoggedIn Then
LCaption = "Save changes"
Else
LCaption = "Create account"
End If
' GetButtonSubmitCreateAccount = GetButton("javascript:document.frmCreateAccount.submit()", "images/submit.gif", "Submit", "")
' (SS,6/10/11) replaced above with following because it now does VAT number validation if applicable
' (SS,9/9/14) replaced "Submit" with LCaption
' (SS,11/10/19) removed "images/submit.gif" (not used), added "form" to allow the new validation in Bootstrap 4
GetButtonSubmitCreateAccount = GetButton("javascript:itp_accounts_submit()", "images/submit.gif", LCaption, "id=accountsubmit,form")
End Function
' used after login
Function GetButtonContinueShopping
GetButtonContinueShopping = GetButton("products.asp", "images/continue-shopping.gif", "Continue shopping", "")
End Function
' on basket page
Function GetButtonBasketContinue
GetButtonBasketContinue = GetButton(GetContinueLink, "images/continue-shop.gif", "Continue shopping", "")
End Function
Function GetButtonBasketRecalculate
GetButtonBasketRecalculate = GetButton("javascript:document.frmBasket.submit()", "images/recalculate.gif", "Recalculate", "")
End Function
' (SS,15/1/15) same as recalculate but with "Apply Voucher Code" text
Function GetButtonBasketApplyVoucherCode
GetButtonBasketApplyVoucherCode = GetButton("javascript:document.frmBasket.submit()", "", "Apply Voucher Code", "")
End Function
Function GetButtonProceedToCheckout
' (SS,13/10/14) moved to GetButtonProceedToCheckoutWithID and added "id=btnProceedToCheckout"
' id allows easy jQuery to override click to show a modal
GetButtonProceedToCheckout = GetButtonProceedToCheckoutWithID("id=btnProceedToCheckout")
End Function
' (SS,13/10/14) another version of GetButtonProceedToCheckout but with no ID
' allows the ID one (above) to have a button override using jquery, without affecting this one, to allow a modal to be added in basket page
Function GetButtonProceedToCheckoutNoID
GetButtonProceedToCheckoutNoID = GetButtonProceedToCheckoutWithID("")
End Function
' (SS,13/10/14) code from GetButtonProceedToCheckout moved here
' (SS,7/10/19) removed the image name "images/pro-checkout.gif" in second parameter to GetButton, old legacy image no longer used
Function GetButtonProceedToCheckoutWithID(AID)
GetButtonProceedToCheckoutWithID = GetButton(GetCheckoutLink, "", "Proceed to checkout", AID)
End Function
' (SS,6/10/11) added id="nextstage"
' (SS,8/9/14) added chevron-right to options for RWD, bootstrap
' (SS,7/10/19) 2nd parameter "images/next-stage.gif" is redundant now, set to ""
' (SS,7/10/19) For Bootstrap 4, added "form" to use <button> for "form" instead of <a>. Will will ensure the new form validation will work. AHRef is really redundant and can be blank
Function GetButtonProceedToNextStage(AHRef)
GetButtonProceedToNextStage = GetButton(AHRef, "", "Proceed to next stage", "id=nextstage,chevron-right,form")
End Function
' used by cheque or bank transfer (*** not yet tested)
Function GetButtonConfirmOrder(AHRef)
GetButtonConfirmOrder = GetButton(AHRef, "images/confirm-order.gif", "Confirm order", "")
End Function
Function GetButtonMakePayment(AHRef)
GetButtonMakePayment = GetButton(AHRef, "images/make-payment.gif", "Make payment", "")
End Function
' also make sure new button not used for certain image files e.g. worldpay, paypal, googlecheckout
' (SS,19/1/15) added new ACaption parameter, which simplifies this routine and allows both button and images to be shown
' (SS,4/2/15) improved layout for not responsive design
Function GetButtonPayment(AHRef, ACaption, AImageFile)
Dim LResult
LResult = GetButton(AHRef, AImageFile, ACaption, "")
If AImageFile <> "" Then
Dim LImageHTML, LHeight
If IsRWD Then
LHeight = "48"
Else
LHeight = "28"
End If
LImageHTML = "<a href=""" + AHRef + """><img style=""max-height:" & LHeight & "px;vertical-align: bottom"" src=""" + AImageFile + """ alt=""" + ACaption + """ border=""0""></a>"
If IsRWD Then
LResult = LResult & " " & LImageHTML
Else
'LResult = "<div style=""margin-top:10px;margin-bottom:2px"">" & LImageHTML & "</div>" & LResult
'LResult = LImageHTML & " " & LResult
LResult = LResult & " " & LImageHTML
End If
End If
GetButtonPayment = LResult
End Function
' (SS,26/5/10)
Function GetButtonOutOfStock
GetButtonOutOfStock = GetButton("", "images/out-of-stock.gif", "Out of stock", "")
End Function
' (SS,20/1/11) returns true if AOptionToFind exists in comma separated list, the comparison is case insensitve add to dbfunctions in future?
Function IsOption(AOptionList, AOptionToFind)
IsOption = InStr(1, "," + AOptionList + ",", "," + AOptionToFind + ",", 1) > 0
End Function
' (SS,6/10/11) returns the value after x=, e.g. GetOptionEquals("abc,id=button1,def", "id") returns button1, if not found then "" is returned
Function GetOptionEquals(AOptionList, AOptionToFind)
Dim LStrToSearch, LResult, LPos, LEnd
LStrToSearch = "," + AOptionList + ","
LPos = InStr(1, LStrToSearch, "," + AOptionToFind + "=", 1)
If LPos > 0 Then
LEnd = InStr(LPos + 1, LStrToSearch, ",", 1)
LResult = Mid(LStrToSearch, LPos + Len(AOptionToFind) + 2, LEnd - LPos - Len(AOptionToFind) - 2)
Else
LResult = ""
End If
GetOptionEquals = LResult
End Function
' (SS,20/1/11) improved AOptions handling, AOptions can contain
' "original" to force original
' "nav", "other" to force this class
' "targetblank" to add target="_blank" to link
' options can be comma separated
' (SS,6/10/11)
' added id, which can be passed here by adding "id=xyz" to AOptions, comma separated
' new function GetOptionEquals added above, this returns the value after id=
' this was added to allow an element to be found easily and hidden, mainly for account form validation please wait
' (SS,28/8/14) changes for RWD Bootstrap
' (SS,26/2/15) added title option for adding tooltip
' (SS,27/9/19) For Bootstrap 4, replaced glyphicon-chevron-right with fa-chevron-right
' (SS,7/10/19) For Bootstrap 4, <button> used if "form" in AOptions and ALink is ignored, other <a> is used (used in GetButtonProceedToNextStage)
Function GetButton(ALink, AImage, ACaption, AOptions)
Dim LButtonType, LClassType
'DebugMsg (ALink & ", " & AImage & ", " & ACaption & ", " & AOptions)
' (SS,20/1/11) replaced Or AOptions = "O" with IsOption(AOptions, "original")
' (SS,17/6/11) added Or ACaption = "", to use original button if no caption, new buttons need a caption
If FButtonType = BT_ORIGINAL Or IsOption(AOptions, "original") Or ACaption = "" Then
LButtonType = BT_ORIGINAL
Else
LButtonType = FButtonType
End If
' (SS,20/1/11) added [Or LCase(AOptions) = "nav"] to force nav if specified in options
If InStr(1, ",Go,Next page,Previous page,", "," + ACaption + ",", 1) > 0 Or IsOption(AOptions, "nav") Then
LClassType = "nav" ' e.g. in blue
' (SS,22/2/24) added following which overrides the else below in some cases
ElseIf InStr(1, ",Recalculate,Email basket,Apply Voucher Code,", "," + ACaption + ",", 1) > 0 Or IsOption(AOptions, "default") Then
LClassType = "default" ' e.g. grey or white (no colour)
' (SS,20/1/11) added [Or LCase(AOptions) = "other"] to force other if specified in options
ElseIf InStr(1, ",Login,Log out,Edit account details,Continue shopping,Recalculate,", "," + ACaption + ",", 1) > 0 Or IsOption(AOptions, "other") Then
LClassType = "other" ' e.g. green
Else
LClassType = "main" ' e.g. red
End If
' translate and also prefix with "<" or ">" if previous or next page
Dim LTransCaption
LTransCaption = tr(ACaption)
If ACaption = "Previous page" Then
LTransCaption = "« " + LTransCaption ' (SS,25/7/11) replaced � with «
ElseIf ACaption = "Next page" Then
LTransCaption = LTransCaption + " »" ' (SS,25/7/11) replaced � with »
End If
' (SS,26/5/10) if there is no link then don't show the hand cursor, i.e. change to default cursor and disable the click
Dim LAddToHRef
If ALink = "" Then
LAddToHRef = " onMouseOver=""this.style.cursor='default'"" onClick=""return false;"""
Else
LAddToHRef = ""
End If
' (SS,20/1/11) added following to add target="_blank"
If IsOption(AOptions, "targetblank") Then
LAddToHRef = LAddToHRef + " target=""_blank"""
End If
' (SS,6/10/11) if id specified then add it to the "a href"
Dim LID
LID = GetOptionEquals(AOptions, "id")
If LID <> "" Then LID = "id=""" & LID & """ "
' (SS,26/2/15) if title attribute specified then add it to the "a href"
Dim LTitle
LTitle = GetOptionEquals(AOptions, "title")
If LTitle <> "" Then LTitle = " title=""" & LTitle & """"
' (SS,20/1/11) added And AImage <> "" to only do this if image specified
' (SS,6/10/11) added LID
' (SS,26/8/14) added If IsRWD for bootstrap buttons, similar to BT_TYPE1 but with different class names
' (SS,10/9/14) swapped If and ElseIf - IsRWD moved to second If i.e. ElseIf
If LButtonType = BT_ORIGINAL And AImage <> "" Then
GetButton = "<a " & LID & "href=""" + ALink + """" + LAddToHRef + LTitle + "><img src=""" + AImage + """ alt=""" + LTransCaption + """ border=""0""></a>"
ElseIf IsRWD Then ' (SS,26/8/14) for bootstrap
If LClassType = "nav" then
LClassType = "primary"
' (SS,22/2/24) keep the same for default
ElseIf LClassType = "default" Then
LClassType = "default"
Else
LClassType = "success"
End If
Dim LButtonHTML
' (SS,30/9/19) Bootstrap 4 version added " type=""submit"">", also replaced a with button
If IsBootstrap4 Then
'LButtonHTML = "<button " & LID & "href=""" + ALink + """ class=""btn btn-default btn-" + LClassType + """" + LAddToHRef + LTitle + " type=""submit""" + ">" + LTransCaption
' (SS,7/10/19) added check for "form", if button is for form then "<a>" used used instead of "<button>"
' button works best with form (especially Bootstrap 4 validation). For links without form then <a> is required because links won't work with <button>
Dim AIsForm
AIsForm = IsOption(AOptions, "form")
If AIsForm Then
LButtonHTML = "<button " & LID & "class=""btn btn-default btn-" + LClassType + """" + LAddToHRef + LTitle + ">" + LTransCaption
Else
LButtonHTML = "<a " & LID & "href=""" + ALink + """ class=""btn btn-default btn-" + LClassType + """" + LAddToHRef + LTitle + ">" + LTransCaption
End If
' Bootstrap 4 uses FontAwesome i.e. fa fa-chevron-right
If IsOption(AOptions, "chevron-right") Then
LButtonHTML = LButtonHTML + " <span class=""fa fa-chevron-right""></span>"
End If
If AIsForm Then
LButtonHTML = LButtonHTML + "</button>"
Else
LButtonHTML = LButtonHTML + "</a>"
End If
Else ' as before i.e. Bootstrap 3
' (SS,27/2/24) added following for submit button validation for proceed to next stage button, only temp improvement for CIRC just moving to Bootstrap 5
If ACaption = "Proceed to next stage" And IsOption(AOptions, "form") Then
LButtonHTML = "<button type=""submit"" " & LID & "class=""btn btn-default btn-" + LClassType + """" + LAddToHRef + LTitle + ">" + LTransCaption
Else ' as before
LButtonHTML = "<a " & LID & "href=""" + ALink + """ class=""btn btn-default btn-" + LClassType + """" + LAddToHRef + LTitle + ">" + LTransCaption
' (SS,8/9/14) added chevron if "chevron-right" in options
If IsOption(AOptions, "chevron-right") Then
LButtonHTML = LButtonHTML + " <span class=""glyphicon glyphicon-chevron-right""></span>"
End If
LButtonHTML = LButtonHTML + "</a>"
End if
End If
GetButton = LButtonHTML
Else ' (SS,20/1/11) removed [If LButtonType = BT_TYPE1 Then]
GetButton = "<a " & LID & "href=""" + ALink + """ class=""button button-" + LClassType + """" + LAddToHRef + LTitle + ">" + LTransCaption + "</a>"
End If
End Function
' login, logout, create account, submit, edit account details, continue shopping, proceed to checkout
' next, previous, proceed to next stage, make payment
' ------------------------------------ '
' End of Language Translation Routines '
' ------------------------------------ '
' (SS,21/3/11) Banner stuff, returns True if banner image found
' calls ShowBannerHeader, ShowBannerItem and ShowBannerFooter in inc-template-other.asp
Function ShowBanner(AShowCaption)
ShowBanner = False
Dim LFileName, LCaption, LURL, LPos
OpenQuery("SELECT Type, Code2, FileName, Extra FROM files WHERE Type = 'P' AND Code = 'BANNER' ORDER BY Code2")
If Not EndOfQuery Then
ShowBannerHeader
' for each image
Do While Not EndOfQuery
LFileName = GetQueryField("FileName")
' take caption from filename just before the extension
If AShowCaption Then
LPos = InStrRev(LFileName, ".")
If LPos > 0 Then
LCaption = Trim(Mid(LFileName, 1, LPos - 1))
Else
LCaption = ""
End If
End If
' (SS,12/9/12) replaced GetProductFileLink with GetProductFileLinkCached to ensure image is cached
' (SS,25/5/17) added new Button Caption parameter, currently blank
ShowBannerItem GetProductFileLinkCached("BANNER", GetQueryField("Code2")), LCaption, GetQueryField("Extra"), ""
NextQueryRecord
Loop
ShowBannerFooter
ShowBanner = True
End If
CloseQuery
End Function
' (SS,30/6/11)
' -------------------------------- '
' Start of Product Option Routines '
' -------------------------------- '
Sub ShowProductOptions(AProductID)
' show the hidden values, used to make add to basket work
' "mainbuy" indicates that this has come from the main buy button on the product details page
' this can be used to prevent redirection to main product page, when add clicked (elsewhere) on a product with options
' (SS,17/1/13) added missing / from mainbuy input tag
%>
<input type="hidden" name="cmd" value="buy" />
<input type="hidden" name="mainbuy" value="yes" />
<input type="hidden" name="productid" value="<%=AProductID%>" />
<%
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT * FROM product_options WHERE ProductID = '" & CleanSQLStr(AProductID) & "' ORDER BY SortOrder, OptionName")
If Not EndOfQuery Then
ShowProductOptionsHeader AProductID
Dim LOptionName, LInputType, LSplitIndex, LSplits, LSplit, LSplitCount
' for each option
Do While Not EndOfQuery
LOptionName = GetQueryField("OptionName")
LInputType = GetQueryField("InputType")
If IsSplitCombo(LOptionName, LInputType) Then
LSplits = Split(LOptionName, PO_SPLIT_COMBO_SEPARATOR)
LSplitCount = 0
For Each LSplit In LSplits
LSplitCount = LSplitCount + 1
' (SS,14/2/12) added GetQueryField("ExtraSettings")
ShowProductOption GetQueryField("ProductOptionID"), LSplit, POIT_COMBO_BOX, GetQueryField("Required"), GetQueryField("ExtraSettings"), LSplitCount
Next
Else
' (SS,14/2/12) added GetQueryField("ExtraSettings")
ShowProductOption GetQueryField("ProductOptionID"), LOptionName, LInputType, GetQueryField("Required"), GetQueryField("ExtraSettings"), 0
End If
NextQueryRecord
Loop
ShowProductOptionsFooter AProductID
End If
CloseQuery
End Sub
' (SS,15/7/11)
Function IsSplitCombo(AOptionName, AInputType)
IsSplitCombo = AInputType = POIT_SPLIT_COMBO And InStr(AOptionName, PO_SPLIT_COMBO_SEPARATOR) > 0
End Function
' (SS,14/7/11) separated from ShowProductOptions above to implement the split combo
' (SS,14/7/11) added ASplitIndex, this is 0 for normal combo, > 1 for split combo
' (SS,14/2/12) added AExtraSettings
' (SS,26/8/14) added ability to override the default option HTML via CustomGetProductOptionHTML when setting contains "CUSTOM"
Sub ShowProductOption(AProductOptionID, AOptionName, AInputType, ARequired, AExtraSettings, ASplitIndex)
Dim LIsCustomSetting, LInputLabelHTML, LInputHTML
LIsCustomSetting = InStr(1, "," + AExtraSettings + ",", ",CUSTOM,", vbTextCompare) ' (SS,26/8/14) set custom flag
' (SS,9/6/17) added GetRWDFullWidthColClass
Response.Write "<div class=""product-option"">" & NL
' (SS,26/8/14) replaced Response.Write with "LInputLabel =" to allow Custom routine to override the label as well
LInputLabelHTML = ""
' label, if required then an * is shown
If ARequired Then LInputLabelHTML = LInputLabelHTML + "<span class=""product-option-required"">*</span>" & NL
LInputLabelHTML = LInputLabelHTML + "<b>" + AOptionName + ":</b>" + BR
' (SS,26/8/14) if custom setting set then call the custom routine to allow the default option label HTML to be overridden
If LIsCustomSetting Then
If FunctionExists("CustomGetProductOptionLabelHTML") Then
LInputLabelHTML = CustomGetProductOptionLabelHTML(LInputLabelHTML, AOptionName, AInputType, ARequired, AExtraSettings)
End If
End If
Response.Write LInputLabelHTML
Dim LValuesOutOfStock ' (SS,14/2/12) array holding list of values are are out of stock, used to show list of option values that are out of stock
If AInputType = POIT_COMBO_BOX Or AInputType = POIT_RADIO Or AInputType = POIT_CHECK_BOX Then
If ASplitIndex = 0 Then
LInputHTML = LInputHTML + GetProductOptionComboBox(AProductOptionID, AInputType, LValuesOutOfStock, AOptionName, LIsCustomSetting) ' (SS,14/2/12) added LValuesOutOfStock ' (SS,27/8/14) added AOptionName and LIsCustomSetting
Else
LInputHTML = LInputHTML + GetProductOptionSplitComboBox(AProductOptionID, ASplitIndex)
End If
ElseIf AInputType = POIT_TEXT Then
LInputHTML = LInputHTML + "<input type=""text"" name=""option-" & AProductOptionID & """ value="""" />" & NL
Else
LInputHTML = ""
End If
' (SS,26/8/14) if custom setting set then call the custom routine to allow the default option HTML to be overridden
If LIsCustomSetting Then
If FunctionExists("CustomGetProductOptionHTML") Then
LInputHTML = CustomGetProductOptionHTML(LInputHTML, AProductOptionID, AOptionName, "option-" & AProductOptionID, AInputType, ARequired, AExtraSettings, ASplitIndex)
End If
End If
Response.Write LInputHTML
' (SS,14/2/12) if LO option set then show the options that are out of stock
' (SS,26/8/14) corrected by swapping ",LO," with AExtraSettings
If InStr("," + AExtraSettings + ",", ",LO,") > 0 And VarType(LValuesOutOfStock) >= vbArray Then
Dim i, LMaxCount
LMaxCount = UBound(LValuesOutOfStock) + 1
If LMaxCount > 0 Then
Response.Write BR & "Following " + Iif(LMaxCount = 1, "option", "options") + " " + Iif(LMaxCount = 1, "is", "are") + " out of stock:" & BR
For i = 0 To UBound(LValuesOutOfStock)
Response.Write "<a href=""" & GetStockNotificationWithOptionLink(GetProductCode, LValuesOutOfStock(i)) & """><b>" & LValuesOutOfStock(i) & "</b></a>" & BR & NL
Next
Response.Write "Please click option above to be notified when back in stock." & BR
End If
End If
' title is used by itp_buyo routine to display the option name is required error, so it knows what is required
Response.Write "<div id=""product-option-error-" & AProductOptionID & IIf(ASplitIndex = 0, "", "-split-" & ASplitIndex) & """ class=""product-option-error"" title=""" & AOptionName &""">" & "</div>" & NL
Response.Write "</div>" & NL
End Sub
' returns true if given product has options, single quote used in query in case routine is called with a blank product id
' if ARequired is True then True is returned if product has required options, else it returns true if it has any option
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Function ProductHasOptions(AProductID, ARequired)
Dim LSQL
LSQL = "SELECT ProductOptionID FROM product_options WHERE ProductID = '" & CleanSQLStr(AProductID) & "'"
If ARequired Then LSQL = LSQL + " AND Required = TRUE"
ProductHasOptions = GetSQLValueAsString(LSQL) <> ""
End Function
' ID is returned as a string, when not found a blank string is return
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Function GetProductIDForProductCode(AProductCode)
GetProductIDForProductCode = GetSQLValueAsString("SELECT ProductID FROM products WHERE ProductCode = '" & CleanSQLStr(AProductCode) & "'")
End Function
' (SS,20/7/11)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Function GetProductCodeForProductID(AProductID)
GetProductCodeForProductID = GetSQLValueAsString("SELECT ProductCode FROM products WHERE ProductID = '" & CleanSQLStr(AProductID) & "'")
End Function
' (SS,18/10/18) returns given field for given product ID
Function GetFieldForProductID(AProductID, AFieldName)
GetFieldForProductID = GetSQLValue("SELECT " & CleanSQLStr(AFieldName) & " FROM products WHERE ProductID = '" & CleanSQLStr(AProductID) & "'")
End Function
' return true if the buy or add to basket request is the main one on product details page
' this can be used to prevent redirection to main product page, when add clicked (elsewhere) on a product with options
Function IsMainBuy
IsMainBuy = CleanRequest("mainbuy") = "yes"
End Function
' (SS,30/6/11) can be called for input types: combo box, radio, or check box
' (SS,2/2/12) modified to show all options if none in stock to allow preorder, empty combo is no good
' (SS,14/2/12) added ByRef AValuesOutOfStock to pass back list of values out of stock
' (SS,5/2/13) modified to default to first item in radio group, hoping it'll cause less confusion on an iPad, also changed order so that most in stock is shown first
' (SS,13/12/13) modified to show radio label text with clickable picture if picture exists for option value
' (SS,19/12/13) improved radio alignment in IE using new div with class option-radio-div
' (SS,27/8/14) added AOptionName, AIsCustomSetting parameters to allow custom routine to be called if custom
' (SS,12/6/17) various changes around this date for Bootstrap (and HF)
' (SS,28/7/17) change to now call Function GetProductDetailOptionImageHTML in inc-template-product-detail.asp for option image render
' (SS,31/3/20) added form-control to class for combo box
' (SS,24/3/25) change to LNoOptionsInStock for HyperFlight when all options get shown instead of just the ones with Null (KITE)
Function GetProductOptionComboBox(AProductOptionID, AInputType, ByRef AValuesOutOfStock, AOptionName, AIsCustomSetting)
Dim LResult, LPriceAdjust, LOptionValue, LOptionValueWithPrice, LInStock, LOptionValueID, LName, LLabelID, LOptionValueCount, LSortOrder ' (SS,5/2/13) added LSortOrder
Dim LNumInStock, LNumInStockForLabel ' (SS,12/6/17) to allow showing of amount in stock if more than 1
Dim LPicture ' (SS,13/12/13)
LResult = ""
LOptionValueCount = 0 ' (SS,26/4/12)
ReDim AValuesOutOfStock(-1) ' (SS,14/2/12) reset array with no elements
' (SS,2/2/12) check if no options in stock, in which case all available options are shown rather than an empty combo box
Dim LNoOptionsInStock
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
'LNoOptionsInStock = GetSQLValue("SELECT COUNT(*) FROM product_option_values WHERE ProductOptionID = '" & CleanSQLStr(AProductOptionID) & "' AND NumInStock IS NOT NULL AND NumInStock > 0") = 0
' (SS,24/3/25) replaced above with following, so that when option is null it's treated as if in stock,
' to fix issue in HyperFlight (productcode=KITE) when all options get shown when one has 0 in stock and others have null, replaced "AND NumInStock IS NOT NULL" with "OR NumInStock IS NULL)
LNoOptionsInStock = GetSQLValue("SELECT COUNT(*) FROM product_option_values WHERE ProductOptionID = '" & CleanSQLStr(AProductOptionID) & "' AND (NumInStock > 0 OR NumInStock IS NULL)") = 0
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,5/2/13) added NumInStock DESC to list most in stock first
OpenQuery2("SELECT * FROM product_option_values WHERE ProductOptionID = '" & CleanSQLStr(AProductOptionID) & "' ORDER BY SortOrder, NumInStock DESC, OptionValue")
If Not EndOfQuery2 Then
LName = "option-" & AProductOptionID
If AInputType = POIT_COMBO_BOX Then
' (SS,27/8/14) added class="" to allow easy class addition via custom routine
' LResult = "<select class="""" name=""" + LName & """ id=""" & LName & """>"
' (SS,31/3/20) there was no class="", added "form-control" for Bootstrap (CIRC), otherwise it looks too plain and square
LResult = "<select class=""form-control"" name=""" + LName & """ id=""" & LName & """>"
LResult = LResult & NL & "<option value="""">" & COMBO_PLEASE_SELECT & "</option>" & NL
End If
' (SS,5/2/13) used to select the first value in option, it should only select first option when radio and only one value exists for the option
' (SS,27/8/14) added LOptionValueHTML
Dim LFirstOptionValueLabelID, LOptionValueHTML
LFirstOptionValueLabelID = ""
Do While Not EndOfQuery2
LOptionValueHTML = "" ' (SS,27/8/14)
LInStock = IsNull(GetQueryValue2("NumInStock")) Or NZL(GetQueryValue2("NumInStock")) > 0
LNumInStock = NZL(GetQueryValue2("NumInStock")) ' (SS,12/6/17)
LOptionValueID = GetQueryValue2("ProductOptionValueID")
LOptionValue = GetQueryValue2("OptionValue")
LPriceAdjust = GetQueryValue2("PriceAdjust")
LSortOrder = GetQueryValue2("SortOrder") ' (SS,5/2/13)
LPicture = IntToBool(GetQueryValue2("Picture")) ' (SS,13/12/13)
' (SS,14/2/12) if not in stock then add to option value out of stock list, which is shown below the combo
' (SS,5/2/13) added And LSortOrder = -1, so that those with -1 are not shown, i.e. they're kept in the table for future reference etc.
If Not LInStock And LSortOrder <> -1 Then
ReDim Preserve AValuesOutOfStock(UBound(AValuesOutOfStock) + 1)
AValuesOutOfStock(UBound(AValuesOutOfStock)) = LOptionValue
End If
' only show option value if in stock
' (SS,2/2/12) added Or LNoOptionsInStock so that all options are shown when none options are in stock
' (SS,5/2/13) added And LSortOrder <> -1 to not show those with SortOrder equal to -1
If LInStock Or (LNoOptionsInStock And LSortOrder <> -1) Then
' (SS,26/4/12) added following to count the values, to allow check option to be selected if radio
LOptionValueCount = LOptionValueCount + 1
' (SS,26/4/12) if not combo, i.e. Radio, then replace semicolons with breaks, and replaced LOptionValue with LOptionValueWithPrice, done before currency because currency will contain ";" for the special char HTML i.e. £
If AInputType <> POIT_COMBO_BOX Then
LOptionValue = ReplaceStr(LOptionValue, ";", "<br />")
End If
If NZD(LPriceAdjust) <> "0" Then
' LOptionValueWithPrice = LOptionValue & " (" & SignedCurrencyPrice(LPriceAdjust) & ")"
' (SS,19/12/13) replaced above with following to prevent the price from wrapping at bracket, + or � sign etc. uses white-space style set to nowrap in a span
LOptionValueWithPrice = LOptionValue & " <span style=""white-space:nowrap;"">(" & SignedCurrencyPrice(LPriceAdjust) & ")</span>"
Else
LOptionValueWithPrice = LOptionValue
End If
' (SS,12/6/17)
' (SS,18/7/17) added And (IsNull(GetNumInStock) Or GetNumInStock > 0) to check if main product is in stock, only then show the stock per option
If LNumInStock >= 1 And (IsNull(GetNumInStock) Or GetNumInStock > 0) Then
LNumInStockForLabel = "<span class=""text-success small"">" & " (" & LNumInStock & " in stock)" & "</span>"
Else
LNumInStockForLabel = ""
End If
If AInputType = POIT_COMBO_BOX Then
' LResult = LResult & "<option value=""" & LOptionValueID & """>" & LOptionValue & "</option>" & NL
'LResult = LResult & "<option value=""" & LOptionValueID & """ title=""icons/" & CleanStrForFileName(LOptionValue) & ".png"">" & LOptionValueWithPrice & "</option>" & NL
LOptionValueHTML = LOptionValueHTML & "<option value=""" & LOptionValueID & """>" & LOptionValueWithPrice & "</option>" & NL
Else
LLabelID = "option-value-" & LOptionValueID
LOptionValueHTML = LOptionValueHTML & "<div class=""row option-row"">" ' (SS,9/6/17) added for Bootstrap & HF
' (SS,19/12/13) added extra div to sort indenting going wrong in IE issue
LOptionValueHTML = LOptionValueHTML & "<div class=""option-radio-div col-lg-12 col-md-12 col-sm-12 col-xs-12"">" & NL
LOptionValueHTML = LOptionValueHTML & "<div class=""option-radio-control col-lg-1 col-md-1 col-sm-1 col-xs-1"">" ' (SS,9/6/17)
LOptionValueHTML = LOptionValueHTML & "<input type=""" & IIf(AInputType = POIT_RADIO, "radio", "checkbox") & """ name=""" & LName & """ value=""" & LOptionValueID & """ id=""" & LLabelID & """ class=""option-radio"" />" & NL
LOptionValueHTML = LOptionValueHTML & "</div>" ' (SS,9/6/17)
' (SS,13/12/13) if picture than add a href for image popup, to be changed to use Magic Zoom
' (SS,17/12/13) added underline using style="text-decoration:underline"
' (SS,9/6/17) temporarily removed following by commented out
'If LPicture Then
'LOptionValueWithPrice = "<a href=""" & GetProductOptionValueImageLink(LOptionValueID) & """ style=""text-decoration:underline"" target=""_blank"">" & LOptionValueWithPrice & "</a>"
'LOptionValueWithPrice = "<a href=""" & GetProductOptionValueImageLink(LOptionValueID) & """ style=""text-decoration:underline"" class=""MagicThumb"" title=""" & LOptionValue & """>" & LOptionValueWithPrice & "</a>"
' (SS,18/12/13) replaced target=""_blank"" with class=""MagicThumb"" for Magic Zoom popup, also added title for caption
' (SS,19/12/13) replaced above with following, most "rel" properties from hyperflight/inc-template-product-detail.asp
'Dim LRel
'LRel = "background-opacity:70; background-color:#000; caption-source:span; hint:false; selectors-effect:pounce; expand-effect:linear; restore-effect:linear; pan-zoom:false"
' (SS,9/6/17) added "o" to GetProductOptionValueImageLink, previously no size parameter
'LOptionValueWithPrice = "<a href=""" & GetProductOptionValueImageLink(LOptionValueID, "o") & """ style=""text-decoration:underline"" class=""MagicThumb"" title=""Click for picture"" rel=""" & LRel & """><span>" & LOptionValueWithPrice & "</span></a>"
' End If
' (SS,26/4/12) replaced LOptionValue with LOptionValueWithPrice, semicolons replaced with break above, added class="option-radio-text" to improve the alignment, removed <br /> after
' LResult = LResult & "<label for=""" & LLabelID & """>" & LOptionValue & "</label><br />" & NL
LOptionValueHTML = LOptionValueHTML & "<div class=""option-radio-label col-lg-9 col-md-9 col-sm-5 col-xs-7"">" ' (SS,9/6/17)
' (SS,12/6/17) added LNumInStockForLabel to following
LOptionValueHTML = LOptionValueHTML & "<label for=""" & LLabelID & """ class=""option-radio-text"">" & LOptionValueWithPrice & LNumInStockForLabel & "</label>" & NL
LOptionValueHTML = LOptionValueHTML & "</div>" ' (SS,9/6/17)
' (SS,9/6/17) show thumbnail after label
If LPicture Then
' (SS,28/7/27) code from below moved to new Function GetProductDetailOptionImageHTML in inc-template-product-detail.asp, where it should have been before
' *** I think I added here due to html above, perhaps need to move some of above HTML to separate template
LOptionValueHTML = LOptionValueHTML & GetProductDetailOptionImageHTML(LOptionValue, LOptionValueID)
End If
' (SS,19/12/13) end of extra div to sort indenting going wrong in IE issue
LOptionValueHTML = LOptionValueHTML & "</div>"
LOptionValueHTML = LOptionValueHTML & "</div>" ' (SS,9/6/17) added for Bootstrap & HF, end of row div
If LFirstOptionValueLabelID = "" Then LFirstOptionValueLabelID = LLabelID ' (SS,5/2/13)
End If
' (SS,27/8/14) if custom setting set then call the custom routine to allow the default option value HTML to be overridden
If AIsCustomSetting Then
If FunctionExists("CustomGetProductOptionValueHTML") Then
LOptionValueHTML = CustomGetProductOptionValueHTML(LOptionValueHTML, LOptionValueID, LOptionValueCount, LOptionValue, LOptionValueWithPrice, AOptionName, AInputType, LPicture)
End If
End If
LResult = LResult & LOptionValueHTML ' (SS,27/6/14)
End If
NextQueryRecord2
Loop
If AInputType = POIT_COMBO_BOX Then
LResult = LResult & "</select>"
' if radio and only one option value
' (SS,5/2/13) removed "And LOptionValueCount = 1" to make sure first option is always selected
ElseIf AInputType = POIT_RADIO Then
' select the option because there's only one
' (SS,5/2/13) replaced name with id and LName with LFirstOptionValueLabelID
%>
<script type="text/javascript">
$(document).ready(function() {
$('input[id="<%=LFirstOptionValueLabelID%>"]').prop('checked', true);
});
</script>
<%
End If
End If
CloseQuery2
GetProductOptionComboBox = LResult
End Function
' (SS,9/6/17)
Function GetRWDFullWidthColClass
Dim Result
If IsRWD Then
' for bootstrap, space prefix important due to being added to other class
Result = " col-lg-12 col-md-12 col-sm-12 col-xs-12"
Else
Result = ""
End If
GetRWDFullWidthColClass = Result
End Function
' (SS,14/6/11) called for split combo box
Function GetProductOptionSplitComboBox(AProductOptionID, ASplitIndex)
Dim LResult, LPriceAdjust, LOptionValue, LInStock, LName, LUsedList
LResult = ""
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery2("SELECT * FROM product_option_values WHERE ProductOptionID = '" & CleanSQLStr(AProductOptionID) & "' ORDER BY SortOrder, OptionValue")
If Not EndOfQuery2 Then
LName = "option-" & AProductOptionID & "-split-" & ASplitIndex
LResult = "<select name=""" + LName & """>"
LResult = LResult & NL & "<option value="""">" & COMBO_PLEASE_SELECT & "</option>" & NL
LUsedList = "" ' used to prevent duplicates
Do While Not EndOfQuery2
LInStock = IsNull(GetQueryValue2("NumInStock")) Or NZL(GetQueryValue2("NumInStock")) > 0
' only show option value if in stock
If LInStock Then
LOptionValue = NthSeparatedValue(GetQueryValue2("OptionValue"), PO_SPLIT_COMBO_SEPARATOR, ASplitIndex)
If LOptionValue <> "" Then
If InStr(1, PO_SPLIT_COMBO_SEPARATOR + LUsedList + PO_SPLIT_COMBO_SEPARATOR, PO_SPLIT_COMBO_SEPARATOR + LOptionValue + PO_SPLIT_COMBO_SEPARATOR, 1) = 0 Then
' Server.HTMLEncode allows quotes etc
LResult = LResult & "<option value=""" & Server.HTMLEncode(LOptionValue) & """>" & LOptionValue & "</option>" & NL
LUsedList = LUsedList + IIf(LOptionValue = "", "", PO_SPLIT_COMBO_SEPARATOR) + LOptionValue
End If
End If
End If
NextQueryRecord2
Loop
LResult = LResult & "</select>"
End If
CloseQuery2
GetProductOptionSplitComboBox = LResult
End Function
' (SS,30/6/11) returns given price in currency prefixed with + or -, or neither if 0
' used by product options to display additional cost of options
' (SS,5/2/13) replaced "-" with "‑" to prevent wordwrap after "-"
Function SignedCurrencyPrice(APrice)
Dim LPrice, LResult
If IsNull(APrice) Or APrice = "" Then
LResult = APrice
Else
LPrice = CDbl(APrice) ' CDbl used in case it's a string
If LPrice > 0 Then
LResult = "+"
ElseIf LPrice < 0 Then
LResult = "‑" ' (SS,5/2/13) replaced "-" with "‑" because "-" can wordwrap "‑" is a non-breaking hyphen
Else
LResult = ""
End If
LResult = LResult & CorrectCurrencyNV(Abs(LPrice)) ' (SS,2/11/12) Replaced CorrectCurrency with CorrectCurrencyNV so that VAT is removed for non-vatable countries
End If
SignedCurrencyPrice = LResult
End Function
' place chosen options into array with ProductOptionID and Value pair
' returns number of options, 0 if no options
' (SS,8/8/17) fixed bug where comma entered into a text input type was result in extra option values to be incorrectly added (call to new GetInputTypeForProductOptionID)
Sub ProductOptionsToArray(ByRef LOptions, ByRef LValues)
Dim LOptionCount, LName, LOptionValue, LOptionValues, i, LOptionID, LIgnore, LSplitIndex, LMaxSplits
' set up the arrays with no elements
ReDim LOptions(-1), LValues(-1)
If Not ProductOptionsEnabled Then Exit Sub ' (SS,15/4/16) quick exist if options not enabled, because all sites now call this routine
LOptionCount = 0
For Each LName in Request.Form
If Left(LName, 7) = "option-" Then
LOptionValue = CleanRequestForm(LName)
If LOptionValue <> "" Then
LIgnore = False
LOptionID = ParseInt(Mid(LName, 8, Len(LName)))
' (SS,15/7/11) added split combo handling
If InStr(LName, "-split-") > 0 Then
LSplitIndex = ParseInt(Mid(LName, InStr(LName, "-split-") + 7, Len(LName)))
If LSplitIndex = 1 Then
' use the option name to determine how many splits there are
LMaxSplits = StrCount(GetSQLValueAsString("SELECT OptionName FROM product_options WHERE ProductOptionID = " & LOptionID), PO_SPLIT_COMBO_SEPARATOR) + 1
LIgnore = True
' handle up to LMaxSplits splits, get list of values from the split combos
LOptionValues = ""
For i = 1 To 5
LOptionValue = CleanRequestForm("option-" & LOptionID & "-split-" & i)
If LOptionValue <> "" Then
LOptionValues = LOptionValues + IIf(LOptionValues = "", "", PO_SPLIT_COMBO_SEPARATOR) + LOptionValue
End If
Next
' using the LOptionValues, lookup the OptionValueID
LOptionValue = GetProductOptionValueIDForOptionValue(LOptionID, LOptionValues)
LIgnore = LOptionValue = "" ' ignore if match not found
Else ' to ignore splits 2 or more because they're handled above
LIgnore = True
End If
End If
If Not LIgnore Then
' (SS,8/8/17) to fix bug when commas entered into a free form text option value was causing extra options to be added due to splitting into array below separated by comma
' now checking for input type text prevents this (! not even sure about why things are being split below, kept code because I didn't want to break anything)
If GetInputTypeForProductOptionID(LOptionID) = POIT_TEXT Then
LOptionValues = Split(LOptionValue, "#@�?%~") ' using an odd separate to prevent separation so code below works without changes
Else ' (SS,8/8/17) as before
LOptionValues = Split(LOptionValue, ",") ' for checkboxes it could contain more than one
End If
For i = 0 To UBound(LOptionValues)
' add another element to the arrays
ReDim Preserve LOptions(UBound(LOptions) + 1), LValues(UBound(LValues) + 1)
LOptions(LOptionCount) = NB(LOptionID)
LValues(LOptionCount) = NB(Trim(LOptionValues(i)))
LOptionCount = LOptionCount + 1
Next
End If
End If
End If
Next
End Sub
' (SS,5/7/11) returns list of required options that are missing
' comma separated list of option IDs, blank if nothing missing
Function ProductOptionsMissingRequiredList(AProductID)
Dim LResult, LProductOptionID, LOptionName, LSplits, LSplit, LSplitCount, LInputNameSuffix, LOptionValue, LOptionValues, LAlert, LProductOptionValueID
LResult = ""
LAlert = ""
' (SS,15/7/11) added OptionName, InputType for new split combo function
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT ProductOptionID, OptionName, InputType, Required FROM product_options WHERE ProductID = '" & CleanSQLStr(AProductID) & "' ORDER BY ProductOptionID")
Do While Not EndOfQuery
LProductOptionID = GetQueryValue("ProductOptionID")
LOptionName = GetQueryValue("OptionName")
If IntToBool(GetQueryValue("Required")) Then
' (SS,15/7/11) modified to handle split combo
If IsSplitCombo(LOptionName, GetQueryValue("InputType")) Then
LSplits = Split(LOptionName, PO_SPLIT_COMBO_SEPARATOR)
LSplitCount = 0
LOptionValues = ""
For Each LSplit In LSplits
LSplitCount = LSplitCount + 1
LInputNameSuffix = LProductOptionID & "-split-" & LSplitCount
LOptionValue = CleanRequestForm("option-" & LInputNameSuffix)
If Trim(LOptionValue) = "" Then
LResult = LResult + IIf(LResult = "", "", ",") & LInputNameSuffix
Else
LOptionValues = LOptionValues + IIf(LOptionValues = "", "", PO_SPLIT_COMBO_SEPARATOR) + LOptionValue
End If
Next
' if result okay so far then do check to see if such a valid combination exists
If LResult = "" Then
LProductOptionValueID = GetProductOptionValueIDForOptionValue(LProductOptionID, LOptionValues)
If LProductOptionValueID = "" Then
LAlert = LAlert + IIf(LAlert = "", "", "##") + LOptionValues + " is not available" '\n wasn't working, ## used and replaced by javascript
Else
' do a stock check
If Not IsProductOptionValueIDInStock(LProductOptionValueID) Then LAlert = LAlert + IIf(LAlert = "", "", "##") + LOptionValues + " is out of stock"
End If
End If
Else
If Trim(CleanRequestForm("option-" & LProductOptionID)) = "" Then
LResult = LResult + IIf(LResult = "", "", ",") & LProductOptionID
End If
End If
End If
NextQueryRecord
Loop
CloseQuery
If LResult = "" And LAlert <> "" Then LResult = "ALERT:" + LAlert ' if result okay, but an alert then return the alert
ProductOptionsMissingRequiredList = LResult
End Function
' (SS,15/7/11) returns ProductOptionValueID for given product option and value, blank is returned if not found
Function GetProductOptionValueIDForOptionValue(AProductOptionID, AOptionValue)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
GetProductOptionValueIDForOptionValue = GetSQLValueAsString("SELECT ProductOptionValueID FROM product_option_values WHERE ProductOptionID = '" & CleanSQLStr(AProductOptionID) & "' AND OptionValue = '" & CleanSQLStr(AOptionValue) & "'")
End Function
' (SS,8/8/17)
Function GetInputTypeForProductOptionID(AProductOptionID)
GetInputTypeForProductOptionID = GetSQLValueAsString("SELECT InputType FROM product_options WHERE ProductOptionID = '" & CleanSQLStr(AProductOptionID) & "'")
End Function
' (SS,15/7/11) returns true if given product option value id is in stock, also returns true if out of stock ordering is allowed
Function IsProductOptionValueIDInStock(AProductOptionValueID)
' = LNumInStockOption
' to be continued
Dim LSQL, LResult, LNumInStockOption, LNumInStockProduct, LAllowOutOfStockOrdering, LProductInStock, LOptionInStock
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "SELECT product_option_values.NumInStock, products.NumInStock, products.AllowOutOfStockOrdering FROM product_option_values INNER JOIN products ON products.ProductID = product_option_values.ProductID WHERE ProductOptionValueID = '" & CleanSQLStr(AProductOptionValueID) & "'"
LResult = GetSQL3Values(LSQL, LNumInStockOption, LNumInStockProduct, LAllowOutOfStockOrdering)
If LResult Then
If Not IntToBool(LAllowOutOfStockOrdering) Then
If (Not IsNull(LNumInStockProduct) And NZ(LNumInStockProduct) = 0) Or (Not IsNull(LNumInStockOption) And NZ(LNumInStockOption) = 0) Then
LResult = False
End If
End if
End If
IsProductOptionValueIDInStock = LResult
End Function
' returns the matching ItemID in basket, which is the same product and has the same options
' ItemID is returned if match found, 0 is returned if no match found
Function GetItemIDForMatchingProduct(AProductID, AOptions, AValues)
Dim LNewOptionCount, i
LNewOptionCount = UBound(AOptions) + 1 ' size of array is number of options
Dim LMatches, LExistingOptionCount, LMatchingItemID, LMatchingOptionCount
Dim LItemID, LProductOptionID, LOptionValue
LMatchingItemID = 0 ' default to no match found
' repeat for each item with same product id in basket
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT ItemID FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND ProductID = '" & CleanSQLStr(AProductID) & "' ORDER BY ItemID")
Do While Not EndOfQuery
LItemID = GetQueryValue("ItemID")
LExistingOptionCount = 0
LMatchingOptionCount = 0
' repeat for each option for this item, and count how many options match
OpenQuery2("SELECT * FROM shopping_basket_options WHERE ItemID = " & LItemID & " ORDER BY ShoppingBasketOptionID")
Do While Not EndOfQuery2
LExistingOptionCount = LExistingOptionCount + 1
LProductOptionID = NB(GetQueryValue2("ProductOptionID"))
' if OptionValueID is zero then it means the value is in OptionValue, i.e. a Text box, else ID is the value
If GetQueryValue2("ProductOptionValueID") = 0 Then
LOptionValue = NB(GetQueryValue2("OptionValue"))
Else
LOptionValue = NB(GetQueryValue2("ProductOptionValueID"))
End If
For i = 0 To LNewOptionCount - 1
' (SS,20/7/11) add CStr because value may be either string or number
If CStr(AOptions(i)) = CStr(LProductOptionID) And CStr(AValues(i)) = CStr(LOptionValue) Then
LMatchingOptionCount = LMatchingOptionCount + 1
End If
Next
NextQueryRecord2
Loop
CloseQuery2
'(SS,4/7/11) to be deleted
'Response.Write "LItemID: " & LItemID & "<br />"
'Response.Write "LNewOptionCount: " & LNewOptionCount & "<br />"
'Response.Write "LExistingOptionCount: " & LExistingOptionCount & "<br />"
'Response.Write "LMatchingOptionCount: " & LMatchingOptionCount & "<br />"
' if all options match then we have found a match, set the matching id and exist
If LNewOptionCount = LExistingOptionCount And LNewOptionCount = LMatchingOptionCount Then
LMatchingItemID = LItemID
Exit Do
End If
NextQueryRecord
Loop
CloseQuery
GetItemIDForMatchingProduct = LMatchingItemID
End Function
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
Sub InsertOptionsIntoBasket(AProductID, AItemID, AOptions, AValues)
Dim i, LProductOptionID, LProductOptionValueID, LOptionName, LOptionValue, LInputType, LDoInsert
' repeat for each option, inserting the basket option record
For i = LBound(AOptions) to UBound(AOptions)
LProductOptionID = AOptions(i)
LProductOptionValueID = AValues(i) ' only if Input Type isn't text
LOptionValue = AValues(i) ' if Input Type is text
' Response.Write AOptions(i) & " = " & AValues(i) & "<br />" & NL
' insert the option, ProductOptionValueID, ProductOptionName and ProductOptionValue, need to be looked up later, although ProductOptionValue will set correctly fine text input type
' ProductID in WHERE is strictly not necessary but added as an extra safety measure
' (SS,20/7/11) added If Not IsNumeric.. to allow special options to be added e.g. products added in a special way e.g. covdem radiator builder, both ids 0
If Not IsNumeric(LProductOptionID) Then
LOptionName = LProductOptionID
LProductOptionID = 0
LProductOptionValueID = 0
LDoInsert = True
ElseIf GetSQL2Values("SELECT OptionName, InputType FROM product_options WHERE ProductID = '" & CleanSQLStr(AProductID) & "' AND ProductOptionID = " & LProductOptionID, LOptionName, LInputType) Then
If LInputType = POIT_TEXT Then
LProductOptionValueID = 0 ' because a text input type has no value record
LDoInsert = True
Else
LOptionValue = GetSQLValueAsString("SELECT OptionValue FROM product_option_values WHERE ProductOptionID = '" & CleanSQLStr(LProductOptionID) & "' AND ProductOptionValueID = '" & CleanSQLStr(LProductOptionValueID) & "'")
LDoInsert = LOptionValue <> ""
End If
Else
LDoInsert = False
End If
If LDoInsert Then
ExecuteQuery "INSERT INTO shopping_basket_options (ItemID, ProductOptionID, ProductOptionValueID, OptionName, OptionValue) VALUES ('" & CleanSQLStr(AItemID) & "', '" & CleanSQLStr(LProductOptionID) & "', '" & CleanSQLStr(LProductOptionValueID) & "', '" & CleanSQLStr(LOptionName) & "', '" & CleanSQLStr(LOptionValue) & "');"
End If
Next
End Sub
' returns string with options list as a string
' AOptions for future expansion
' OpenQuery2 used in case another query loop is used by calling routine
' (SS,9/10/14) added AobjOptionsDict
Function GetOptionsListForBasketItem(AItemID, AOptions, AobjOptionsDict)
Dim LResult, LSpace
LResult = ""
AobjOptionsDict.RemoveAll ' (SS,9/10/14) make sure previous values in dictionary are cleared
' repeat for each option for this item
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery2("SELECT * FROM shopping_basket_options WHERE ItemID = '" & CleanSQLStr(AItemID) & "' ORDER BY ShoppingBasketOptionID")
Do While Not EndOfQuery2
AobjOptionsDict.Add GetQueryValue2("OptionName"), GetQueryValue2("OptionValue") ' (SS,9/10/14)
LResult = LResult & Iif(LResult = "", "", ", ") & GetQueryValue2("OptionName") & ": " & GetQueryValue2("OptionValue")
NextQueryRecord2
Loop
CloseQuery2
GetOptionsListForBasketItem = LResult
End Function
' returns False to allow calling AddToBasket procedure to continue, True to exit
' (SS,20/7/11) modified to allow calling from within server to add to basket, e.g CovDem radiator builder
' added AAllowRedirect to prevent the redirect, added AOptions, AValues so that options are passed directly
' rather than being taken from form elements
' (SS,13/4/16) modified to handle stock for out of stock items, i.e. it doesn't allow adding to stock if there is no stock
' previously there was no stock restriction, it allow anything to be added, even if out of stock
' renamed from ProcessAddToBasketForOptions to AddProductToBasketIncludingOptions
' change to function which returns True if adding to basket was successful
' added new parameter AItemID, AAllowAlert
' (SS,18/10/18) now calls CustomAddSubproductsToBasket if set up and subproducts feature enabled
' (SS,25/10/18) Renamed LQty to LQtyToAdd, added LQtyInBasket
Function AddProductToBasketIncludingOptions(AProductCode, AQty, AItemID, AAllowRedirect, AAllowAlert, AOptions, AValues)
ClearBasketOutOfStockMessage
' basket operation issued, make sure items previously reserved are cleared to ensure accuracy of following
' (SS,15/4/16) False to make sure detail records aren't deleted
ClearExistingOrderPlaced False
AddProductToBasketIncludingOptions = True ' (SS,14/4/16) default to returning True
Dim LProductID, LQtyToAdd, LInStock
LQtyToAdd = NZL(Trim(AQty))
' exit if qty is zero or blank
If LQtyToAdd = 0 Then Exit Function
LProductID = GetProductIDForProductCode(AProductCode)
' if not main buy button on detail page, and product has required options then redirect to the detail page, to allow user to select the options
If AAllowRedirect Then
If Not IsMainBuy And ProductHasOptions(LProductID, True) Then
DoRedirect GetProductLink(AProductCode), False
' following doesn't actually get run because DoRedirect will exit the page
Exit Function
End If
End If
' make sure the product is valid and not disabled
Dim LValidProduct
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LValidProduct = GetSQLValueAsString("SELECT ProductID FROM products WHERE ProductDisabled = FALSE AND ProductID = '" & CleanSQLStr(LProductID) & "'") <> ""
If Not LValidProduct Then Exit Function
' place options into arrays for easier handling
' (SS,14/4/16) added If AItemID = 0 to only do this if ItemID not specified (i.e. not called from RecalculateBasket)
If AItemID = 0 Then
Dim LOptions, LValues, LItemID
' (SS,20/7/11) if array was provided then use it for options, else get array of options from form
If VarType(AOptions) >= vbArray Then
LOptions = AOptions
LValues = AValues
Else
ProductOptionsToArray LOptions, LValues
End If
End If
' (SS,25/10/18)
Dim LQtyInBasket
' # Add product and options into stock
' if same product already exists in the basket, with same options then we need to increase the qty for the item rather than add a new item
' following returns ItemID of matching item in basket, 0 if not found
If AItemID = 0 Then
LItemID = GetItemIDForMatchingProduct(LProductID, LOptions, LValues)
Else ' (SS,14/4/16) use the provided ItemID because it was called from recalculate basket
LItemID = AItemID
End If
' if not found then insert new basket record and new options, else update the quantity
If LItemID = 0 Then
LQtyInBasket = 0 ' (SS,25/10/18)
If LQtyToAdd > 0 Then ' (SS,13/4/16) added If to only insert if qty is positive
' insert the basket record
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
ExecuteQuery "INSERT INTO shoppingbaskets (SessionID, ProductID, ProductCode, Qty) VALUES ('" & CleanSQLStr(FSessionID) & "', '" & CleanSQLStr(LProductID) & "', '" & CleanSQLStr(AProductCode) & "', " & LQtyToAdd & ");"
LItemID = GetSQLLastInsertID
' insert the options
InsertOptionsIntoBasket LProductID, LItemID, LOptions, LValues
End If
Else
' (SS,25/10/18) LQtyInBasket is passed on to CustomAddSubproductsToBasket later
LQtyInBasket = CLng(GetSQLValue("SELECT Qty FROM shoppingbaskets WHERE ItemID = '" & CleanSQLStr(LItemID) & "'"))
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
ExecuteQuery "UPDATE shoppingbaskets SET Qty = Qty + " & LQtyToAdd & " WHERE ItemID = '" & CleanSQLStr(LItemID) & "'"
End If
' Response.Write("Options List: " & GetOptionsListForBasketItem(LItemID, "") & "<br />")
' (SS,18/10/18) added following to handle new subproducts feature, custom routine is called if subproducts enabled and this product has subproducts
If ProductSubproductsEnabled Then
If IntToBool(GetFieldForProductID(LProductID, "HasSubproducts")) Then
If FunctionExists("CustomAddSubproductsToBasket") Then
CustomAddSubproductsToBasket LProductID, LItemID, LQtyInBasket, LQtyToAdd
End If
End If
End If
' # Check enough in stock if Qty > 0
' (SS,13/4/16) if Qty is > 0 then check item in stock
Dim LQtyAdded, LProductHasOptions
LQtyAdded = LQtyToAdd
If LQtyToAdd > 0 Then
Dim LNumOutOfStock
LInStock = IsStockAvailable ' this returns true if out of stock ordering allowed, or stock availability is enabled and available soon
' NB. can't do "If IsStockAvailable Or CheckProductInBasketInStock" due to VB always calling second condition even when first is True
If Not LInStock Then
LInStock = CheckProductInBasketInStock(LProductID, LProductHasOptions, LNumOutOfStock) ' if not fully in stock then LNumOutOfStock is set to number out of stock
' if not enough in stock then adjust LQty, add back in stock what we don't have in stock
If Not LInStock Then
If LProductHasOptions Then
LQtyAdded = 0
LNumOutOfStock = LQtyToAdd
Else
LQtyAdded = LQtyToAdd - LNumOutOfStock
End If
' main item, remove by using negative LQty
' remove item/qty added above because not enough were in stock
' remove number that aren't in stock using -LNumOutOfStock
ExecuteQuery "UPDATE shoppingbaskets SET Qty = Qty + " & -LNumOutOfStock & " WHERE ItemID = '" & CleanSQLStr(LItemID) & "'"
' options will automatically be deleted by clean up basket below which removes orphaned records
End If
End If
Else
LInStock = True
End If
' (SS,13/10/23) and (SS,17/10/23)
' NB. followings needs to be run before cleaning the basket due to record being required by GTMSendBasketOperation
oGTM.EventAddToCart
' oGTM.AddItem AProductCode, "AProductName", "", GetProductPrice, LQtyAdded, "ABrandName", "ACategory", "ASubcategory"
' (SS,17/10/23)
GTMSendBasketOperation LItemID, False, LQtyAdded, False
' # Clean up basket
' (SS,14/4/16) clean up basket, removing those with zero or negative qty for this session
ExecuteQuery "DELETE FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND Qty <= 0"
' remove orphaned options records due to deletion above (it removes across all sessions which shouldn't be a problem)
ExecuteQuery "DELETE FROM shopping_basket_options WHERE ItemID NOT IN (SELECT ItemID FROM shoppingbaskets)"
' # Show alert if applicable
' (SS,19/2/14) if item was added then redirect to basket page at the end of script
' (SS,20,2/14) replaced SetPageRedirection with SetAddToBasketAlert
' (SS,13/4/16) added If LQty and If LInStock, also added SetAlertMessage to show out of stock
' (SS,14/4/16) added AAllowAlert
If AAllowAlert Then
If LQtyAdded > 0 Then
SetAddToBasketAlert LQtyAdded, AProductCode
End If
If GetBasketOutOfStockMessage <> "" Then
If Not AlertMessageContains("Sorry, following out of stock:") Then SetAlertMessage "Sorry, following out of stock:" & BR ' only add this if it doesn't already contain, remember this RecalculateBasket will call for each product line
SetAlertMessage GetBasketOutOfStockMessage
End If
End If
AddProductToBasketIncludingOptions = LInStock ' (SS,14/4/16)
End Function
' (SS,18/4/16) returns True if current basket is fully in stock, other False and alert is display
Function CheckBasketInStock(AShowOutOfStockAlert)
Dim LSQL, LInStock
Dim LProductHasOptions, LNumOutOfStock ' dummy variables to call CheckProductInBasketInStock, not used in this routine
ClearBasketOutOfStockMessage
' create unique product ID list in order they are in the basket, and call CheckProductInBasketInStock to check each
LSQL = "SELECT ProductID, MIN(ItemID) AS MinItemID FROM shoppingbaskets" & NL _
+ "WHERE SessionID = '" & CleanSQLStr(FSessionID) & "'" & NL _
+ "GROUP BY ProductID" & NL _
+ "ORDER BY MinItemID"
OpenQuery(LSQL)
LInStock = True
Do While Not EndOfQuery
LInStock = LInStock And CheckProductInBasketInStock(GetQueryValue("ProductID"), LProductHasOptions, LNumOutOfStock)
NextQueryRecord
Loop
CloseQuery
If AShowOutOfStockAlert And GetBasketOutOfStockMessage <> "" Then
AddAlertMessageSection ' (19/4/16) add line separator because there might be a previous stock message
SetAlertMessage "Sorry, following out of stock, please adjust basket:" & BR
SetAlertMessage GetBasketOutOfStockMessage
End If
CheckBasketInStock = LInStock
End Function
' (SS,13/4/16) AProductHasOptions set to true if product has options, ANumOutOfStock number of product that were out of stock
Function CheckProductInBasketInStock(AProductID, ByRef AProductHasOptions, ByRef ANumOutOfStock)
Dim LSQL, LMainInStock, LOptionsInStock, LNumInStock, LQtyRequired, LProductName
AProductHasOptions = ProductHasOptions(AProductID, False)
' check main product in stock
' (SS,18/4/16) added GREATEST(, 0) to prevent negative value giving more than this customer added to basket
' (SS,18/4/16) can't use s alias for shoppingbaskets and p for products because it's used on ProcessOrder with read lock
' (SS,19/4/16) added NOT AllowOutOfStockOrdering AND, top level ignores NumInStock if this flag is set
LSQL = "SELECT s1.QtyRequired, GREATEST(products.NumInStock, 0), products.ProductName FROM" _
+ " (SELECT shoppingbaskets.ProductID, SUM(shoppingbaskets.Qty) AS QtyRequired" & NL _
+ " FROM shoppingbaskets" & NL _
+ " WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND ProductID = " & AProductID & NL _
+ " ) s1" & NL _
+ "INNER JOIN products ON products.ProductID = s1.ProductID" & NL _
+ "WHERE NOT AllowOutOfStockOrdering AND NumInStock IS NOT NULL AND QtyRequired > NumInStock"
LMainInStock = Not GetSQL3Values(LSQL, LQtyRequired, LNumInStock, LProductName)
If Not LMainInStock Then
ANumOutOfStock = CLng(LQtyRequired) - CLng(LNumInStock)
AddBasketOutOfStockMessage ANumOutOfStock & " x " & LProductName
Else
ANumOutOfStock = 0
End If
LOptionsInStock = True
' to add qty in stock for option free product
' to show options out of stock for options product
' (SS,19/4/16) removed "LInStock And" because even if main product is out of stock we still want to know the options that are out of stock because more than one of the same may be in basket
' and customers may need to know which one to remove
If AProductHasOptions Then
' check options in stock
' (SS,18/4/16) added GREATEST(, 0)
' (SS,18/4/16) can't use s alias for shoppingbaskets, so for shopping_basket_options, po for product_options, and pv for product_option_values because it's used on ProcessOrder with read lock
' (SS,19/4/16) added products.ProductName, product_options.OptionName
LSQL = "SELECT s1.*, products.ProductName, product_options.OptionName, GREATEST(product_option_values.NumInStock, 0) AS NumInStock, product_option_values.OptionValue FROM" _
+ " (SELECT shoppingbaskets.ProductID, shopping_basket_options.ProductOptionID, shopping_basket_options.ProductOptionValueID, SUM(shoppingbaskets.Qty) AS QtyRequired" & NL _
+ " FROM shoppingbaskets" & NL _
+ " INNER JOIN shopping_basket_options ON shopping_basket_options.ItemID = shoppingbaskets.ItemID" & NL _
+ " WHERE SessionID = '" & CleanSQLStr(FSessionID) & "' AND ProductID = " & AProductID & NL _
+ " GROUP BY ProductOptionValueID) s1" & NL _
+ "INNER JOIN products ON products.ProductID = s1.ProductID" & NL _
+ "INNER JOIN product_options ON product_options.ProductOptionID = s1.ProductOptionID" & NL _
+ "INNER JOIN product_option_values ON product_option_values.ProductOptionValueID = s1.ProductOptionValueID" & NL _
+ "WHERE product_option_values.NumInStock IS NOT NULL AND QtyRequired > product_option_values.NumInStock" & NL _
+ "ORDER BY product_options.SortOrder, product_option_values.SortOrder"
OpenQuery2(LSQL)
LOptionsInStock = EndOfQuery2
' (SS,19/4/16) added product name before option(s)
If LMainInStock And Not LOptionsInStock Then AddBasketOutOfStockMessage GetQueryValue2("ProductName") & ":"
Do While Not EndOfQuery2
' Response.Write "##QtyRequired:" & GetQueryValue2("QtyRequired") & "##, NumInStock:" & GetQueryValue2("NumInStock") & "##, OptionValue:" & GetQueryValue2("OptionValue") & "##" & LInStock & BR
AddBasketOutOfStockMessage " " & (CLng(GetQueryValue2("QtyRequired")) - CLng(GetQueryValue2("NumInStock"))) & " x " & GetQueryValue2("OptionName") & ": " & GetQueryValue2("OptionValue")
NextQueryRecord2
Loop
CloseQuery2
End If
CheckProductInBasketInStock = LMainInStock And LOptionsInStock
End Function
' (SS,15/4/16)
Sub ClearBasketOutOfStockMessage
FBasketOutOfStockMessage = ""
End Sub
' (SS,15/4/16)
Sub AddBasketOutOfStockMessage(AMessage)
FBasketOutOfStockMessage = FBasketOutOfStockMessage & IIf(FBasketOutOfStockMessage = "", "", BR) & AMessage
End Sub
' (SS,15/4/16)
Function GetBasketOutOfStockMessage
GetBasketOutOfStockMessage = FBasketOutOfStockMessage
End Function
' (SS,7/7/11) this is not strictly part of product options, but placed next to TakeProductOptionsFromStock below
' created when product options feature added
' called from TryProcessOrder, just after the stock has been updated from orderdetails, with ATake set to True
' or just after deleting previous order details with ATake set to False
Sub TakeProductsFromStock(AOrderNo, ATake)
Dim LSQL
' add the items back in stock from orderdetails
'LSQL = "UPDATE products, orderdetails SET NumInStock = NumInStock + orderdetails.Qty" &_
' " WHERE orderdetails.OrderNo = " & LOrderNo & " AND products.ProductCode = orderdetails.ProductCode"
' (SS,7/7/11) replaced above with following, because we can now have same product more than once in a order with different options
' previous query would only update for one of these records, following works correctly by summing the Qty per product, also uses ProductID to link instead of ProductCode
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "UPDATE products, " &_
"(SELECT ProductID, SUM(Qty) AS Qty FROM orderdetails" &_
" WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'" &_
" GROUP BY ProductID" &_
") AS t2" &_
" SET NumInStock = NumInStock " & IIf(ATake, "-", "+") & " Qty" &_
" WHERE products.ProductID = t2.ProductID AND NumInStock IS NOT NULL"
ExecuteQuery(LSQL)
' take/put the options back in/out of stock
' (SS,15/4/16) used it be a separate call in TryProcessOrder and ClearExistingOrderPlaced, simplifies and reduces repeated code by moving here
If ProductOptionsEnabled Then
TakeProductOptionsFromStock AOrderNo, ATake
End If
End Sub
' (SS,6/7/11) adds or subtracts options from stock
' called from TryProcessOrder, just after the stock has been updated from orderdetails, with ATake set to True
' only called when product options are enabled
' just after deleting previous order details with ATake set to False
Sub TakeProductOptionsFromStock(AOrderNo, ATake)
' create a list from order details options for all the product options that need updating, with a qty from order detail record, total up because same one could appear more than once
Dim LSQL
' a multi-table update, using Qty per ProductOptionValueID
' product_option_values link was removed from t2 because it created locking error (product_option_values not locked), wasn't necessary because it was only being used to filter out records with NumInStock IS NOT NULL
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "UPDATE product_option_values, " &_
"(SELECT order_detail_options.ProductOptionValueID, SUM(orderdetails.Qty) AS Qty" &_
" FROM order_detail_options, orderdetails" &_
" WHERE orderdetails.OrderDetailID = order_detail_options.OrderDetailID" &_
" AND order_detail_options.OrderNo = '" & CleanSQLStr(AOrderNo) & "' AND order_detail_options.ProductOptionValueID <> 0" &_
" GROUP BY ProductOptionValueID" &_
") AS t2" &_
" SET NumInStock = NumInStock " & IIf(ATake, "-", "+") & " Qty" &_
" WHERE product_option_values.ProductOptionValueID = t2.ProductOptionValueID AND NumInStock IS NOT NULL"
ExecuteQuery(LSQL)
End Sub
' (SS,7/7/11) returns value of attribute for given product id and attribute name, "" is return if not found
' used by options header and footer in inc-template-other.asp
' (SS,26/4/12) added '' around AProductID in case it's null, which it can be when ProductCode is invalid, this prevent query from failing
' (SS,9/10/14) remove alias 'pa' and 'a' because routine may be called in TryProcessOrder which locks the tables and it can't lock 'p' because it's an alias
Function GetProductAttributeByName(AProductID, AAttributeName)
Dim LResult
If ProductAttributesEnabled Then
Dim LSQL
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "SELECT AttributeValue FROM product_attributes" &_
" INNER JOIN attributes ON attributes.AttributeID = product_attributes.AttributeID" &_
" WHERE product_attributes.ProductID = '" & CleanSQLStr(AProductID) & "' AND attributes.AttributeName = '" & CleanSQLStr(AAttributeName) & "'"
LResult = GetSQLValueAsString(LSQL)
Else
LResult = ""
End If
GetProductAttributeByName = LResult
End Function
' (SS,10/5/12) returns true if given attribute exists for given product
Function ProductAttributeExists(AProductID, AAttributeName)
Dim LResult
If ProductAttributesEnabled Then
Dim LSQL
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
LSQL = "SELECT AttributeValue FROM product_attributes pa" &_
" INNER JOIN attributes a ON a.AttributeID = pa.AttributeID" &_
" WHERE pa.ProductID = '" & CleanSQLStr(AProductID) & "' AND a.AttributeName = '" & CleanSQLStr(AAttributeName) & "'"
LResult = GetSQLRecordExists(LSQL)
Else
LResult = False
End If
ProductAttributeExists = LResult
End Function
' (SS,19/8/14) returns true if given option exists for given product
Function ProductOptionExists(AProductID, AOptionName)
Dim LResult
If ProductOptionsEnabled Then
Dim LSQL
LSQL = "SELECT OptionName FROM product_options" &_
" WHERE ProductID = '" & CleanSQLStr(AProductID) & "' AND OptionName = '" & CleanSQLStr(AOptionName) & "'"
LResult = GetSQLRecordExists(LSQL)
Else
LResult = False
End If
ProductOptionExists = LResult
End Function
' (SS,4/10/11) returns the number of items in basket that have the given attribute name and value
' e.g. GetAttributeInBasketCount("Product Type", "Door")
' (SS,5/10/11) bug in checkout, missed tables, product_attributes, attributes from the LOCK TABLES in process order, removed the aliases too for LOCK TABLES
Function GetAttributeInBasketCount(AAttributeName, AAttributeValue)
Dim LSQL
' (SS,18/3/15) added "If InGoogleShoppingDataFeedthis" to handle when doing this check for Google Shopping delivery costs, i.e. there is no basket
If InGoogleShoppingDataFeed Then
LSQL = "SELECT COUNT(*) AS AttributeCount FROM products" &_
" INNER JOIN product_attributes ON product_attributes.ProductID = products.ProductID" &_
" INNER JOIN attributes ON attributes.AttributeID = product_attributes.AttributeID" &_
" WHERE products.ProductID = " & GetGoogleShoppingDataFeedProductID & " AND attributes.AttributeName = '" & CleanSQLStr(AAttributeName) & "' AND product_attributes.AttributeValue = '" & CleanSQLStr(AAttributeValue) & "'"
Else
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
' (SS,31/10/18) added GetShoppingBasketFilter(False) to filter out subproducts
LSQL = "SELECT SUM(Qty) AS AttributeCount FROM shoppingbaskets " &_
" INNER JOIN product_attributes ON product_attributes.ProductID = shoppingbaskets.ProductID" &_
" INNER JOIN attributes ON attributes.AttributeID = product_attributes.AttributeID" &_
" WHERE SessionID = '" + CleanSQLStr(FSessionID) + "' AND attributes.AttributeName = '" & CleanSQLStr(AAttributeName) & "' AND product_attributes.AttributeValue = '" & CleanSQLStr(AAttributeValue) & "'" + GetShoppingBasketFilter(False)
End If
GetAttributeInBasketCount = NZL(GetSQLValue(LSQL)) ' NZL ensures a long and converts null to 0
End Function
' (SS,16/6/21) counts how many of given attribute and option name there are in basket (based on GetAttributeInBasketCount above)
' e.g. for CIRC: GetAttributeWithOptionNameInBasketCount("Product Type", "Radiator", "Sections")
Function GetAttributeWithOptionNameInBasketCount(AAttributeName, AAttributeValue, AOptionName)
Dim LResult, LSQL
If InGoogleShoppingDataFeed Then
LResult = 0
Else
LSQL = "SELECT SUM(Qty) AS AttributeCount FROM shoppingbaskets " &_
" INNER JOIN product_attributes ON product_attributes.ProductID = shoppingbaskets.ProductID" &_
" INNER JOIN attributes ON attributes.AttributeID = product_attributes.AttributeID" &_
" INNER JOIN shopping_basket_options ON shopping_basket_options.ItemID = shoppingbaskets.ItemID" &_
" WHERE SessionID = '" + CleanSQLStr(FSessionID) + "' AND attributes.AttributeName = '" & CleanSQLStr(AAttributeName) & "' AND product_attributes.AttributeValue = '" & CleanSQLStr(AAttributeValue) & "' AND shopping_basket_options.OptionName = '" & CleanSQLStr(AOptionName) & "'" + GetShoppingBasketFilter(False)
LResult = NZL(GetSQLValue(LSQL)) ' NZL ensures a long and converts null to 0
End If
GetAttributeWithOptionNameInBasketCount = LResult
End Function
' (SS,18/4/12) returns true if collection only products exist in basket
Function HasCollectionOnlyInBasket
Dim LResult
If ProductAttributesEnabled Then
LResult = GetAttributeInBasketCount("Collection Only", "Yes") > 0
Else
LResult = False
End If
HasCollectionOnlyInBasket = LResult
End Function
' (SS,5/7/12) similar to GetAttributeInBasketCount above but can also link to shopping_basket_options table to lookup the OptionValue
' and compares a decimal value; ACompare can be ">", "<", "=", ">=" or "<="
' if AOptionValue is blank then OptionValue is ignored
' (SS,4/10/12) replaced by GetAttributeInBasketMaxOptionValue below (commented out for now)
'Function GetAttributeInBasketCountNumValCompare(AAttributeName, ACompare, AAttributeValue, AOptionValue)
' Dim LSQL
' LSQL = "SELECT SUM(Qty) AS AttributeCount FROM shoppingbaskets " &_
' " INNER JOIN product_attributes ON product_attributes.ProductID = shoppingbaskets.ProductID" &_
' " INNER JOIN attributes ON attributes.AttributeID = product_attributes.AttributeID"
' If AOptionValue <> "" Then LSQL = LSQL + " INNER JOIN shopping_basket_options ON shopping_basket_options.ItemID = shoppingbaskets.ItemID"
' LSQL = LSQL &_
' " WHERE SessionID = '" + CleanSQLStr(FSessionID) + "' AND attributes.AttributeName = '" & CleanSQLStr(AAttributeName) &_
' "' AND CONVERT(product_attributes.AttributeValue, DECIMAL(12,4)) " & ACompare & "'" & CleanSQLStr(AAttributeValue) & "'"
' If AOptionValue <> "" Then LSQL = LSQL + " AND CONVERT(shopping_basket_options.OptionValue, DECIMAL(12,4)) " & ACompare & "'" & CleanSQLStr(AOptionValue) & "'"
' GetAttributeInBasketCountNumValCompare = NZL(GetSQLValue(LSQL)) ' NZL ensures a long and converts null to 0
'End Function
' (SS,4/10/12) replaces above GetAttributeInBasketCountNumValCompare
' returns max option value (inital integer is parsed), if no option value exists but attribute exists then 0 is returned
' if attribute doesn't exist at all then -1 is return
Function GetAttributeInBasketMaxOptionValue(AAttributeName)
Dim LSQL, LAttributeCount, LMaxValue, LResult
LSQL = "SELECT SUM(Qty) AS AttributeCount, MAX(CONVERT(shopping_basket_options.OptionValue, DECIMAL(12,4))) AS MaxLength FROM shoppingbaskets " &_
" INNER JOIN product_attributes ON product_attributes.ProductID = shoppingbaskets.ProductID" &_
" INNER JOIN attributes ON attributes.AttributeID = product_attributes.AttributeID" &_
" LEFT JOIN shopping_basket_options ON shopping_basket_options.ItemID = shoppingbaskets.ItemID"
LSQL = LSQL &_
" WHERE SessionID = '" + CleanSQLStr(FSessionID) + "' AND attributes.AttributeName = '" & CleanSQLStr(AAttributeName) & "'"
If Not GetSQL2Values(LSQL, LAttributeCount, LMaxValue) Then
LResult = -1 ' this will never actually occur because aggregate query always returns one record
ElseIf NZL(LMaxValue) > 0 Then ' NZL ensures a long and converts null to 0
LResult = NZL(LMaxValue)
ElseIf NZL(LAttributeCount) > 0 Then
LResult = 0
Else
LResult = -1
End If
GetAttributeInBasketMaxOptionValue = LResult
End Function
' (SS,5/10/22) modified version of above GetAttributeInBasketMaxOptionValue
' returns max attribute value in basket for given attribute name (inital integer is parsed), if no value exists but attribute exists then 0 is returned
' if attribute doesn't exist at all then -1 is returned
Function GetAttributeInBasketMaxValue(AAttributeName)
Dim LSQL, LAttributeCount, LMaxValue, LResult
' (SS,5/10/22) MaxAttributeValue name used in following because MaxValue wasn't working
LSQL = "SELECT SUM(Qty) AS AttributeCount, MAX(CONVERT(product_attributes.AttributeValue, DECIMAL(12,4))) AS MaxAttributeValue FROM shoppingbaskets " &_
" INNER JOIN product_attributes ON product_attributes.ProductID = shoppingbaskets.ProductID" &_
" INNER JOIN attributes ON attributes.AttributeID = product_attributes.AttributeID"
LSQL = LSQL &_
" WHERE SessionID = '" + CleanSQLStr(FSessionID) + "' AND attributes.AttributeName = '" & CleanSQLStr(AAttributeName) & "'"
If Not GetSQL2Values(LSQL, LAttributeCount, LMaxValue) Then
LResult = -1 ' this will never actually occur because aggregate query always returns one record
ElseIf NZL(LMaxValue) > 0 Then ' NZL ensures a long and converts null to 0
LResult = NZL(LMaxValue)
ElseIf NZL(LAttributeCount) > 0 Then
LResult = 0
Else
LResult = -1
End If
GetAttributeInBasketMaxValue = LResult
End Function
' (SS,17/7/13)
Function GetAttributeIDForName(AAttributeName)
GetAttributeIDForName = GetSQLValueAsString("SELECT AttributeID FROM attributes WHERE AttributeName = '" & CleanSQLStr(AAttributeName) & "'")
End Function
' (SS,19/10/18) added following to lookup an option value for given option name and basket item.
' Used by subproduct feature for CIRC (custom) to look up paint finish and sections in given basket item
' value is returned as a string
Function GetBasketOptionValueForItemID(AItemID, AOptionName)
GetBasketOptionValueForItemID = GetSQLValueAsString("SELECT OptionValue FROM shopping_basket_options WHERE ItemID = '" & CleanSQLStr(AItemID) & "' AND OptionName = '" & CleanSQLStr(AOptionName) & "'")
End Function
' (SS,30/10/18) added following to look up option value for given option name and order detail line
' Used by custom utils (CIRC) to help create historical subproduct records
Function GetOrderOptionValueForOrderDetailID(AOrderDetailID, AOptionName)
GetOrderOptionValueForOrderDetailID = GetSQLValueAsString("SELECT OptionValue FROM order_detail_options WHERE OrderDetailID = '" & CleanSQLStr(AOrderDetailID) & "' AND OptionName = '" & CleanSQLStr(AOptionName) & "'")
End Function
' (SS,1/3/24) a very long name for a function!
' returns count of number of times Option Value compares with Attribute value
' AComparator can be " >= " or anything passed onto SQL for comparison
' e.g. "Sections" > = "Min Sections Oversize" (for CIRC)
Function GetBasketOptionValueComparedWithAttributeCount(AOptionName, AComparator, AAttributeName)
Dim LResult, LSQL
If InGoogleShoppingDataFeed Then
LResult = 0
Else
' , MAX(CONVERT(shopping_basket_options.OptionValue, DECIMAL(12,4))) AS MaxLength
' SUM(Qty) used instead of COUNT(*) to take Qty into account
LSQL = "SELECT SUM(Qty) FROM shoppingbaskets " &_
" INNER JOIN product_attributes ON product_attributes.ProductID = shoppingbaskets.ProductID" &_
" INNER JOIN attributes ON attributes.AttributeID = product_attributes.AttributeID" &_
" LEFT JOIN shopping_basket_options ON shopping_basket_options.ItemID = shoppingbaskets.ItemID" &_
" WHERE SessionID = '" + CleanSQLStr(FSessionID) + "' AND attributes.AttributeName = '" & CleanSQLStr(AAttributeName) & "'" &_
" AND shopping_basket_options.OptionName = '" & CleanSQLStr(AOptionName) & "'" &_
" AND CONVERT(shopping_basket_options.OptionValue, DECIMAL(12,4)) " & CleanSQLStr(AComparator) & " CONVERT(product_attributes.AttributeValue, DECIMAL(12,4))"
LResult = NZL(GetSQLValue(LSQL)) ' NZL ensures a long and converts null to 0
End If
GetBasketOptionValueComparedWithAttributeCount = LResult
End Function
' ------------------------------ '
' End of Product Option Routines '
' ------------------------------ '
' (SS,19/7/11)
' -------------------------------- '
' Start of Special Basket Routines '
' Used by e.g. CovDem radiator builder
' -------------------------------- '
' looks up price and stock level of given product id, returns true if product in stock
' (SS,26/11/20) modified to check the AQty provided is in stock by calling new InStockQty instead of InStock, also calls SetAllowOutOfStockOrdering to ensure correct value for AllowOutOfStockOrdering
Function GetPriceAndStockForProductID(AProductID, AQty, ByRef AProductPrice)
Dim LResult
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
OpenQuery("SELECT * FROM products WHERE ProductID = '" & CleanSQLStr(AProductID) & "'")
GetPricingFromProductRecord(False)
SetAllowOutOfStockOrdering IntToBool(GetFieldValue("AllowOutOfStockOrdering")) ' (SS,26/11/20) added to ensure GetAllowOutOfStockOrdering gets the value from this product record so that InStockQty sees the AllowOutOfStockOrdering flag from the product record
AProductPrice = GetProductPrice
'LResult = InStock(GetQueryValue("NumInStock"))
' (SS,26/11/20) replaced with following to check the AQty is in stock, above was only checking for qty of 1 in stock
LResult = InStockQty(GetQueryValue("NumInStock"), AQty)
CloseQuery
GetPriceAndStockForProductID = LResult
End Function
' looks up price of given product and option value, returns true if found, AOptionPrice is set to the price
Function GetPriceForProductOptionValue(AProductID, AOptionValue, ByRef AOptionPrice)
Dim LResult
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
AOptionPrice = GetSQLValueAsString("SELECT PriceAdjust FROM product_option_values WHERE ProductID = '" & CleanSQLStr(AProductID) & "' AND OptionValue = '" & CleanSQLStr(AOptionValue) & "'")
If AOptionPrice = "" Then
LResult = False
AOptionPrice = 0
Else
LResult = True
' (SS,24/11/11) added CDbl because GetSQLValueAsString now definitely returns a string, found that it wasn't really necessary because FormatNumber in Round2dp doesn't mind a string
AOptionPrice = Round2dp(CDbl(AOptionPrice))
End If
GetPriceForProductOptionValue = LResult
End Function
' looks up product option id and value id of given product and option value, returns false if not found
Function GetIDsForProductOptionValue(AProductID, AOptionValue, ByRef AProductOptionID, ByRef AProductOptionValueID)
' (SS,12/6/12) added CleanSQLStr to prevent SQL injection
GetIDsForProductOptionValue = GetSQL2Values("SELECT ProductOptionID, ProductOptionValueID FROM product_option_values WHERE ProductID = '" & CleanSQLStr(AProductID) & "' AND OptionValue = '" & CleanSQLStr(AOptionValue) & "'", AProductOptionID, AProductOptionValueID)
End Function
' returns true if it's an ajax call, i.e. ajax.asp requested
Function IsAjaxRequest
IsAjaxRequest = GetScriptName = "ajax.asp"
End Function
' ------------------------------ '
' End of Special Basket Routines '
' ------------------------------ '
' (SS,30/5/12) called from stock-snapshot.asp adds records to the stock_snapshots table the NumInStock value for each product
Sub StockSnapshot
Dim LSQL
LSQL = "INSERT INTO stock_snapshots " +_
"SELECT CURDATE() AS DateOfStock, CURTIME() AS TimeOfStock, ProductID, NumInStock, ProductDisabled FROM products " +_
"WHERE NOT ProductDisabled OR (ProductDisabled AND NumInStock <> 0)"
ExecuteQuery(LSQL)
End Sub
' (SS,28/8/21) called from stock-check-log.asp (via scheduled task) adds records to the stock_check_log table (used by CIRC)
Sub StockCheckLog
Dim LSQL
LSQL = "INSERT INTO stock_check_log " +_
"SELECT NULL AS ID, " +_
"CURDATE() AS DateOfStockCheck, CURTIME() AS TimeOfStockCheck, " +_
"p.ProductID, p.NumInStock, " +_
"COALESCE(qr.QtyReserved, 0) AS QtyReserved, " +_
"p.NumInStock + COALESCE(qr.QtyReserved, 0) AS QtyOnShelf, " +_
"COALESCE(qrd.QtyReadyForDespatch, 0) AS QtyReadyForDespatch, " +_
"COALESCE(qip.QtyInProduction, 0) AS QtyInProduction, " +_
"COALESCE(qpo.QtyOnPurchaseOrder, 0) - COALESCE(qpo.QtyAddedToStock, 0) AS QtyOnOrder, " +_
"p.NumInStock + COALESCE(qr.QtyReserved, 0) - COALESCE(qrd.QtyReadyForDespatch, 0) AS QtyForStockCheck " +_
"FROM products p " +_
"LEFT JOIN " +_
"(" +_
"SELECT ProductID, SUM(pol.QtyOrdered) AS QtyOnPurchaseOrder, SUM(pil.QtyAddedToStock) AS QtyAddedToStock " +_
"FROM purchase_order_lines pol " +_
"INNER JOIN purchase_orders po ON po.PurchaseOrderNo = pol.PurchaseOrderNo " +_
"LEFT JOIN purchase_invoice_lines pil ON pil.PurchaseOrderLineID = pol.PurchaseOrderLineID " +_
"WHERE po.OrderStatus = 'PLACED' OR po.OrderStatus = 'PARTIALLY RECEIVED' " +_
"GROUP BY ProductID " +_
") qpo ON qpo.ProductID = p.ProductID " +_
"LEFT JOIN " +_
"( " +_
"SELECT ProductID, SUM(od.Qty) AS QtyReserved " +_
"FROM orderdetails od " +_
"INNER JOIN orders o ON o.OrderNo = od.OrderNo " +_
"WHERE (o.Status <> 'COMPLETED' AND o.Status <> 'CANCELLED') " +_
"GROUP BY ProductID " +_
") qr ON qr.ProductID = p.ProductID " +_
"LEFT JOIN " +_
"( " +_
"SELECT ProductID, SUM(od.Qty) AS QtyReadyForDespatch " +_
"FROM orderdetails od " +_
"INNER JOIN orders o ON o.OrderNo = od.OrderNo " +_
"WHERE ReadyForDespatch IS NOT NULL AND (o.Status <> 'COMPLETED' AND o.Status <> 'CANCELLED') " +_
"GROUP BY ProductID " +_
") qrd ON qrd.ProductID = p.ProductID " +_
"LEFT JOIN " +_
"( " +_
"SELECT ProductID, SUM(od.Qty) AS QtyInProduction " +_
"FROM orderdetails od " +_
"INNER JOIN orders o ON o.OrderNo = od.OrderNo " +_
"WHERE ReadyForDespatch IS NULL AND PickListID IS NOT NULL AND (o.Status <> 'COMPLETED' AND o.Status <> 'CANCELLED') " +_
"GROUP BY ProductID " +_
") qip ON qip.ProductID = p.ProductID " +_
"WHERE NOT HasSubproducts AND NOT ProductDisabled AND NumInStock IS NOT NULL " +_
"ORDER BY ProductID"
ExecuteQuery(LSQL)
End Sub
' (SS,18/6/12) returns SQL used to encrypt the password, password must be passed to this function
' (SS,19/6/12) added AIsField to allow it to be called from UpgradeSchemaTo159 where it encrypts the password for all customer records
Function GetSQLForPasswordEncryption(APassword, AIsField)
Const PWD_KEY = "It@Q2SHNx{UTwq4D,EtGi;q6tKR,c+{*" ' password encryption key
Dim LResult, LPassword
LPassword = CleanSQLStr(APassword)
If Not AIsField Then LPassword = "'" + LPassword + "'"
LResult = "" &_
"AES_ENCRYPT(" &_
" SHA1(" &_
" CONCAT(" & LPassword & ", '" & PWD_KEY & "', " &_
" SHA1(CONCAT('itp~h', CustomerID * 3 + 1, 'itp~h', CRC32(CustomerID + 157)))))" &_
"," &_
" CONCAT('" & PWD_KEY & "', SHA1(CONCAT('itp~e', CustomerID * 2 - 1, 'itp~e', CRC32(CustomerID + 943)))" &_
" )" &_
")"
GetSQLForPasswordEncryption = LResult
End Function
' (SS,13/9/12) new favourites functionality
Sub ShowFavourites
' get customer ID from session, exit if not available
Dim LCustomerID
LCustomerID = GetCustomerID ' (SS,20/9/12) replaced GetSetCookieCustomerID with GetCustomerID
If LCustomerID = "" Then Exit Sub
Dim LSQL
' following retrieves all products ordered by customer in past 3 years, ordered by ave order qty, first 10
' perhaps holds these in session to run query one
' (SS,31/10/18) added GetOrderDetailsFilter to filter out subproducts
LSQL = "SELECT od.ProductCode, p.ProductName, COUNT(*) AS OrderCount, ROUND(AVG(Qty)) AS AveQty FROM orderdetails od" +_
" INNER JOIN orders o ON o.OrderNo = od.OrderNo" +_
" INNER JOIN products p ON p.ProductCode = od.ProductCode" +_
" WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "' AND Status = 'COMPLETED' AND DateTimeOrdered >= CURDATE() - INTERVAL 3 YEAR AND NOT p.ProductDisabled" + GetOrderDetailsFilter +_
" GROUP BY ProductCode" +_
" ORDER BY OrderCount DESC, AveQty DESC, ProductCode" +_
" LIMIT 10"
OpenQuery(LSQL)
If GetQueryRecordCount > 0 Then
ShowFavouritesHeader
Dim LCount, LProductCode
LCount = 0
Do While Not EndOfQuery
LCount = LCount + 1
LProductCode = GetQueryField("ProductCode")
ShowFavouritesItem LCount, LProductCode, HTMLEncode(GetQueryField("ProductName")), GetQueryField("AveQty")
NextQueryRecord
Loop
ShowFavouritesFooter
End If
CloseQuery
End Sub
' --------------------------------
' Start of Review Request Routines
' --------------------------------
' (SS,29/8/12) currently galleon only, will eventually get from settings
Function GetFeefoLogon
' GetFeefoLogon = "www.galleonsupplies.co.uk"
GetFeefoLogon = FFeefoLogon ' (SS,20/10/14) replaced above hardcoded with this
End Function
' (SS,27/9/12)
Function GetFeefoFTPHost
' GetFeefoFTPHost = "ftp.feefo.com"
GetFeefoFTPHost = FFeefoFTPHost ' (SS,20/10/14) replaced above hardcoded with this
End Function
' (SS,25/9/12)
Function GetFeefoFTPUser
' GetFeefoFTPUser = "www-galleonsupplies-co-uk@feefo.com"
GetFeefoFTPUser = FFeefoFTPUser ' (SS,20/10/14) replaced above hardcoded with this
End Function
' (SS,25/9/12)
Function GetFeefoFTPPassword
' GetFeefoFTPPassword = "Js8ko9~2t#8"
GetFeefoFTPPassword = FFeefoFTPPassword ' (SS,20/10/14) replaced above hardcoded with this
End Function
' (SS,25/9/12) returns True for Galleon, will eventually get from settings
Function ReviewTypeIsFeefo
' If GetStoreName = "Galleon Supplies" Then
If FReviewsType = "Feefo" Then ' (SS,20/10/14) replaced above with this
ReviewTypeIsFeefo = True
Else
ReviewTypeIsFeefo = False
End If
End Function
' (SS,17/8/15)
Function ReviewTypeIsNormal
If FReviewsType = "Normal" Or FReviewsType = "" Then
ReviewTypeIsNormal = True
Else
ReviewTypeIsNormal = False
End If
End Function
' (SS,17/8/15)
Function ReviewTypeIsTrustpilot
If FReviewsType = "Trustpilot" Then
ReviewTypeIsTrustpilot = True
Else
ReviewTypeIsTrustpilot = False
End If
End Function
' (SS,18/5/17)
Function GetTrustpilotAFSEmailAddress
GetTrustpilotAFSEmailAddress = FTrustpilotAFSEmailAddress
End Function
' (SS,12/5/21)
Function TrustpilotReviewsVisible
TrustpilotReviewsVisible = FTrustpilotReviewsVisible
End Function
' (SS,13/5/21)
Function GetTrustpilotSiteName
GetTrustpilotSiteName = FTrustpilotSiteName
End Function
' (SS,1/9/15)
Function GetTrustpilotRating(ByRef ARatingWord)
Dim LRating
If Not GetSQL2Values("SELECT ReviewRating, ReviewTitle FROM trustpilot_reviews WHERE ReviewID = 1", LRating, ARatingWord) Then
LRating = 0
ARatingWord = "Not found"
End If
GetTrustpilotRating = LRating
End Function
' (SS,25/9/12) send review requests, send 7 days after order completed, if date completed is >= 14 Dec and <= 31 Dec then delay until feedback date to 7 Jan check year
' (SS,13/1/20) added new test modes via SEND_EMAIL and UPDATE_ORDER so that it doesn't send the emails and modify the orders when these constants are set to false
' (SS,13/1/20) the CIRC customers getting emails for 4 days in a row was caused by script not completing i.e. timing out, fixed by adding Server.ScriptTimeout = 5 * 60 to review-requests.asp script.
' (SS,14/1/20) further mod (for HF) to remove the >= 14 Dec and <= 31 Dec (Christmas delay), added different delay for non-uk orders (for HF) if set
' (SS,23/8/23) change for HF, to send not just review requests matching today but previous ones too in case the request days were adjusted like thay have been from 60 to 30 for non-UK
Sub SendReviewRequests
Const PRODUCT_LEVEL_DEBUG = False
Const TEST_MODE = False
Const SEND_EMAIL = True
Const UPDATE_ORDER = True
' (SS,15/1/13)
If Not ReviewRequestsEnabled Then Exit Sub
' (SS,1/3/13) if order number specified then only send to this, for testing purposes
Dim LRequestedOrderNo
LRequestedOrderNo = CleanRequest("OrderNo")
' list of orders items in order number / order detail id order
' only listing those that need a review request email sent (or upload to Feefo)
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
' (SS,14/1/20) added left join to countries to lookup postal area to use different delay for non-uk orders (HF)
Dim LSQL, LWhere
LSQL = "SELECT EmailAddress, TRIM(CONCAT(Title, ' ', FirstName, ' ', Surname)) AS FullName," &_
" DATE(DateTimeOrdered) AS DateOrdered," &_
" DATE(DateTimeCompleted) AS DateCompleted," &_
" od.ProductName, o.OrderNo, od.ProductCode," &_
" pc.Category, o.CustomerID, Qty * PriceEach AS Amount" &_
" FROM orders o" &_
" INNER JOIN orderdetails od ON od.OrderNo = o.OrderNo" &_
" INNER JOIN products p ON p.ProductCode = od.ProductCode" &_
" LEFT JOIN productcategories pc ON pc.ProductCode = od.ProductCode AND pc.Main = TRUE" &_
" LEFT JOIN countries c ON c.Country = IF(COALESCE(o.DeliveryCountry, '') = '', o.Country, o.DeliveryCountry)" &_
" WHERE p.ProductDisabled = FALSE" & GetProductsFilter & " AND "
' (SS,1/3/13) added If/Else
If LRequestedOrderNo = "" Then
' build WHERE which is also used by UPDATE query later to mark orders with review request sent date
LWhere = "Status = 'COMPLETED' AND ReviewRequestSentDate IS NULL"
' less than 60 days ago, CURDATE() not used in case it passes over midnight between the two queries
LWhere = LWhere & " AND DATEDIFF(" & ConvertUKToMySQLDate(Date) & ", DATE(DateTimeCompleted)) < 60"
' if DateOrdered >= 14 Dec and DateOrder <= 31 Dec then set to 7 Jan of next year else add 7 days
' CAST used because it wouldn't treat number from ConvertUKToMySQLDate as date otherwise, probably due to IF()
' (SS,15/1/13) replaced 7 in "INTERVAL 7 DAY" with ReviewRequestsDays
'LWhere = LWhere & " AND" &_
' " IF(MONTH(DATE(DateTimeCompleted)) = 12 AND DAYOFMONTH(DATE(DateTimeCompleted)) >= 14 AND DAYOFMONTH(DATE(DateTimeCompleted)) <= 31," &_
' " STR_TO_DATE(CONCAT_WS('-', YEAR(DATE(DateTimeCompleted)) + 1, 1, 7), '%Y-%m-%d'), " &_
' " DATE_ADD(DATE(DateTimeCompleted), INTERVAL " & ReviewRequestsDays & " DAY)) <= CAST(" & ConvertUKToMySQLDate(Date) & " AS DATE)"
' (SS,14/1/20) replaced above with following, i.e. removed the delay between 14/12 and 7/1, added difference delay for non uk orders (for HyperFlight)
' (SS,23/8/23) replaced the " = " in " DAY)) = CAST(" with <= to send all reviews up to 60 days ago max not just the ones for today, previously non-uk review requests were disable by setting ReviewRequestsDaysNonUK to 60, now changed to 30 but we want to send out reviews from 60 days ago
LWhere = LWhere & " AND" &_
" IF(c.PostalArea = 'UK', DATE_ADD(DATE(DateTimeCompleted), INTERVAL " & ReviewRequestsDays & " DAY), DATE_ADD(DATE(DateTimeCompleted), INTERVAL " & ReviewRequestsDaysNonUK & " DAY)) <= CAST(" & ConvertUKToMySQLDate(Date) & " AS DATE)"
' if test mode then only test with orders with my email address
If TEST_MODE Then LWhere = LWhere & " AND EmailAddress = 'surinder@itpartnership.com'"
Else ' (SS,1/3/13) also added o to the update query called later, it'll fail without it
LWhere = LWhere & "o.OrderNo = '" & CleanSQLStr(LRequestedOrderNo) & "'"
End If
LSQL = LSQL & LWhere & " ORDER BY o.OrderNo, OrderDetailID"
' iterate each order line
' upload to feefo or build email body
' if successful then set ReviewRequestSentDate so it isn't sent again
' if next order then
' add to list of requests sent
Dim LReviewTypeIsFeefo
LReviewTypeIsFeefo = ReviewTypeIsFeefo
If LReviewTypeIsFeefo Then SetFeefoFileName
OpenQuery(LSQL)
If Not EndOfQuery Then
If PRODUCT_LEVEL_DEBUG Then
Response.Write "<table>" & NL
Response.Write "<tr>"
Response.Write "<th>Email</th>"
Response.Write "<th>Name</th>"
Response.Write "<th>OrderNo</th>"
Response.Write "<th>OrderDate</th>"
Response.Write "<th>CustomerID</th>"
Response.Write "<th>ProductCode</th>"
Response.Write "<th>ProductName</th>"
Response.Write "<th>Category</th>"
Response.Write "<th>Amount</th>"
Response.Write "<th>ProductLink</th>"
End If
Response.Write "</tr>" & NL
Dim LOrderCount, LPrevOrderNo, LOrderCompleted, LEmailBody, LProductList
LOrderCount = 0
LEmailBody = ""
LProductList = ""
Dim LEmailAddress, LName, LDateOrdered, LDateCompleted, LOrderNo, LProductCode, LProductName, LCategory, LProductLink, LCustomerID, LAmount
Dim LFeefoHeaderAdded, LFeefoRecord
LFeefoHeaderAdded = False
Do While Not EndOfQuery
' added header record with field names if it hasn't already
If LReviewTypeIsFeefo And Not LFeefoHeaderAdded Then
LFeefoRecord = ""
LFeefoRecord = AddFeefoField(LFeefoRecord, "Name")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Email")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Date")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Description")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Logon")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Category")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Feedback Date")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Product search code")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Order Ref")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Product link")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Customer Ref")
LFeefoRecord = AddFeefoField(LFeefoRecord, "Amount")
AddFeefoRecord LFeefoRecord
LFeefoHeaderAdded = True
End If
LEmailAddress = GetQueryField("EmailAddress")
LName = GetQueryField("FullName")
LDateOrdered = GetQueryField("DateOrdered")
LDateCompleted = GetQueryField("DateCompleted")
LOrderNo = GetQueryField("OrderNo")
LProductCode = GetQueryField("ProductCode")
LProductName = GetQueryField("ProductName")
LCategory = GetQueryField("Category")
LCustomerID = NB(GetQueryField("CustomerID")) ' (SS,4/2/14) added NB to prevent Invalid use of Null CStr when customer ID is null
LAmount = Format2dpnc(GetQueryField("Amount"))
LProductLink = GetFullProductLink(LProductCode)
If LReviewTypeIsFeefo Then
LFeefoRecord = ""
LFeefoRecord = AddFeefoField(LFeefoRecord, LName) ' Name
LFeefoRecord = AddFeefoField(LFeefoRecord, LEmailAddress) ' Email
LFeefoRecord = AddFeefoField(LFeefoRecord, LDateOrdered) ' Date (date needs DD/MM/YYYY which it will by default)
LFeefoRecord = AddFeefoField(LFeefoRecord, LProductName) ' Description
LFeefoRecord = AddFeefoField(LFeefoRecord, GetFeefoLogon) ' Logon
LFeefoRecord = AddFeefoField(LFeefoRecord, ReplaceStr(LCategory, "/", "-")) ' Category (forward slash replaced with dash as recommended)
LFeefoRecord = AddFeefoField(LFeefoRecord, "") ' Feedback Date (leave blank)
LFeefoRecord = AddFeefoField(LFeefoRecord, LProductCode) ' Product search code
LFeefoRecord = AddFeefoField(LFeefoRecord, LOrderNo) ' Order Ref
LFeefoRecord = AddFeefoField(LFeefoRecord, LProductLink) ' Product link
LFeefoRecord = AddFeefoField(LFeefoRecord, LCustomerID) ' Customer Ref
LFeefoRecord = AddFeefoField(LFeefoRecord, LAmount) ' Amount
AddFeefoRecord LFeefoRecord
' (SS,2/9/15) added following if review type is Trustpilot, i.e. there is just a list of products, no link to write a review directly on site
ElseIf ReviewTypeIsTrustpilot Then
LProductList = LProductList & "<li>" & LProductName & "</li>" & NL
Else
LProductList = LProductList & Iif(LProductList = "", "", BR) & "<a href=""" & GetWriteReviewFullLink(LProductCode) & """>" & LProductName & "</a>" & NL
End If
If PRODUCT_LEVEL_DEBUG Then
Response.Write "<tr>"
Response.Write "<td>" & LEmailAddress & "</td>"
Response.Write "<td>" & LName & "</td>"
Response.Write "<td>" & LOrderNo & "</td>"
Response.Write "<td>" & LDateOrdered & "</td>"
Response.Write "<td>" & LCustomerID & "</td>"
Response.Write "<td>" & LProductCode & "</td>"
Response.Write "<td>" & LProductName & "</td>"
Response.Write "<td>" & LCategory & "</td>"
Response.Write "<td>" & LAmount & "</td>"
Response.Write "<td>" & LProductLink & "</td>"
Response.Write "</tr>" & NL
End If
NextQueryRecord
' if order has been dealt with, i.e. no more order lines for same order
If EndOfQuery Then
LOrderCompleted = True
ElseIf LOrderNo <> GetQueryField("OrderNo") Then
LOrderCompleted = True
Else ' i.e. LOrderNo = GetQueryField("OrderNo")
LOrderCompleted = False
End If
If LOrderCompleted Then
LOrderCount = LOrderCount + 1
' add table header
If LOrderCount = 1 Then
LEmailBody = LEmailBody + ReviewRequestResultHeader
End If
LEmailBody = LEmailBody + ReviewRequestResultRow(LEmailAddress, LName, LOrderNo, LDateOrdered, LDateCompleted, LCustomerID)
' if not feefo then email the review request
' (SS,13/1/20) added SEND_EMAIL
If Not LReviewTypeIsFeefo And SEND_EMAIL Then
SendReviewRequestEmail LEmailAddress, LName, LProductList, LOrderNo ' (SS,2/11/12) added LOrderNo
End If
LProductList = ""
End If
Loop
If PRODUCT_LEVEL_DEBUG Then
Response.Write "</table>" & NL
End If
' if orders exist
If LOrderCount > 0 Then
LEmailBody = LEmailBody + ReviewRequestResultFooter(LOrderCount)
Dim LSuccess
' if Feefo then FTP the review request to Feefo
If LReviewTypeIsFeefo Then
Dim LFTPLog
LSuccess = FTPFile(GetFeefoFTPHost, GetFeefoFTPUser, GetFeefoFTPPassword, True, "", FFeefoFileName, LFTPLog)
LEmailBody = LEmailBody + BR + "FTP " + Iif(LSuccess, "Successful", "Failed") + BR + ReplaceNewLinesWithBR(LFTPLog)
Else
LSuccess = True
End If
' if successful then mark order with today's date in ReviewRequestSentDate to prevent sending again
' (SS,13/1/20) added UPDATE_ORDER for testing
If LSuccess And UPDATE_ORDER Then
' ExecuteQuery "UPDATE orders o SET ReviewRequestSentDate = CURDATE() WHERE " & LWhere
' (SS,5/8/22) following was failing with Unknown column 'c.PostalArea' in 'where clause' due to no link to countries table, replaced above with following, luckily extra emails weren't being sent
ExecuteQuery "UPDATE orders o, countries c SET o.ReviewRequestSentDate = CURDATE() WHERE c.Country = IF(COALESCE(o.DeliveryCountry, '') = '', o.Country, o.DeliveryCountry) AND " & LWhere
End If
If LReviewTypeIsFeefo Then
EmailReviewRequestsResult LEmailBody, FFeefoFileName
DeleteFile FFeefoFileName ' not required anymore so delete it
Else
EmailReviewRequestsResult LEmailBody, ""
End If
End If
End If
CloseQuery
End Sub
' (SS,28/9/12) email the results of the review request process
' *** email addresses to be corrected
Sub EmailReviewRequestsResult(ABody, AAttachedFileName)
Dim LSubject
LSubject = "Review Requests Result for " + GetStoreName + " on " & Now
' SendEmailByCDO used because it can handle attachments
' ATo, ABcc, ABcc2, AFrom, ASubject, ABody, AFiles, AIsHTML, AUrl
' FEmailContactTo, FEmailContactBcc1
' FEmailContactBcc1, ""
SendEmailByCDO FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, ABody, AAttachedFileName, True, "", ""
End Sub
' (SS,28/9/12)
Function ReviewRequestResultHeader
' NL used at end of each HTML line because emailer is adding a space after 1000 characters
Dim LResult
LResult = "<table border=1 cellspacing=0>" & NL
LResult = LResult & "<tr><th colspan=""6"">" & "Review Requests" & "</th></tr>" & NL
LResult = LResult & "<tr>" & NL
LResult = LResult & "<th>Email</th>" & NL
LResult = LResult & "<th>Name</th>" & NL
LResult = LResult & "<th>OrderNo</th>" & NL
LResult = LResult & "<th>Date Ordered</th>" & NL
LResult = LResult & "<th>Date Completed</th>" & NL
LResult = LResult & "<th>CustomerID</th>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
ReviewRequestResultHeader = LResult
End Function
' (SS,28/9/12)
Function ReviewRequestResultFooter(ACount)
Dim LResult
LResult = "<tr><td colspan=""6"">Reviews requested for " & PluralString(ACount, "order", "orders") & "</td></tr>" & NL
LResult = LResult & "</table>" & NL
Response.Write LResult
ReviewRequestResultFooter = LResult
End Function
' (SS,28/9/12)
Function ReviewRequestResultRow(AEmail, AName, AOrderNo, ADateOrdered, ADateCompleted, ACustomerID)
Dim LResult
LResult = "<tr>" & NL
LResult = LResult & "<td>" & AEmail & "</td>" & NL
LResult = LResult & "<td>" & AName & "</td>" & NL
LResult = LResult & "<td>" & AOrderNo & "</td>" & NL
LResult = LResult & "<td>" & ADateOrdered & "</td>" & NL
LResult = LResult & "<td>" & ADateCompleted & "</td>" & NL
LResult = LResult & "<td>" & ACustomerID & "</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
ReviewRequestResultRow = LResult
End Function
' (SS,14/3/12) created from code in SendStockNotificationEmails above, to make it easier to read, also returns the output HTML
' (SS,2/11/12) added AOrderNo
Sub SendReviewRequestEmail(AEmail, ACustomerName, AProductList, AOrderNo)
Const LOGO_FILE_NAME = "logo-review-request.png"
Dim LSubject, LBody
LSubject = "Review Request from " & GetStoreName & " - " & AOrderNo ' (SS,2/11/12) added AOrderNo
LBody = GetSiteDetail("Other", "ReviewRequestTemplate")
If LBody <> "" Then ' only send if template not blank
LBody = ReplaceStr(LBody, "{CUSTOMER_NAME}", ACustomerName)
LBody = ReplaceStr(LBody, "{PRODUCT_LIST}", AProductList)
LBody = ReplaceStr(LBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
' send the email with embedded logo
' SendEmail FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, True
' "surinder@itpartnership.com", "",
' AEmail, FEmailContactBcc1
SendEmailByCDO AEmail, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", True, "", LOGO_FILE_NAME
' (SS,20/3/18) send SMS, which will only be sent by SendSMS if SMSs are enabled and telephone is a mobile number
' (SS,2/12/21) added 4 empty parameters not used here: "", "", "", ""
SendSMS AOrderNo, ST_REVIEW_REQUEST, "", "", "", ""
End If
End Sub
' (SS,26/9/12)
Sub SetFeefoFileName
Dim LDate
LDate = Date
FFeefoFileName = TEMP_FOLDER & "feefo_sales_" & Year(LDate) & "-" & Right("0" & Month(LDate), 2) & "-" & Right("0" & Day(LDate), 2) & ".txt"
DeleteFile FFeefoFileName ' delete file if it already exists
End Sub
' (SS,26/9/12) adds tab separated field value to given record string
Function AddFeefoField(ARecordStr, AFieldValue)
Dim LFieldStr
LFieldStr = TrimAll(CStr(AFieldValue)) ' converts to string and removes all leading/trailing spaces and control chars
LFieldStr = ReplaceStr(LFieldStr, Chr(9), " ") ' replace all tabs in field with a space, otherwise it'll break the file format
AddFeefoField = ARecordStr + Iif(ARecordStr = "", "", Chr(9)) + LFieldStr ' add field separated by a tab, if record empty then no tab is added
End Function
' (SS,26/9/12) save record to file
Sub AddFeefoRecord(ARecordStr)
AddRecordToFile ARecordStr, FFeefoFileName, True
End Sub
' (SS,18/5/17)
Sub SendTrustpilotAFSEmail(AName, ARefID, AEmailAddress)
Dim LBody, LScript
LScript = "<script type=""application/json+trustpilot"">" & NL
LScript = LScript & "{" & NL
LScript = LScript & " ""recipientName"": """ & HTMLEncode(AName) & """," & NL
LScript = LScript & " ""referenceId"": """ & ARefID & """," & NL
LScript = LScript & " ""recipientEmail"": """ & AEmailAddress & """" & NL
LScript = LScript & "}" & NL
LScript = LScript & "</script>"
LBody = "<html>" & NL
LBody = LBody & "<head>" & NL
LBody = LBody & LScript & NL
LBody = LBody & "</head>" & NL
LBody = LBody & "<body>" & NL
LBody = LBody & "<pre>"
LBody = LBody & HTMLEncode(LScript) & NL
LBody = LBody & "</pre>" & NL
LBody = LBody & "</body>" & NL
LBody = LBody & "</html>" & NL
If AEmailAddress <> "" Then
Dim LBcc1, LBcc2, LFrom
LBcc1 = FEmailOrderConfirmationBcc1
LBcc2 = FEmailOrderConfirmationBcc2
LFrom = FEmailOrderConfirmationFrom
' ignore BCC to store (i.e. same as LFrom address)
' (SS,25/11/20) removed following two lines to ensure the store also receives a copy
'If LBcc1 = LFrom Then LBcc1 = ""
'If LBcc2 = LFrom Then LBcc2 = ""
SendEmailByCDO GetTrustpilotAFSEmailAddress, LBcc1, LBcc2, LFrom, "Trustpilot AFS Email from " & GetStoreName, LBody, "", True, "", ""
End If
End Sub
' (SS,7/12/20) used to send Trustpilot review invitations to customers who have already left positive reviews (for CIRC & VDK)
Sub SendTrustpilotReviewInvitations
Const TEST_MODE = False
' if Trustpilot AFS email not set up then exit without doing anything
If GetTrustpilotAFSEmailAddress = "" Then
Response.Write "TrustpilotAFSEmailAddress not set" & BR
Exit Sub
End If
Dim LSQL, LHTML
LHTML = ""
' first check if there are new reviews, i.e. 5 star that haven't been set to ShowOnSite since 1/11/2020
LSQL = "SELECT * FROM productreviews WHERE NOT ShowOnSite AND ProductRating = 5 AND ReviewDateTime >= '2020-11-01' ORDER BY ReviewID"
OpenQuery(LSQL)
If Not EndOfQuery Then
LHTML = LHTML & "<table border=1 cellspacing=0>" & NL
LHTML = LHTML & "<tr><th colspan=""8"">" & "New Reviews Shown On Site" & "</th></tr>" & NL
LHTML = LHTML & "<tr>" & NL
LHTML = LHTML & "<th>Review ID</th>" & NL
LHTML = LHTML & "<th>Review Date Time</th>" & NL
LHTML = LHTML & "<th>Product Code</th>" & NL
LHTML = LHTML & "<th>Review Title</th>" & NL
LHTML = LHTML & "<th>Product Rating</th>" & NL
LHTML = LHTML & "<th>Reviewer Name</th>" & NL
LHTML = LHTML & "<th>Reviewer Email</th>" & NL
LHTML = LHTML & "<th>Review Text</th>" & NL
LHTML = LHTML & "</tr>" & NL
Do While Not EndOfQuery
LHTML = LHTML & "<tr>"
LHTML = LHTML & "<td>" & GetQueryField("ReviewID") & "</td>"
LHTML = LHTML & "<td>" & GetQueryField("ReviewDateTime") & "</td>"
LHTML = LHTML & "<td>" & GetQueryField("ProductCode") & "</td>"
LHTML = LHTML & "<td>" & GetQueryField("ReviewTitle") & "</td>"
LHTML = LHTML & "<td>" & GetQueryField("ProductRating") & "</td>"
LHTML = LHTML & "<td>" & GetQueryField("ReviewerName") & "</td>"
LHTML = LHTML & "<td>" & GetQueryField("ReviewerEmail") & "</td>"
LHTML = LHTML & "<td>" & HTMLEncode(GetQueryField("ReviewText")) & "</td>"
LHTML = LHTML & "</tr>" & NL
If Not TEST_MODE Then
' set ShowOnSite to True to show on site
ExecuteQuery "UPDATE productreviews SET ShowOnSite = True WHERE ReviewID = '" & CleanSQLStr(GetQueryField("ReviewID")) & "'"
End If
NextQueryRecord
Loop
LHTML = LHTML & "</table>" & NL
LHTML = LHTML & "<table><tr><td> </td></tr></table>" ' separator especially to work in email
End If
' find all reviews which are rated 5 and have ShowOnSite ticked and Trustpilot review hasn't yet been requested
LSQL = "SELECT DISTINCT ReviewerEmail, CONCAT(FirstName, ' ', Surname) AS FullName, OrderNo" &_
" FROM productreviews pr" &_
" LEFT JOIN" &_
" (" &_
" SELECT MAX(OrderNo) AS OrderNo, EmailAddress, FirstName, Surname, DateTimeOrdered, DateTimeCompleted FROM orders" &_
" WHERE Status = 'COMPLETED'" &_
" GROUP BY EmailAddress" &_
" ) o_max ON o_max.EmailAddress = pr.ReviewerEmail" &_
" WHERE ShowOnSite AND ProductRating = 5 AND TrustpilotReviewRequested = FALSE AND pr.ReviewDateTime >=" &_
" '2020-10-01' AND ReviewerEmail <> ''" &_
" ORDER BY ReviewID DESC, ReviewID"
OpenQuery(LSQL)
If Not EndOfQuery Then
LHTML = LHTML & "<table border=1 cellspacing=0>" & NL
LHTML = LHTML & "<tr><th colspan=""3"">" & "Trustpilot Review Invitations Sent" & "</th></tr>" & NL
LHTML = LHTML & "<tr>" & NL
LHTML = LHTML & "<th>Reviewer Email</th>" & NL
LHTML = LHTML & "<th>Name</th>" & NL
LHTML = LHTML & "<th>Order No</th>" & NL
LHTML = LHTML & "</tr>" & NL
Dim LCount
LCount = 0
Dim LReviewerEmail, LFullName, LOrderNo
Do While Not EndOfQuery
LCount = LCount + 1
LReviewerEmail = GetQueryField("ReviewerEmail")
LFullName = GetQueryField("FullName")
LOrderNo = GetQueryField("OrderNo")
LHTML = LHTML & "<tr>"
LHTML = LHTML & "<td>" & LReviewerEmail & "</td>"
LHTML = LHTML & "<td>" & LFullName & "</td>"
LHTML = LHTML & "<td>" & LOrderNo & "</td>"
LHTML = LHTML & "</tr>" & NL
' send the actual email to Trustpilot (if not in test mode)
If Not TEST_MODE Then
SendTrustpilotAFSEmail LFullName, LOrderNo, LReviewerEmail
' mark the review(s) as requested so that it's not requested again
ExecuteQuery "UPDATE productreviews SET TrustpilotReviewRequested = True WHERE TrustpilotReviewRequested = False AND ReviewerEmail = '" & CleanSQLStr(LReviewerEmail) & "'"
End If
NextQueryRecord
Loop
LHTML = LHTML & "</table>" & NL
End If
If LHTML <> "" Then
Response.Write LHTML
Dim LSubject
LSubject = "Trustpilot Review Invitations Result for " + GetStoreName + " on " & Now
'SendEmail "surinder@itpartnership.com", "", "", FEmailContactFrom, LSubject, LHTML, True
SendEmail FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LHTML, True
End If
CloseQuery
End Sub
' ------------------------------
' End of Review Request Routines
' ------------------------------
' --------------------------------
' Start of Order Reminder Routines
' --------------------------------
' (SS,28/11/12) send order reminders, send 30 days after customer last ordered ordered, send again every 30 days, perhaps don't send during Christmas period
Sub SendOrderReminders
' don't send between 21 Dec and 7 Jan, i.e. Christmas break
If Month(Date) = 12 And Day(Date) >= 21 Or Month(Date) = 1 And Day(Date) <= 7 Then Exit Sub
Const TEST_MODE = False
Const MIN_DAYS_SINCE_LAST_ORDER = 30
' list of customer who haven't ordered between min days and max days ago
' if order reminder sent in past 30 days then don't send again, if OrderReminderOptOut is true then customer has opted out, so don't send any more reminders
' maximum of 500 are sent at any one time, with newest first
Dim LSQL
' (SS,19/12/12) replaced WHERE Status = 'COMPLETED' with WHERE (Status = '" & ORDER_COMPLETED_STATUS & "' OR Status = '" & PAYMENT_RECEIVED_STATUS & "')"
LSQL = "SELECT c.CustomerID, c.EmailAddress, TRIM(CONCAT(c.Title, ' ', c.FirstName, ' ', c.Surname)) AS FullName, MAX(DATE(DateTimeOrdered)) AS DateLastOrdered, MAX(o.OrderNo) AS LastOrderNo, OrderReminderSentDate" &_
" FROM orders o" &_
" INNER JOIN orderdetails od ON od.OrderNo = o.OrderNo" &_
" INNER JOIN customers c ON c.CustomerID = o.CustomerID" &_
" WHERE (Status = '" & ORDER_COMPLETED_STATUS & "' OR Status = '" & PAYMENT_RECEIVED_STATUS & "')" &_
" AND NOT OrderReminderOptOut AND (OrderReminderSentDate IS NULL OR DATEDIFF(CURDATE(), OrderReminderSentDate) > " & MIN_DAYS_SINCE_LAST_ORDER & ")" &_
" GROUP BY CustomerID, EmailAddress, FullName" &_
" HAVING DATEDIFF(CURDATE(), DateLastOrdered) > " & MIN_DAYS_SINCE_LAST_ORDER
' if test mode then only test with orders with my email address
If TEST_MODE Then LSQL = LSQL + " AND (EmailAddress = 'surinder@itpartnership.com' OR EmailAddress = 'srinda@gmail.com')"
'If TEST_MODE Then LSQL = LSQL + " AND (EmailAddress = 'surinder@itpartnership.com' OR EmailAddress = 'srinda@gmail.com' OR EmailAddress = 'tim@galleonsupplies.com')"
LSQL = LSQL + " ORDER BY MAX(DateTimeOrdered) DESC" &_
" LIMIT 500"
' iterate each customer
' build email body and sent email
' if successful then set OrderReminderSentDate so it isn't sent again for another 30 days
' add to list of order reminders sent
OpenQuery(LSQL)
If Not EndOfQuery Then
Dim LEmailBody, LReminderCount
LEmailBody = ""
LReminderCount = 0
Dim LCustomerID, LEmailAddress, LName, LDateLastOrdered
Do While Not EndOfQuery
LCustomerID = GetQueryField("CustomerID")
LEmailAddress = GetQueryField("EmailAddress")
LName = GetQueryField("FullName")
LDateLastOrdered = GetQueryField("DateLastOrdered")
LReminderCount = LReminderCount + 1
' add table header
If LReminderCount = 1 Then
LEmailBody = LEmailBody + OrderReminderResultHeader
End If
' add the row
LEmailBody = LEmailBody + OrderReminderResultRow(LCustomerID, LEmailAddress, LName, LDateLastOrdered, GetQueryField("OrderReminderSentDate"))
' send the email
SendOrderReminderEmail LCustomerID, LEmailAddress, LName, LDateLastOrdered, GetQueryField("LastOrderNo")
' change the OrderReminderSentDate to today so that we don't send again for another 30 days
ExecuteQuery "UPDATE customers SET OrderReminderSentDate = CURDATE() WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "'"'
NextQueryRecord
Loop
' if reminders sent then email the results
If LReminderCount > 0 Then
LEmailBody = LEmailBody + OrderReminderResultFooter(LReminderCount)
EmailOrderRemindersResult LEmailBody, ""
End If
End If
CloseQuery
End Sub
' (SS,29/11/12) email the results of the order reminders process
Sub EmailOrderRemindersResult(ABody, AAttachedFileName)
Dim LSubject
LSubject = "Order Reminders Result for " + GetStoreName + " on " & Now
' SendEmailByCDO used because it can handle attachments
' ATo, ABcc, ABcc2, AFrom, ASubject, ABody, AFiles, AIsHTML, AUrl
' FEmailContactTo, FEmailContactBcc1
' FEmailContactBcc1, ""
SendEmailByCDO FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, ABody, AAttachedFileName, True, "", ""
End Sub
' (SS,29/11/12)
Function OrderReminderResultHeader
' NL used at end of each HTML line because emailer is adding a space after 1000 characters
Dim LResult
LResult = "<table border=1 cellspacing=0>" & NL
LResult = LResult & "<tr><th colspan=""5"">" & "Order Reminders" & "</th></tr>" & NL
LResult = LResult & "<tr>" & NL
LResult = LResult & "<th>CustomerID</th>" & NL
LResult = LResult & "<th>Email</th>" & NL
LResult = LResult & "<th>Name</th>" & NL
LResult = LResult & "<th>Last Ordered</th>" & NL
LResult = LResult & "<th>Order Reminder Sent</th>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
OrderReminderResultHeader = LResult
End Function
' (SS,29/11/12)
Function OrderReminderResultFooter(ACount)
Dim LResult
LResult = "<tr><td colspan=""5"">Order reminders for " & PluralString(ACount, "customer", "customers") & "</td></tr>" & NL
LResult = LResult & "</table>" & NL
Response.Write LResult
OrderReminderResultFooter = LResult
End Function
' (SS,29/11/12)
Function OrderReminderResultRow(ACustomerID, AEmail, AName, ADateLastOrdered, AOrderReminderSentDate)
Dim LResult
LResult = "<tr>" & NL
LResult = LResult & "<td>" & ACustomerID & "</td>" & NL
LResult = LResult & "<td>" & AEmail & "</td>" & NL
LResult = LResult & "<td>" & AName & "</td>" & NL
LResult = LResult & "<td>" & ADateLastOrdered & "</td>" & NL
LResult = LResult & "<td>" & AOrderReminderSentDate & "</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
OrderReminderResultRow = LResult
End Function
' (SS,29/11/12)
' (SS,31/1/13) changes to work correctly in gmail because gmail ignores the stylesheet set in the header, i.e. only works with inline styles
Sub SendOrderReminderEmail(ACustomerID, AEmail, ACustomerName, ADateLastOrdered, LLastOrderNo)
Const LOGO_FILE_NAME = "logo-email.png" ' (SS,31/1/13) changed from "logo-review-request.png" to "logo-email.png"
' (SS,31/1/13) added LAttachLogoFileName
Dim LAttachLogoFileName, LSubject, LProductItemTemplate, LBody, LProductList, LProductLine, LProductCode, LProductName, LQty
LBody = GetSiteDetail("Other", "OrderReminderTemplate")
' (SS,4/12/12) get subject from template (i.e. <!--SUBJECT=Please check your stock of..-->), if it doesn't exist then use the default
' LSubject = "Order Reminder from " & GetStoreName & " - " & ACustomerID
' (SS,31/1/13) moved code to ExtractSettingFromTemplate so more than one setting can be extracted
LSubject = ExtractSettingFromTemplate(LBody, "SUBJECT")
If LSubject = "" Then LSubject = "Did we do something wrong?" & " (" & GetStoreName & " - " & ACustomerID & ")"
' (SS,31/1/13) product list template is now separate line in header of template called <!--PRODUCT_ITEM_TEMPLATE=
LProductItemTemplate = ExtractSettingFromTemplate(LBody, "PRODUCT_ITEM_TEMPLATE")
LProductList = ""
' (SS,31/10/18) added GetOrderDetailsFilter to filter out subproducts
OpenQuery2("SELECT * FROM orderdetails WHERE OrderNo = '" & LLastOrderNo & "'" + GetOrderDetailsFilter)
Do While Not EndOfQuery2
LProductCode = GetQueryField2("ProductCode")
LProductName = GetQueryField2("ProductName")
LQty = GetQueryField2("Qty")
' (SS,31/1/13) modified to work using inline CSS rather than stylesheet in html header because gmail doesn't support styles in header
LProductLine = LProductItemTemplate
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_LINK}", GetFullProductLink(LProductCode))
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_IMAGE_LINK}", GetFullProductImageLink(LProductCode, "s"))
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_NAME_AND_QTY}", LProductName & " (" & LQty & ")")
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_BUY_LINK}", GetBuyLinkHRef(LProductCode, LQty))
LProductList = LProductList + LProductLine & NL
NextQueryRecord2
Loop
CloseQuery2
If LBody <> "" Then ' only send if template not blank
LBody = ReplaceStr(LBody, "{CUSTOMER_NAME}", ACustomerName)
' (SS,31/1/13) added "if" to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LBody, "{LOGO}") > 0 Then
LBody = ReplaceStr(LBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
LAttachLogoFileName = LOGO_FILE_NAME
Else
LBody = ReplaceStr(LBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LAttachLogoFileName = ""
End If
LBody = ReplaceStr(LBody, "{DATE_LAST_ORDERED}", FormatDateTime(ADateLastOrdered, 1))
LBody = ReplaceStr(LBody, "{PRODUCT_LIST}", LProductList)
LBody = ReplaceStr(LBody, "{STORE_URL}", GetStoreURL) ' "http://www.galleonsupplies.co.uk") ' GetStoreURL)
LBody = ReplaceStr(LBody, "{STORE_NAME}", GetStoreName)
LBody = ReplaceStr(LBody, "{STORE_EMAIL}", GetStoreEmail) ' "sales@galleonsupplies.co.uk") ' GetStoreEmail
LBody = ReplaceStr(LBody, "{STORE_TELEPHONE}", GetStoreTelephone)
LBody = ReplaceStr(LBody, "{EMAIL_ADDRESS}", AEmail)
LBody = ReplaceStr(LBody, "{OPT_OUT_URL}", GetStoreURL & "/products.asp?page=optout" & "&email=" & URLEncode(AEmail) & "&id=" & ACustomerID)
' send the email with embedded logo
' SendEmail FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, True
' "surinder@itpartnership.com", "",
' AEmail, FEmailContactBcc1
SendEmailByCDO AEmail, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", True, "", LAttachLogoFileName '(SS,31/1/13) changed LOGO_FILE_NAME to LAttachLogoFileName
' SendEmailByCDO "surinder@itpartnership.com", "", FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
End If
End Sub
' (SS,31/1/13) returns the setting modifying ATemplate
' looks for a setting held in format <!--ABC=xxxx-->
' e.g. ExtractSettingFromTemplate(LBody, "ABC") will return xxxx and set LBody with section containing <!--ABC removed
' see SendOrderReminderEmail for actual usage
Function ExtractSettingFromTemplate(ByRef ATemplate, ASettingName)
Dim LPos1, LPos2, LResult
LResult = ""
LPos1 = InStr(1, ATemplate, "<!--" + ASettingName + "=", 1)
If LPos1 > 0 Then
LPos2 = InStr(LPos1, ATemplate, "-->", 1)
If LPos2 > 0 Then
LResult = Mid(ATemplate, LPos1 + Len(ASettingName) + 5, LPos2 - LPos1 - (Len(ASettingName) + 5))
' remove the found setting from ATemplate, also trim any newlines and spaces
ATemplate = TrimAll(Mid(ATemplate, 1, LPos1 - 1)) + TrimAll(Mid(ATemplate, LPos2 + 3))
End If
End If
ExtractSettingFromTemplate = LResult
End Function
' (SS,29/11/12)
Sub OrderReminderOptOut
Dim LEmail, LCustomerID
LEmail = CleanRequest("Email")
LCustomerID = CleanRequest("ID")
ExecuteQuery "UPDATE customers SET OrderReminderOptOut = 1 WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "' AND EmailAddress = '" & CleanSQLStr(LEmail) & "'"
ShowPageContentGiven "Opt-Out", "You have been removed from our list and will not receive further reminder emails."
End Sub
' ------------------------------
' End of Order Reminder Routines
' ------------------------------
' ---------------------------------------
' Start of Chase Cancelled Order Routines
' ---------------------------------------
' (SS,14/2/13) send cancelled order emails, don't send during Christmas period
' (SS,15/2/13) added ability to specify order no, for testing purposes
' (SS,15/2/13) added Title, FirstName, Surname
Sub SendChaseCancelledOrderEmails
' don't send between 21 Dec and 7 Jan, i.e. Christmas break
If Month(Date) = 12 And Day(Date) >= 21 Or Month(Date) = 1 And Day(Date) <= 7 Then Exit Sub
Const TEST_MODE = False
Const MIN_DAYS_AGO = 1
Const MAX_DAYS_AGO = 30
' (SS,15/2/13) if order number specified then only send to this, for testing purposes
Dim LRequestedOrderNo
LRequestedOrderNo = CleanRequest("OrderNo")
' list of cancelled orders between 1 and 30 days ago who haven't ordered since the cancelled order and now, excluding those that have already been sent emails
Dim LSQL
LSQL = "SELECT EmailAddress, OrderNo, TRIM(CONCAT(Title, ' ', FirstName, ' ', Surname)) AS FullName, Title, FirstName, Surname, DateTimeOrdered, DATEDIFF(CURDATE(), DateTimeOrdered) AS DaysAgo FROM orders o1"
If LRequestedOrderNo = "" Then
LSQL = LSQL & " WHERE Status = '" & ORDER_CANCELLED_STATUS & "'" &_
" AND DATEDIFF(CURDATE(), DateTimeOrdered) BETWEEN " & MIN_DAYS_AGO & " AND " & MAX_DAYS_AGO &_
" AND CancelledOrderChasedDate IS NULL" &_
" AND (SELECT EmailAddress FROM orders o2 WHERE o2.Status <> '" & ORDER_CANCELLED_STATUS & "'" &_
" AND o2.EmailAddress = o1.EmailAddress AND o2.DateTimeOrdered > o1.DateTimeOrdered LIMIT 1)" &_
" IS NULL"
Else
LSQL = LSQL & " WHERE OrderNo = '" & LRequestedOrderNo & "'"
End If
' if test mode then only test with orders with my email address
If TEST_MODE Then LSQL = LSQL + " AND (EmailAddress = 'surinder@itpartnership.com' OR EmailAddress = 'srinda@gmail.com')"
LSQL = LSQL + " ORDER BY EmailAddress, OrderNo DESC"
' iterate each customer
' build email body and sent email
' if successful then set CancelledOrderChasedDate to now
' add to list of cancelled orders chased
OpenQuery(LSQL)
If Not EndOfQuery Then
Dim LEmailBody, LChasedCount, LPrevEmail
LEmailBody = ""
LChasedCount = 0
LPrevEmail = ""
Dim LOrderNo, LEmailAddress, LName, LDateTimeOrdered
Do While Not EndOfQuery
LOrderNo = GetQueryField("OrderNo")
LEmailAddress = GetQueryField("EmailAddress")
LName = GetQueryField("FullName")
LDateTimeOrdered = GetQueryField("DateTimeOrdered")
If LPrevEmail <> LEmailAddress Then
LChasedCount = LChasedCount + 1
' add table header
If LChasedCount = 1 Then
LEmailBody = LEmailBody + ChaseCancelledOrdersResultHeader
End If
' add the row
LEmailBody = LEmailBody + ChaseCancelledOrdersResultRow(LOrderNo, LEmailAddress, LName, LDateTimeOrdered)
' send the email
SendChaseCancelledOrderEmail LOrderNo, LEmailAddress, LName, LDateTimeOrdered
' change the CancelledOrderChasedDate to today so that we don't send again
ExecuteQuery "UPDATE orders SET CancelledOrderChasedDate = CURDATE() WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'"'
Else ' i.e. matches previous email, duplicate
' set CancelledOrderChasedDate to special date 01/01/1902
ExecuteQuery "UPDATE orders SET CancelledOrderChasedDate = '1902-01-01' WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'"'
End If
LPrevEmail = LEmailAddress
NextQueryRecord
Loop
' if reminders sent then email the results
If LChasedCount > 0 Then
LEmailBody = LEmailBody + ChaseCancelledOrdersResultFooter(LChasedCount)
EmailChaseCancelledOrdersResult LEmailBody, ""
End If
End If
CloseQuery
End Sub
' (SS,29/11/12) email the results of the order reminders process
Sub EmailChaseCancelledOrdersResult(ABody, AAttachedFileName)
Dim LSubject
LSubject = "Chase Cancelled Orders Result for " + GetStoreName + " on " & Now
' SendEmailByCDO used because it can handle attachments
' ATo, ABcc, ABcc2, AFrom, ASubject, ABody, AFiles, AIsHTML, AUrl
' FEmailContactTo, FEmailContactBcc1
' FEmailContactBcc1, ""
SendEmailByCDO FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, ABody, AAttachedFileName, True, "", ""
End Sub
' (SS,14/2/13)
Function ChaseCancelledOrdersResultHeader
' NL used at end of each HTML line because emailer is adding a space after 1000 characters
Dim LResult
LResult = "<table border=1 cellspacing=0>" & NL
LResult = LResult & "<tr><th colspan=""4"">" & "Order Reminders" & "</th></tr>" & NL
LResult = LResult & "<tr>" & NL
LResult = LResult & "<th>Order No</th>" & NL
LResult = LResult & "<th>Email</th>" & NL
LResult = LResult & "<th>Name</th>" & NL
LResult = LResult & "<th>Date/Time Ordered</th>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
ChaseCancelledOrdersResultHeader = LResult
End Function
' (SS,14/2/13)
Function ChaseCancelledOrdersResultFooter(ACount)
Dim LResult
LResult = "<tr><td colspan=""4"">" & PluralString(ACount, "email", "emails") & " sent for cancelled orders</td></tr>" & NL
LResult = LResult & "</table>" & NL
Response.Write LResult
ChaseCancelledOrdersResultFooter = LResult
End Function
' (SS,14/2/13)
Function ChaseCancelledOrdersResultRow(AOrderNo, AEmail, AName, ADateTimeOrdered)
Dim LResult
LResult = "<tr>" & NL
LResult = LResult & "<td>" & AOrderNo & "</td>" & NL
LResult = LResult & "<td>" & AEmail & "</td>" & NL
LResult = LResult & "<td>" & AName & "</td>" & NL
LResult = LResult & "<td>" & ADateTimeOrdered & "</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
ChaseCancelledOrdersResultRow = LResult
End Function
' (SS,14/2/13) emails sent in plain text
Sub SendChaseCancelledOrderEmail(AOrderNo, AEmail, ACustomerName, ADateTimeOrdered)
Dim LSubject, LBody, LProductList, LProductLine, LProductCode, LProductName, LQty
LSubject = GetStoreName & " Purchase Not Completed - " & AOrderNo ' (SS,15/2/13) changed from "Cancelled Order at " & GetStoreName to this
LBody = TrimAll(GetSiteDetail("Other", "ChaseCancelledOrderTemplate") & "")
If LBody <> "" Then ' only send if template not blank
LBody = ReplaceStr(CStr(LBody), "{CUSTOMER_NAME}", CStr(ACustomerName))
LBody = ReplaceStr(LBody, "{ORDER_NO}", AOrderNo)
LBody = ReplaceStr(LBody, "{DATE_TIME_ORDERED}", FormatDateTime(ADateTimeOrdered, 1))
LBody = ReplaceStr(LBody, "{STORE_URL}", GetStoreURL)
LBody = ReplaceStr(LBody, "{STORE_NAME}", GetStoreName)
LBody = ReplaceStr(LBody, "{STORE_EMAIL}", GetStoreEmail)
LBody = ReplaceStr(LBody, "{STORE_TELEPHONE}", GetStoreTelephone)
LBody = ReplaceStr(LBody, "{EMAIL_ADDRESS}", AEmail)
LBody = ReplaceStr(LBody, "{TITLE}", GetQueryField("Title"))
LBody = ReplaceStr(LBody, "{FIRST_NAME}", GetQueryField("FirstName"))
LBody = ReplaceStr(LBody, "{SURNAME}", GetQueryField("Surname"))
SendEmailByCDO AEmail, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", False, "", ""
'SendEmailByCDO "surinder@itpartnership.com", "", FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", False, "", ""
End If
End Sub
' -------------------------------------
' End of Chase Cancelled Order Routines
' -------------------------------------
' ---------------------------------
' Start of Email Marketing Routines
' ---------------------------------
' (SS,19/12/12) (SS,22/2/13) added to update or add a customer record
' change was made to always ensure a customer record exists for any order for which payment has been received or awaiting payment
Sub UpdateCustomerRecord(AOrderNo)
' if we're forcing account creation then return because account will already exist, code below only runs for sites with optional accounts
If Not AccountsOptional then Exit Sub
' if order already has a Customer ID then not necessary to create an account because customer would have logged in
If GetSQLValueAsString("SELECT CustomerID FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'") <> "" Then Exit Sub
Dim LEmailAddress, LCustomerID, LSQL
LEmailAddress = GetSQLValueAsString("SELECT EmailAddress FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
If LEmailAddress = "" Then Exit Sub ' abort if email address not found, unlikely to ever happen
' lookup for email address in customer table
LCustomerID = GetSQLValueAsString("SELECT CustomerID FROM customers WHERE EmailAddress = '" & CleanSQLStr(LEmailAddress) & "'")
If LCustomerID <> "" Then
' if password is blank in customers table then update all fields (from order to customer record) because this isn't a proper account
' (SS,22/2/13) replaced Password = '' with Password IS NULL because it's a VARBINARY not VARCHAR
If GetSQLValueAsString("SELECT CustomerID FROM customers WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "' AND Password IS NULL") <> "" Then
LSQL = "UPDATE customers c, orders o" &_
" SET c.Title = o.Title, c.FirstName = o.FirstName, c.Surname = o.Surname," &_
" c.CompanyName = o.CompanyName, c.AddressLine1 = o.AddressLine1, c.AddressLine2 = o.AddressLine2," &_
" c.Town = o.Town, c.County = o.County, c.Postcode = o.Postcode, c.Country = o.Country," &_
" c.Telephone = o.Telephone, c.Mobile = o.Mobile, c.VATNumber = o.VATNumber," &_
" c.DeliveryAddressSameAsInvoice = o.DeliveryAddressSameAsInvoice, c.DeliveryName = o.DeliveryName," &_
" c.DeliveryCompanyName = o.DeliveryCompanyName, c.DeliveryAddressLine1 = o.DeliveryAddressLine1, c.DeliveryAddressLine2 = o.DeliveryAddressLine2," &_
" c.DeliveryTown = o.DeliveryTown, c.DeliveryCounty = o.DeliveryCounty, c.DeliveryPostcode = o.DeliveryPostcode, c.DeliveryCountry = o.DeliveryCountry," &_
" c.Subscribe = o.Subscribe, c.HearAboutUs = o.HearAboutUs" &_
" WHERE o.OrderNo = '" & CleanSQLStr(AOrderNo) & "' AND c.CustomerID = '" & CleanSQLStr(LCustomerID) & "'"
ExecuteQuery LSQL
'Else ' if password exists then update the subscribe field only
' update the subscribe field in customers
' (SS,22/2/13) discovered that there's no need to do the following because once properly logged it the subscribe field isn't shown, so commented out
' Dim LSubscribe
' LSubscribe = GetSQLValueAsString("SELECT Subscribe FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
' ExecuteQuery "UPDATE customers SET Subscribe = '" & LSubscribe & "' WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "'"
End If
Else ' LCustomerID = ""
' if customer not found then create new customer record from values in order record
LSQL = "INSERT INTO customers" &_
" (Title, FirstName, Surname, CompanyName," &_
" AddressLine1, AddressLine2, Town, County, Postcode, Country," &_
" Telephone, Mobile, EmailAddress, VATNumber," &_
" DeliveryAddressSameAsInvoice, DeliveryName, DeliveryCompanyName, DeliveryAddressLine1, DeliveryAddressLine2," &_
" DeliveryTown, DeliveryCounty, DeliveryPostcode, DeliveryCountry," &_
" Subscribe, HearAboutUs, DateTimeCreated)" &_
" SELECT Title, FirstName, Surname, CompanyName," &_
" AddressLine1, AddressLine2, Town, County, Postcode, Country," &_
" Telephone, Mobile, EmailAddress, VATNumber," &_
" DeliveryAddressSameAsInvoice, DeliveryName, DeliveryCompanyName, DeliveryAddressLine1, DeliveryAddressLine2," &_
" DeliveryTown, DeliveryCounty, DeliveryPostcode, DeliveryCountry," &_
" Subscribe, HearAboutUs, NOW()" &_
" FROM orders" &_
" WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'"
ExecuteQuery LSQL
' get the newly inserted customer ID to save in orders record below
LCustomerID = GetSQLLastInsertID
End If
' update orders table with customer ID
ExecuteQuery "UPDATE orders SET CustomerID = '" & LCustomerID & "' WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'"
End Sub
' (26/2/13)
Sub SendMarketingEmails
' don't send between 21 Dec and 7 Jan, i.e. Christmas break
' (SS,23/12/13) removed following, requested by Neil, wanted to send Christmas messages
' If Month(Date) = 12 And Day(Date) >= 21 Or Month(Date) = 1 And Day(Date) <= 7 Then Exit Sub
Const TEST_MODE = False
' (SS,27/2/13) if customer id specified then only send to this, for testing purposes
Dim LRequestedCustomerID, LMax, LCmd
LRequestedCustomerID = CleanRequest("CustomerID")
LMax = CleanRequest("Max") ' use to set the maximium amount of emails to send in one go, assumes all if left blank
LCmd = LCase(CleanRequest("cmd")) ' can be clear for next marketing campaign, "list" for
' cmd can be
' "clear" to clear the MarketingEmailSentDate ready for next campaign
' "list" the emails to send only
' "email" to send the emails
' clear the MarketingEmailSentDate clear ready for next campaign
If LCmd = "clear" Then
ExecuteQuery "UPDATE customers SET MarketingEmailSentDate = NULL WHERE MarketingEmailSentDate IS NOT NULL"
Exit Sub
ElseIf LCmd <> "list" And LCmd <> "email" Then
Response.Write "cmd must be specified: clear, list or email.<br />"
Response.Write "Use max to specify the maximum emails to send in one go.<br />"
Response.Write "To send a test email use CustomerID = xxxxx."
End If
' list of customers who have ordered and have subscribed to receive emails
' maximum of 500 are sent at any one time, with smallest customer ID first
Dim LSQL
' new field MarketingEmailSentDate must be null, this is cleared for a new campaign
LSQL = "SELECT DISTINCT c.CustomerID, c.EmailAddress, c.Title, c.FirstName, c.Surname, TRIM(CONCAT(c.Title, ' ', c.FirstName, ' ', c.Surname)) AS FullName" &_
" FROM customers c"
If LRequestedCustomerID = "" Then
LSQL = LSQL &_
" INNER JOIN orders o ON o.CustomerID = c.CustomerID AND (o.Status = '" & ORDER_COMPLETED_STATUS & "' OR o.Status = '" & PAYMENT_RECEIVED_STATUS & "')" &_
" WHERE c.Subscribe = TRUE AND c.MarketingEmailSentDate IS NULL"
' if test mode then only test with customers with my email address
If TEST_MODE Then LSQL = LSQL + " AND (c.EmailAddress = 'surinder@itpartnership.com' OR c.EmailAddress = 'srinda@gmail.com' OR c.EmailAddress = 'neil@itpartnership.com')"
LSQL = LSQL + " ORDER BY CustomerID"
If LMax <> "" Then LSQL = LSQL + " LIMIT " + CleanSQLStr(LMax)
Else
LSQL = LSQL & " WHERE CustomerID = '" & LRequestedCustomerID & "'"
End If
' iterate each customer
' build email body and send email
' if successful then set MarketingEmailSentDate so it isn't sent again
' add to list of marketing emails sent
OpenQuery(LSQL)
If Not EndOfQuery Then
Dim LEmailBody, LCount
LEmailBody = ""
LCount = 0
Dim LCustomerID, LEmailAddress, LName, LDateLastOrdered
Do While Not EndOfQuery
LCustomerID = GetQueryField("CustomerID")
LEmailAddress = GetQueryField("EmailAddress")
LName = GetQueryField("FullName")
LCount = LCount + 1
' add table header
If LCount = 1 Then
LEmailBody = LEmailBody + MarketingEmailResultHeader
End If
' add the row
LEmailBody = LEmailBody + MarketingEmailResultRow(LCustomerID, LEmailAddress, LName)
If LCmd = "email" Then
' send the email
SendMarketingEmail LCustomerID, LEmailAddress, LName
' change the MarketingEmailSentDate to today so that we don't send again during this campaign
ExecuteQuery "UPDATE customers SET MarketingEmailSentDate = CURDATE() WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "'"'
End If
NextQueryRecord
Loop
' if marketing emails sent then email the results
If LCount > 0 Then
LEmailBody = LEmailBody + MarketingEmailResultFooter(LCount)
If LCmd = "email" Then EmailMarketingEmailsResult LEmailBody, ""
End If
End If
CloseQuery
End Sub
' (SS,26/2/13) email the results of the marketing emails process
Sub EmailMarketingEmailsResult(ABody, AAttachedFileName)
Dim LSubject
LSubject = "Marketing Emails Result for " + GetStoreName + " on " & Now
' SendEmailByCDO used because it can handle attachments
' ATo, ABcc, ABcc2, AFrom, ASubject, ABody, AFiles, AIsHTML, AUrl
' FEmailContactTo, FEmailContactBcc1
' FEmailContactBcc1, ""
SendEmailByCDO FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, ABody, AAttachedFileName, True, "", ""
End Sub
' (SS,26/2/13)
Function MarketingEmailResultHeader
' NL used at end of each HTML line because emailer is adding a space after 1000 characters
Dim LResult
LResult = "<table border=1 cellspacing=0>" & NL
LResult = LResult & "<tr><th colspan=""3"">" & "Marketing Emails" & "</th></tr>" & NL
LResult = LResult & "<tr>" & NL
LResult = LResult & "<th>CustomerID</th>" & NL
LResult = LResult & "<th>Email</th>" & NL
LResult = LResult & "<th>Name</th>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
MarketingEmailResultHeader = LResult
End Function
' (SS,26/2/13)
Function MarketingEmailResultFooter(ACount)
Dim LResult
LResult = "<tr><td colspan=""3"">Marketing emails for " & PluralString(ACount, "customer", "customers") & "</td></tr>" & NL
LResult = LResult & "</table>" & NL
Response.Write LResult
MarketingEmailResultFooter = LResult
End Function
' (SS,26/2/13)
Function MarketingEmailResultRow(ACustomerID, AEmail, AName)
Dim LResult
LResult = "<tr>" & NL
LResult = LResult & "<td>" & ACustomerID & "</td>" & NL
LResult = LResult & "<td>" & AEmail & "</td>" & NL
LResult = LResult & "<td>" & AName & "</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
MarketingEmailResultRow = LResult
End Function
' (SS,26/2/13)
Sub SendMarketingEmail(ACustomerID, AEmail, ACustomerName)
Const LOGO_FILE_NAME = "logo-email.png"
Dim LAttachLogoFileName, LSubject, LProductItemTemplate, LBody, LProductList, LProductLine, LProductCode, LProductName, LQty
LBody = GetSiteDetail("Other", "MarketingEmailTemplate")
' get subject from template (i.e. <!--SUBJECT=Sale Now On..-->), if it doesn't exist then use the default
LSubject = ExtractSettingFromTemplate(LBody, "SUBJECT")
If LSubject = "" Then LSubject = "Sale Now On" & " (" & GetStoreName & " - " & ACustomerID & ")"
LSubject = ReplaceStr(LSubject, "{STORE_NAME}", GetStoreName)
LSubject = ReplaceStr(LSubject, "{CUSTOMER_ID}", ACustomerID)
If LBody <> "" Then ' only send if template not blank
LBody = ReplaceStr(LBody, "{CUSTOMER_NAME}", ACustomerName)
LBody = ReplaceStr(LBody, "{TITLE}", GetQueryField("Title"))
LBody = ReplaceStr(LBody, "{FIRST_NAME}", GetQueryField("FirstName"))
LBody = ReplaceStr(LBody, "{SURNAME}", GetQueryField("Surname"))
' to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LBody, "{LOGO}") > 0 Then
LBody = ReplaceStr(LBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
LAttachLogoFileName = LOGO_FILE_NAME
Else
LBody = ReplaceStr(LBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LAttachLogoFileName = ""
End If
LBody = ReplaceStr(LBody, "{STORE_URL}", GetStoreURL)
LBody = ReplaceStr(LBody, "{STORE_NAME}", GetStoreName)
LBody = ReplaceStr(LBody, "{STORE_EMAIL}", GetStoreEmail)
LBody = ReplaceStr(LBody, "{STORE_TELEPHONE}", GetStoreTelephone)
LBody = ReplaceStr(LBody, "{EMAIL_ADDRESS}", AEmail)
LBody = ReplaceStr(LBody, "{UNSUBSCRIBE_URL}", GetStoreURL & "/products.asp?page=unsubscribe" & "&email=" & URLEncode(AEmail) & "&id=" & ACustomerID)
' send the email with embedded logo
SendEmailByCDO AEmail, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
' SendEmailByCDO "surinder@itpartnership.com", "", FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
End If
End Sub
' (SS,26/2/13)
Sub MarketingEmailUnsubscribe
Dim LEmail, LCustomerID
LEmail = CleanRequest("Email")
LCustomerID = CleanRequest("ID")
ExecuteQuery "UPDATE customers SET Subscribe = 0 WHERE CustomerID = '" & CleanSQLStr(LCustomerID) & "' AND EmailAddress = '" & CleanSQLStr(LEmail) & "'"
ShowPageContentGiven "Unsubscribe", "You have been unsubscribed from our list and will not receive further marketing emails."
End Sub
' -------------------------------
' End of Email Marketing Routines
' -------------------------------
' (SS,16/7/13) returns comma separated list of product ID and product descriptions of all enabled products
' called via ajax.asp to return complete list to ShoppingAdmin for sending to Google Products, because it needs to convert the tokens
' (SS,1/5/19) I think this is now redundant, so removed (commented out)
'Function ProductDescriptionListForGoogleShopping
' Dim LResult, LDescription
' LResult = NL ' prefix with a newline to make searching for product ID easier using string match
' (SS,31/10/18) added GetProductsFilter to filter out subproducts
' OpenQuery("SELECT ProductID, ProductDescription FROM products WHERE ProductDisabled = FALSE" + GetProductsFilter + "ORDER BY ProductID")
' Do While Not EndOfQuery
' (SS,13/3/15) moved code from here to separate GetProductDescriptionForGoogleShopping
' (SS,16/3/15) added True parameter to compose
' LResult = LResult & GetQueryValue("ProductID") & ", " & GetProductDescriptionForGoogleShopping(GetQueryValue("ProductDescription"), True) & NL
' NextQueryRecord
' Loop
' CloseQuery
' ProductDescriptionListForGoogleShopping = LResult
'End Function
' (SS,13/3/15) moved code here from ProductDescriptionListForGoogleShopping, now also called from DoGoogleShoppingDataFeed
' (SS,16/3/15) added ACompose parameter, because when using GetProductDescriptionFirstSection ACompose will be false because GetProductDescriptionFirstSection does the compose
Function GetProductDescriptionForGoogleShopping(ADescription, ACompose)
Const MAX_LENGTH = 9000 ' max for Google Shopping
Dim LDescription
' (SS,16/3/15) added "If ACompose Then" because it will already be composed if called from DoGoogleShoppingDataFeed
If ACompose Then
LDescription = ComposeDescription(ADescription, True, False)
Else
LDescription = ADescription
End If
' remove HTML Tags
LDescription = RemoveHTMLTags(LDescription)
' replace quote with single quote
LDescription = ReplaceStr(LDescription,"""", "'")
' replace new lines with space and trim leading and trailing spaces
LDescription = Trim(ReplaceStr(LDescription, Chr(13) + Chr(10) , " "))
LDescription = Trim(ReplaceStr(LDescription, Chr(9), " ")) ' (SS,29/11/13) replaced tabs with spaces, because tab is a delimited on the products file sent to Google
If Len(LDescription) > MAX_LENGTH Then
LDescription = Mid(LDescription, 1, MAX_LENGTH) + ".."
Else
LDescription = LDescription
End If
GetProductDescriptionForGoogleShopping = LDescription
End Function
' ---------------------------------
' Start of generic counter routines
' ---------------------------------
' (SS,13/9/14) a generic counter which can be used by templates
Dim FCounter
Sub ClearCounter
FCounter = 0
End Sub
' (SS,13/9/14)
Sub IncCounter
FCounter = FCounter + 1
End Sub
Function GetCounter
GetCounter = FCounter
End Function
' -------------------------------
' End of generic counter routines
' -------------------------------
' (SS,9/10/14)
Function SetDeliveryInfo(ADeliveryInfo)
FDeliveryInfo = ADeliveryInfo
' (SS,18/5/17) saving of delivery info in session for use by saved basket (a bit messy I know, didn't have time to investigate why it needs to be cleared)
If ADeliveryInfo <> "" Then
Session("DeliveryInfoForSavedBasket") = ADeliveryInfo
End If
End Function
' (SS,9/10/14)
Function GetDeliveryInfo
GetDeliveryInfo = FDeliveryInfo
End Function
' (SS,18/5/17) due to it being cleared at start of apputils.asp load, we're saving it for email basket routine and returning it here
Function GetDeliveryInfoForSavedBasket
GetDeliveryInfoForSavedBasket = Session("DeliveryInfoForSavedBasket") & "" ' "" ensures empty string
End Function
' (SS,22/4/21) sets the delivery option shown on the checkout final stage and email confirmation
Sub SetDeliveryOptionLabel(ADeliveryOption)
' (SS,12/5/22)
ShowDebug "SetDeliveryOptionLabel before: " & FDeliveryOptionLabel
ShowDebug "SetDeliveryOptionLabel ADeliveryOption: " & ADeliveryOption
FDeliveryOptionLabel = ADeliveryOption
' (SS,29/4/21) modified following to include "Collection" and "Add To Previous"
If FDeliveryOptionLabel = "" Then
FDeliveryOptionLabel = "Delivery"
ElseIf ADeliveryOption = "Collection" Then
FDeliveryOptionLabel = "Free Collection"
ElseIf ADeliveryOption = "Add To Previous" Then
' keep the same
Else ' i.e. Untracked, Tracked, Expedited
' if it doesn't already contain delivery then add it
If InStr(FDeliveryOptionLabel, " Delivery") = 0 Then
FDeliveryOptionLabel = FDeliveryOptionLabel + " Delivery"
End If
End If
' (SS,12/5/22)
ShowDebug "SetDeliveryOptionLabel after: " & FDeliveryOptionLabel
End Sub
' (SS,22/4/21)
Function GetDeliveryOptionLabel
GetDeliveryOptionLabel = FDeliveryOptionLabel
End Function
' ---------------------------------
' Start of basket saving routines
' ---------------------------------
' (SS,19/2/15) uses current session ID and email address to save basket
' (SS,30/10/18) modified to not save and email the hidden subproducts
' (SS,1/10/20) modified to allow a maximum of 10 saved baskets per day (no restriction in local mode)
' This change was made due to hacking attempt to inject code on 27/9/20 in HF
' table schema change for saved_baskets. New field IPAddress also index added to this field and existing DateTimeSaved field:
' ALTER TABLE saved_baskets ADD COLUMN IPAddress VARCHAR(20) DEFAULT NULL AFTER DateTimeSaved, ADD INDEX idxDateTimeSaved (DateTimeSaved), ADD INDEX idxIPAddress (IPAddress);
Sub SaveBasket
If Not SaveBasketEnabled Then Exit Sub ' (SS,1/10/20) in case featured disable and hacker bypassing normal methods
Const MAX_SAVED_BASKETS_PER_DAY = 10 ' (SS,1/10/20)
' (SS,19/5/17) added LName and LAddress which only appear in local mode
Dim LEmailAddress, LSessionID, LSavedBasketID, LSavedBasketItemID, LItemID, LMessage, LName, LAddress
LEmailAddress = Trim(CleanRequest("email"))
If LEmailAddress = "" Then Exit Sub
LMessage = Trim(CleanRequest("message"))
' (SS,19/5/17)
LName = Trim(CleanRequest("name"))
LAddress = Trim(CleanRequest("address"))
LSessionID = GetSessionID
' (SS,1/10/20) added following to limit to x saved baskets per day, unless local mode
Dim LIPAddress, LTodaysCount, LLimitExceeded
LIPAddress = Left(GetIPAddress, 50) ' maximum of 50 chars (allows for IPv6)
LLimitExceeded = False
If Not IsLocalMode Then
LTodaysCount = GetSQLValue("SELECT COUNT(*) FROM saved_baskets WHERE DATE(DateTimeSaved) = CURDATE() AND IPAddress = '" & CleanSQLStr(LIPAddress) & "'")
LLimitExceeded = LTodaysCount >= MAX_SAVED_BASKETS_PER_DAY
End If
' (SS,1/10/20) added If not save and email if limit exceeded
If LLimitExceeded Then
Response.Write "Daily limit has been exceeded. Please try again later." & BR
Else ' as before
' create new saved basket record and save the email address and current date and time
' (SS,19/5/17) added Name and Address fields
' (SS,1/10/20) added IPAddress
ExecuteQuery("INSERT INTO saved_baskets SET EmailAddress = '" & CleanSQLStr(LEmailAddress) & "', DateTimeSaved = NOW(), IPAddress = '" & CleanSQLStr(LIPAddress) & "', Message = '" & CleanSQLStr(LMessage) & "', Name = '" & CleanSQLStr(LName) & "', Address = '" & CleanSQLStr(LAddress) & "'")
LSavedBasketID = GetSQLLastInsertID
' copy the current basket items into saved basket items table
' due to options linking to correct item id, it needs to be done on an item by item basis, Qty > 0 added just to be safe, unlikely to occur
' (SS,30/10/18) to prevent new subproducts from being added, added " AND SubproductItemID IS NULL" to WHERE clause
OpenQuery("SELECT * FROM shoppingbaskets WHERE SessionID = '" & CleanSQLStr(LSessionID) & "' AND SubproductItemID IS NULL AND Qty > 0 ORDER BY ItemID")
Do While Not EndOfQuery
LItemID = GetQueryValue("ItemID")
' add the item
' (SS,26/2/15) added OriginalBasketItemID = LItemID, new field, because ProductID isn't unique, same product can be added with different options
ExecuteQuery("INSERT INTO saved_basket_items SET OriginalBasketItemID = " & LItemID & ", SavedBasketID = " & LSavedBasketID & ", ProductID = " & GetQueryValue("ProductID") & ", Qty = " & GetQueryValue("Qty"))
' add the matching options
If ProductOptionsEnabled Then
LSavedBasketItemID = GetSQLLastInsertID
ExecuteQuery("INSERT INTO saved_basket_options SELECT NULL, " & LSavedBasketItemID & ", ProductOptionID, ProductOptionValueID, OptionName, OptionValue FROM shopping_basket_options WHERE ItemID = " & LItemID & " ORDER BY ShoppingBasketOptionID")
End If
NextQueryRecord
Loop
CloseQuery
' send an email with items and link to restore the basket
'Dim LBody
'LBody = "Please click the link below to restore the saved basket." & NL & GetStoreURL & "/products.asp?cmd=restorebasket&id=" & LSavedBasketID & "&email=" & URLEncode(LEmailAddress)
'SendEmail LEmailAddress, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, GetStoreName & " Saved Basket - " & LSavedBasketID, LBody, False
' (SS,19/5/17) added LName and LAddress
SendSavedBasketEmail LSavedBasketID, LEmailAddress, LMessage, LName, LAddress
Response.Write "Basket has been saved and emailed to " & LEmailAddress & "." & BR
SetPageRedirection GetBasketPageURL
End If
End Sub
' (SS,19/2/15) uses provided saved basket id and email address to restore basket into current session
' (SS,30/10/18) modified to also create the subproducts for products that have subproducts
' (SS,6/4/20) modified to fix loophole of suspended products from being ordered due to this feature
' (SS,4/11/20) modified to call CustomRestoreBasketExtras if new Extras field has a value
' (SS,25/2/22) modified to not restore quotes older than a year
Sub RestoreBasket
Dim LSavedBasketID, LEmailAddress, LSessionID, LItemID, LProductID, LProductOrderingSuspended
' validate the basket id and email
LSavedBasketID = Trim(CleanRequest("id"))
LEmailAddress = Trim(CleanRequest("email"))
If LSavedBasketID = "" Or LEmailAddress = "" Then Exit Sub
' (SS,25/2/22) added DATE(DateTimeSaved) > DATE_SUB(CURDATE(), INTERVAL 1 YEAR) to not restore quotes old than a year, added message saying quote has expired
If Not GetSQLRecordExists("SELECT * FROM saved_baskets WHERE SavedBasketID = '" & CleanSQLStr(LSavedBasketID) & "' AND EmailAddress = '" & CleanSQLStr(LEmailAddress) & "' AND DATE(DateTimeSaved) > DATE_SUB(CURDATE(), INTERVAL 1 YEAR)") Then
Response.Write "Quote has expired." & BR
Exit Sub
End If
' (SS,4/11/20) if new Extras field has a value then call custom routine to handle it instead, if defined
Dim LExtras
LExtras = GetSQLValueAsString("SELECT Extras FROM saved_baskets WHERE SavedBasketID = '" & CleanSQLStr(LSavedBasketID) & "'")
If LExtras <> "" Then
If FunctionExists("CustomRestoreBasketExtras") Then
' run the custom routine and exit if true is returned
If CustomRestoreBasketExtras(LExtras) Then
Exit Sub
End If
End If
End If
LSessionID = GetSessionID
' empty current basket
EmptyBasket(LSessionID)
LProductOrderingSuspended = False ' (SS,6/4/20)
' restore the basket in session
' due to options linking to correct item id, it needs to be done on an item by item basis, lookup product code from products table
OpenQuery("SELECT sbi.*, p.ProductCode FROM saved_basket_items sbi INNER JOIN products p ON p.ProductID = sbi.ProductID WHERE SavedBasketID = '" & CleanSQLStr(LSavedBasketID) & "' ORDER BY SavedBasketItemID")
Do While Not EndOfQuery
LProductID = GetQueryValue("ProductID") ' (SS,30/10/18)
' (SS,6/4/20) check the ProductOrderingSuspended routine to fix loophole i.e. if ordering is suspended for this product then don't allow it to be added
If ProductOrderingSuspended(LProductID) Then
LProductOrderingSuspended = True
Exit Do
End If
' add the item
ExecuteQuery("INSERT INTO shoppingbaskets SET SessionID = '" & LSessionID & "', ProductID = " & LProductID & ", ProductCode = '" & GetQueryValue("ProductCode") & "', Qty = " & GetQueryValue("Qty"))
LItemID = GetSQLLastInsertID ' (SS,30/10/18) moved here from "If ProductOptionsEnabled", also used by "If ProductSubproductsEnabled "
' add the matching options
If ProductOptionsEnabled Then
ExecuteQuery("INSERT INTO shopping_basket_options SELECT NULL, " & LItemID & ", ProductOptionID, ProductOptionValueID, OptionName, OptionValue FROM saved_basket_options WHERE SavedBasketItemID = " & GetQueryValue("SavedBasketItemID") & " ORDER BY SavedBasketOptionID")
End If
' (SS,30/10/18) added following to add subproducts if applicable, custom routine is called if subproducts enabled and this product has subproducts
If ProductSubproductsEnabled Then
If IntToBool(GetFieldForProductID(LProductID, "HasSubproducts")) Then
If FunctionExists("CustomAddSubproductsToBasket") Then
CustomAddSubproductsToBasket LProductID, LItemID, 0, GetQueryValue("Qty")
End If
End If
End If
NextQueryRecord
Loop
CloseQuery
' (SS,6/4/20) if a product was suspended then show message and empty basket
If LProductOrderingSuspended Then
Response.Write "Unfortunately, basket could not be restored for " & LEmailAddress & "." & BR
Response.Write "This is due to one or more products being suspended from ordering." & BR
Response.Write "Please try again later. Sorry for any inconvenience caused." & BR
EmptyBasket(LSessionID)
Else ' as before
' redirect to basket page
Response.Write "Basket has been restored for " & LEmailAddress & "." & BR
SetPageRedirection GetBasketPageURL
End If
End Sub
' (SS,20/2/15) based on Galleon's SendOrderReminderEmail
' (SS,19/5/17) added AName and AAddress
' (SS,1/8/18) added call to AddMoreOptionsInfo to add more info if applicable
Sub SendSavedBasketEmail(ASavedBasketID, AEmailAddress, AMessage, AName, AAddress)
Const LOGO_FILE_NAME = "logo-email.png"
Dim LAttachLogoFileName, LSubject, LBody, LProductList, LProductLine, LProductID, LProductCode, LProductName, LProductOptions, LOriginalBasketItemID, LQty, LPriceEach, LSQL
Dim LProductItemTemplate, LDiscountTemplate, LVATTemplate, LBCC, LBCC2, LFrom, LName, LMessage
LBody = GetSiteDetail("Other", "EmailBasketTemplate")
LSubject = ExtractSettingFromTemplate(LBody, "SUBJECT")
LBCC = ExtractSettingFromTemplate(LBody, "BCC")
LFrom = ExtractSettingFromTemplate(LBody, "FROM")
' (SS,26/2/15) if AMessage has a single line with name=xxx then {NAME} is replaced with xxx
LMessage = TrimAll(AMessage) ' trim all removes spaces and control characters
LName = AName ' (SS,19/5/17) replaced "" with AName
' if single line (no new line) and contains name= then get the name
' (SS,19/5/17) added LName = "" because it may already be passed here via new AName
If LName = "" And InStr(LMessage, Chr(13)) = 0 Then
Dim LPos
LPos = InStr(1, LMessage, "name=", vbTextCompare)
If LPos > 0 Then
LName = Trim(Mid(LMessage, LPos + 5)) ' leading space allows separation from salutation
LMessage = "" ' empty it so it doesn't appear in message section
End If
End If
If LName <> "" Then LName = " " & LName ' leading space allows separation from salutation (SS/19/5/17) moved from above to here
If LSubject = "" Then LSubject = "Saved Basket from {STORE_NAME}"
' (SS,19/5/17) SUBJECT2 used for proforma when address provided
If AAddress <> "" Then
Dim LSubject2
LSubject2 = ExtractSettingFromTemplate(LBody, "SUBJECT2")
If LSubject2 <> "" Then LSubject = LSubject2
End If
LSubject = ReplaceStr(LSubject, "{STORE_NAME}", GetStoreName) + " - " & ASavedBasketID
' product list template is separate line in header of template called <!--PRODUCT_ITEM_TEMPLATE=
LProductItemTemplate = ExtractSettingFromTemplate(LBody, "PRODUCT_ITEM_TEMPLATE")
' discount and VAT are separate optional lines
LDiscountTemplate = ExtractSettingFromTemplate(LBody, "DISCOUNT_TEMPLATE")
LVATTemplate = ExtractSettingFromTemplate(LBody, "VAT_TEMPLATE")
LProductList = ""
LSQL = "SELECT sbi.*, p.ProductCode, p.ProductName" &_
" FROM saved_basket_items sbi" &_
" INNER JOIN products p ON p.ProductID = sbi.ProductID" &_
" WHERE SavedBasketID = " & ASavedBasketID &_
" ORDER BY SavedBasketItemID"
Dim LobjBasketPricesDict
' (SS,23/2/15)
Set LobjBasketPricesDict = Session("BasketPricesDict")
OpenQuery(LSQL)
Do While Not EndOfQuery
LProductID = GetQueryField("ProductID")
LProductCode = GetQueryField("ProductCode")
LProductName = GetQueryField("ProductName")
LOriginalBasketItemID = GetQueryField("OriginalBasketItemID") ' (SS,26/12/15) now used instead of ProductID because ProductID can appear multiple times
LQty = GetQueryField("Qty")
' (SS,31/1/13) modified to work using inline CSS rather than stylesheet in html header because gmail doesn't support styles in header
LProductLine = LProductItemTemplate
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_LINK}", GetFullProductLink(LProductCode))
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_IMAGE_LINK}", GetFullProductImageLink(LProductCode, "s"))
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_NAME}", LProductName)
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_QTY}", LQty)
' (SS,23/2/15)
' (SS,26/2/15) LProductID with LOriginalBasketItemID because ProductID isn't unique, same product can be added with different options
If LobjBasketPricesDict.Exists(LOriginalBasketItemID) Then
LPriceEach = LobjBasketPricesDict.Item(LOriginalBasketItemID)
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_PRICE_EACH}", CorrectCurrencyNV(LPriceEach))
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_PRICE_TOTAL}", CorrectCurrencyNV(LPriceEach * LQty))
End If
' add the matching options
LProductOptions = ""
If ProductOptionsEnabled Then
OpenQuery2("SELECT OptionName, OptionValue FROM saved_basket_options WHERE SavedBasketItemID = " & GetQueryField("SavedBasketItemID") & " ORDER BY SavedBasketOptionID")
Do While Not EndOfQuery2
LProductOptions = LProductOptions & Iif(LProductOptions = "", "", ", ") & GetQueryField2("OptionName") & ": " & GetQueryField2("OptionValue")
NextQueryRecord2
Loop
End If
' (SS,1/8/18) added following to add additional option info
LProductOptions = AddMoreOptionsInfo(LProductID, LProductOptions)
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_OPTIONS}", LProductOptions)
LProductList = LProductList + LProductLine & NL
NextQueryRecord
Loop
CloseQuery
' (SS,23/2/15)
Set LobjBasketPricesDict = Nothing
If LBody <> "" Then ' only send if template not blank
' "if" to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LBody, "{LOGO}") > 0 Then
LBody = ReplaceStr(LBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
LAttachLogoFileName = LOGO_FILE_NAME
Else
LBody = ReplaceStr(LBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LAttachLogoFileName = ""
End If
LBody = ReplaceStr(LBody, "{PRODUCT_LIST}", LProductList)
LBody = ReplaceStr(LBody, "{STORE_URL}", GetStoreURL)
LBody = ReplaceStr(LBody, "{STORE_NAME}", GetStoreName)
LBody = ReplaceStr(LBody, "{STORE_EMAIL}", GetStoreEmail)
LBody = ReplaceStr(LBody, "{STORE_TELEPHONE}", GetStoreTelephone)
LBody = ReplaceStr(LBody, "{EMAIL_ADDRESS}", AEmailAddress)
LBody = ReplaceStr(LBody, "{RESTORE_BASKET_LINK}", GetRestoreBasketURL(ASavedBasketID, AEmailAddress))
LBody = ReplaceStr(LBody, "{MESSAGE}", ReplaceNewLinesWithBR(LMessage))
LBody = ReplaceStr(LBody, "{NAME}", LName) ' (SS,26/2/15)
' (SS,19/5/15) added following, mainly for CIRC proforma feature
Dim LAddress
LAddress = Trim(AAddress)
If LAddress <> "" Then
If LName <> "" Then LAddress = LName & NL & LAddress
LAddress = "<b>Your address details:</b>" & NL & LAddress
End If
LBody = ReplaceStr(LBody, "{ADDRESS}", ReplaceNewLinesWithBR(LAddress))
LBody = ReplaceStr(LBody, "{STORE_NAME}", GetStoreName)
LBody = ReplaceStr(LBody, "{STORE_ADDRESS}", GetStoreAddressAsHTML)
LBody = ReplaceStr(LBody, "{STORE_EMAIL}", GetStoreEmail)
LBody = ReplaceStr(LBody, "{STORE_FAX}", GetStoreFax)
LBody = ReplaceStr(LBody, "{STORE_TELEPHONE}", GetStoreTelephone)
LBody = ReplaceStr(LBody, "{VAT_REG_NO}", GetStoreVATRegNo)
If GetBasketDiscount <> 0 Then
Dim LVoucherCode
LVoucherCode = GetVoucherCode
If GetVoucherCode <> "" Then LVoucherCode = " (" & LVoucherCode & ")"
LDiscountTemplate = ReplaceStr(LDiscountTemplate, "{VOUCHER_CODE}", LVoucherCode)
LDiscountTemplate = ReplaceStr(LDiscountTemplate, "{DISCOUNT}", CorrectCurrencyNV(GetBasketDiscount))
Else
LDiscountTemplate = ""
End If
' VAT only shown if prices in system exclude VAT
Dim LVAT
LVAT = GetBasketVAT
If LVAT <> 0 And Not PricesEnteredIncludeVAT Then
LVATTemplate = ReplaceStr(LVATTemplate, "{VAT}", CorrectCurrency(GetBasketVAT))
Else
LVATTemplate = ""
End If
LBody = ReplaceStr(LBody, "{SUBTOTAL}", CorrectCurrencyNV(GetBasketSubtotal))
LBody = ReplaceStr(LBody, "{DISCOUNT_LINE}", LDiscountTemplate)
LBody = ReplaceStr(LBody, "{DELIVERY_COUNTRY}", " (" & GetDeliveryCountry & ")")
LBody = ReplaceStr(LBody, "{DELIVERY}", CorrectCurrencyNV(GetBasketDelivery))
LBody = ReplaceStr(LBody, "{VAT_LINE}", LVATTemplate)
LBody = ReplaceStr(LBody, "{GRAND_TOTAL}", CorrectCurrency(GetBasketGrandTotal))
LBody = ReplaceStr(LBody, "{DELIVERY_INFO}", GetDeliveryInfoForSavedBasket) ' (SS,18/5/17)
' (SS,25/2/15) sorted email bcc and from addresses, because we might be overriding the standard ones
If LFrom = "" Then LFrom = FEmailContactFrom
If LBCC = "" Then
LBCC = FEmailContactBcc1
LBCC2 = FEmailContactBcc2
Else
If FEmailContactBcc1 <> "" Then
LBCC2 = FEmailContactBcc1
Else
LBCC2 = FEmailContactBcc2
End If
End If
' SendEmailByCDO AEmailAddress, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", True, "", LAttachLogoFileName '(SS,31/1/13) changed LOGO_FILE_NAME to LAttachLogoFileName
SendEmailByCDO AEmailAddress, LBCC, LBCC2, LFrom, LSubject, LBody, "", True, "", LAttachLogoFileName '(SS,31/1/13) changed LOGO_FILE_NAME to LAttachLogoFileName
' SendEmailByCDO "surinder@itpartnership.com", "", FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
End If
End Sub
' (SS,4/11/20) for sending an alternative email using given template, provided SavedBasketID is used to fetch the EmailAddress and Message
' {EXTRA_INFO} is replaced with value AExtraInfo parameter
' (SS,13/11/20) added Name and Phone, (new field Phone added to saved_baskets)
Sub SendSavedBasketEmailExtra(ATemplateName, ASavedBasketID, AExtraInfo)
Dim LEmailAddress, LMessage, LName, LPhone
If Not GetSQL4Values("SELECT EmailAddress, Message, Name, Phone FROM saved_baskets WHERE SavedBasketID = '" & CleanSQLStr(ASavedBasketID) & "'", LEmailAddress, LMessage, LName, LPhone) Then Exit Sub
Const LOGO_FILE_NAME = "logo-email.png"
Dim LAttachLogoFileName, LSubject, LBody
Dim LBCC, LBCC2, LFrom
LBody = GetSiteDetail("Other", ATemplateName)
LSubject = ExtractSettingFromTemplate(LBody, "SUBJECT")
LBCC = ExtractSettingFromTemplate(LBody, "BCC")
LFrom = ExtractSettingFromTemplate(LBody, "FROM")
LMessage = TrimAll(LMessage) ' trim all removes spaces and control characters
If LSubject = "" Then LSubject = "Email Extra from {STORE_NAME}"
LSubject = ReplaceStr(LSubject, "{STORE_NAME}", GetStoreName) + " - " & ASavedBasketID
If LBody <> "" Then ' only send if template not blank
' "if" to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LBody, "{LOGO}") > 0 Then
LBody = ReplaceStr(LBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
LAttachLogoFileName = LOGO_FILE_NAME
Else
LBody = ReplaceStr(LBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LAttachLogoFileName = ""
End If
' (SS,13/11/20)
LBody = ReplaceStr(LBody, "{NAME}", LName)
LBody = ReplaceStr(LBody, "{PHONE}", LPhone)
LBody = ReplaceStr(LBody, "{STORE_URL}", GetStoreURL)
LBody = ReplaceStr(LBody, "{STORE_NAME}", GetStoreName)
LBody = ReplaceStr(LBody, "{STORE_EMAIL}", GetStoreEmail)
LBody = ReplaceStr(LBody, "{STORE_TELEPHONE}", GetStoreTelephone)
LBody = ReplaceStr(LBody, "{EMAIL_ADDRESS}", LEmailAddress)
LBody = ReplaceStr(LBody, "{RESTORE_LINK}", GetRestoreBasketURL(ASavedBasketID, LEmailAddress))
LBody = ReplaceStr(LBody, "{MESSAGE}", ReplaceNewLinesWithBR(LMessage))
LBody = ReplaceStr(LBody, "{EXTRA_INFO}", AExtraInfo)
' (SS,25/2/15) sorted email bcc and from addresses, because we might be overriding the standard ones
If LFrom = "" Then LFrom = FEmailContactFrom
If LBCC = "" Then
LBCC = FEmailContactBcc1
LBCC2 = FEmailContactBcc2
Else
If FEmailContactBcc1 <> "" Then
LBCC2 = FEmailContactBcc1
Else
LBCC2 = FEmailContactBcc2
End If
End If
' SendEmailByCDO AEmailAddress, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", True, "", LAttachLogoFileName '(SS,31/1/13) changed LOGO_FILE_NAME to LAttachLogoFileName
SendEmailByCDO LEmailAddress, LBCC, LBCC2, LFrom, LSubject, LBody, "", True, "", LAttachLogoFileName '(SS,31/1/13) changed LOGO_FILE_NAME to LAttachLogoFileName
' SendEmailByCDO "surinder@itpartnership.com", "", FEmailContactBcc2, FEmailContactFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
End If
End Sub
' (SS,4/11/20) to saved additional content to the saved baskets table, returns the SavedBasketID
' (SS<13/11/20) added saving of name and phone
Function SaveBasketExtras(AExtras)
If Not SaveBasketEnabled Then Exit Function ' (SS,1/10/20) in case featured disabled and hacker bypassing normal methods
' (SS,19/5/17) added LName and LAddress which only appear in local mode
Dim LEmailAddress, LSavedBasketID, LSavedBasketItemID, LItemID, LMessage, LIPAddress, LName, LPhone
LEmailAddress = Trim(CleanRequest("email"))
If LEmailAddress = "" Then Exit Function
LMessage = Trim(CleanRequest("message"))
LIPAddress = Left(GetIPAddress, 50) ' maximum of 50 chars (allows for IPv6)
' (SS,13/11/20)
LName = Left(Trim(CleanRequest("name")), 255) ' maximum of 50 chars
LPhone = Left(Trim(CleanRequest("phone")), 100) ' maximum of 100 chars
' create new saved basket record and save the email address and current date and time, message, IP address and extras value passed here
' (SS,13/11/20) added Name and Phone
ExecuteQuery("INSERT INTO saved_baskets SET EmailAddress = '" & CleanSQLStr(LEmailAddress) & "', DateTimeSaved = NOW(), IPAddress = '" & CleanSQLStr(LIPAddress) & "', Message = '" & CleanSQLStr(LMessage) & "', Name = '" & CleanSQLStr(LName) & "', Phone = '" & CleanSQLStr(LPhone) & "', Extras = '" & CleanSQLStr(AExtras) & "'")
' (SS,4/11/20) return the ID, used to restore later
SaveBasketExtras = GetSQLLastInsertID
End Function
' ---------------------------------
' End of basket saving routines
' ---------------------------------
' -------------------------------------------
' Start of Google Shopping Data Feed routines
' -------------------------------------------
' (SS,17/3/15)
Sub StartGoogleShoppingDataFeed
Session("InGoogleShoppingDataFeed") = True
End Sub
Sub EndGoogleShoppingDataFeed
Session("InGoogleShoppingDataFeed") = False
End Sub
Function InGoogleShoppingDataFeed
InGoogleShoppingDataFeed = Session("InGoogleShoppingDataFeed") = True
End Function
Sub SetGoogleShoppingDataFeedProductID(AProductID)
Session("GoogleShoppingDataFeedProductID") = AProductID
End Sub
Function GetGoogleShoppingDataFeedProductID
GetGoogleShoppingDataFeedProductID = Session("GoogleShoppingDataFeedProductID")
End Function
' (SS,13/3/15)
Function GoogleShoppingDataFeedHeaderDone
GoogleShoppingDataFeedHeaderDone = Session("GoogleShoppingDataFeedHeaderDone") = True
End Function
' (SS,13/3/15)
Sub AddGoogleShoppingField(AFieldName, AFieldValue)
' Response.Write AFieldName & " = " & AFieldValue & BR
Dim LFieldValue
LFieldValue = TrimAll(NB(AFieldValue))
If Not FGoogleShoppingDataFeedHeaderDone Then
FGoogleShoppingDataFeedHeader = FGoogleShoppingDataFeedHeader + IIf(FGoogleShoppingDataFeedHeader = "", "", Chr(9)) + AFieldName
End If
' (SS,22/9/17) added following to default the condition product attribute to "new" if blank
' (SS,25/9/17) if set as "damaged" then change to "used". Microdata can be "damaged" but Google Shopping Data Feed prefers "used" for both used and damagad.
If AFieldName = "condition" Then
If LFieldValue = "" Then
LFieldValue = "new"
ElseIf LFieldValue = "damaged" Then
LFieldValue = "used"
End If
End If
FGoogleShoppingDataFeedLine = FGoogleShoppingDataFeedLine + IIf(FGoogleShoppingDataFeedLine = "", "", Chr(9)) + LFieldValue
End Sub
' (SS,13/3/15)
' some of the code taken from ShoppingAdmin procedure TdmMain.CreateFroogleTable
' routines GetFlaggedItemsInBasket and GetAttributeInBasketCount modified to cope with this, these routines may be code from CustomGetDelivery and need to copy directly
' with single product for this Google Shopping Data Feed and shopping basket as before
' above functions InGoogleShoppingDataFeed and GetGoogleShoppingDataFeedProductID used by GetFlaggedItemsInBasket and GetAttributeInBasketCount
' (SS,27/1/16) change to call optional custom function CustomGoogleShoppingProductAdjust to make adjustments
' (SS,19/5/16) change to add gtin and identifier_exists, also not to default mpn to product code
' (SS,28/9/16) added extra product attributes for google shopping, also added new field to attributes table
' GoogleShopping TINYINT(1) DEFAULT '0' COMMENT 'Added 28/9/2016 to specify if it\'s for Google Shopping',
' (SS,1/5/19) Bugfix to product name renaming for HF, setting the product code global before call to ComposeDescription fixed it
Sub DoGoogleShoppingDataFeed
StartGoogleShoppingDataFeed
Response.ContentType = "text/plain" ' tells browser that it's an plain txt document
' Global FGoogleShoppingDataFeedHeader, FGoogleShoppingDataFeedLine, FGoogleShoppingDataFeedHeaderDone
FGoogleShoppingDataFeedHeader = ""
FGoogleShoppingDataFeedHeaderDone = False
' (SS,27/1/16) added LProductID and LProductName
Dim LAttributeID, LSQL, LDefaultProductType, LExpirationDate, LProductID, LProductCode, LProductType, LCategory, LSubcategory, LProductName, LProductDesc, LProductPrice
Dim LProductImageURL, LAvailability, LNumInStock, LMPN, LGTIN, LIdentifierExists
' (SS,27/1/16) Moved following here from loop, don't know why this didn't cause error in the loop because you can't redefine a DIM for same variable bame
Dim LDeliveryCost, LWeight, LFlaggedWeight, LNonFlaggedWeight, LNonWeightPrice, LVATTotal
' (SS,28/9/16) added google shopping detailed product attributes
Dim LGoogleShoppingProductAttributeNames, LGoogleShoppingProductAttributeIDs, i
ReDim LGoogleShoppingProductAttributeNames(-1) ' empty array
ReDim LGoogleShoppingProductAttributeIDs(-1) ' empty array
Dim LConditionInGoogleShoppingAttribute ' (SS,22/9/17) if condition is a product attribute we're using that instead of the default "new" for "condition" field
LConditionInGoogleShoppingAttribute = False ' (SS,22/9/17)
If ProductAttributesEnabled Then
LAttributeID = GetAttributeIDForName("Exclude from Google Shopping")
' (SS,28/9/16) get list of google shopping attributes
LSQL = "SELECT AttributeID, AttributeName FROM attributes WHERE GoogleShopping = TRUE ORDER BY SortOrder"
OpenQuery(LSQL)
Do While Not EndOfQuery
' add to array
ReDim Preserve LGoogleShoppingProductAttributeNames(UBound(LGoogleShoppingProductAttributeNames) + 1)
LGoogleShoppingProductAttributeNames(UBound(LGoogleShoppingProductAttributeNames)) = LCase(GetQueryField("AttributeName"))
ReDim Preserve LGoogleShoppingProductAttributeIDs(UBound(LGoogleShoppingProductAttributeIDs) + 1)
LGoogleShoppingProductAttributeIDs(UBound(LGoogleShoppingProductAttributeIDs)) = GetQueryField("AttributeID")
' (SS,22/9/17) if it's named condition then flag it as such
If LCase(GetQueryField("AttributeName")) = "condition" Then LConditionInGoogleShoppingAttribute = True
NextQueryRecord
Loop
CloseQuery
Else
LAttributeID = ""
End If
LDefaultProductType = FFroogleProductType
LExpirationDate = ISODate(DateAdd("d", 30, Date)) ' today's date plus 30 days, in ISO format
' (SS,19/5/16) added GTIN
LSQL = "SELECT products.ProductID, products.ProductCode, products.ProductName, products.ProductDescription," &_
" products.StdPrice, products.SalePrice, products.Price2, products.Price3, products.Price4, products.Discount, products.VATBand," &_
" productcategories.Category, productcategories.Subcategory, vatbands.VATRate," &_
" subcategories.GoogleProductCategory, BrandName, MPN, GTIN," &_
" products.NumInStock, products.AllowOutOfStockOrdering, products.AvailabilityDaysFrom, products.PostalWeight, products.CustomFlag," &_
" google_adwords_groups.AdWordsGroupName, subcategories.CustomLabel0, subcategories.CustomLabel1," &_
" subcategories.CustomLabel2, subcategories.CustomLabel3, subcategories.CustomLabel4"
' (SS,28/9/16) add the extra google shopping product attribute fields, if applicable
If UBound(LGoogleShoppingProductAttributeIDs) <> -1 Then
For i = LBound(LGoogleShoppingProductAttributeIDs) To UBound(LGoogleShoppingProductAttributeIDs)
LSQL = LSQL + ", pa" & i & ".AttributeValue AS AttributeValue_" & i
Next
End If
LSQL = LSQL &_
" FROM products" &_
" LEFT JOIN productcategories ON productcategories.ProductCode = products.productcode" &_
" LEFT JOIN subcategories ON subcategories.Category = productcategories.Category AND subcategories.Subcategory = productcategories.Subcategory" &_
" LEFT JOIN vatbands ON vatbands.VATBand = products.VATBand" &_
" LEFT JOIN brands ON brands.BrandID = products.BrandID" &_
" LEFT JOIN google_adwords_groups ON google_adwords_groups.AdWordsGroupID = subcategories.AdWordsGroupID"
' (SS,28/9/16) add the extra google shopping product attribute fields, if applicable
If UBound(LGoogleShoppingProductAttributeIDs) <> -1 Then
For i = LBound(LGoogleShoppingProductAttributeIDs) To UBound(LGoogleShoppingProductAttributeIDs)
LSQL = LSQL + " LEFT JOIN product_attributes pa" & i & " ON pa" & i & ".ProductID = products.ProductID AND pa" & i & ".AttributeID = " & LGoogleShoppingProductAttributeIDs(i)
Next
End If
If LAttributeID <> "" Then LSQL = LSQL + " LEFT JOIN product_attributes ON product_attributes.ProductID = products.ProductID AND product_attributes.AttributeID = " & LAttributeID
' (SS,31/10/18) added GetProductsFilter to filter out subproducts even though it's not absolutely necessary here due to subproducts not having a productcategories.Main
LSQL = LSQL + " WHERE products.ProductDisabled = 0 AND productcategories.Main" & GetProductsFilter
if LAttributeID <> "" Then LSQL = LSQL + " AND product_attributes.AttributeID IS NULL"
LSQL = LSQL + " ORDER BY ProductCode"
' LHeader = "id, product_type, google_product_category, expiration_date, price, image_link, link, title, description, condition, availability, brand, mpn, adwords_grouping, shipping_weight, custom_label_0, custom_label_1, custom_label_2, custom_label_3, custom_label_4"
' Response.Write "##" & LSQL & NL
OpenQuery(LSQL)
Do While Not EndOfQuery
LProductID = GetQueryField("ProductID") ' (SS,27/1/16)
SetGoogleShoppingDataFeedProductID LProductID ' used by routines including GetFlaggedItemsInBasket and GetAttributeInBasketCount
' product code
LProductCode = GetQueryField("ProductCode")
' (SS,1/5/19) added following because ComposeDescription will need the current page's product code
' i.e. HyperFlight product name rename feature relies on it (for servo specs)
' It does get set by call to GetPricingFromProductRecord later, but need to set it before calling ComposeDescription
' This fixes a bug which was resulting in some servo products having the wrong names (just the labels without values)
SetProductCode LProductCode
' product type
LCategory = NB(GetQueryField("Category"))
LSubcategory = NB(GetQueryField("Subcategory"))
LProductType = ""
' (SS,27/1/16) product name
LProductName = NB(GetQueryField("ProductName"))
If LCategory <> "" Then LProductType = LCategory
If LSubcategory <> "" Then LProductType = LProductType + IIf(LProductType = "", "", " > ") + LSubcategory
If LProductType = "" Then LProductType = LDefaultProductType
' detokenise etc., then get the first section only (e.g. CIRC which has section), then convert to suitable format for Google
LProductDesc = NB(GetQueryField("ProductDescription"))
LProductDesc = ComposeDescription(LProductDesc, True, False)
LProductDesc = GetProductDescriptionFirstSection(LProductDesc)
LProductDesc = GetProductDescriptionForGoogleShopping(LProductDesc, False)
' product price
GetPricingFromProductRecord(False)
LProductPrice = GetProductPrice
' Add VAT if necessary
If Not PricesEnteredIncludeVAT Then LProductPrice = LProductPrice + GetVATAmountToAddNC(LProductPrice)
' multiply by exchange rate if not 1 (i.e. not GBP) i.e. for Galleon IE, DE and FR
If FCurrencyDefaultRate <> 1 then LProductPrice = LProductPrice * FCurrencyDefaultRate
' product image URL, ### need to check if image already exists
' LProductImageURL = GetStoreURL & "/getpic.asp?size=o&code=" & LProductCode
' (SS,9/8/18) replaced above with following to make use of direct jpg images from files without getpic.asp
LProductImageURL = GetFullProductImageLink(LProductCode, "o")
' availability
LNumInStock = GetQueryField("NumInStock")
If IsNull(LNumInStock) Or NZ(LNumInStock) > 0 Then
LAvailability = "in stock"
ElseIf IntToBool(GetQueryField("AllowOutOfStockOrdering")) Then
If NZ(GetQueryField("AvailabilityDaysFrom")) >= 0 Then
LAvailability = "in stock"
Else
LAvailability = "preorder"
End If
Else
LAvailability = "out of stock"
End If
' GTIN
' (SS,19/5/16) new number that is required, if we don't have it or mpn and identifier_exists must be set to false
' this field was added to the products table on 19/5/16
LGTIN = Trim(NB(GetQueryField("GTIN")))
' MPN
LMPN = Trim(NB(GetQueryField("MPN")))
' (SS,19/5/16) commented out the following we're now leaving blank and setting identifier_exists to false
' If LMPN = "" then LMPN = LProductCode ' i.e. if no MPN then use ProductCode
' (SS,19/5/16) set new field LIdentifierExists to true or false depending on whether GTIN MPN
If LGTIN = "" And LMPN = "" Then
LIdentifierExists = "FALSE"
Else
LIdentifierExists = "TRUE"
End If
' delivery cost
' set up values to call GetDeliveryCost (which is normally called from GetOrderTotalsForBasket)
' following created from code in GetOrderTotalsForBasket
LWeight = NZ(GetQueryField("PostalWeight"))
If LWeight = 0 Then LNonWeightPrice = LProductPrice
If IntToBool(GetFieldValue("CustomFlag")) Then
LFlaggedWeight = LWeight
LNonFlaggedWeight = 0 ' (SS,27/1/16)
Else
LNonFlaggedWeight = LWeight
LFlaggedWeight = 0 ' (SS,27/1/16)
End If
' (SS,27/1/16) hook to allow product price and weight to be adjusted
If FunctionExists("CustomGoogleShoppingProductAdjust") Then
' CustomGoogleShoppingProductAdjust may adjust any of the following: LProductName, LProductPrice, LNonWeightPrice, LWeight, LFlaggedWeight, LNonFlaggedWeight
' was originally added to allow a product to have minimum sections for CIRC, for correct price for e.g. the 3 sections rather than per section
CustomGoogleShoppingProductAdjust LProductID, LProductCode, LProductName, LProductPrice, LNonWeightPrice, LWeight, LFlaggedWeight, LNonFlaggedWeight
End If
' calculate VAT and add to VAT total, also takes VAT Band into account, if PricesEnteredIncludeVAT then it's the VAT content of the Price
LVATTotal = LVATTotal + GetVATForProduct(LProductPrice)
LDeliveryCost = GetDeliveryCost(LProductPrice, LNonWeightPrice, LWeight, LFlaggedWeight, LNonFlaggedWeight, LVATTotal) ' will include VAT if PricesEnteredIncludeVAT
' add delivery cost if PricesEnteredIncludeVAT is false don't include VAT, GetDeliveryCost adds VAT if PricesEnteredIncludeVAT true
If Not PricesEnteredIncludeVAT Then LDeliveryCost = LDeliveryCost + GetVATAmountToAddNC(LDeliveryCost)
FGoogleShoppingDataFeedLine = ""
AddGoogleShoppingField "id", LProductCode
AddGoogleShoppingField "product_type", LProductType
AddGoogleShoppingField "google_product_category", Trim(GetQueryField("GoogleProductCategory"))
AddGoogleShoppingField "expiration_date", LExpirationDate ' ### to check format
AddGoogleShoppingField "price", Format2dpnc(LProductPrice) & " " & GetDefaultCurrencyCode
AddGoogleShoppingField "image_link", LProductImageURL
AddGoogleShoppingField "link", GetFullProductLinkWithName(LProductCode, LProductName)
AddGoogleShoppingField "title", RemoveHTMLTags(LProductName)
AddGoogleShoppingField "description", LProductDesc
if Not LConditionInGoogleShoppingAttribute Then AddGoogleShoppingField "condition", "new" ' (SS,22/9/17) added if condition to not include this default if "condition" product attribute is set
AddGoogleShoppingField "availability", LAvailability
AddGoogleShoppingField "brand", GetQueryField("BrandName")
AddGoogleShoppingField "gtin", LGTIN
AddGoogleShoppingField "mpn", LMPN ' (SS,19/5/16)
AddGoogleShoppingField "identifier_exists", LIdentifierExists ' (SS,19/5/16)
' (SS,28/9/16) add the extra google shopping product attribute fields, if applicable
If UBound(LGoogleShoppingProductAttributeIDs) <> -1 Then
For i = LBound(LGoogleShoppingProductAttributeIDs) To UBound(LGoogleShoppingProductAttributeIDs)
AddGoogleShoppingField LGoogleShoppingProductAttributeNames(i), Trim(NB(GetQueryField("AttributeValue_" & i)))
Next
End If
AddGoogleShoppingField "shipping_weight", LWeight
AddGoogleShoppingField "shipping", "GB:::" & Format2dpnc(LDeliveryCost) & " " & GetDefaultCurrencyCode
AddGoogleShoppingField "adwords_grouping", GetQueryField("AdWordsGroupName")
AddGoogleShoppingField "custom_label_0", GetQueryField("CustomLabel0")
AddGoogleShoppingField "custom_label_1", GetQueryField("CustomLabel1")
AddGoogleShoppingField "custom_label_2", GetQueryField("CustomLabel2")
AddGoogleShoppingField "custom_label_3", GetQueryField("CustomLabel3")
AddGoogleShoppingField "custom_label_4", GetQueryField("CustomLabel4")
If Not FGoogleShoppingDataFeedHeaderDone Then
Response.Write FGoogleShoppingDataFeedHeader & NL
FGoogleShoppingDataFeedHeaderDone = True
End If
Response.Write FGoogleShoppingDataFeedLine & NL
NextQueryRecord
Loop
CloseQuery
' assume the feed is collected by Google, set the date time last sent to now
SetSettingDateTimeNow "Froogle", "DateTimeLastSent"
' CloseDatabase used instead of Finalise in google-shipping.asp, because Finalise adds google analytics stuff
CloseDatabase
EndGoogleShoppingDataFeed
End Sub
' -------------------------------------------
' End of Google Shopping Data Feed routines
' -------------------------------------------
' -------------------------------------------
' Start of Order Progress Email routines
' -------------------------------------------
' (SS,4/7/16) based on Galleon's SendOrderReminderEmail
' (SS,6/7/16) change to show WorkingDaysToDespatch, also added {TITLE} and Order No to subject, improvements to results email
' (SS,8/3/17) adjusted gap from 4 to 2 days
' (SS,26/9/17) amended gap from 2 to LTemplateGapsDays, i.e. getting from email templates
' (SS,6/2/18) improved to now make use of the new order_progress_email_days table, which automatically handles different lead time ranges. No need for templates to be updated
' (SS,27/2/19) change to use DateTimePaid instead of DateTimeOrdered due to bank transfer payment delays
' (SS,10/12/19) modified LWorkingDaysToDespatch to prevent less than 1 appearing in from days. Now the minimum will be 1 - 2.
' (SS,4/10/20) added separate email via OrderProgressReadyForDespatchAlert
' (SS,16/6/21) modified to add DespatchByDate (template also change to show from and to dates)
' (SS,20/12/23) modified to call ShowOrderProgressEmailSample and also check for cmd=do before running
Sub SendOrderProgressEmails
CONST TEST_MODE = 0 ' can be 0 for off, 1 for log and emails to test account, 2 for log only, 3 log soon in browser not emailed
' (SS,20/12/23) if cmd specified then go to showing a sample, also to check for cmd=do as a safety before running the main routine
Dim LCmd
LCmd = CleanRequestQueryString("cmd")
If LCmd = "sample" Then
ShowOrderProgressEmailSample
Exit Sub
ElseIf LCmd <> "do" Then
Response.Write "No operation chosen"
Exit Sub
End If
' check if today is a working day, abort if not
' scan each OrderProgressEmailTemplate (1 to 9)
' extract BCC, FROM, SUBJECT, MIN DESPATCH DAYS, WORKINGS DAY SINCE ORDER from template
' run query to find orders with min despatch days and matching working days since order
' for each order
' add to log
' send the email (test mode, 0 = normal, 1 = log and send emails to test account, 2 = log only)
' exit if today isn't a working day
If Not IsTodayWorkingDay Then Exit Sub
' (SS,4/10/20) added following separate alert email
OrderProgressReadyForDespatchAlert
Const LOGO_FILE_NAME = "logo-email.png"
Dim LAttachLogoFileName, LTemplateTitle, LTemplateSubject, LSubject, LTemplateBody, LSQL
' (SS,6/2/18) added LMaxDespatchDays, removed LTemplateGapsDays, LTemplateWorkingDaysSinceOrder and LTemplateMinDespatchDays
Dim LBCC, LBCC2, LFrom, LMinDespatchDays, LMaxDespatchDays, LTemplateNo
Dim LTemplateBCC, LTemplateBCC2, LTemplateFrom
Dim LOrderNo, LOrderDate, LTitle, LFirstName, LSurname, LName, LEmailAddress
Dim LLogBody, LCount, LBody, LAnticipatedDespatchDate, LDedicatedDeliveryFromDate, LDespatchByDate
Dim LWorkingDaysToDespatch ' (SS,6/7/16)
Dim LWorkingDaysField, LWorkingDaysSinceOrder ' (SS,6/2/18)
LLogBody = ""
LTemplateNo = 0
LLogBody = LLogBody + OrderProgressEmailResultOverallHeader
' scan each OrderProgressEmailTemplate (1 to 9)
Do While LTemplateNo < 9
LTemplateNo = LTemplateNo + 1
' get body of template (also check it exists)
LTemplateBody = GetSiteDetail("Other", "OrderProgressEmailTemplate" & LTemplateNo)
Do ' null loop for logic short-circuit (bit like a continue)
If LTemplateBody = "" Then Exit Do
' extract BCC, FROM, SUBJECT, MIN DESPATCH DAYS, WORKINGS DAY SINCE ORDER from template
LTemplateTitle = ExtractSettingFromTemplate(LTemplateBody, "TITLE")
LTemplateSubject = ExtractSettingFromTemplate(LTemplateBody, "SUBJECT")
LTemplateSubject = ReplaceStr(LTemplateSubject, "{STORE_NAME}", GetStoreName)
LTemplateBCC = ExtractSettingFromTemplate(LTemplateBody, "BCC")
LTemplateFrom = ExtractSettingFromTemplate(LTemplateBody, "FROM")
' (SS,6/2/18) removed following 2 lines, no longer applicable
'LTemplateMinDespatchDays = ExtractSettingFromTemplate(LTemplateBody, "MIN_DESPATCH_DAYS")
'LTemplateWorkingDaysSinceOrder = ExtractSettingFromTemplate(LTemplateBody, "WORKING_DAYS_SINCE_ORDER")
' (SS,6/2/18) removed following line
' LTemplateGapsDays = ExtractSettingFromTemplate(LTemplateBody, "WORKING_DAYS_TO_DESPATCH_GAP_DAYS") ' (SS,26/9/17)
' (SS,6/2/18) removed following, keeping just the LTemplateSubject
'If LTemplateSubject = "" Or LTemplateMinDespatchDays = "" Or LTemplateWorkingDaysSinceOrder = "" Then Exit Do ' validation
'LTemplateMinDespatchDays = CLng(LTemplateMinDespatchDays)
'LTemplateWorkingDaysSinceOrder = CLng(LTemplateWorkingDaysSinceOrder)
'If LTemplateMinDespatchDays <= 5 Or LTemplateWorkingDaysSinceOrder <= 1 Then Exit Do ' validation
If LTemplateSubject = "" Then Exit Do ' validation
' (SS,26/9/17) default to 2 if not defined
' (SS,6/2/18) removed following, no longer needed
'If LTemplateGapsDays = "" Then
' LTemplateGapsDays = 2
'Else
' LTemplateGapsDays = CLng(LTemplateGapsDays)
'End If
' replace template variables that weren't change for each order
' "if" to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LTemplateBody, "{LOGO}") > 0 Then
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
LAttachLogoFileName = LOGO_FILE_NAME
Else
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LAttachLogoFileName = ""
End If
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_URL}", GetStoreURL)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_NAME}", GetStoreName)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_EMAIL}", GetStoreEmail)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_TELEPHONE}", GetStoreTelephone)
' sort email bcc and from addresses, because we might be overriding the standard ones
If LTemplateFrom = "" Then LTemplateFrom = FEmailOrderConfirmationFrom
If LTemplateBCC = "" Then
LTemplateBCC = FEmailOrderConfirmationBcc1
ElseIf LTemplateBCC = "NONE" Then ' if NONE then don't send BCC
LTemplateBCC = ""
End If
LTemplateBCC2 = FEmailOrderConfirmationBcc2
LCount = 0
'LLogBody = LLogBody + OrderProgressEmailResultHeader(LTemplateTitle, "Min. Despatch Days: " & LTemplateMinDespatchDays & ", Working Days Since Order: " & LTemplateWorkingDaysSinceOrder)
' (SS,6/2/18) replaced above with following, info no longer required
LLogBody = LLogBody + OrderProgressEmailResultHeader(LTemplateTitle, "")
' (SS,6/2/18) old SQL, commented out
'LSQL = "SELECT OrderNo, DATE(DateTimeOrdered) AS OrderDate, Title, FirstName, Surname, EmailAddress, DeliveryInfo, common.GetFirstInteger(DeliveryInfo) AS MinDespatchDays, " &_
' "common.GetNthWorkingDay(DATE(DateTimeOrdered), common.GetFirstInteger(DeliveryInfo)) AS AnticipatedDespatchDate, common.GetNthWorkingDay(DATE(DateTimeOrdered), common.GetFirstInteger(DeliveryInfo) + 2) AS DedicatedDeliveryFromDate " &_
' "FROM orders WHERE Status = 'PAYMENT RECEIVED' AND common.GetFirstInteger(DeliveryInfo) >= " & LTemplateMinDespatchDays & " AND common.GetNthWorkingDay(DATE(DateTimeOrdered), " & LTemplateWorkingDaysSinceOrder & ") = CURDATE()"
' (SS,6/2/18) new version of SQL which looks at the new order_progress_email_days table, saves having to keep modifying the templates everytime the lead time changes
' (SS,27/2/19) modified to use DateTimePaid as the OrderDate, i.e. replaced 3 occurrences of DateTimeOrdered with DateTimePaid (due to bank transfer payment delays)
' (SS,16/6/21) added DespatchByDate
LSQL = "SELECT * FROM " & NL &_
"(" & NL &_
"SELECT OrderNo, DATE(DateTimePaid) AS OrderDate, Title, FirstName, Surname, EmailAddress, DeliveryInfo, " & NL &_
"common.GetFirstInteger(DeliveryInfo) AS MinDespatchDays, " & NL &_
"common.GetSecondInteger(DeliveryInfo) AS MaxDespatchDays, " & NL &_
"common.GetNthWorkingDay(DATE(DateTimePaid), common.GetFirstInteger(DeliveryInfo)) AS AnticipatedDespatchDate, " & NL &_
"common.GetNthWorkingDay(DATE(DateTimePaid), common.GetFirstInteger(DeliveryInfo) + 2) AS DedicatedDeliveryFromDate, " & NL &_
"common.GetNthWorkingDay(DATE(DateTimePaid), common.GetSecondInteger(DeliveryInfo)) AS DespatchByDate " & NL &_
"FROM orders " & NL &_
"WHERE Status = 'PAYMENT RECEIVED'" & NL &_
") o" & NL &_
"INNER JOIN order_progress_email_days op ON op.LeadTimeMinDays = o.MinDespatchDays AND op.LeadTimeMaxDays = o.MaxDespatchDays" & NL
' (SS,6/2/18) look at the title and create the appropriate WHERE SQL, i.e. field OrderProgressEmailDays or DespatchUpdateEmailDays
If LTemplateTitle = "Order Progress" Then
LWorkingDaysField = "OrderProgressEmailDays"
Else
LWorkingDaysField = "DespatchUpdateEmailDays"
End If
LSQL = LSQL & "WHERE common.GetNthWorkingDay(OrderDate, op." + LWorkingDaysField + ") = CURDATE()"
' run query to find orders with min despatch days and matching working days since order
OpenQuery(LSQL)
' for each order
Do While Not EndOfQuery
LCount = LCount + 1
LOrderNo = GetQueryField("OrderNo")
LOrderDate = GetQueryField("OrderDate")
LTitle = Trim(GetQueryField("Title"))
LFirstName = Trim(GetQueryField("FirstName"))
LSurname = Trim(GetQueryField("Surname"))
LName = Trim(LTitle & IIf(LTitle = "", "", " ") & LFirstName & IIf(LFirstName = "", "", " ") & LSurname)
LEmailAddress = GetQueryField("EmailAddress")
LAnticipatedDespatchDate = GetQueryField("AnticipatedDespatchDate")
LDedicatedDeliveryFromDate = GetQueryField("DedicatedDeliveryFromDate")
LDespatchByDate = GetQueryField("DespatchByDate") ' (SS,16/6/21)
LMinDespatchDays = GetQueryField("MinDespatchDays")
LMaxDespatchDays = GetQueryField("MaxDespatchDays") ' (SS,6/2/18)
' (SS,6/7/16) e.g. 4-8, (SS,8/3/17) changed from + 4 to + 2 e.g. 5-7
' (SS,26/7/19) replaced + 2 with LTemplateGapsDays, now taken from email template
' (SS,27/7/19) added Max to prevent 0 e.g. 0-3 will become 1-3
'LWorkingDaysToDespatch = Max(1, LMinDespatchDays - LTemplateWorkingDaysSinceOrder) & "-" & (LMinDespatchDays - LTemplateWorkingDaysSinceOrder + LTemplateGapsDays)
' (SS,6/2/18) replaced above with following, i.e. we now have LMaxDespatchDays, no need for LTemplateGapsDays
'LWorkingDaysToDespatch = Max(1, LMinDespatchDays - LTemplateWorkingDaysSinceOrder) & "-" & (LMaxDespatchDays - LTemplateWorkingDaysSinceOrder)
' (SS,6/2/18) replaced above with following
' (SS,10/12/19) to prevent -1 and 0 added Max(1, ..), also added Max(2, ..) to second section to prevent 1 or less i.e. min will be 1 - 2
LWorkingDaysToDespatch = Max(1, GetQueryField("LeadTimeMinDays") - GetQueryField(LWorkingDaysField)) & "-" & Max(2, GetQueryField("LeadTimeMaxDays") - GetQueryField(LWorkingDaysField))
' (SS,6/2/18)
LWorkingDaysSinceOrder = LMinDespatchDays - (GetQueryField("LeadTimeMinDays") - GetQueryField(LWorkingDaysField))
' (SS,6/7/16) changed LDedicatedDeliveryFromDate to LWorkingDaysToDespatch
' (SS,6/2/18) added LWorkingDaysSinceOrder, LMaxDespatchDays
LLogBody = LLogBody + OrderProgressEmailResultRow(LOrderNo, LOrderDate, LName, LEmailAddress, LWorkingDaysSinceOrder, LMinDespatchDays, LMaxDespatchDays, LAnticipatedDespatchDate, LWorkingDaysToDespatch)
' send the email (test mode, 0 = normal, 1 = log and send emails to test account, 2 = log only)
LBody = LTemplateBody
If LBody <> "" Then ' only send if template not blank
' replace order specific template values
LSubject = ReplaceStr(LTemplateSubject, "{ORDER_NO}", LOrderNo)
LBody = ReplaceStr(LBody, "{ORDER_NO}", LOrderNo)
LBody = ReplaceStr(LBody, "{ORDER_DATE}", LOrderDate)
LBody = ReplaceStr(LBody, "{NAME}", LName)
LBody = ReplaceStr(LBody, "{ANTICIPATED_DESPATCH_DATE}", LAnticipatedDespatchDate)
LBody = ReplaceStr(LBody, "{DEDICATED_DELIVERY_FROM_DATE}", LDedicatedDeliveryFromDate)
LBody = ReplaceStr(LBody, "{WORKING_DAYS_TO_DESPATCH}", LWorkingDaysToDespatch) ' (SS,6/7/16)
LBody = ReplaceStr(LBody, "{WORKING_DAYS_TO_DESPATCH}", LWorkingDaysToDespatch) ' (SS,6/7/16)
LBody = ReplaceStr(LBody, "{DESPATCH_BY_DATE}", LDespatchByDate) ' (SS,16/6/21)
' send the email with embedded logo, if not test mode or test mode 1
If TEST_MODE = 0 Or TEST_MODE = 1 Then
' if test mode 1 then send email to test address, set the BCCs for normal and test mode
LFrom = LTemplateFrom
If TEST_MODE = 0 Then
LBCC = LTemplateBCC
LBCC2 = LTemplateBCC2
Else ' i.e. 1
LEmailAddress = LTemplateBCC2
LBCC = ""
LBCC2 = ""
End If
' debug code to show email addresses
'Response.Write "LEmailAddress: " & LEmailAddress & BR
'Response.Write "LBCC: " & LBCC & BR
'Response.Write "LBCC2: " & LBCC2 & BR
'Response.Write "LFrom: " & LFrom & BR
If LEmailAddress <> "" Then
SendEmailByCDO LEmailAddress, LBCC, LBCC2, LFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
' (SS,20/3/18) send SMS, title of template should match the SMS constant
' SMS will only be sent by SendSMS if SMSs are enabled and telephone is a mobile number
' (SS,16/6/21) added If TEST_MODE = 0 to only send SMS when not in test mode
If TEST_MODE = 0 And (LTemplateTitle = ST_ORDER_PROGRESS Or LTemplateTitle = ST_ANTICIPATED_DESPATCH_UPDATE) Then
' (SS,2/12/21) added 4 news parameter for the two additional tokens after LTemplateTitle
SendSMS LOrderNo, LTemplateTitle, "ANTICIPATED_DESPATCH_DATE", LAnticipatedDespatchDate, "DESPATCH_BY_DATE", LDespatchByDate
End If
End If
End If
End If
NextQueryRecord
Loop
LLogBody = LLogBody + OrderProgressEmailResultFooter(LTemplateTitle, LCount)
Loop While False ' end of null loop
Loop ' scan each OrderProgressEmailTemplate (1 to 9)
CloseQuery
LLogBody = LLogBody + OrderProgressEmailResultOverallFooter
' send log email
If LLogBody <> "" And TEST_MODE < 3 Then
SendEmailByCDO FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, "Order Progress Result for " + GetStoreName + " on " & Now, LLogBody, "", True, "", ""
End If
End Sub
' (SS,4/7/16) returns true if today is a working day
Function IsTodayWorkingDay
IsTodayWorkingDay = GetSQLValue("SELECT common.IsWorkingDay(CURDATE())") = 1
End Function
' (SS,23/4/21) uses common table stored function to return if given date is a working day
' NB. there's a function called IWorkingDay which doesn't use the common calender routines, just looks at whether Saturday or Sunday
Function IsDateWorkingDay(ADate)
Dim LDate
LDate = ISODate(CDate(ADate))
IsDateWorkingDay = GetSQLValue("SELECT common.IsWorkingDay(""" & CleanSQLStr(LDate) & """)") = 1
End Function
' (SS,23/4/21) uses stored function to return working days in between given dates, start date must be before end date
Function WorkingDaysBetween(AStartDate, AEndDate)
Dim LStartDate, LEndDate
LStartDate = ISODate(CDate(AStartDate))
LEndDate = ISODate(CDate(AEndDate))
WorkingDaysBetween = GetSQLValue("SELECT common.GetWorkingDaysBetween(""" & CleanSQLStr(LStartDate) & """, """ & CleanSQLStr(LEndDate) & """)")
End Function
' (SS,6/7/16)
Function OrderProgressEmailResultOverallHeader
Dim LResult
LResult = ""
LResult = LResult & "<html>" & NL
LResult = LResult & "<head>" & NL
LResult = LResult & "<title>Order Progress Emails " & Now & "</title>" & NL
LResult = LResult & "<style>" & NL
LResult = LResult & "table {border-collapse: collapse;}" & NL
LResult = LResult & "table, th, td {border: 1px solid black;}" & NL
LResult = LResult & "th, td {padding: 5px;}" & NL
LResult = LResult & "</style>" & NL
LResult = LResult & "</head>" & NL
LResult = LResult & "<body>" & NL
LResult = LResult & "<table>" & NL
Response.Write LResult
OrderProgressEmailResultOverallHeader = LResult
End Function
' (SS,6/7/16)
Function OrderProgressEmailResultOverallFooter
Dim LResult
LResult = LResult & "</table>" & NL
LResult = LResult & "</body>" & NL
LResult = LResult & "</html>" & NL
Response.Write LResult
OrderProgressEmailResultOverallFooter = LResult
End Function
' (SS,4/7/16)
' (SS,6/7/16) replaced Dedicated Delivery Date with Working Days to Despatch
Function OrderProgressEmailResultHeader(AInfo1, AInfo2)
' NL used at end of each HTML line because emailer is adding a space after 1000 characters
Dim LResult
LResult = LResult & "<tr><th colspan=""8""> </tr>" & NL ' empty line separator
LResult = LResult & "<tr><th colspan=""4"">" & AInfo1 & "</th><th colspan=""4"">" & AInfo2 & "</th></tr>" & NL
LResult = LResult & "<tr>" & NL
LResult = LResult & "<th>Order No</th>" & NL
LResult = LResult & "<th>Order Date</th>" & NL
LResult = LResult & "<th>Name</th>" & NL
LResult = LResult & "<th>Email</th>" & NL
LResult = LResult & "<th>Working Days<br>Since Order</th>" & NL ' (SS,6/2/18)
LResult = LResult & "<th>Anticipated<br>Despatch Days</th>" & NL ' (SS,6/2/18) was Minimum Despatch Days
LResult = LResult & "<th>Earliest Anticipated<br>Despatch Date</th>" & NL
LResult = LResult & "<th>Days Remaining<br>to Despatch</th>" & NL ' (SS,6/2/18) was Working Days to Despatch
LResult = LResult & "</tr>" & NL
Response.Write LResult
OrderProgressEmailResultHeader = LResult
End Function
' (SS,4/7/16)
Function OrderProgressEmailResultFooter(ATitle, ACount)
Dim LResult
LResult = "<tr><td colspan=""8""><b>" & ATitle & " emails sent for " & PluralString(ACount, "order", "orders") & "</b></td></tr>" & NL
Response.Write LResult
OrderProgressEmailResultFooter = LResult
End Function
' (SS,4/7/16)
' (SS,6/7/16) replaced ADedicatedDeliveryFromDate with AWorkingDaysToDespatch
' (SS,6/2/18) added AWorkingDaysSinceOrder
Function OrderProgressEmailResultRow(AOrderNo, AOrderDate, AName, AEmail, AWorkingDaysSinceOrder, AMinDespatchDays, AMaxDespatchDays, AAnticipatedDespatchDate, AWorkingDaysToDespatch)
Dim LResult, LCentre
LCentre = " style=""text-align:center"""
LResult = "<tr>" & NL
LResult = LResult & "<td" & LCentre & ">" & AOrderNo & "</td>" & NL
LResult = LResult & "<td" & LCentre & ">" & AOrderDate & "</td>" & NL
LResult = LResult & "<td>" & AName & "</td>" & NL
LResult = LResult & "<td>" & AEmail & "</td>" & NL
LResult = LResult & "<td" & LCentre & ">" & AWorkingDaysSinceOrder & "</td>" & NL
LResult = LResult & "<td" & LCentre & ">" & AMinDespatchDays & "-" & AMaxDespatchDays & "</td>" & NL ' (SS,6/2/18) added AMaxDespatchDays
LResult = LResult & "<td" & LCentre & ">" & AAnticipatedDespatchDate & "</td>" & NL
LResult = LResult & "<td" & LCentre & ">" & AWorkingDaysToDespatch & "</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
OrderProgressEmailResultRow = LResult
End Function
' (SS,3/10/20) sends an alert email if orders are ready for despatch but not sent (for CIRC)
Sub OrderProgressReadyForDespatchAlert
Dim LSQL, LLogBody, LCount
LSQL = _
"SELECT OrderNo, DATE(DateTimePaid) AS OrderDate, FirstName, Surname, EmailAddress, DeliveryInfo, ReadyForDespatch" & NL &_
"FROM orders " & NL &_
"WHERE Status = 'PAYMENT RECEIVED' AND ReadyForDespatch IS NOT NULL" & NL &_
"ORDER BY OrderNo"
LLogBody = OrderProgressEmailResultOverallHeader
LLogBody = LLogBody + OrderProgressReadyForDespatchAlertHeader
LCount = 0
OpenQuery LSQL
Do While Not EndOfQuery
LCount = LCount + 1
LLogBody = LLogBody + OrderProgressReadyForDespatchAlertRow(GetQueryField("OrderNo"), GetQueryField("OrderDate"), Trim(GetQueryField("FirstName") & IIf(GetQueryField("FirstName") = "", "", " ") & GetQueryField("Surname")), GetQueryField("EmailAddress"), GetQueryField("ReadyForDespatch"))
NextQueryRecord
Loop
CloseQuery
LLogBody = LLogBody + OrderProgressEmailResultOverallFooter
' send log email if there are records
If LCount > 0 Then
SendEmailByCDO FEmailContactTo, FEmailContactBcc1, FEmailContactBcc2, FEmailContactFrom, "Orders Ready for Despatch but not sent for " + GetStoreName + " on " & Now, LLogBody, "", True, "", ""
End If
End Sub
' (SS,3/10/20)
Function OrderProgressReadyForDespatchAlertHeader
' NL used at end of each HTML line because emailer is adding a space after 1000 characters
Dim LResult
LResult = LResult & "<th>Order No</th>" & NL
LResult = LResult & "<th>Order Date</th>" & NL
LResult = LResult & "<th>Name</th>" & NL
LResult = LResult & "<th>Email</th>" & NL
LResult = LResult & "<th>Ready for<br>Despatch Date</th>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
OrderProgressReadyForDespatchAlertHeader = LResult
End Function
' (SS,4/10/20)
Function OrderProgressReadyForDespatchAlertRow(AOrderNo, AOrderDate, AName, AEmail, AReadyForDespatchDate)
Dim LResult, LCentre
LCentre = " style=""text-align:center"""
LResult = "<tr>" & NL
LResult = LResult & "<td" & LCentre & ">" & AOrderNo & "</td>" & NL
LResult = LResult & "<td" & LCentre & ">" & AOrderDate & "</td>" & NL
LResult = LResult & "<td>" & AName & "</td>" & NL
LResult = LResult & "<td>" & AEmail & "</td>" & NL
LResult = LResult & "<td" & LCentre & ">" & AReadyForDespatchDate & "</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
OrderProgressReadyForDespatchAlertRow = LResult
End Function
' (SS,20/12/23) to show a sample in a browser for testing, called when cmd=sample i.e. order-progress-emails.asp?cmd=sample&no=1
Sub ShowOrderProgressEmailSample
Const LOGO_FILE_NAME = "logo-email.png"
Dim LTemplateBody, LTemplateNo, LTemplateName
LTemplateNo = Left(CleanRequestQueryString("no"), 1) ' i.e. 1 to 9
LTemplateName = "OrderProgressEmailTemplate" & LTemplateNo
LTemplateBody = GetSiteDetail("Other", LTemplateName)
If LTemplateBody = "" Then
Response.Write "Template <b>" + LTemplateName + "</b> is missing." & BR
If LTemplateNo = "" Then Response.Write "Also need to include '&no=x' where x = 1 to 9." & BR
Exit Sub
End If
' following copied from ShowOrderProgressEmailSample above
' replace template variables that weren't change for each order
' "if" to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LTemplateBody, "{LOGO}") > 0 Then
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
Else
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
End If
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_URL}", GetStoreURL)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_NAME}", GetStoreName)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_EMAIL}", GetStoreEmail)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_TELEPHONE}", GetStoreTelephone)
Response.Write LTemplateBody
End Sub
' -------------------------------------------
' End of Order Progress Email routines
' -------------------------------------------
' -------------------------------------------
' Start of VAT Number checking routines
' -------------------------------------------
Function CheckVATNumber(AVATNumber, AErrorMessage)
' if successful check already done in session on same number then return, no need to check again
' perform check and log to database, hold in session (to later save in order and also alert email to website address)
Dim LResult
Dim LCountryCode, LVATNumber, LValid, LName, LAddress, LErrorOccurred, LErrorMessage
AErrorMessage = "" ' set default error message
' same number already successfully checked, return True
If Session("VATNumberLastChecked") = AVATNumber Then
CheckVATNumber = True
Exit Function
End If
LResult = CheckVATNumberViaWebsite(AVATNumber, LCountryCode, LVATNumber, LValid, LName, LAddress, LErrorOccurred, LErrorMessage)
If Not LResult And LErrorOccurred Then
' Response.Write LErrorMessage
Session("VATNumberResultErrorMessage") = LErrorMessage
ElseIf Not LResult Then
LErrorMessage = "VAT Number " & AVATNumber & " is invalid" ' i.e. check was performed okay but number isn't valid
Else
Session("VATNumberResultErrorMessage") = ""
End If
If LResult Then
Session("VATNumberLastChecked") = AVATNumber
Session("VATNumberResultCountryCode") = LCountryCode
Session("VATNumberResultVATNumber") = LVATNumber
Session("VATNumberResultValid") = LValid
Session("VATNumberResultName") = LName
Session("VATNumberResultAddress") = LAddress
End If
AErrorMessage = LErrorMessage
CheckVATNumber = LResult
End Function
' for further info see php verison here: http://stackoverflow.com/questions/9158119/vies-vat-number-validation
' if error occurs or timeout then AErrorOccurred is True and AErrorMessage contains the error message
Function CheckVATNumberViaWebsite(AVATReg, ByRef ACountryCode, ByRef AVATNumber, ByRef AValid, ByRef AName, ByRef AAddress, ByRef AErrorOccurred, ByRef AErrorMessage)
Const WAIT_TIMEOUT = 10 ' (SS,21/11/18 changed from 5 to 10)
Dim LResult, LVATReg, LCountryCode, LVATNumber
LResult = False
LVATReg = Trim(AVATReg)
LCountryCode = Left(LVATReg, 2)
LVATNumber = Trim(Mid(LVATReg, 3))
' clear the values, i.e. default of blank
ACountryCode = ""
AVATNumber = ""
AValid = ""
AName = ""
AAddress = ""
AErrorOccurred = False
AErrorMessage = ""
Dim oXmlHTTP, LSOAPRequest
Set oXmlHTTP = CreateObject("MSXML2.ServerXMLHTTP") ' NB. "Microsoft.XMLHTTP" doesn't have waitForResponse method to check for timeout
oXmlHTTP.Open "POST", "http://ec.europa.eu/taxation_customs/vies/services/checkVatService", True
oXmlHTTP.setRequestHeader "Content-Type", "text/xml; charset=ISO-8859-1" ' charset=utf-8 charset=ISO-8859-1
oXmlHTTP.setRequestHeader "SOAPAction", "checkVatService"
LSOAPRequest = _
"<s11:Envelope xmlns:s11='http://schemas.xmlsoap.org/soap/envelope/'>" & NL &_
" <s11:Body>" & NL &_
" <tns1:checkVat xmlns:tns1='urn:ec.europa.eu:taxud:vies:services:checkVat:types'>" & NL &_
" <tns1:countryCode>" & LCountryCode & "</tns1:countryCode>" & NL &_
" <tns1:vatNumber>" & LVATNumber & "</tns1:vatNumber>" & NL &_
" </tns1:checkVat>" & NL &_
" </s11:Body>" & NL &_
"</s11:Envelope>"
oXmlHTTP.send LSOAPRequest
' Response.Write oXmlHTTP.responseText
' *** need to add some validation if call fails
Dim LHTTPResponse
On Error Resume Next
If oXmlHTTP.waitForResponse(WAIT_TIMEOUT) Then 'response ready
If Err.Number = 0 Then
LHTTPResponse = oXmlHTTP.responseText
Else
AErrorOccurred = True
AErrorMessage = "Error checking VAT Number: " & Err.Description
End If
Else 'wait timeout exceeded
'Handling timeout etc
AErrorOccurred = True
AErrorMessage = "Timed out while checking VAT Number"
End If
On Error GoTo 0 ' cancel the error handling
Set oXmlHTTP = Nothing
If Not AErrorOccurred Then
LResult = GetVATCheckResultFromXML(LHTTPResponse, ACountryCode, AVATNumber, AValid, AName, AAddress)
' debug code
'If LResult Then
' Response.Write "CountryCode: " & ACountryCode & "<br>"
' Response.Write "VATNumber: " & AVATNumber & "<br>"
' Response.Write "Name: " & AName & "<br>"
' Response.Write "Address: " & AAddress & "<br>"
'End If
End If
' Response.Write "<br>END<hr>"
CheckVATNumberViaWebsite = LResult
End Function
' see http://stackoverflow.com/questions/892161/asp-classic-xml-dom
' following might help: http://www.codeguru.com/csharp/.net/net_asp/article.php/c19551/ServerSide-XML-in-ASP.htm
' also?: http://stackoverflow.com/questions/11522316/reading-xml-data-using-classic-asp
Function GetVATCheckResultFromXML(AXMLStr, ByRef ACountryCode, ByRef AVATNumber, ByRef AValid, ByRef AName, ByRef AAddress)
Dim LResult, objXML, objList, LElem, LChildNodes, LNode
LResult = False
AValid = ""
Set objXML = Server.CreateObject("Microsoft.XMLDOM")
objXML.LoadXml(AXMLStr)
Set objList = objXML.getElementsByTagName("checkVatResponse")
If objList.length > 0 Then
Dim LName, LValue
'Response.Write "<hr>" & vbCrLf
For Each LElem In objList
Set LChildNodes = LElem.childNodes
For Each LNode In LChildNodes
' Response.Write node.nodeName & " = " & Server.HTMLEncode(node.text) & "<br />" & vbCrLf
LName = LNode.nodeName
LValue = LNode.text
If LName = "countryCode" Then
ACountryCode = LValue
ElseIf LName = "vatNumber" Then
AVATNumber = LValue
ElseIf LName = "valid" Then
AValid = LValue
ElseIf LName = "name" Then
AName = LValue
ElseIf LName = "address" Then
AAddress = LValue
End If
'Response.Write node.nodeName & " = " & Server.HTMLEncode(node.text) & "<br />" & vbCrLf
Next
'Response.Write "<hr>" & vbCrLf
Next
End If
Set objXML = Nothing
If AValid <> "" Then
LResult = UCase(AValid) = "TRUE"
End If
GetVATCheckResultFromXML = LResult
End Function
' (SS,6/10/11) to check VAT validation and note in notes field, called for orders and customers (accounts)
' (SS,10/8/16) moved here from just before Function GetOutOfStockDetails
' (SS,10/8/16) rewrote to save the new values set in CheckVATNumber above
' (SS,6/10/16) modified to save in payment log field instead of notes
' (SS,27/1/17) fixed bug which caused when saving account details because PaymentLog field doesn't exist in customers table, now Notes used if table is customers
Sub NoteVATValidation(ATable, ACriteria)
If Session("VATNumberLastChecked") = "" And Session("VATNumberResultErrorMessage") = "" Then Exit Sub
Dim LNote
LNote = NL & "VAT Number Check Result:" & NL
If Session("VATNumberResultErrorMessage") <> "" Then
LNote = LNote & Session("VATNumberResultErrorMessage")
Else
' (SS,23/8/17) moved Valid to the top from below VATNumber
LNote = LNote &_
"Valid: " & Session("VATNumberResultValid") & NL &_
"CountryCode: " & Session("VATNumberResultCountryCode") & NL &_
"VATNumber: " & Session("VATNumberResultVATNumber") & NL &_
"Name: " & Session("VATNumberResultName") & NL &_
"Address: " & Session("VATNumberResultAddress") & NL
End If
' (SS,6/10/16) replaced Notes with PaymentLog
' (SS,27/1/17) fixed bug was was causing "Unknown column 'PaymentLog' in 'field list'" error when updating account details, this is due to customers table not having a PaymentLog field
' Fixed by using PaymentLog field for orders, and Notes for customers table, PaymentLog replaced with LLogField
' (SS,23/8/17) Fixed bug where PaymentLog was being overwritten, now calls AddToPaymentLog routine for "orders" table
If ATable = "orders" Then
AddToPaymentLog "VAT No Check", LNote ' (SS,23/8/17)
Else
ExecuteQuery("UPDATE " & ATable & " SET Notes = CONCAT(COALESCE(Notes, """"), NOW(), "" "", '" & CleanSQLStr(LNote) & "', ""\r\n"") WHERE " & ACriteria)
End If
End Sub
' (SS,1/10/20) used for making a note in order if customer using a free delivery voucher
Sub ClearFreeDeliveryVoucherUsed
Session("FreeDeliveryVoucherUsed") = False
End Sub
' (SS,1/10/20) used for making a note in order if customer using a free delivery voucher
Sub SetFreeDeliveryVoucherUsed
Session("FreeDeliveryVoucherUsed") = True
End Sub
' (SS,1/10/20) returns true if free delivery voucher used
Function FreeDeliveryVoucherUsed
FreeDeliveryVoucherUsed = Session("FreeDeliveryVoucherUsed") = True
End Function
' (SS,1/10/20) adds a note if free delivery voucher used
Sub NoteFreeDeliveryVoucherUsage
If Not FreeDeliveryVoucherUsed Then Exit Sub
Const FREE_DELIVERY_NOTE = "Free Delivery - check for other order"
Dim LOrderNo, LNotes
LOrderNo = GetOrderNo
If LOrderNo <> "" Then
' get existing notes
LNotes = TrimAll(GetSQLValueAsString("SELECT Notes FROM orders WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'"))
' check if note already added, if not then add
If InStr(1, LNotes, FREE_DELIVERY_NOTE, vbTextCompare) = 0 Then
If LNotes <> "" Then LNotes = LNotes & NL & NL ' add two new lines if notes not empty
LNotes = LNotes & FREE_DELIVERY_NOTE
ExecuteQuery("UPDATE orders SET Notes = '" & CleanSQLStr(LNotes) & "' WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'")
End If
End If
End Sub
' (SS,10/8/16) added following to add given fields from orders table to VAT alert email, called from EmailOrder
Function EmailOrderVATAlertAddFields(AOrderNo, AFieldList)
Dim LResult, LFields, i, LFieldName
LResult = ""
LFields = Split(AFieldList, ",")
For i = 0 To UBound(LFields)
LFieldName = TrimAll(LFields(i)) ' TrimAll used instead of Trim to also remove leading and trailing newline/carriage returns
LResult = LResult & LFieldName & ": " & NB(GetOrderFieldValue(AOrderNo, LFieldName)) & NL
Next
EmailOrderVATAlertAddFields = LResult
End Function
' (SS,11/8/16) following code moved here from end of EmailOrder
Sub SendVATNumberAlertEmail(AOrderNo, AStatus)
' (SS,12/12/12) if VAT deducted for intracommunity supply then send alert email if enabled
If VATIntraCommunityEmailAlertEnabled And (AStatus = PAYMENT_RECEIVED_STATUS Or AStatus = AWAITING_PAYMENT_STATUS) Then
Dim LVATNumber, LBody
LVATNumber = NB(GetOrderFieldValue(AOrderNo, "VATNumber"))
If LVATNumber <> "" Then
Dim LVATDeducted
LVATDeducted = NZ(GetOrderFieldValue(AOrderNo, "VATDeducted"))
If CDbl(LVATDeducted) > 0 Then
' LBody defined earlier, reused here
' (SS,3/12/15) replaced:
' "Check URL 2: " & "http://isvat.appspot.com/" & Left(LVATNumber, 2) & "/" & Mid(LVATNumber, 3)
' with following and some help text prefixing it:
' "Check URL 2: " & "https://vatlayer.com/?vat_number=" & LVATNumber
LBody =_
"Order No: " & AOrderNo & NL &_
"Status: " & AStatus & NL &_
"VAT Number: " & LVATNumber & NL &_
"VAT Deducted: " & LVATDeducted & NL & NL
' (SS,10/8/16) added following
' (SS,24/8/17) added FirstName and Surname
LBody = LBody & EmailOrderVATAlertAddFields(AOrderNo, "FirstName,Surname,CompanyName,AddressLine1,AddressLine2,Town,County,Postcode,Country,DeliveryAddressSameAsInvoice,DeliveryCompanyName,DeliveryAddressLine1,DeliveryAddressLine2,DeliveryTown,DeliveryCounty,DeliveryPostcode,DeliveryCountry")
' (SS,10/8/16) removed following, replaced with check results below
' & NL &_
' "Check URL 1: " & "http://vatid.eu/check/" & Left(LVATNumber, 2) & "/" & Mid(LVATNumber, 3)& NL &_
' "For following you need to copy and paste VAT No into text box:" & NL &_
' "Check URL 2: " & "https://vatlayer.com/?vat_number=" & LVATNumber
' (SS,10/8/16) following replaces above with notes that should contain the results of the VAT check
' LBody = LBody & NL & GetOrderFieldValue(AOrderNo, "Notes")
' (SS,23/8/17) replaced above with following
LBody = LBody & NL & GetPaymentLogSection(GetOrderFieldValue(AOrderNo, "PaymentLog"), "VAT No Check")
' (SS,24/8/17) to send different subject in email if VAT No was valid or not
Dim LVATNoValid
LVATNoValid = InStr(1, LBody, "Valid: true", vbTextCompare) > 0
' (SS,24/8/17) added following to added a HTML table
LBody = GetTextAsHTMLTable(LBody, ": ", True, True, "right") ' space after : prevents the date/time field from being separated
' SendAlertEmail "VAT deducted for Intra-Community supply. VAT Number to be checked.", LBody, True
' (SS,24/8/17) above replaced by below
SendNotificationEmail "VAT deducted for Intra-Community supply. VAT Number " + iif(LVATNoValid, "Okay", "BAD"), LBody, Not LVATNoValid, True
End If
End If
End If
End Sub
' (SS,23/8/17)
Function GetVATNoCheckResults(AOrderNo)
Dim LVATCheckResult, LPaymentLog
LPaymentLog = GetOrderFieldValue(AOrderNo, "PaymentLog")
End Function
' -------------------------------------------
' End of VAT Number checking routines
' -------------------------------------------
' (SS,3/10/16)
' -------------------------------------------
' Start of Local Mode Features
' -------------------------------------------
Sub SetLocalMode(ALocalMode)
Session("LocalMode") = ALocalMode
End Sub
' checks local mode using querystring localmodekey, sets local mode to true if key matches, key will change daily
Sub CheckLocalMode
If Not LocalModeEnabled Then Exit Sub
Dim LLocalModeKey, LSQL
LLocalModeKey = CleanRequestQueryString("localmodekey")
If Not IsLocalMode And LLocalModeKey <> "" Then
' CAST AS CHAR used for whole value ensure string, else it appears as ????...
LSQL = "SELECT CAST(MD5(CONCAT('" + GetStoreName + "Salt123', CAST(CURDATE() AS CHAR))) AS CHAR) AS LocalModeKey"
'Response.Write "### LOCAL MODE KEY: " & GetSQLValueAsString(LSQL) & "###" & NL
If LLocalModeKey = GetSQLValueAsString(LSQL) Then
Response.Write "### LOCAL MODE HAS BEEN ACTIVATED ###" & NL
SetLocalMode True
End If
End If
End Sub
Function IsLocalMode
IsLocalMode = Session("LocalMode") = True ' ensure "" is treated as False
End Function
Sub GetLocalModeDetailsFromForm
Session("DeliveryCostOverride") = Trim(CleanRequestForm("DeliveryCostOverride"))
Session("DeliveryCostOverrideAmount") = Trim(CleanRequestForm("DeliveryCostOverrideAmount")) ' (SS,24/3/17)
Session("DiscountOverride") = Trim(CleanRequestForm("DiscountOverride"))
Session("Priority") = CleanRequestForm("Priority")
Session("Exchange") = CleanRequestForm("Exchange") = "checked"
Session("ExchangeReason") = Trim(CleanRequestForm("ExchangeReason"))
If Session("ExchangeReason") = COMBO_PLEASE_SELECT Then Session("ExchangeReason") = "" ' (SS,5/4/17) set to blank if "Please select..." selected
Session("Notes") = Trim(CleanRequestForm("Notes"))
' (SS,22/4/21) add following to capture LocalModeDespatchByDate (for CIRC)
If DespatchDatesEnabled Then
Session("LocalModeDespatchByDate") = CleanRequestForm("LocalModeDespatchByDate")
End If
End Sub
' clears ready for new session / order
' (SS,6/5/17) renamed from ClearLocalModeDetails to ClearLocalModeSettings
Sub ClearLocalModeSettings
'Session("DeliveryCostOverride") = Empty ' (SS,4/11/16) replaced "" with Empty
'Session("DeliveryCostOverrideAmount") = Empty ' (SS,4/4/17)
'Session("DiscountOverride") = Empty ' (SS,4/11/16) replaced "" with Empty
'Session("Priority") = Empty ' (SS,4/11/16) replaced "" with Empty
'Session("Exchange") = False
'Session("ExchangeReason") = ""
'Session("Notes") = ""
' (SS,6/4/17) replaced above with following, also retains local mode setting which is held in a session variable
If IsLocalMode Then
Session.Contents.RemoveAll()
SetLocalMode True
End If
End Sub
' (SS,1/12/16) priority is now always saved, this sets the default of 5 if it has already been assigned
Sub SetPriorityDefault(ADefaultPriority)
If IsEmpty(Session("Priority")) Then SetPriority(ADefaultPriority)
End Sub
' (SS,1/12/16) sets the priority for the order, can be called from customutils.asp
Sub SetPriority(APriority)
ShowDebug "SetPriority before: " & Session("Priority") ' (SS,12/5/22)
Session("Priority") = APriority
ShowDebug "SetPriority after: " & Session("Priority") ' (SS,12/5/22)
End Sub
' (SS,1/12/16) returns the existing priority, can be called from customutils.asp
Function GetPriority
ShowDebug "GetPriority: " & Session("Priority") ' (SS,12/5/22)
GetPriority = Session("Priority")
End Function
' (SS,22/4/21)
Function GetLocalModeDespatchByDate
GetLocalModeDespatchByDate = Session("LocalModeDespatchByDate")
End Function
' (SS,24/3/17) modified to use
Function IsDeliveryCostOverride
Dim LResult
If IsLocalMode Then
' (SS,4/11/16) added IsEmpty because IsNumeric returns True if no value yet set
'LResult = Not IsEmpty(Session("DeliveryCostOverride")) And IsNumeric(Session("DeliveryCostOverride"))
If Session("DeliveryCostOverride") = "Please select..." Then
LResult = False
ElseIf Session("DeliveryCostOverride") = "Other" Then
LResult = Not IsEmpty(Session("DeliveryCostOverrideAmount")) And IsNumeric(Session("DeliveryCostOverrideAmount"))
Else
LResult = True
End If
Else
LResult = False
End If
IsDeliveryCostOverride = LResult
End Function
' need to call IsDeliveryCostOverride first and then call this if IsDeliveryCostOverride returns true
' (SS,24/3/17) new version with ADeliveryCost paramater
Function GetDeliveryCostOverride(ADeliveryCost)
Dim LDeliveryCostOverride, LResult
LDeliveryCostOverride = Session("DeliveryCostOverride")
If LDeliveryCostOverride = "FOC" Then
LResult = 0
ElseIf LDeliveryCostOverride = "Standard delivery and collection" Then
LResult = ADeliveryCost * 2
ElseIf LDeliveryCostOverride = "Other" Then
LResult = Round2dp(Session("DeliveryCostOverrideAmount"))
Else ' i.e. "Standard delivery" or "Collection only"
LResult = ADeliveryCost
End If
GetDeliveryCostOverride = LResult
End Function
' (SS,24/3/17) new version which is now a percentage
Function IsDiscountOverride
Dim LResult
If IsLocalMode Then
If Session("DiscountOverride") <> "" Then
' (SS,23/3/17) now a percentage instead of fixed value
Dim LPercentage
LPercentage = ReplaceStr(Session("DiscountOverride"), "%", "")
LResult = IsNumeric(LPercentage)
' set to false if value is 0
If LResult Then
LResult = CInt(LPercentage) > 0
End If
Else
LResult = False
End If
Else
LResult = False
End If
IsDiscountOverride = LResult
End Function
' need to call IsDiscountOverride first and then call this if IsDiscountOverride returns true
' (SS,23/3/17) added const ASubtotal which discount override is now entered as a percentage, this as a percentage of subtotal is now returned
Function GetDiscountOverride(ASubtotal)
'GetDiscountOverride = -Round2dp(Session("DiscountOverride")) ' minus used to subtract
' (SS,23/3/17) replaced above with following
Dim LPercentage
LPercentage = CInt(ReplaceStr(Session("DiscountOverride"), "%", ""))
GetDiscountOverride = -Round2dp(ASubtotal * LPercentage / 100)
End Function
' (SS,28/3/17) called by custutils.asp when determining price
Function IsExchange
IsExchange = Session("Exchange") = True
End Function
' (SS,28/3/17) called by custutils.asp when determining price
Function GetExchangeReason
GetExchangeReason = Session("ExchangeReason")
End Function
' (SS,6/10/16) used in local mode
Function GetLocalModePaymentReference
GetLocalModePaymentReference = CleanRequestForm("paymentref")
End Function
' (SS,21/10/16) new settings for local mode
Function LocalModeEnabled
LocalModeEnabled = FLocalModeEnabled
End Function
' (SS,21/10/16) new settings for local mode
' (SS,3/8/17) added default if blank, also renamed from LocalModeExchangeReasons to GetLocalModeExchangeReasons
Function GetLocalModeExchangeReasons
If FLocalModeExchangeReasons = "" Then
GetLocalModeExchangeReasons = "Warranty (FOC),Warranty (Charged),Damaged in transit,Other"
Else
GetLocalModeExchangeReasons = FLocalModeExchangeReasons
End If
End Function
' (SS,21/10/16) new settings for local mode
' (SS,3/8/17) added default if blank, also renamed from LocalModePaymentMethods to GetLocalModePaymentMethods
Function GetLocalModePaymentMethods
If FLocalModePaymentMethods = "" Then
GetLocalModePaymentMethods = "BANK TRANSFER,CASH,CHEQUE,PAYPAL MANUAL,EPDQ,CARD OVER PHONE,CARD IN SHOP,OTHER"
Else
GetLocalModePaymentMethods = FLocalModePaymentMethods
End If
End Function
' -------------------------------------------
' End of Local Mode Features
' -------------------------------------------
' -------------------------------------------
' Start of Address Lookup Features
' -------------------------------------------
' (SS,21/10/16) new settings for address lookup
Function AddressLookupEnabled
AddressLookupEnabled = FAddressLookupEnabled
End Function
Function AddressLookupType
AddressLookupType = FAddressLookupType
End Function
Function AddressLookupAccountCode
AddressLookupAccountCode = FAddressLookupAccountCode
End Function
Function AddressLookupLocalModeOnly
AddressLookupLocalModeOnly = FAddressLookupLocalModeOnly
End Function
Sub DoAddressLookup
If Not AddressLookupEnabled Or AddressLookupType = "" Or AddressLookupAccountCode = "" Then Exit Sub
If AddressLookupLocalModeOnly And Not IsLocalMode Then Exit Sub
If AddressLookupType = "PCAPredict" Then
' ITPAR11111
%>
<script>(function (a, c, b, e) {
a[b] = a[b] || {}; a[b].initial = { accountCode: "<%=AddressLookupAccountCode%>", host: "<%=AddressLookupAccountCode%>.pcapredict.com" };
a[b].on = a[b].on || function () { (a[b].onq = a[b].onq || []).push(arguments) }; var d = c.createElement("script");
d.async = !0; d.src = e; c = c.getElementsByTagName("script")[0]; c.parentNode.insertBefore(d, c)
})(window, document, "pca", "//<%=AddressLookupAccountCode%>.pcapredict.com/js/sensor.js");
</script>
<%
End If
End Sub
' -------------------------------------------
' End of Address Lookup Features
' -------------------------------------------
' -------------------------------------------
' Start of Refund Email routines
' -------------------------------------------
' (SS,13/4/17) based on SendOrderProgressEmails, using template from site settings
' called from refund-details.asp orderno is in query string
' if cmd=email then email is sent, else output as HTML,
' (SS,5/12/18) changes to include new RefundAmount and RefundAccountLast4Digits fields
' (SS,25/1/22) added RefundID, refunds now in separate refunds table
' (SS,4/2/22) added REFUND_REF
Sub SendRefundEmail
' following taken from ShowEmailConfirmationHTML to only allow if correct details
Dim LOrderNo, LRefundID, LSessionID, LIPAddress, LSendEmail
LOrderNo = CleanRequestQueryString("orderno")
LRefundID = CleanRequestQueryString("refundid") ' (SS,25/1/22)
LSessionID = CleanRequestQueryString("sid")
LIPAddress = CleanRequestQueryString("ip")
LSendEmail = CleanRequestQueryString("cmd") = "email"
' (SS,25/1/22) added LRefundID = ""
If LOrderNo = "" Or LRefundID= "" Or LSessionID = "" Or LIPAddress = "" Then
Response.Write("Sorry, not enough info to show refund details<br>")
Exit Sub
End If
' check if order has refund amount
' calculate goods refund and vat from refund vat
' replace tokens in template and send email (to same address as order confirmation)
CONST TEST_MODE = 0 ' can be 0 for off, 1 for log and emails to test account, 2 for log only, 3 log soon in browser not emailed
Const LOGO_FILE_NAME = "logo-email.png"
Dim LAttachLogoFileName, LTemplateTitle, LTemplateSubject, LSubject, LTemplateBody, LSQL
Dim LBCC, LBCC2, LFrom
Dim LTemplateBCC, LTemplateBCC2, LTemplateFrom
Dim LOrderDate, LTitle, LFirstName, LSurname, LName, LEmailAddress, LBody
' (SS,25/1/22) removed LVATRate, LVATIncluded, LGoodsRefunded, LVATRefunded, LGrandTotal,
' added LRefundNet and LRefundVAT
Dim LRefundDate, LRefundDetails, LRefundAmount, LRefundNet, LRefundVAT
' (SS,5/12/18)
Dim LRefundMethod, LRefundAccountLast4Digits
' get body of template (also check it exists)
LTemplateBody = GetSiteDetail("Other", "RefundEmailTemplate")
Do ' null loop for logic short-circuit (bit like a continue)
If LTemplateBody = "" Then Exit Do
' extract BCC, FROM, SUBJECT, MIN DESPATCH DAYS, WORKINGS DAY SINCE ORDER from template
LTemplateTitle = ExtractSettingFromTemplate(LTemplateBody, "TITLE")
LTemplateSubject = ExtractSettingFromTemplate(LTemplateBody, "SUBJECT")
LTemplateSubject = ReplaceStr(LTemplateSubject, "{STORE_NAME}", GetStoreName)
LTemplateBCC = ExtractSettingFromTemplate(LTemplateBody, "BCC")
LTemplateFrom = ExtractSettingFromTemplate(LTemplateBody, "FROM")
' replace template variables that weren't change for each order
' "if" to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LTemplateBody, "{LOGO}") > 0 Then
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
LAttachLogoFileName = LOGO_FILE_NAME
Else
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LAttachLogoFileName = ""
End If
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_URL}", GetStoreURL)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_NAME}", GetStoreName)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_EMAIL}", GetStoreEmail)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_TELEPHONE}", GetStoreTelephone)
' sort email bcc and from addresses, because we might be overriding the standard ones
If LTemplateFrom = "" Then LTemplateFrom = FEmailOrderConfirmationFrom
If LTemplateBCC = "" Then
LTemplateBCC = FEmailOrderConfirmationBcc1
ElseIf LTemplateBCC = "NONE" Then ' if NONE then don't send BCC
LTemplateBCC = ""
End If
LTemplateBCC2 = FEmailOrderConfirmationBcc2
' (SS,20/4/17) removed VATDeducted, CurrencyCode, ExchangeRate
' (SS,5/12/18) added RefundMethod and RefundAccountLast4Digits
' (SS,25/1/22) added join to refunds table where the refund fields are now, also added RefundID to WHERE clause and SELECT, also added RefundNet and RefundVAT, added orders. prefix to OrderNo
' (SS,4/2/22) added RefundNo
LSQL = "SELECT orders.OrderNo, DATE(DateTimeOrdered) AS OrderDate, Title, FirstName, Surname, EmailAddress, RefundID, RefundNo, RefundDate, RefundAmount, RefundNet, RefundVAT, RefundDetails, RefundMethod, RefundAccountLast4Digits, VATIncluded, GrandTotal FROM orders"_
& " INNER JOIN refunds ON refunds.OrderNo AND orders.OrderNo"_
& " WHERE orders.OrderNo = '" & CleanSQLStr(LOrderNo) & "'"_
& " AND RefundID = '" & CleanSQLStr(LRefundID) & "'"_
& " AND SessionID = '" & CleanSQLStr(LSessionID) & "'"_
& " AND IPAddress = '" & CleanSQLStr(LIPAddress) & "'"
OpenQuery(LSQL)
If EndOfQuery Then
Response.Write("Sorry, not enough credentials to show order details<br>")
Exit Do
Else
' (SS,13/4/17) handle currency
' (SS,19/4/17) removed to force GBP because exchange rate may be different due to refund issued at a later date
'Dim LCurrencyCode
'LCurrencyCode = GetFieldValue("CurrencyCode")
'SetCurrencyRate(CDbl(GetFieldValue("ExchangeRate")))
'SetCurrencyCode(LCurrencyCode) ' (SS,28/10/09) added this to correct pound symbol incorrectly appearing in HTML emails when non UK currency
'SetCurrencySymbol(LCurrencyCode) ' (SS,28/10/09) sets the currency symbol
' LOrderNo = GetQueryField("OrderNo")
LOrderDate = GetQueryField("OrderDate")
LTitle = Trim(GetQueryField("Title"))
LFirstName = Trim(GetQueryField("FirstName"))
LSurname = Trim(GetQueryField("Surname"))
LName = Trim(LTitle & IIf(LTitle = "", "", " ") & LFirstName & IIf(LFirstName = "", "", " ") & LSurname)
LEmailAddress = GetQueryField("EmailAddress")
' (SS,25/1/22) removed following
'LVATIncluded = GetQueryField("VATIncluded")
'LGrandTotal = GetQueryField("GrandTotal")
LRefundDate = GetQueryField("RefundDate")
LRefundAmount = Round2dp(GetQueryField("RefundAmount"))
LRefundDetails = GetQueryField("RefundDetails")
' (SS,5/12/18)
LRefundMethod = GetQueryField("RefundMethod")
LRefundAccountLast4Digits = GetQueryField("RefundAccountLast4Digits")
' calculate goods refunded and VAT refunded
' (SS,25/1/22) removed VAT rate, no longer applicable
'LVATRate = Round2dp(LVATIncluded / (LGrandTotal - LVATIncluded)) ' VAT rate calculated from VAT amount of order
'LGoodsRefunded = Round2dp(LRefundAmount / (1 + LVATRate))
'LVATRefunded = Round2dp(LRefundAmount - LGoodsRefunded)
' (SS,25/1/22) replaced above with following, values now held as fields in refunds table
LRefundNet = Round2dp(GetQueryField("RefundNet"))
LRefundVAT = Round2dp(GetQueryField("RefundVAT"))
' format for display
' (SS,25/1/22) renamed LGoodsRefunded to LRefundNet, LVATRefunded to LRefundVAT
LRefundAmount = CorrectCurrencyActual(LRefundAmount, True)
LRefundNet = CorrectCurrencyActual(LRefundNet, True)
LRefundVAT = CorrectCurrencyActual(LRefundVAT, True)
' send the email (test mode, 0 = normal, 1 = log and send emails to test account, 2 = log only)
LBody = LTemplateBody
' replace order specific template values
LSubject = ReplaceStr(LTemplateSubject, "{ORDER_NO}", LOrderNo)
LBody = ReplaceStr(LBody, "{ORDER_NO}", LOrderNo)
LBody = ReplaceStr(LBody, "{ORDER_DATE}", LOrderDate)
LBody = ReplaceStr(LBody, "{NAME}", LName)
LBody = ReplaceStr(LBody, "{REFUND_ID}", LRefundID) ' (SS,25/1/22)
LBody = ReplaceStr(LBody, "{REFUND_DATE}", LRefundDate)
LBody = ReplaceStr(LBody, "{REFUND_AMOUNT}", LRefundAmount)
LBody = ReplaceStr(LBody, "{REFUND_DETAILS}", ConvertNewlinesToHTML(LRefundDetails))
' (SS,25/1/22) renamed LGoodsRefunded to LRefundNet, LVATRefunded to LRefundVAT
LBody = ReplaceStr(LBody, "{GOODS_REFUNDED}", LRefundNet)
LBody = ReplaceStr(LBody, "{VAT_REFUNDED}", LRefundVAT)
' (SS,25/1/22) following are replacements for above, above kept for backward compatibility
LBody = ReplaceStr(LBody, "{REFUND_NET}", LRefundNet)
LBody = ReplaceStr(LBody, "{REFUND_VAT}", LRefundVAT)
' (SS,4/2/22) added following
LBody = ReplaceStr(LBody, "{REFUND_REF}", LOrderNo & "-" & GetQueryField("RefundNo") & "-" & GetQueryField("RefundID"))
LBody = ReplaceStr(LBody, "{VAT_REG_NO}", GetStoreVATRegNo)
' (SS,5/12/18) added following two
LBody = ReplaceStr(LBody, "{REFUND_METHOD}", LRefundMethod)
LBody = ReplaceStr(LBody, "{REFUND_ACCOUNT_LAST_4_DIGITS}", LRefundAccountLast4Digits)
' send the email with embedded logo, if not test mode or test mode 1
If TEST_MODE = 0 Or TEST_MODE = 1 Then
' if test mode 1 then send email to test address, set the BCCs for normal and test mode
LFrom = LTemplateFrom
If TEST_MODE = 0 Then
LBCC = LTemplateBCC
LBCC2 = LTemplateBCC2
Else ' i.e. 1
LEmailAddress = LTemplateBCC2
LBCC = ""
LBCC2 = ""
End If
' debug code to show email addresses
'Response.Write "LEmailAddress: " & LEmailAddress & BR
'Response.Write "LBCC: " & LBCC & BR
'Response.Write "LBCC2: " & LBCC2 & BR
'Response.Write "LFrom: " & LFrom & BR
If LEmailAddress <> "" And LSendEmail Then
SendEmailByCDO LEmailAddress, LBCC, LBCC2, LFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
Response.Write LBody
Else
Response.Write LBody
End If
End If
End If
Loop While False ' end of null loop
CloseQuery
End Sub
' -------------------------------------------
' End of Refund Email routines
' -------------------------------------------
' -------------------------------------------
' Start of Payment Received Email routines
' -------------------------------------------
' (SS,11/8/17) based on SendRefundEmail above, using template from site settings
' called from payment-received-email.asp orderno is in query string
' if cmd=email then email is sent, else output as HTML,
' (!!!**** I'm aware of the repeated code, perhaps in future commonise some of the code with SendRefundEmail)
Sub SendPaymentReceivedEmail
' following taken from ShowEmailConfirmationHTML to only allow if correct details
Dim LOrderNo, LSessionID, LIPAddress, LSendEmail
LOrderNo = CleanRequestQueryString("orderno")
LSessionID = CleanRequestQueryString("sid")
LIPAddress = CleanRequestQueryString("ip")
LSendEmail = CleanRequestQueryString("cmd") = "email"
If LOrderNo = "" Or LSessionID = "" Or LIPAddress = "" Then
Response.Write("Sorry, not enough info to show payment details<br>")
Exit Sub
End If
' check if order has refund amount
' calculate goods refund and vat from refund vat
' replace tokens in template and send email (to same address as order confirmation)
CONST TEST_MODE = 0 ' can be 0 for off, 1 for log and emails to test account, 2 for log only, 3 log soon in browser not emailed
Const LOGO_FILE_NAME = "logo-email.png"
Dim LAttachLogoFileName, LTemplateTitle, LTemplateSubject, LSubject, LTemplateBody, LSQL
Dim LBCC, LBCC2, LFrom
Dim LTemplateBCC, LTemplateBCC2, LTemplateFrom
Dim LOrderDate, LTitle, LFirstName, LSurname, LName, LEmailAddress, LBody
Dim LPaymentAmount
' get body of template (also check it exists)
LTemplateBody = GetSiteDetail("Other", "PaymentReceivedEmailTemplate")
Do ' null loop for logic short-circuit (bit like a continue)
If LTemplateBody = "" Then Exit Do
' extract BCC, FROM, SUBJECT, MIN DESPATCH DAYS, WORKINGS DAY SINCE ORDER from template
LTemplateTitle = ExtractSettingFromTemplate(LTemplateBody, "TITLE")
LTemplateSubject = ExtractSettingFromTemplate(LTemplateBody, "SUBJECT")
LTemplateSubject = ReplaceStr(LTemplateSubject, "{STORE_NAME}", GetStoreName)
LTemplateBCC = ExtractSettingFromTemplate(LTemplateBody, "BCC")
LTemplateFrom = ExtractSettingFromTemplate(LTemplateBody, "FROM")
' replace template variables that weren't change for each order
' "if" to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LTemplateBody, "{LOGO}") > 0 Then
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
LAttachLogoFileName = LOGO_FILE_NAME
Else
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LAttachLogoFileName = ""
End If
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_URL}", GetStoreURL)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_NAME}", GetStoreName)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_EMAIL}", GetStoreEmail)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_TELEPHONE}", GetStoreTelephone)
' sort email bcc and from addresses, because we might be overriding the standard ones
If LTemplateFrom = "" Then LTemplateFrom = FEmailOrderConfirmationFrom
If LTemplateBCC = "" Then
LTemplateBCC = FEmailOrderConfirmationBcc1
ElseIf LTemplateBCC = "NONE" Then ' if NONE then don't send BCC
LTemplateBCC = ""
End If
LTemplateBCC2 = FEmailOrderConfirmationBcc2
LSQL = "SELECT OrderNo, DATE(DateTimeOrdered) AS OrderDate, DATE(DateTimePaid) AS PaymentDate, Title, FirstName, Surname, EmailAddress, GrandTotal, PaymentReceived, PaymentMethod, PaymentReference, DefaultPaymentCurrencyCode, DefaultPaymentCurrencyRate FROM orders WHERE OrderNo = '" _
& CleanSQLStr(LOrderNo) & "' AND SessionID = '" + CleanSQLStr(LSessionID) + "' AND IPAddress = '" + CleanSQLStr(LIPAddress) + "' AND PaymentReceived = TRUE"
OpenQuery(LSQL)
If EndOfQuery Then
Response.Write("Sorry, not enough credentials to show payment details<br>")
Exit Do
Else
' (SS,1/8/17) set the currency code, rate, symbols for calls to CorrectCurrencyActual etc to work correctly to show the values using the actual historical currency and exchange rate
SetCurrencyForOrder GetFieldValue("DefaultPaymentCurrencyCode"), GetFieldValue("DefaultPaymentCurrencyRate")
' LOrderNo = GetQueryField("OrderNo")
LOrderDate = GetQueryField("OrderDate")
LTitle = Trim(GetQueryField("Title"))
LFirstName = Trim(GetQueryField("FirstName"))
LSurname = Trim(GetQueryField("Surname"))
LName = Trim(LTitle & IIf(LTitle = "", "", " ") & LFirstName & IIf(LFirstName = "", "", " ") & LSurname)
LEmailAddress = GetQueryField("EmailAddress")
' format for display
LPaymentAmount = CorrectCurrencyActual(GetQueryField("GrandTotal"), True)
' send the email (test mode, 0 = normal, 1 = log and send emails to test account, 2 = log only)
LBody = LTemplateBody
' replace order specific template values
LSubject = ReplaceStr(LTemplateSubject, "{ORDER_NO}", LOrderNo)
LBody = ReplaceStr(LBody, "{ORDER_NO}", LOrderNo)
LBody = ReplaceStr(LBody, "{ORDER_DATE}", LOrderDate)
LBody = ReplaceStr(LBody, "{NAME}", LName)
LBody = ReplaceStr(LBody, "{PAYMENT_DATE}", GetQueryField("PaymentDate"))
LBody = ReplaceStr(LBody, "{PAYMENT_METHOD}", GetQueryField("PaymentMethod"))
LBody = ReplaceStr(LBody, "{PAYMENT_REFERENCE}", Trim(GetQueryField("PaymentReference")))
LBody = ReplaceStr(LBody, "{PAYMENT_AMOUNT}", LPaymentAmount)
LBody = ReplaceStr(LBody, "{VAT_REG_NO}", GetStoreVATRegNo)
' send the email with embedded logo, if not test mode or test mode 1
If TEST_MODE = 0 Or TEST_MODE = 1 Then
' if test mode 1 then send email to test address, set the BCCs for normal and test mode
LFrom = LTemplateFrom
If TEST_MODE = 0 Then
LBCC = LTemplateBCC
LBCC2 = LTemplateBCC2
Else ' i.e. 1
LEmailAddress = LTemplateBCC2
LBCC = ""
LBCC2 = ""
End If
' debug code to show email addresses
'Response.Write "LEmailAddress: " & LEmailAddress & BR
'Response.Write "LBCC: " & LBCC & BR
'Response.Write "LBCC2: " & LBCC2 & BR
'Response.Write "LFrom: " & LFrom & BR
If LEmailAddress <> "" And LSendEmail Then
SendEmailByCDO LEmailAddress, LBCC, LBCC2, LFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
Response.Write LBody
Else
Response.Write LBody
End If
End If
End If
Loop While False ' end of null loop
CloseQuery
End Sub
' -------------------------------------------
' End of Payment Received Email routines
' -------------------------------------------
' (SS,21/7/17) returns GrandTotal for given order no, used in new bank transfer payment options
Function GetGrandTotalForOrder(AOrderNo)
GetGrandTotalForOrder = GetOrderFieldValue(AOrderNo, "GrandTotal")
End Function
' (SS,21/7/17)
Sub UpdateOrderDefaultPaymentCurrency(AOrderNo, ADefaultPaymentCurrencyCode)
' get the latest adjusted currency rate
Dim LDefaultPaymentCurrencyRate, LCurrencySymbol
GetCurrencyExchangeRateAdjusted ADefaultPaymentCurrencyCode, LDefaultPaymentCurrencyRate, LCurrencySymbol
' save it in order record
ExecuteQuery("UPDATE orders " &_
"SET DefaultPaymentCurrencyCode='" & CleanSQLStr(ADefaultPaymentCurrencyCode) & "'" &_
", DefaultPaymentCurrencyRate='" & CleanSQLStr(LDefaultPaymentCurrencyRate) & "'" &_
" WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
End Sub
' (SS,21/7/17) update the bank transfer details to display on form
Sub UpdateBankTransferDetails(AOrderNo)
' following also exists in Sub ShowOrderDetails(AInCheckout, AOrderNo)
' need to open the orders record the get the fields referred to by GetBankTransferPaymentLine, GetBankTransferDetailsAsHTML, messy I know
' (SS,29/9/17) added Country field, required by GetBankTransferDetailsAsHTML, then decided to have the whole record,
' replaced "OrderNo, GrandTotal, CurrencyCode, ExchangeRate, DefaultPaymentCurrencyCode, DefaultPaymentCurrencyRate, ExchangeRate, GrandTotal, Country" with *
OpenQuery("SELECT * FROM Orders WHERE orderNo = '" & CleanSQLStr(AOrderNo) & "'")
Session("BankTransferPaymentLine") = GetBankTransferPaymentLine
Session("BankTransferDetails") = GetBankTransferDetailsAsHTML
CloseQuery
End Sub
' -------------------------------------------
' Start of SMS routines
' -------------------------------------------
' (SS,20/3/18)
' get phone number from order, or pass phone no here
' (SS,2/12/21) added 4 new parameters to allow 2 tokens to be replaced
' These are: ATokenName1, ATokenValue1, ATokenName2, ATokenValue2
' Set these to "" if not used, TokenName should be without the curly brackets
Sub SendSMS(AOrderNo, ASMSType, ATokenName1, ATokenValue1, ATokenName2, ATokenValue2)
Dim LTemplateName, LTemplateBody, LTelephone, LTo, LFrom, LSubject
' exit if SMSs are not enabled
If Not SMSEnabled Then Exit Sub
' default to same template name as ASMSType e.g. "Order Confirmation", "Order Progress", "Anticipated Despatch/Update", "Order Despatched", "Review Request"
LTemplateName = ASMSType
' if custom routine exists then call to check if SMS is necessary, if "" is returned then exit
' e.g. routine could check if customer orders a particular item, e.g. a radiator for CIRC
' Routine may also return the name of the template to use, i.e. used to override the default chosen by ASMSType
If FunctionExists("CustomCheckSMS") Then
LTemplateName = CustomCheckSMS(AOrderNo, ASMSType)
If LTemplateName = "" Then
Exit Sub
End If
End If
' get template and exit if empty
LTemplateBody = Trim(GetSiteDetail("SMS Templates", LTemplateName))
If LTemplateBody = "" Then Exit Sub
' get phone no and check if mobile, exit if not, CleanNum function strips everything except numbers
LTelephone = CleanNum(GetOrderFieldValue(AOrderNo, "Telephone"))
If Not TelephoneIsMobile(LTelephone) Then Exit Sub
' replace tokens in template with values e.g. ORDER_NO
LTemplateBody = ReplaceStr(LTemplateBody, "{ORDER_NO}", AOrderNo)
' (SS,2/12/21) added following to replace additional tokens if set
If ATokenName1 <> "" Then
LTemplateBody = ReplaceStr(LTemplateBody, "{" & ATokenName1 & "}", ATokenValue1)
End If
If ATokenName2 <> "" Then
LTemplateBody = ReplaceStr(LTemplateBody, "{" & ATokenName2 & "}", ATokenValue2)
End If
' send the SMS message, via Textlocal
LTo = LTelephone + "@txtlocal.co.uk"
' LTo = "surinder@itpartnership.com"
' From used (for security) is sms + last 4 digits of store telephone and normal email from address e.g. sms8603shoppingtest@itpartnership.com
LFrom = "sms" & Trim(Right(GetStoreTelephone, 4)) & FEmailOrderConfirmationFrom
LSubject = "SMS from " & GetStoreName & " - " & ASMSType & " - " & AOrderNo
SendEmailByCDO LTo, FEmailOrderConfirmationBcc1, FEmailOrderConfirmationBcc2, LFrom, LSubject, LTemplateBody, "", False, "", ""
End Sub
' (SS,20/3/18)
Function SMSEnabled
SMSEnabled = FSMSEnabled
End Function
' (SS,20/3/18)
Function TelephoneIsMobile(ATelephone)
TelephoneIsMobile = Left(ATelephone, 2) = "07" Or Left(ATelephone, 3) = "447" Or Left(ATelephone, 4) = "4407"
End Function
' -------------------------------------------
' End of SMS routines
' -------------------------------------------
' -------------------------------------------
' Start of Subscription Routines
' -------------------------------------------
' (SS,23/5/18)
Sub DoSubscribe
Dim LCustomerID, LEmail, LOptin
LCustomerID = CleanRequestQueryString("id")
LEmail = CleanRequestQueryString("email")
LOptin = CleanRequestQueryString("optin")
ShowSubscribeHeader
If SetCustomerSubscribed(LCustomerID, LEmail, LOptin = "yes") Then
ShowCustomerSubscription LCustomerID
Else
Response.Write "Failed to change subscription setting."
End If
ShowSubscribeFooter
End Sub
Function GetCustomerIDForOrder(AOrderNo)
GetCustomerIDForOrder = GetOrderFieldValue(AOrderNo, "CustomerID")
End Function
Function IsCustomerOptedIn(ACustomerID)
IsCustomerOptedIn = StrToBool(GetSQLValueAsString("SELECT Subscribe FROM customers WHERE CustomerID = '" & CleanSQLStr(ACustomerID) & "'"))
End Function
' set the subscribed field for given customer to given value, only if customer ID and email address matches. True is returned if change was made.
Function SetCustomerSubscribed(ACustomerID, AEmail, ASubscribe)
Dim LResult
LResult = GetSQLRecordExists("SELECT * FROM customers WHERE CustomerID = '" & CleanSQLStr(ACustomerID) & "' AND EmailAddress = '" & CleanSQLStr(AEmail) & "'")
If LResult Then ExecuteQuery("UPDATE customers SET Subscribe = " & IIF(ASubscribe, "TRUE", "FALSE") & " WHERE CustomerID = '" & CleanSQLStr(ACustomerID) & "'")
SetCustomerSubscribed = LResult
End Function
' AValue is True for Subscribe link, False for Unsubscribe link
Function GetSubscribeLink(ACustomerID, ASubscribe)
Dim LURL, LEmail, LOptin
LURL = ""
If ACustomerID <> "" Then
LEmail = GetSQLValueAsString("SELECT EmailAddress FROM customers WHERE CustomerID = '" & CleanSQLStr(ACustomerID) & "'")
If LEmail <> "" Then
If ASubscribe Then
LOptin = "yes"
Else
LOptin = "no"
End If
LURL = GetStoreURL & "/products.asp?page=account&cmd=subscribe&id=" & ACustomerID & "&email=" & URLEncode(LEmail) & "&optin=" & LOptin
End If
End If
GetSubscribeLink = LURL
End Function
' -------------------------------------------
' End of Subscription Routines
' -------------------------------------------
' -------------------------------------------
' Start of Delivery Options / Tracked Delivery Routines
' -------------------------------------------
' (SS,28/6/18)
' !!! need to set delivery option string or clear it depending on this selection
' AllowTrackedDeliverySelection(Session("DeliveryCountry"), APostalArea, ASubtotal)
' (SS,22/4/21) added expedited option, new routines SetExpeditedDeliverySelected, GetExpeditedDeliverySelected,
' SetExpeditedDeliverySelectionAllowed, GetExpeditedDeliverySelectionAllowed
' SetUntrackedDeliverySelectionAllowed, GetUntrackedDeliverySelectionAllowed
Function TrackedDeliveryOptionEnabled
TrackedDeliveryOptionEnabled = IsHyperFlight ' only enabled for HyperFlight
End Function
Sub SetTrackedDeliverySelected(ASelected)
Session("TrackedDeliverySelected") = ASelected
End Sub
Function GetTrackedDeliverySelected
GetTrackedDeliverySelected = Session("TrackedDeliverySelected") = True
End Function
Sub SetTrackedDeliverySelectionAllowed(AAllowed)
Session("TrackedDeliverySelectionAllowed") = AAllowed
End Sub
Function GetTrackedDeliverySelectionAllowed
GetTrackedDeliverySelectionAllowed = Session("TrackedDeliverySelectionAllowed") = True
End Function
' (SS,22/4/21) added due to adding expedited selection
Function GetUntrackedDeliverySelected
GetUntrackedDeliverySelected = Not GetTrackedDeliverySelected And Not GetExpeditedDeliverySelected
End Function
' (SS,22/4/21) added due to adding expedited selection
Function SetUntrackedDeliverySelectionAllowed(AAllowed)
Session("UntrackedDeliverySelectionAllowed") = AAllowed
End Function
' (SS,22/4/21) added due to adding expedited selection
Function GetUntrackedDeliverySelectionAllowed
GetUntrackedDeliverySelectionAllowed = Session("UntrackedDeliverySelectionAllowed") = True
End Function
' (SS,22/4/21)
Sub SetExpeditedDeliverySelected(ASelected)
Session("ExpeditedDeliverySelected") = ASelected
End Sub
' (SS,22/4/21)
Function GetExpeditedDeliverySelected
GetExpeditedDeliverySelected = Session("ExpeditedDeliverySelected") = True
End Function
' (SS,22/4/21)
Sub SetExpeditedDeliverySelectionAllowed(AAllowed)
Session("ExpeditedDeliverySelectionAllowed") = AAllowed
End Sub
' (SS,22/4/21)
Function GetExpeditedDeliverySelectionAllowed
GetExpeditedDeliverySelectionAllowed = Session("ExpeditedDeliverySelectionAllowed") = True
End Function
' (SS,29/4/21) corrected from Function to Sub
Sub SetDeliveryOption(ADeliveryOption)
ShowDebug "SetDeliveryOption before: " & Session("DeliveryOption") ' (SS,12/5/22)
Session("DeliveryOption") = ADeliveryOption
ShowDebug "SetDeliveryOption after: " & Session("DeliveryOption") ' (SS,12/5/22)
End Sub
Function GetDeliveryOption
ShowDebug "GetDeliveryOption before: " & Session("DeliveryOption") ' (SS,12/5/22)
' (SS,29/4/21) following for HyperFlight only, set delivery info if customer is collecting, adding to order
' a bit messy adding it here, but reason for adding here instead of CustomGetDelivery is because this isn't called when GetDeliveryWillCollect
If IsHyperFlight Then
If GetDeliveryWillCollect Then
SetDeliveryOption("Collection")
ElseIf GetDeliveryAddToExistingOrder Then
SetDeliveryOption("Add To Previous")
End If
End If
ShowDebug "GetDeliveryOption after: " & Session("DeliveryOption") ' (SS,12/5/22)
GetDeliveryOption = Session("DeliveryOption")
End Function
' (SS,29/3/22) returns true if ADeliveryOption contains untracked
Function IsDeliveryOptionUntracked(ADeliveryOption)
IsDeliveryOptionUntracked = InStr(1, ADeliveryOption, "untracked", 1) > 0
End Function
Function GetCountryOptions(ACountry)
GetCountryOptions = GetSQLValueAsString("SELECT Options FROM countries WHERE Country = '" + CleanSQLStr(ACountry) + "'")
End Function
' -------------------------------------------
' End of Tracked Delivery Routines
' -------------------------------------------
' (SS,1/8/18) added following for more options info, i.e. for CIRC
' returns the original options list with extra added to the end if applicable
' current shown only in the basket page, quotation emails and order confirmation emails.
Function AddMoreOptionsInfo(AProductID, AOptionsList)
Dim LResult
' only add if add custom function exists
If FunctionExists("CustomAddMoreOptionsInfo") Then
LResult = CustomAddMoreOptionsInfo(AProductID, AOptionsList)
Else
LResult = AOptionsList ' default to returning what we already have
End If
AddMoreOptionsInfo = LResult
End Function
' -------------------------------------------
' Start of Image / Picture Naming Routines
' -------------------------------------------
' Moved all image URL fetching routines to this new section
' Written to optionally fetch using full JPG file name from cache
' Following routines now removed, no longer used since new RWD framework:
' Function GetProductLinkWithImageNo
' Sub ShowHomePagePictures
' Sub GetProductPictureSize
' Function GetProductImageLinkWithImageNo
' Sub ShowRelatedProductsOldVersion_to_be_deleted
'
' Removed references to strImageNo and imgno from
' Sub ProductsMain and Function GetProductLink
' Also Dim strImageNo removed
' (SS,7/8/18) a setting which returns True to use GetPic.asp (default), else False i.e. JPG saved from database int images/products/ are used instead
Function UseGetPicASP
UseGetPicASP = FUseGetPicASP
End Function
' (SS,18/5/07) added CleanSQLStr to SQL error when category/subcategory contains quote (")
' (SS,12/6/12) added CleanSQLStr before AType to prevent SQL injection
Function PictureExists(AType, ACode, ACode2)
Dim LWhereCode2
If ACode2 <> "" Then
LWhereCode2 = " AND Code2 = """ & CleanSQLStr(ACode2) & """"
Else
LWhereCode2 = ""
End If
OpenQuery2("SELECT Type, Code, Code2 FROM pictures WHERE Type = '" + CleanSQLStr(AType) + "' AND Code = """ & CleanSQLStr(ACode) & """" + LWhereCode2)
PictureExists = Not EndOfQuery2
CloseQuery2
End Function
' (SS,6/7/06) new
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
' (SS,11/9/14) new version which works with new pictures table schema, i.e. Code2 not longer used for imageno, SortOrder used instead to order the pictures
' we need to keep the imageno working for old sites, i.e. ExpressMusic
' (SS,7/8/18) modified to allow saved/cached images in actual .jpg files to be used
' to help with SEO, speed up images, allowing web server to manage the images better
' also more SEO friendly names used, removed redundant code referring to strImageNo
Function GetProductImageLink(AProductCode, ASize)
Dim LResult
' (SS,7/8/18) added If UseGetPicASP
If UseGetPicASP Then
LResult = "getpic.asp?size=" + ASize + "&code=" & Server.URLEncode(AProductCode)
Else ' (SS,7/8/18) new method to use JPG file names
' (SS,7/4/19) new version
LResult = GetImageName("P", AProductCode, "", "", ASize)
End If
GetProductImageLink = LResult
End Function
' (SS,5/4/19) new, returns either getpic or jpg image from cache (called from inc-template-category-list.asp)
Function GetCategoryImageLink(ACategory, ASize)
Dim LResult
If UseGetPicASP Then
LResult = "getpic.asp?type=c&size=" & ASize & "&code=" & Server.URLEncode(ACategory)
Else
LResult = GetImageName("C", ACategory, "", "", ASize)
End If
GetCategoryImageLink = LResult
End Function
' (SS,5/4/19) new, returns either getpic or jpg image from cache (called from inc-template-subcategory-list.asp)
Function GetSubcategoryImageLink(ACategory, ASubcategory, ASize)
Dim LResult
If UseGetPicASP Then
LResult = "getpic.asp?type=s&size=" & ASize & "&code=" & Server.URLEncode(ACategory) & "&code2=" & Server.URLEncode(ASubcategory)
Else
LResult = GetImageName("S", ACategory, ASubcategory, "", ASize)
End If
GetSubcategoryImageLink = LResult
End Function
' (SS,13/12/13) for product option value pictures when radio type used
' (SS,9/6/17) added ASize parameter which can be o, s or l
' (SS,5/4/19) modified to allow saved/cached images in actual .jpg files to be used
Function GetProductOptionValueImageLink(AProductOptionValueID, ASize)
Dim LResult
' (SS,5/4/19) added If UseGetPicASP
If UseGetPicASP Then
' (SS,9/6/17) replaced o with ASize
LResult = "getpic.asp?type=ov&size=" & ASize &"&code=" & AProductOptionValueID
Else ' (SS,5/4/18) new method to use JPG file names
LResult = GetImageName("OV", AProductOptionValueID, "", "", ASize)
End If
GetProductOptionValueImageLink = LResult
End Function
' (SS,10/8/11) used by "Facebook like" in meta tag
Function GetFullProductImageLink(AProductCode, ASize)
GetFullProductImageLink = GetStoreURL + "/" + GetProductImageLink(AProductCode, ASize)
End Function
' (SS,22/8/14) returns image link using APictureID
' (SS,7/8/18) modified to make use of more friendly URLs i.e. JPG image files
' call to UseGetPicASP decide which to use
Function GetProductImageLinkForPictureID(APictureID, ASize)
Dim LResult
If UseGetPicASP Then
LResult = "getpic.asp?id=" & APictureID & "&size=" & ASize
Else
LResult = GetImageName("P", "", "", APictureID, ASize)
End If
GetProductImageLinkForPictureID = LResult
End Function
' (SS,17/5/07) new *** to be replaced with more flexible version which has class and width
' (SS,8/8/18) modified to allow actual JPG files to be used if UseGetPicASP is False
Function GetProductImgSrcThumbnailSmall(AProductCode, AProductName)
' GetProductImgSrcThumbnailSmall = "<img src=""getpic.asp?code=" & Server.URLEncode(AProductCode) & """ alt=""" & Server.URLEncode(AProductName) & " (" & AProductCode & ")"" class=""thumbnailsmall"">"
' (SS,8/8/18) replaced above with following to also handle full JPG file names
Dim LLink
If UseGetPicASP Then
LLink = "getpic.asp?code=" & Server.URLEncode(AProductCode)
Else
LLink = GetProductImageLink(AProductCode, "s")
End If
GetProductImgSrcThumbnailSmall = "<img src=""" & LLink & """ alt=""" & Server.URLEncode(AProductName) & " (" & AProductCode & ")"" class=""thumbnailsmall"">"
End Function
' (SS,6/7/11) new get image function, which has class and width
' ASize, AAlt, AClass and AWidth are ignored if blank
' (SS,19/7/11) added AOptions, "t" in options means add title attribute from Alt
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
' (SS,8/8/18) modified to allow actual JPG files to be used if UseGetPicASP is False
Function GetProductImgSrc(AProductCode, ASize, AAlt, AClass, AWidth, AOptions)
Dim LResult, LLink
If UseGetPicASP Then
LLink = "getpic.asp?"
If ASize <> "" Then LLink = LLink & "size=" & ASize & "&"
LLink = LLink & "code=" & Server.URLEncode(AProductCode)
Else
LLink = GetProductImageLink(AProductCode, ASize)
End If
LResult = "<img src=""" & LLink & """"
If AAlt <> "" Then
LResult = LResult & " alt=""" & Server.HTMLEncode(AAlt) & """" ' Server.HTMLEncode allows quotes to be included in the string
If InStr(1, AOptions, "t", 1) > 0 Then LResult = LResult & " title=""" & Server.HTMLEncode(AAlt) & """" ' Server.HTMLEncode allows quotes to be included in the string
End If
If AClass <> "" Then LResult = LResult & " class=""" & AClass & """"
If AWidth <> "" Then LResult = LResult & " width=""" & AWidth & """"
LResult = LResult & " />"
GetProductImgSrc = LResult
End Function
' (SS,8/11/07)
' (SS,17/1/13) replaced & with & to reduce HTML errors in http://validator.w3.org
' (SS,5/4/19) added UseGetPicASP to return jpg image from cache
Function GetStoreLogoLink
Dim LResult
If UseGetPicASP Then
LResult = "getpic.asp?type=o&size=o&code=StoreLogo"
Else
LResult = GetImageName("O", "StoreLogo", "", "", "o")
End If
GetStoreLogoLink = LResult
End Function
' (SS,7/8/18)
' if caption missing use sort order?
' for first main image, perhaps don't use caption added to it
' for large thumbnail there's no suffix, for small use "_thm", for original use "_org"
' perhaps don't make lower case as (see https://www.shopify.com/blog/7412852-10-must-know-image-optimization-tips)
' returns friendly image name for given size
' (SS,29/8/19) basket page was showing largest "o" image due to size being set to "". Modified so that "" results in the smallest thumbnail. This was the default for getpic.asp
Function GetSEOFriendlyImageName(LImageName, ASize)
' for main image ASize "o" use no suffix
' for small thumbnail, "s" use width and w as suffix
' for large thumbnail, "l" use width and w as suffix
' (SS,29/8/19) modified so that "s" or "" or any other is the small thumbnail
Dim LSuffix
If ASize = "o" then
LSuffix = ""
ElseIf ASize = "l" then
LSuffix = "-" & LargeThumbnailWidth & "w"
Else ' i.e. "s" or ""
LSuffix = "-" & SmallThumbnailWidth & "w"
End If
GetSEOFriendlyImageName = SEOFriendlyStr(LImageName) + LSuffix + ".jpg"
End Function
' (SS,10/4/19)
Function GetImageCacheFolder
GetImageCacheFolder = "img"
End Function
' (SS,7/4/19) returns image file name for given image
' Also checks existence of image in cache, creates it if it doesn't already exist
Function GetImageName(AType, ACode, ACode2, APictureID, ASize)
Dim LImageName, LPictureID, LLastUpdated, LSQL
' determine name of image, also look up the picture ID in case we don't already have it to pass on to a later routine
If AType = "P" Then
LSQL = "SELECT pictures.PictureID, pictures.Caption, pictures.SortOrder, pictures.LastUpdated, products.ProductName" &_
" FROM pictures" &_
" INNER JOIN products ON products.ProductCode = pictures.Code" &_
" WHERE "
If APictureID = "" Then
' if only product code specified then get the first enabled picture by sort order
LSQL = LSQL + "pictures.Type = 'P' AND pictures.Code = '" & CleanSQLStr(ACode) & "' AND Enabled ORDER BY SortOrder, Code2, PictureID LIMIT 1"
Else
LSQL = LSQL + "pictures.PictureID = '" & APictureID & "'"
End If
Dim LCaption, LSortOrder, LProductName
If GetSQL5Values(LSQL, LPictureID, LCaption, LSortOrder, LLastUpdated, LProductName) Then
LImageName = LProductName
' if caption specified then use it, else add the sort order if not 0 and not 10 (assuming it's the first image)
' (SS,11/8/18) added "If LSortOrder <> 10" if SortOrder is 10 then no caption is added to image name, otherwise caption is added, if not caption then sortorder is added
If LSortOrder <> 10 Then
If LCaption <> "" Then
LImageName = LImageName & "-" & LCaption
Else
LImageName = LImageName & "-" & LSortOrder
End If
End If
Else
LImageName = ""
End If
Else ' i.e. C, S, OV or O
LImageName = ACode
LSQL = "SELECT PictureID, LastUpdated FROM pictures WHERE Type = '" & AType & "' AND Code = '" & CleanSQLStr(ACode) & "'"
If ACode2 <> "" Then
LImageName = LImageName + "-" + ACode2
LSQL = LSQL + " AND Code2 = '" & CleanSQLStr(ACode2) & "'"
End If
If IsNull(GetSQL2Values(LSQL, LPictureID, LLastUpdated)) Then
LImageName = ""
End If
End If
If LImageName <> "" Then
LImageName = GetImageCacheFolder + "/" + LCase(AType) + "/" + GetSEOFriendlyImageName(LImageName, ASize)
EnsureImageExists LImageName, LPictureID, LLastUpdated, ASize
Else ' no image found
' if not already no picture then do a recursive call to determine name of no picture
If AType <> "O" And ACode <> "NoPicture" Then
LImageName = GetImageName("O", "NoPicture", "", "", ASize)
End If
End If
GetImageName = LImageName
End Function
' (SS,7/4/19) if file doesn't already exist in cache with correct date, it creates it
' writing binary files help from https://www.motobit.com/tips/detpg_read-write-binary-files/
Sub EnsureImageExists(AImageName, APictureID, ALastUpdated, ASize)
Dim LResult, LFullFileName
LFullFileName = Server.MapPath(AImageName)
' (SS,23/6/18) check whether file already exists with the same date and time
LResult = FileExistsWithSameDateTime(LFullFileName, ALastUpdated)
' create the file if doesn't exist
If Not LResult Then
' get image from pictures table
Dim LPictureField, LByteArray
Select Case UCase(ASize)
Case "O"
LPictureField = "OriginalPicture"
Case "L"
LPictureField = "LargeThumbnail"
Case Else
LPictureField = "SmallThumbnail"
End Select
LByteArray = GetSQLValue("SELECT " + LPictureField + " FROM pictures WHERE PictureID = '" & APictureID & "'")
If Not IsNull(LByteArray) Then
' (SS,6/4/19) ensure folder exists for this file path
EnsureFolderExistsForFileName(LFullFileName)
' create the jpg file using stream object, binary type
' *** perhaps add an error trap in case file couldn't created
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary
objStream.Open
objStream.Write LByteArray
objStream.SaveToFile LFullFileName, adSaveCreateOverWrite
objStream.Close
Set objStream = Nothing
' (SS,7/8/18) set the file last modified date
SetFileLastModifiedDate LFullFileName, ALastUpdated
End If
End If
SetImageCreatedInCache(Not LResult) ' flag for use by CreateImageCache log
End Sub
' (SS,7/4/19) used by CreateImageCache for log
Sub SetImageCreatedInCache(AValue)
FImageCreatedInCache = AValue
End Sub
' (SS,7/4/19)
Function GetImageCreatedInCache
GetImageCreatedInCache = FImageCreatedInCache
End Function
' (SS,23/8/18) Returns true if given file name and date matches existing file.
' Returns false if file doesn't exist, or it exists but with a different date & time.
Function FileExistsWithSameDateTime(AFullFileName, ADateTime)
Dim LResult, objFSO, f
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
' if name matches then check the date & time as well
If objFSO.FileExists(AFullFileName) Then
'Response.Write " File name match" & "<br>" & NL
LResult = objFSO.GetFile(AFullFileName).DateLastModified = ADateTime
'If LResult Then Response.Write " Date time match" & "<br>" & NL
Else
LResult = False
End If
Set objFSO = Nothing
FileExistsWithSameDateTime = LResult
End Function
' (SS,6/4/19) ensure the folder exists for given filename
Sub EnsureFolderExistsForFileName(AFullFileName)
Dim objFSO, LFolderName
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
LFolderName = objFSO.GetParentFolderName(AFullFileName)
' create the folder if it doesn't exist (must have IUSR write access)
If Not objFSO.FolderExists(LFolderName) Then
objFSO.CreateFolder(LFolderName)
End If
Set objFSO = Nothing
End Sub
' (SS,7/8/18) set given file to given date/time
' taken from https://stackoverflow.com/questions/15197043/manually-changing-date-and-time-of-a-file
' *** to tidy with variable names
Sub SetFileLastModifiedDate(AFullFileName, ADateTime)
Dim objFSO, file, app, folder, fileModify
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set file = objFSO.GetFile(AFullFileName)
Set app = Server.CreateObject("Shell.Application")
Set folder = app.NameSpace(file.ParentFolder & "\")
Set fileModify = folder.ParseName(file.Name)
fileModify.ModifyDate = ADateTime
Set objFSO = Nothing
Set file = Nothing
Set folder = Nothing
Set app = Nothing
Set fileModify = Nothing
End Sub
' -------------------------------------------
' End of Image / Picture Naming Routines
' -------------------------------------------
' -------------------------------------------
' Start of Cancel Order Routines
' -------------------------------------------
' (SS,12/12/18) To allow orders awaiting payment with payment method of cheque or bank transfer to be cancelled
' (SS,12/12/18) returns true if order cancellation is allowed for given order, i.e. if awaiting payment and payment method is bank transfer or cheque
Function CancelOrderAllowed(AOrderNo)
CancelOrderAllowed = GetSQLRecordExists("SELECT OrderNo FROM orders WHERE OrderNo = '" + CleanSQLStr(AOrderNo) + "' AND Status = '" + AWAITING_PAYMENT_STATUS + "' AND (PaymentMethod = '" + ptCheque + "' OR INSTR(PaymentMethod, '" + ptBankTransfer + "') > 0)")
End Function
' (SS,13/12/18) returns a unique MD5 hash for given order, used for secure cancel order link
Function GetOrderHashKey(AOrderNo)
GetOrderHashKey = GetSQLValueAsString("SELECT CAST(MD5(CONCAT_WS(',', '" + GetStoreName + "', 'Salt123', OrderNo, EmailAddress, SessionID, IPAddress)) AS CHAR) AS KeyVal FROM orders WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'")
End Function
' (SS,12/12/18)
Function GetCancelOrderURL(AOrderNo)
GetCancelOrderURL = GetStoreURL & "/products.asp?cmd=cancelorder&orderno=" & AOrderNo & "&key=" & GetOrderHashKey(AOrderNo)
End Function
' (SS,13/12/18) returns true if order has already been cancelled
Function OrderAlreadyCancelled(AOrderNo)
OrderAlreadyCancelled = GetSQLRecordExists("SELECT OrderNo FROM orders WHERE OrderNo = '" + CleanSQLStr(AOrderNo) + "' AND Status = '" + ORDER_CANCELLED_STATUS + "'")
End Function
' (SS,12/12/18)
Sub CancelOrder
Dim LOrderNo, LOrderHashKey
LOrderNo = CleanRequestQueryString("orderno")
LOrderHashKey = CleanRequestQueryString("key")
If LOrderNo = "" Or LOrderHashKey = "" Then
Response.Write("Sorry, not enough info to cancel order")
Exit Sub
End If
' compare the hash key for this order and only allow if they match
If LOrderHashKey <> GetOrderHashKey(LOrderNo) Then
Response.Write("Sorry, not enough credentials to cancel order.")
Exit Sub
End If
' if order cancelling allowed
If CancelOrderAllowed(LOrderNo) Then
' cancel the order
ExecuteQuery("UPDATE orders SET Status = '" & ORDER_CANCELLED_STATUS & "' WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "' AND Status = '" & AWAITING_PAYMENT_STATUS & "'")
' add items back into stock
TakeProductsFromStock LOrderNo, False
' send the order cancelled confirmation
EmailOrder(LOrderNo)
' display cancellation message
Response.Write("Your order " & LOrderNo & " has been cancelled.<br>Confirmation of the cancellation has been emailed to you.")
ElseIf OrderAlreadyCancelled(LOrderNo) Then
Response.Write("Sorry, order " & LOrderNo & " has already been cancelled.")
Else
Response.Write("Sorry, order " & LOrderNo & " cannot be cancelled.")
End If
End Sub
' -------------------------------------------
' End of Cancel Order Routines
' -------------------------------------------
' --------------------------------------------
' Start of Send Cancelled Order Email Routines
' --------------------------------------------
' (SS,18/4/19)
' (SS,3/6/19) modified to not send if another subsequent order exists
' (SS,25/2/22) added restore basket link
' (SS,3/3/22) added code, copied from Sub SendSavedBasketEmail and modified to suite, to include the product details
' (SS,15/9/23) modified "SELECT * FROM orderdetails" statement to filter out subproducts using GetOrderDetailsFilter
Sub SendCancelledOrderEmail
Const LOGO_FILE_NAME = "logo-email.png"
If Not Application("CancelledOrderEmailsEnabled") Then Exit Sub ' exit if feature not enabled
Dim LOrderNo
If Not AuthenticateOrderNo(LOrderNo) Then Exit Sub ' AuthenticateOrderNo returns LOrderNo, exit if it couldn't be authenticated
Dim LBody
' LBody = "Just testing. Order cancelled was: " & LOrderNo
LBody = GetSiteDetail("Other", "CancelledOrderEmailTemplate")
If LBody = "" Then Exit Sub ' exit if no template or it's blank
' LField4, LField5 are not used but need to be passed onto GetOrderFieldValues which requires 5 variables (ByRef)
Dim LFirstName, LSurname, LEmailAddress, LIsHTML, LVoucherID, LField5
If Not GetOrderFieldValues(LOrderNo, "FirstName", LFirstName, "Surname", LSurname, "EmailAddress", LEmailAddress, "VoucherID", LVoucherID, "", LField5) Then Exit Sub ' exit if fetching the fields failed
' (SS,3/6/19) don't send if customer has since placed another order, because it may confuse them
If GetSQLRecordExists("SELECT OrderNo FROM orders WHERE OrderNo > '" & CleanSQLStr(LOrderNo) & "' AND EmailAddress = '" & CleanSQLStr(LEmailAddress) & "'") Then Exit Sub
Dim LSubject, LBCC, LBCC2, LFrom
LSubject = ExtractSettingFromTemplate(LBody, "SUBJECT")
LBCC = ExtractSettingFromTemplate(LBody, "BCC")
LFrom = ExtractSettingFromTemplate(LBody, "FROM")
If LSubject = "" Then LSubject = "{STORE_NAME} Order {ORDER_NO} Not Completed Alert"
LSubject = ReplaceStr(LSubject, "{ORDER_NO}", LOrderNo)
LSubject = ReplaceStr(LSubject, "{STORE_NAME}", GetStoreName)
' *** following taken from SendChaseCancelledOrderEmails but should be moved to a separate routine, perhaps there is one or need to create a generic order field replacement routine
LBody = ReplaceStr(LBody, "{ORDER_NO}", LOrderNo)
LBody = ReplaceStr(LBody, "{STORE_URL}", GetStoreURL)
LBody = ReplaceStr(LBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LBody = ReplaceStr(LBody, "{STORE_NAME}", GetStoreName)
LBody = ReplaceStr(LBody, "{STORE_EMAIL}", GetStoreEmail)
LBody = ReplaceStr(LBody, "{STORE_TELEPHONE}", GetStoreTelephone)
LBody = ReplaceStr(LBody, "{FIRST_NAME}", LFirstName)
LBody = ReplaceStr(LBody, "{SURNAME}", LSurname)
' (SS,25/2/22) added following to add link to restore basket from the cancelled order
LBody = ReplaceStr(LBody, "{RESTORE_BASKET_LINK}", GetRestoreBasketFromOrderURL(LOrderNo))
' (SS,3/3/22) following necessary for CorrectCurrencyNV to work to appropriately remove VAT, also to get the correct currency and exchange rate
Dim LCountry, LDeliveryCountry, LCurrencyCode, LExchangeRate
GetOrderFieldValues LOrderNo, "Country", LCountry, "DeliveryCountry", LDeliveryCountry, "CurrencyCode", LCurrencyCode, "ExchangeRate", LExchangeRate, "", LField5
If LDeliveryCountry = "" Then LDeliveryCountry = LCountry
SetDeliveryCountry(LDeliveryCountry)
SetCurrencyForOrder LCurrencyCode, LExchangeRate
' (SS,3/3/22) added following to also include the product details, based on code from Sub SendSavedBasketEmail
Dim LProductItemTemplate, LDiscountTemplate, LVATTemplate, LProductList
' product list template is separate line in header of template called <!--PRODUCT_ITEM_TEMPLATE=
LProductItemTemplate = ExtractSettingFromTemplate(LBody, "PRODUCT_ITEM_TEMPLATE")
' discount and VAT are separate optional lines
LDiscountTemplate = ExtractSettingFromTemplate(LBody, "DISCOUNT_TEMPLATE")
LVATTemplate = ExtractSettingFromTemplate(LBody, "VAT_TEMPLATE")
LProductList = ""
Dim LSQL, LProductID, LProductCode, LProductName, LQty, LPriceEach, LProductLine, LProductOptions
' (SS,15/9/23) added GetOrderDetailsFilter to filter out subproducts
LSQL = "SELECT * FROM orderdetails WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'" & GetOrderDetailsFilter & " ORDER BY OrderDetailID"
OpenQuery(LSQL)
Do While Not EndOfQuery
LProductID = GetQueryField("ProductID")
LProductCode = GetQueryField("ProductCode")
LProductName = GetQueryField("ProductName")
LQty = GetQueryField("Qty")
LPriceEach = GetQueryField("PriceEach")
' modified to work using inline CSS rather than stylesheet in html header because gmail doesn't support styles in header
LProductLine = LProductItemTemplate
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_LINK}", GetFullProductLink(LProductCode))
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_IMAGE_LINK}", GetFullProductImageLink(LProductCode, "s"))
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_NAME}", LProductName)
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_QTY}", LQty)
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_PRICE_EACH}", CorrectCurrencyNV(LPriceEach))
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_PRICE_TOTAL}", CorrectCurrencyNV(LPriceEach * LQty))
' add the matching options
LProductOptions = ""
If ProductOptionsEnabled Then
OpenQuery2("SELECT OptionName, OptionValue FROM order_detail_options WHERE OrderDetailID = " & GetQueryField("OrderDetailID") & " ORDER BY OrderDetailID")
Do While Not EndOfQuery2
LProductOptions = LProductOptions & Iif(LProductOptions = "", "", ", ") & GetQueryField2("OptionName") & ": " & GetQueryField2("OptionValue")
NextQueryRecord2
Loop
End If
LProductOptions = AddMoreOptionsInfo(LProductID, LProductOptions)
LProductLine = ReplaceStr(LProductLine, "{PRODUCT_OPTIONS}", LProductOptions)
LProductList = LProductList + LProductLine & NL
NextQueryRecord
Loop
CloseQuery
LBody = ReplaceStr(LBody, "{PRODUCT_LIST}", LProductList)
Dim LSubtotal, LDiscount, LDelivery, LVAT, LGrandTotal
GetOrderFieldValues LOrderNo, "Subtotal", LSubtotal, "GrandTotal", LGrandTotal, "Discount", LDiscount, "Delivery", LDelivery, "VATIncluded", LVAT
If LDiscount <> 0 Then
Dim LVoucherCode
LVoucherCode = GetVoucherCodeForVoucherID(LVoucherID)
If LVoucherCode <> "" Then LVoucherCode = " (" & LVoucherCode & ")"
LDiscountTemplate = ReplaceStr(LDiscountTemplate, "{VOUCHER_CODE}", LVoucherCode)
LDiscountTemplate = ReplaceStr(LDiscountTemplate, "{DISCOUNT}", CorrectCurrencyNV(LDiscount))
Else
LDiscountTemplate = ""
End If
' VAT only shown if prices in system exclude VAT
If LVAT <> 0 And Not PricesEnteredIncludeVAT Then
LVATTemplate = ReplaceStr(LVATTemplate, "{VAT}", CorrectCurrency(LVAT))
Else
LVATTemplate = ""
End If
GetDeliveryCountry
LBody = ReplaceStr(LBody, "{SUBTOTAL}", CorrectCurrencyNV(LSubtotal))
LBody = ReplaceStr(LBody, "{DISCOUNT_LINE}", LDiscountTemplate)
LBody = ReplaceStr(LBody, "{DELIVERY_COUNTRY}", " (" & GetDeliveryCountry & ")")
LBody = ReplaceStr(LBody, "{DELIVERY}", CorrectCurrencyNV(LDelivery))
LBody = ReplaceStr(LBody, "{VAT_LINE}", LVATTemplate)
LBody = ReplaceStr(LBody, "{GRAND_TOTAL}", CorrectCurrency(LGrandTotal))
' sort email bcc and from addresses, because we might be overriding the standard ones
If LFrom = "" Then LFrom = FEmailContactFrom
If LBCC = "" Then
LBCC = FEmailContactBcc1
LBCC2 = FEmailContactBcc2
Else
If FEmailContactBcc1 <> "" Then
LBCC2 = FEmailContactBcc1
Else
LBCC2 = FEmailContactBcc2
End If
End If
' if template contains <html> tag then assume it's HTML
LIsHTML = InStr(1, LBody, "<html>", vbTextCompare) > 0
SendEmailByCDO LEmailAddress, LBCC, LBCC2, LFrom, LSubject, LBody, "", LIsHTML, "", ""
End Sub
' (SS,25/2/22) restores a basket from a cancelled order, based on RestoreBasket which restores saved baskets
Sub RestoreBasketFromOrder
Dim LOrderNo
If Not AuthenticateOrderNo(LOrderNo) Then Exit Sub ' AuthenticateOrderNo returns LOrderNo, exit if it couldn't be authenticated
Dim LSessionID, LItemID, LProductID, LProductOrderingSuspended
LSessionID = GetSessionID
' empty current basket
EmptyBasket(LSessionID)
LProductOrderingSuspended = False ' (SS,6/4/20)
' restore the cancelled order into basket session
' (SS,3/3/22) added SubproductOrderDetailID IS NULL otherwise we'll end up also restoring the subproducts as normal products and doubling up
OpenQuery("SELECT od.* FROM orderdetails od WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "' AND SubproductOrderDetailID IS NULL ORDER BY OrderDetailID")
Do While Not EndOfQuery
LProductID = GetQueryValue("ProductID") ' (SS,30/10/18)
' (SS,6/4/20) check the ProductOrderingSuspended routine to fix loophole i.e. if ordering is suspended for this product then don't allow it to be added
If ProductOrderingSuspended(LProductID) Then
LProductOrderingSuspended = True
Exit Do
End If
' add the item
ExecuteQuery("INSERT INTO shoppingbaskets SET SessionID = '" & LSessionID & "', ProductID = " & LProductID & ", ProductCode = '" & GetQueryValue("ProductCode") & "', Qty = " & GetQueryValue("Qty"))
LItemID = GetSQLLastInsertID ' (SS,30/10/18) moved here from "If ProductOptionsEnabled", also used by "If ProductSubproductsEnabled "
' add the matching options
If ProductOptionsEnabled Then
' ExecuteQuery("INSERT INTO shopping_basket_options SELECT NULL, " & LItemID & ", ProductOptionID, ProductOptionValueID, OptionName, OptionValue FROM saved_basket_options WHERE SavedBasketItemID = " & GetQueryValue("SavedBasketItemID") & " ORDER BY SavedBasketOptionID")
ExecuteQuery("INSERT INTO shopping_basket_options SELECT NULL, " & LItemID & ", ProductOptionID, ProductOptionValueID, OptionName, OptionValue FROM order_detail_options WHERE OrderDetailID = " & GetQueryValue("OrderDetailID") & " ORDER BY OrderDetailOptionID")
End If
' (SS,30/10/18) added following to add subproducts if applicable, custom routine is called if subproducts enabled and this product has subproducts
' (SS,25/2/22) not tested, not applicable to HyperFlight
If ProductSubproductsEnabled Then
If IntToBool(GetFieldForProductID(LProductID, "HasSubproducts")) Then
If FunctionExists("CustomAddSubproductsToBasket") Then
CustomAddSubproductsToBasket LProductID, LItemID, 0, GetQueryValue("Qty")
End If
End If
End If
NextQueryRecord
Loop
CloseQuery
' if a product was suspended then show message and empty basket
If LProductOrderingSuspended Then
Response.Write "Unfortunately, basket could not be restored." & BR
Response.Write "This is due to one or more products being suspended from ordering." & BR
Response.Write "Please try again later. Sorry for any inconvenience caused." & BR
EmptyBasket(LSessionID)
Else ' as before
' redirect to basket page
Response.Write "Basket has been restored." & BR
SetPageRedirection GetBasketPageURL
End If
End Sub
' --------------------------------------------
' End of Send Cancelled Order Email Routines
' --------------------------------------------
' -------------------------------------------
' Start of Mailshot routines
' -------------------------------------------
' (SS,25/3/20) based on Sub SendOrderProgressEmails
' called from send-mailshot.asp
' e.g. send-mailshot.asp?tpn=xxx&ssn=yyy"
' to do an actual run and bypass test mode:
' https://www.castironradiatorcentre.co.uk/send-mailshot.asp?ssn=OutstandingRadiatorOrders&tpn=MailshotTemplateRadiatorOrdersCOVID19&testmode=false
Sub SendMailshot
CONST TEST_MODE = True
CONST TEST_EMAIL = "contactforms@itpartnership.com"
Dim LTestMode
If Request.QueryString("testmode") = "false" Then
LTestMode = False
Else
LTestMode = TEST_MODE
End If
' show a form to get the emailshot name and template name, maybe same name for both
' get emailshot template name and sql select name
' call custom routine to open table, go to next record, and end
' for each record, add to list, build template, send email
' at the end, send the list
Dim LSelectSQLName, LTemplateName
LSelectSQLName = Request.QueryString("ssn")
LTemplateName = Request.QueryString("tpn")
' if no SQL select name and template then exit without doing anything
If LSelectSQLName = "" Or LTemplateName = "" Then
Response.Write "Select SQL Name: " & LSelectSQLName & BR
Response.Write "Template Name: " & LTemplateName & BR
Exit Sub
End If
Const LOGO_FILE_NAME = "logo-email.png"
Dim LAttachLogoFileName, LTemplateTitle, LTemplateSubject, LSubject, LTemplateBody, LSQL
Dim LBCC, LBCC2, LFrom
Dim LTemplateBCC, LTemplateBCC2, LTemplateFrom
Dim LOrderNo, LOrderDate, LTitle, LFirstName, LSurname, LName, LEmailAddress
Dim LLogBody, LCount, LBody
LLogBody = ""
' get body of template (also check it exists and exit if it doesn't)
LTemplateBody = GetSiteDetail("Other", LTemplateName)
If LTemplateBody = "" Then
Response.Write "TemplateBody: " & LTemplateBody & BR
Exit Sub
End If
' make sure CustomMailshotGetSQL exists and returns a value for given SQL
If Not FunctionExists("CustomMailshotGetSQL") Then
Response.Write "No CustomMailshotGetSQL"
Exit Sub
End If
LSQL = CustomMailshotGetSQL(LSelectSQLName)
If LSQL = "" Then
Response.Write "SelectSQLName: " & LSelectSQLName & BR
Response.Write "SQL: " & LSQL & BR
Exit Sub
End If
' extract BCC, FROM, SUBJECT from template
LTemplateTitle = ExtractSettingFromTemplate(LTemplateBody, "TITLE")
LTemplateSubject = ExtractSettingFromTemplate(LTemplateBody, "SUBJECT")
LTemplateSubject = ReplaceStr(LTemplateSubject, "{STORE_NAME}", GetStoreName)
LTemplateBCC = ExtractSettingFromTemplate(LTemplateBody, "BCC")
LTemplateFrom = ExtractSettingFromTemplate(LTemplateBody, "FROM")
' exit if no subject
If LTemplateSubject = "" Then
Response.Write "Template Subject: " & LTemplateSubject & BR
Exit Sub
End If
LLogBody = LLogBody + MailshotResultOverallHeader
' replace template variables that weren't change for each order
' "if" to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LTemplateBody, "{LOGO}") > 0 Then
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
LAttachLogoFileName = LOGO_FILE_NAME
Else
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LAttachLogoFileName = ""
End If
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_URL}", GetStoreURL)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_NAME}", GetStoreName)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_EMAIL}", GetStoreEmail)
LTemplateBody = ReplaceStr(LTemplateBody, "{STORE_TELEPHONE}", GetStoreTelephone)
' sort email bcc and from addresses, because we might be overriding the standard ones
If LTemplateFrom = "" Then LTemplateFrom = FEmailOrderConfirmationFrom
If LTemplateBCC = "" Then
LTemplateBCC = FEmailOrderConfirmationBcc1
ElseIf LTemplateBCC = "NONE" Then ' if NONE then don't send BCC
LTemplateBCC = ""
End If
LTemplateBCC2 = FEmailOrderConfirmationBcc2
LLogBody = LLogBody + MailshotResultHeader(LTemplateTitle)
' run query to find orders
OpenQuery(LSQL)
' for each order
Do While Not EndOfQuery
LCount = LCount + 1
LOrderNo = GetQueryField("OrderNo")
LOrderDate = GetQueryField("OrderDate")
LTitle = Trim(GetQueryField("Title"))
LFirstName = Trim(GetQueryField("FirstName"))
LSurname = Trim(GetQueryField("Surname"))
LName = Trim(LTitle & IIf(LTitle = "", "", " ") & LFirstName & IIf(LFirstName = "", "", " ") & LSurname)
LEmailAddress = GetQueryField("EmailAddress")
LLogBody = LLogBody + MailshotResultRow(LOrderNo, LOrderDate, LName, LEmailAddress)
' debug info in browser
'Response.Write LCount & ". Order No: " & LOrderNo & ", Order Date: " & LOrderDate & ", Name: " & LName & ", EmailAddress: " & LEmailAddress & BR
' send the email (test mode, 0 = normal, 1 = log and send emails to test account, 2 = log only)
LBody = LTemplateBody
If LBody <> "" Then ' only send if template not blank
' replace order specific template values
LSubject = ReplaceStr(LTemplateSubject, "{ORDER_NO}", LOrderNo)
LBody = ReplaceStr(LBody, "{ORDER_NO}", LOrderNo)
LBody = ReplaceStr(LBody, "{ORDER_DATE}", LOrderDate)
LBody = ReplaceStr(LBody, "{NAME}", LName)
' send the email with embedded logo
If Not LTestMode Then
LBCC = LTemplateBCC
LBCC2 = LTemplateBCC2
Else ' test mode, just send the one test email
If LCount = 1 Then
LEmailAddress = TEST_EMAIL
Else
LEmailAddress = "" ' no more emails, just the one due to above
End If
LBCC = ""
LBCC2 = ""
End If
' debug code to show email addresses
'Response.Write "LEmailAddress: " & LEmailAddress & BR
'Response.Write "LBCC: " & LBCC & BR
'Response.Write "LBCC2: " & LBCC2 & BR
'Response.Write "LFrom: " & LFrom & BR
If LEmailAddress <> "" Then
SendEmailByCDO LEmailAddress, LBCC, LBCC2, LTemplateFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
End If
End If
NextQueryRecord
Loop
LLogBody = LLogBody + MailshotResultFooter(LTemplateTitle, LCount)
CloseQuery
LLogBody = LLogBody + MailshotResultOverallFooter
' send log email
If LLogBody <> "" Then
If LTestMode Then
LEmailAddress = TEST_EMAIL
LBCC = ""
LBCC2 = ""
Else
LEmailAddress = FEmailContactTo
LBCC = FEmailContactBcc1
LBCC2 = FEmailContactBcc2
End If
SendEmailByCDO LEmailAddress, LBCC, LBCC2, FEmailContactFrom, "Mailshot Result for " + GetStoreName + " on " & Now, LLogBody, "", True, "", ""
End If
End Sub
Function MailshotResultOverallHeader
Dim LResult
LResult = ""
LResult = LResult & "<html>" & NL
LResult = LResult & "<head>" & NL
LResult = LResult & "<title>Mailshot " & Now & "</title>" & NL
LResult = LResult & "<style>" & NL
LResult = LResult & "table {border-collapse: collapse;}" & NL
LResult = LResult & "table, th, td {border: 1px solid black;}" & NL
LResult = LResult & "th, td {padding: 5px;}" & NL
LResult = LResult & "</style>" & NL
LResult = LResult & "</head>" & NL
LResult = LResult & "<body>" & NL
LResult = LResult & "<table>" & NL
Response.Write LResult
MailshotResultOverallHeader = LResult
End Function
Function MailshotResultOverallFooter
Dim LResult
LResult = LResult & "</table>" & NL
LResult = LResult & "</body>" & NL
LResult = LResult & "</html>" & NL
Response.Write LResult
MailshotResultOverallFooter = LResult
End Function
Function MailshotResultHeader(AInfo)
' NL used at end of each HTML line because emailer is adding a space after 1000 characters
Dim LResult
LResult = LResult & "<tr><th colspan=""4""> </tr>" & NL ' empty line separator
LResult = LResult & "<tr><th colspan=""4"">" & AInfo & "</th></tr>" & NL
LResult = LResult & "<tr>" & NL
LResult = LResult & "<th>Order No</th>" & NL
LResult = LResult & "<th>Order Date</th>" & NL
LResult = LResult & "<th>Name</th>" & NL
LResult = LResult & "<th>Email</th>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
MailshotResultHeader = LResult
End Function
Function MailshotResultFooter(ATitle, ACount)
Dim LResult
LResult = "<tr><td colspan=""4""><b>" & ATitle & " emails sent for " & PluralString(ACount, "order", "orders") & "</b></td></tr>" & NL
Response.Write LResult
MailshotResultFooter = LResult
End Function
Function MailshotResultRow(AOrderNo, AOrderDate, AName, AEmail)
Dim LResult, LCentre
LCentre = " style=""text-align:center"""
LResult = "<tr>" & NL
LResult = LResult & "<td" & LCentre & ">" & AOrderNo & "</td>" & NL
LResult = LResult & "<td" & LCentre & ">" & AOrderDate & "</td>" & NL
LResult = LResult & "<td>" & AName & "</td>" & NL
LResult = LResult & "<td>" & AEmail & "</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
MailshotResultRow = LResult
End Function
' -------------------------------------------
' End of Mailshot routines
' -------------------------------------------
' -------------------------------------------
' Start of Meilshot Simple routines
' (SS,15/12/21)
' This is email address only, no order no (as in Mailshot routines above)
' -------------------------------------------
' (SS,25/3/20) based on Sub SendMailshot
' called from send-mailshot-simple.asp
' e.g. send-mailshot-simple.asp?tpn=xxx"
' Table used used mailshot_list (it needs to contain ID, EmailAddress, Sent)
' to do an actual run and bypass test mode:
' https://www.castironradiatorcentre.co.uk/send-mailshot-simple.asp?tpn=DataBreachEmailTemplate&testmode=false
Sub SendMailshotSimple
CONST BATCH_SIZE = 200
CONST TEST_MODE = True
CONST TEST_EMAIL = "contactforms@itpartnership.com"
Dim LTestMode
If Request.QueryString("testmode") = "false" Then
LTestMode = False
Else
LTestMode = TEST_MODE
End If
' show a form to get the emailshot name and template name, maybe same name for both
' get emailshot template name and sql select name
' call custom routine to open table, go to next record, and end
' for each record, add to list, build template, send email
' at the end, send the list
Dim LTemplateName
LTemplateName = Request.QueryString("tpn")
' if no template then exit without doing anything
If LTemplateName = "" Then
Response.Write "Template Name: " & LTemplateName & BR
Exit Sub
End If
Const LOGO_FILE_NAME = "logo-email.png"
Dim LAttachLogoFileName, LTemplateTitle, LTemplateSubject, LSubject, LTemplateBody, LSQL
Dim LBCC, LBCC2, LFrom
Dim LTemplateBCC, LTemplateBCC2, LTemplateFrom
Dim LEmailAddress
Dim LLogBody, LCount, LID, LBody
LLogBody = ""
' get body of template (also check it exists and exit if it doesn't)
LTemplateBody = GetSiteDetail("Other", LTemplateName)
If LTemplateBody = "" Then
Response.Write "TemplateBody: " & LTemplateBody & BR
Exit Sub
End If
' create the SQL, using mailshot_simple_list
LSQL = "SELECT * FROM mailshot_simple_list WHERE NOT Sent ORDER BY ID"
Response.Write "SQL: " & LSQL & BR
' extract BCC, FROM, SUBJECT from template
LTemplateTitle = ExtractSettingFromTemplate(LTemplateBody, "TITLE")
LTemplateSubject = ExtractSettingFromTemplate(LTemplateBody, "SUBJECT")
LTemplateSubject = ReplaceStr(LTemplateSubject, "{STORE_NAME}", GetStoreName)
LTemplateBCC = ExtractSettingFromTemplate(LTemplateBody, "BCC")
LTemplateFrom = ExtractSettingFromTemplate(LTemplateBody, "FROM")
' exit if no subject
If LTemplateSubject = "" Then
Response.Write "Template Subject: " & LTemplateSubject & BR
Exit Sub
End If
LLogBody = LLogBody + MailshotSimpleResultOverallHeader
' replace template variables that weren't change for each order
' "if" to only attach logo if template contains {LOGO}, also added LOGO_URL which doesn't embed the URL
If InStr(LTemplateBody, "{LOGO}") > 0 Then
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO}", "<img src=""" + LOGO_FILE_NAME + """>")
LAttachLogoFileName = LOGO_FILE_NAME
Else
LTemplateBody = ReplaceStr(LTemplateBody, "{LOGO_URL}", GetStoreURL & "/images/" & LOGO_FILE_NAME)
LAttachLogoFileName = ""
End If
' sort email bcc and from addresses, because we might be overriding the standard ones
If LTemplateFrom = "" Then LTemplateFrom = FEmailOrderConfirmationFrom
'If LTemplateBCC = "" Then
' LTemplateBCC = FEmailOrderConfirmationBcc1
'ElseIf LTemplateBCC = "NONE" Then ' if NONE then don't send BCC
' LTemplateBCC = ""
'End If
'LTemplateBCC2 = FEmailOrderConfirmationBcc2
' (SS,15/12/21) don't send BCCs, there might be too many to send
LTemplateBCC = ""
LTemplateBCC2 = ""
LLogBody = LLogBody + MailshotSimpleResultHeader(LTemplateTitle)
' run query to find orders
OpenQuery(LSQL)
' for each order
LCount = 0
Do While Not EndOfQuery And LCount < BATCH_SIZE
LCount = LCount + 1
LID = GetQueryField("ID")
LEmailAddress = GetQueryField("EmailAddress")
LLogBody = LLogBody + MailshotSimpleResultRow(LID, LEmailAddress)
' debug info in browser
'Response.Write LCount & ". Order No: " & LOrderNo & ", Order Date: " & LOrderDate & ", Name: " & LName & ", EmailAddress: " & LEmailAddress & BR
' send the email (test mode, 0 = normal, 1 = log and send emails to test account, 2 = log only)
LBody = LTemplateBody
If LBody <> "" Then ' only send if template not blank
' replace order specific template values
LSubject = LTemplateSubject
' send the email with embedded logo
If Not LTestMode Then
LBCC = LTemplateBCC
LBCC2 = LTemplateBCC2
Else ' test mode, just send the one test email
If LCount = 1 Then
LEmailAddress = TEST_EMAIL
Else
LEmailAddress = "" ' no more emails, just the one due to above
End If
LBCC = ""
LBCC2 = ""
End If
' debug code to show email addresses
'Response.Write "LEmailAddress: " & LEmailAddress & BR
'Response.Write "LBCC: " & LBCC & BR
'Response.Write "LBCC2: " & LBCC2 & BR
'Response.Write "LFrom: " & LFrom & BR
If LEmailAddress <> "" Then
SendEmailByCDO LEmailAddress, LBCC, LBCC2, LTemplateFrom, LSubject, LBody, "", True, "", LAttachLogoFileName
' (SS,15/12/21) mark as sent
ExecuteQuery "UPDATE mailshot_simple_list SET Sent = TRUE WHERE ID = " & LID
End If
End If
NextQueryRecord
Loop
LLogBody = LLogBody + MailshotSimpleResultFooter(LTemplateTitle, LCount)
CloseQuery
LLogBody = LLogBody + MailshotSimpleResultOverallFooter
' send log email
' (SS,15/12/21) only send to myself, i.e. contact forms test email
If LLogBody <> "" Then
LEmailAddress = TEST_EMAIL
LBCC = ""
LBCC2 = ""
SendEmailByCDO LEmailAddress, LBCC, LBCC2, FEmailContactFrom, "Mailshot Simple Result for " + GetStoreName + " on " & Now, LLogBody, "", True, "", ""
End If
End Sub
Function MailshotSimpleResultOverallHeader
Dim LResult
LResult = ""
LResult = LResult & "<html>" & NL
LResult = LResult & "<head>" & NL
LResult = LResult & "<title>Mailshot Simple " & Now & "</title>" & NL
LResult = LResult & "<style>" & NL
LResult = LResult & "table {border-collapse: collapse;}" & NL
LResult = LResult & "table, th, td {border: 1px solid black;}" & NL
LResult = LResult & "th, td {padding: 5px;}" & NL
LResult = LResult & "</style>" & NL
LResult = LResult & "</head>" & NL
LResult = LResult & "<body>" & NL
LResult = LResult & "<table>" & NL
Response.Write LResult
MailshotSimpleResultOverallHeader = LResult
End Function
Function MailshotSimpleResultOverallFooter
Dim LResult
LResult = LResult & "</table>" & NL
LResult = LResult & "</body>" & NL
LResult = LResult & "</html>" & NL
Response.Write LResult
MailshotSimpleResultOverallFooter = LResult
End Function
Function MailshotSimpleResultHeader(AInfo)
' NL used at end of each HTML line because emailer is adding a space after 1000 characters
Dim LResult
LResult = LResult & "<tr><th colspan=""2""> </tr>" & NL ' empty line separator
LResult = LResult & "<tr><th colspan=""2"">" & AInfo & "</th></tr>" & NL
LResult = LResult & "<tr>" & NL
LResult = LResult & "<th>ID</th>" & NL
LResult = LResult & "<th>Email</th>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
MailshotSimpleResultHeader = LResult
End Function
Function MailshotSimpleResultFooter(ATitle, ACount)
Dim LResult
LResult = "<tr><td colspan=""4""><b>" & ATitle & " emails sent: " & ACount & "</b></td></tr>" & NL
LResult = LResult & "<br>" & GetTimer ' (SS,15/12/21)
Response.Write LResult
MailshotSimpleResultFooter = LResult
End Function
Function MailshotSimpleResultRow(AID, AEmail)
Dim LResult, LCentre
LCentre = " style=""text-align:center"""
LResult = "<tr>" & NL
LResult = LResult & "<td" & LCentre & ">" & AID & "</td>" & NL
LResult = LResult & "<td>" & AEmail & "</td>" & NL
LResult = LResult & "</tr>" & NL
Response.Write LResult
MailshotSimpleResultRow = LResult
End Function
' -------------------------------------------
' End of Mailshot Simple routines
' -------------------------------------------
' ------------------------
' Start of NetPay routines
' ------------------------
' (SS,16/9/20)
Function IsNetPayPayment
IsNetPayPayment = GetPaymentType = ptNetPay
End Function
' (SS,16/9/20)
Function GetNetPayMerchantID
GetNetPayMerchantID = FNetPayMerchantID
End Function
' (SS,16/9/20)
Function GetNetPayUserName
GetNetPayUserName = FNetPayUserName
End Function
' (SS,16/9/20)
Function GetNetPayEncryptionKey
GetNetPayEncryptionKey = FNetPayEncryptionKey
End Function
' (SS,16/9/20)
Function GetNetPayEncryptionIV
GetNetPayEncryptionIV = FNetPayEncryptionIV
End Function
' (SS,16/9/20)
Function GetNetPayIntegrationPassword
GetNetPayIntegrationPassword = FNetPayIntegrationPassword
End Function
' (SS,16/9/20) 1 for live, 2 for test
Function GetNetPayOperationMode
GetNetPayOperationMode = FNetPayOperationMode
End Function
' (SS,16/9/20) 1 for live, 2 for test
Function IsNetPayTestMode
IsNetPayTestMode = GetNetPayOperationMode <> "1"
End Function
' (SS,16/2/21)
Function GetNetPayTemplate
If FNetPayTemplate = "" Then
GetNetPayTemplate = "STANDARD"
Else
GetNetPayTemplate = FNetPayTemplate
End If
End Function
' (SS,16/2/21)
Function IsNetPayStandardTemplate
IsNetPayStandardTemplate = GetNetPayTemplate = "STANDARD"
End Function
' (SS,17/09/20)
Sub SetUpNetPayForm(AOrderNo)
' Server Post method
%>
<form name="frmNetPay" action="<%=GetNetPayFormURL%>" method="post" class="nospace">
</form>
<%
End Sub
' (SS,23/9/20) called from above, also from retry button in Sub ShowPaymentFailureAlert (in inc-template-checkout.asp)
Function GetNetPayFormURL
' GetNetPayFormURL = GetScriptName + "?cmd=payment&type=netpay"
' (SS,4/10/20) replaced above with following
GetNetPayFormURL = GetScriptName + "?cmd=checkout&xcmd=serverpost&pt=" & ptNetPay
End Function
' (SS,16/09/20) based on SetUpPayzoneForm
Sub NetPayServerPost
Dim LOrderNo, LTotal, LISOCurrencyCode, LEndPointURL, LResponseURL, LSessionToken, LTransactionID, LAddress
LOrderNo = GetOrderNo
If LOrderNo = "" Then
Response.Write "Missing Order No"
Exit Sub
End If
LTotal = Session("PaymentAmount") ' amount in selected currency
If IsCurrencyUSD Then
LISOCurrencyCode = "USD"
ElseIf IsCurrencyEUR Then
LISOCurrencyCode = "EUR"
Else ' GBP or other
LISOCurrencyCode = "GBP"
LTotal = Session("PaymentAmountGBP") ' amount in GBP
End If
' USD and EUR not set up or working currently so adding the following to default all to GBP, need to comment out the following once USD and EUR working
LISOCurrencyCode = "GBP"
LTotal = Session("PaymentAmountGBP") ' amount in GBP
If IsNetPayTestMode Then
LEndPointURL = "https://hostedtest.revolution.netpay.co.uk/v1/gateway/create_payment_link"
Else
LEndPointURL = "https://hosted.revolution.netpay.co.uk/v1/gateway/create_payment_link"
End If
' *** to set to correct URL
'LResponseURL = "http://hyperflight.itpartnership.com/netpay/response.asp"
LResponseURL = GetReturnFromPaymentURL & "&pt=" & ptNetPay
' clear global variable used here for the crypted string
' set up encryption / decryption
InitialiseNetPayCrypt
AddToNetPayCrypt "merchant_id", GetNetPayMerchantID, 0, False
AddToNetPayCrypt "username", GetNetPayUserName, 0, True
AddToNetPayCrypt "password", GetNetPayIntegrationPassword, 0, True
AddToNetPayCrypt "response_url", LResponseURL, 0, True
AddToNetPayCrypt "response_format", "JSON", 0, True
' AddToNetPayCrypt "custom_fields", LCustomFields, 152, True
LTransactionID = LOrderNo
LSessionToken = LCase(GetNetPayMerchantID) & GetMySQLUnixTimestamp & LTransactionID
'Response.Write "###" & LSessionToken & "###" & BR
AddToNetPayCrypt "session_token", LSessionToken, 32, True
' return strtolower($merchant_id) . time() . strtolower($transaction_id);
AddToNetPayCrypt "transaction_id", LTransactionID, 40, True
AddToNetPayCrypt "operation_mode", GetNetPayOperationMode, 0, True
AddToNetPayCrypt "amount", LTotal, 0, True
AddToNetPayCrypt "currency", LISOCurrencyCode, 3, True
' AddToNetPayCrypt "checksum", LChecksum, 40, True
AddToNetPayCrypt "iframe", "0", 1, True
' (SS,28/1/21) back to SWIFT
' (SS,16/2/21) replaced "SWIFT" with GetNetPayTemplate
AddToNetPayCrypt "checkout_template", GetNetPayTemplate, 10, True ' STANDARD or SWIFT
'AddToNetPayCrypt "description", GetDescriptionForPaymentProvider(100), 100, True
AddToNetPayCrypt "description", "Products purchased from " & GetStoreName, 100, True
'AddToNetPayCrypt "backend_response", "0"
AddToNetPayCrypt "checksum", GetNetPayChecksum(LSessionToken & LTotal & LISOCurrencyCode & LTransactionID), 0, True
' $checksum = sha1($session_token . $amount . $currency . $transaction_id);
AddToNetPayCrypt "customer_email", Session("Email"), 50, True
' (SS,16/2/21) added "if" following to only pass on address and phone if standard template
If IsNetPayStandardTemplate Then
' (SS,23/1/21) there's no address line 2, so concatenated, it's later truncated to 100 chars
LAddress = Session("Address1")
If Session("Address2") <> "" Then LAddress = LAddress + ", " + Session("Address2")
AddToNetPayCrypt "bill_to_address", LAddress, 100, True
AddToNetPayCrypt "bill_to_town_city", Session("Town"), 50, True
' (SS,23/1/21) check for blank, NetPay says it's option and doesn't like it when blank, fixed by only sending when it's not blank
If Session("County") <> "" Then AddToNetPayCrypt "bill_to_county", Session("County"), 50, True
AddToNetPayCrypt "bill_to_postcode", Session("Postcode"), 10 , True
AddToNetPayCrypt "bill_to_country", GetCountryISOCodeA3(Session("Country")), 3, True
' (SS,22/1/21) for telephone it has to be a proper number, i.e. can't have spaces, dashes or pluses, CleanNum function ensures propert number
AddToNetPayCrypt "customer_phone", CleanNum(Session("Telephone")), 15, True
End If
'AddToNetPayCrypt "card_holder_firstname", LBillFirstName
'AddToNetPayCrypt "card_holder_lastname", LBillSurname
' AddToNetPayCrypt "ship_to_firstname", LBillFirstName
' AddToNetPayCrypt "ship_to_lastname", LBillSurname
' (SS,22/1/21) added order no as optional reference field this was showing as blank on the payment receipts
AddToNetPayCrypt "reference", LTransactionID, 20, True
' AddToNetPayCrypt "order_items", ""
'LText = postFormData(TEST_MODE_ENDPOINT_URL, LPostData)
Dim LResponseText, LDecryptedResponse
LResponseText = PostFormData(LEndPointURL, FNetPayCrypt)
' Response.Write LResponseText
LDecryptedResponse = NetPayDecryptStr(LResponseText)
'Response.Write BR & BR
'Response.Write "Decrypted reply:" & BR & LDecryptedResponse
'Response.Write BR & BR
' *** following uses JSONobject in jsonObject.class.asp
' make sure jsonObject.class.asp in not in UTF-8-BOM format, which results in different values !!! to investigate
' included in dbfunctions.asp, to investigate if there's a Microsoft object that does this
NetPayHandleResponse(LDecryptedResponse)
' Response.Write "result: " & NetPayGetResponseValue("result")
' Response.Write BR & BR
' Response.Write "link: " & NetPayGetResponseValue("link")
' (SS,24/1/21)
Dim LPaymentLog
If NetPayGetResponseValue("result") = "SUCCESS" Then
Dim LLink
LLink = NetPayGetResponseValue("link")
If LLink <> "" Then
' *** perhaps use the built in redirect?
Response.Write "Redirecting to NetPay"
' Response.Redirect LLink
' (SS,4/10/20) replaced above with following
SetPageRedirection LLink
End If
' (SS,24/1/21) added following to also log when successful
LPaymentLog = "NetPayServerPost Success"
LPaymentLog = LPaymentLog & NL & LDecryptedResponse
If LLink <> "" Then
LPaymentLog = LPaymentLog & NL & "Redirected to " & LLink
Else
LPaymentLog = LPaymentLog & NL & "Could not redirect due to missing link"
End If
Else
' (SS,22/1/21) added following to show and log an error message
LPaymentLog = "NetPayServerPost Error" & NL & LDecryptedResponse
Response.Write ReplaceNewLinesWithBR(LPaymentLog)
End If
AddToPaymentLog "NetPay", LPaymentLog ' (SS,24/1/21)
FinaliseNetPayCrypt ' *** to check if it reaches here
End Sub
' (SS,22/9/20) returns number of secs as integer since '1970-01-01 00:00:00' UTC
Function GetMySQLUnixTimestamp
GetMySQLUnixTimestamp = GetSQLValueAsString("SELECT UNIX_TIMESTAMP(NOW())")
End Function
' (SS,22/9/20) returns SHA1 hash of give string, uses MySQL
Function GetNetPayChecksum(AStr)
Dim LResult
' use SHA1 function of MySQL to create the hash
' (SS,5/4/18) added CAST(AS CHAR) for MySQL server 5.1.x and old ODBC driver, otherwise it returns ????, fine in MySQL 5.7.x on test server
LResult = GetSQLValueAsString("SELECT CAST(SHA1(""" & CleanSQLStr(AStr) & """) AS CHAR)")
GetNetPayChecksum = LResult
End Function
Sub ProcessNetPayCallback
' clear global variable used here for the encrypted string
Dim LResponse, LDecryptedResponse
LResponse = CleanRequestQueryString("Response")
' Response.Write BR & "### Response ### = " & LResponse & BR
InitialiseNetPayCrypt ' set up encryption / decryption
LDecryptedResponse = NetPayDecryptStr(LResponse)
NetPayHandleResponse(LDecryptedResponse)
' !!! also check &response_format=JSON and extra custom values passed on
Dim LOrderNo
Dim LResult, LCode, LCause, LExplanation
LResult = NetPayGetResponseValue("result")
LCode = NetPayGetResponseValue("code")
LCause = NetPayGetResponseValue("cause")
LExplanation = NetPayGetResponseValue("explanation")
Dim LMerchantID, LOperationType, LOperationMode, LOrderID, LTransactionID, LDescription, LAmount, LCurrency, LAVSGatewayCode, LReference
LMerchantID = NetPayGetResponseValue("merchant_id")
LOperationType = NetPayGetResponseValue("operation_type")
LOperationMode = NetPayGetResponseValue("operation_mode")
LOrderID = NetPayGetResponseValue("order_id")
LTransactionID = NetPayGetResponseValue("transaction_id")
LDescription = NetPayGetResponseValue("description")
LAmount = NetPayGetResponseValue("amount")
LCurrency = NetPayGetResponseValue("currency")
LAVSGatewayCode = NetPayGetResponseValue("avs_gateway_code")
' (SS,22/1/21) added following optional reference field which is passed back because it are now passing it on to them, it's just the order no
LReference = NetPayGetResponseValue("reference")
LOrderNo = LTransactionID & "" ' added "" ensures a string otherwise it'll won't be able to check for a blank string in next statement
' (SS,22/9/20) if not supplied due to error then assume Order No in session
If LOrderNo = "" Then LOrderNo = GetOrderNo
FinaliseNetPayCrypt
'Response.Write BR & "### Decrypted Response ### = " & LDecryptedResponse & BR & BR
'Response.Write BR & "transaction_id: " & "#" & LOrderNo & "#"
'Response.Write BR & "result: " & LResult
'Response.Write BR & "code: " & LCode
'Response.Write BR & "cause: " & LCause
'Response.Write BR & "explanation: " & LExplanation
' STOP_HERE
' show message and abort if no order no specified
If LOrderNo = "" Then
Response.Write("Order No must be specified" & BR & NL)
Exit Sub
End If
' (SS,4/10/20) detect duplicate and calculate SHA1 hash
' prevents the customer from staying on same page and causing issues later because they didn't close the page and it was refreshed many days later
' as if they're just made another successful payment
Dim LDuplicateDetected, LResponseSHA1, LInternalStatus
LResponseSHA1 = GetNetPayChecksum(LResponse)
' (SS,26/1/20) added (LResult = "SUCCESS") to only detect duplicate if it was successful, i.e. we don't want it to redirect to home page successful more than once
LDuplicateDetected = (LResult = "SUCCESS") AND GetSQLRecordExists("SELECT OrderNo FROM netpay_callbacks WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "' AND ResponseSHA1 = '" & CleanSQLStr(LResponseSHA1) & "'")
If LDuplicateDetected Then
LInternalStatus = "DUPLICATE"
Else
LInternalStatus = ""
End If
' add to netpay_callbacks log
' (SS,22/1/21) added reference field
' (SS,22/1/21) change size of AVSGatewayCode from 20 to 50 after noticing a truncation by 1 char for SERVICE_NOT_SUPPORTE(D), NetPay documentation doesn't appear to mention the size of this field
' (SS,25/1/21) resized Code from 20 to 50 due to AUTHENTICATION_FAILE being returned and truncated
Dim LSQL
LSQL = "INSERT INTO netpay_callbacks SET OrderNo='" & LOrderNo & "'" &_
", SessionID='" & GetSessionID & "'" &_
", DateTimeReceived=NOW()" &_
", Result='" & CleanSQLStrMax(LResult, 20) & "'" &_
", Code='" & CleanSQLStrMax(LCode, 50) & "'" &_
", Cause='" & CleanSQLStrMax(LCause, 255) & "'" &_
", Explanation='" & CleanSQLStrMax(LExplanation, 255) & "'" &_
", MerchantID='" & CleanSQLStrMax(LMerchantID, 20) & "'" &_
", OperationType ='" & CleanSQLStrMax(LOperationType, 20) & "'" &_
", OperationMode ='" & CleanSQLStrMax(LOperationMode, 20) & "'" &_
", OrderID='" & CleanSQLStrMax(LOrderID, 50) & "'" &_
", TransactionID='" & CleanSQLStrMax(LTransactionID, 20) & "'" &_
", Description='" & CleanSQLStrMax(LDescription, 255) & "'" &_
", Amount='" & CleanSQLStrMax(LAmount, 20) & "'" &_
", Currency='" & CleanSQLStrMax(LCurrency, 3) & "'" &_
", AVSGatewayCode='" & CleanSQLStrMax(LAVSGatewayCode, 50) & "'" &_
", Reference='" & CleanSQLStrMax(LReference, 20) & "'" &_
", ResponseSHA1='" & CleanSQLStrMax(LResponseSHA1, 40) & "'" &_
", InternalStatus='" & CleanSQLStrMax(LInternalStatus, 20) & "'"
ExecuteQuery(LSQL)
' (SS,4/10/20) if duplicate then redirect to home page to prevent this from occurring repeatedly
If LDuplicateDetected Then
SetPageRedirection GetStoreURL
Exit Sub
End If
' (SS,4/10/20) improved payment log to log more details for success, i.e. amount, currency and AVSGatewayCode
Dim LPaymentLog
LPaymentLog = "Result = " & LResult & NL
If LResult = "SUCCESS" Then
LPaymentLog = LPaymentLog & "OrderID = " & LOrderID & NL & "TransactionID = " & LTransactionID & NL
LPaymentLog = LPaymentLog & "Amount = " & LAmount & NL & "Currency = " & LCurrency & NL & "AVSGatewayCode = " & LAVSGatewayCode
LPaymentLog = LPaymentLog & NL &"Reference = " & LReference ' (SS,22/1/21)
Else
LPaymentLog = LPaymentLog & "Code = " & LCode & NL & "Cause = " & LCause & NL & "Explanation = " & LExplanation
End If
SetCallbackOrderNoForPaymentLog LOrderNo ' (SS,26/1/21) tells AddToPaymentLog to use OrderNo from callback in case session was lost (which it where it normally gets it from)
AddToPaymentLog "NetPay", LPaymentLog
' if paid then mark the order as paid and send email
If LResult = "SUCCESS" And LOrderNo <> "" Then
' following will update the status, send email and empty basket
' (SS,25/6/18) calculate the Fee on the amount, 1.25% + 5p
Dim LPaymentProviderFee
'LAmount = Round2dp(ParseFloat(LAmount) / 100) ' (SS,26/6/18) amount is in pence, so divde by 100 to convert to pounds
' *** to set LPaymentProviderFee or not?
' LPaymentProviderFee = Round2dp(Round2dp(LAmount * 0.0125) + 0.05)
LPaymentProviderFee = 0 ' set to 0 for now
ProcessOrderThirdPartyPayment True, LOrderNo, GetSessionID, ptNetPay, LOrderID, PAYMENT_RECEIVED_STATUS, "", ParseFloat(LAmount), LCurrency, 0, LPaymentProviderFee
Else
' (SS,6/4/18) show error message and retry button
ShowPaymentFailureAlert ""
SetCreditCardPaymentProviderFailure ' (SS,20/4/18) flag the error
End If
End Sub
' (SS,4/10/20) used by conversion via IsSuccessfulReturnFromPaymentProviderPage to check for successful payment when returning from payment provider
Function NetPaySuccessfulPayment
Dim LResponse, LDecryptedResponse, LResult
LResponse = CleanRequestQueryString("Response")
InitialiseNetPayCrypt ' set up encryption / decryption
LDecryptedResponse = NetPayDecryptStr(LResponse)
NetPayHandleResponse(LDecryptedResponse)
LResult = NetPayGetResponseValue("result")
FinaliseNetPayCrypt
' if result is "SUCCESS" then return True else False
NetPaySuccessfulPayment = LResult = "SUCCESS"
End Function
Sub InitialiseNetPayCrypt
' Global FNetPayCrypt
FNetPayCrypt = ""
Set FoUTF8 = CreateObject("System.Text.UTF8Encoding")
Set FoB64Enc = CreateObject("System.Security.Cryptography.ToBase64Transform")
Set FoB64Dec = CreateObject("System.Security.Cryptography.FromBase64Transform")
Set FoAES = CreateObject("System.Security.Cryptography.RijndaelManaged")
End Sub
Sub FinaliseNetPayCrypt
Set FoUTF8 = Nothing
Set FoB64Enc = Nothing
Set FoAES = Nothing
Set FoB64Dec = Nothing
End Sub
Sub AddToNetPayCrypt(AFieldName, AFieldValue, AMaxLength, AEncrypt)
'Response.Write AFieldName & "=" & AFieldValue & BR
If FNetPayCrypt <> "" Then FNetPayCrypt = FNetPayCrypt + "&"
Dim LFieldValue
LFieldValue = AFieldValue
If AMaxLength > 0 Then LFieldValue = Left(LFieldValue, AMaxLength)
'Response.Write BR & "Before encryption: " & AFieldName & "=" & AFieldValue & BR
If AEncrypt Then LFieldValue = B64ToHex(NetPayEncryptStr(LFieldValue))
FNetPayCrypt = FNetPayCrypt & AFieldName & "=" & LFieldValue
' Response.Write BR & "Encrypted " & AFieldName & "=" & B64ToHex(EncryptStr(AFieldValue)) & BR
' Dim LResult
' LResult = B64ToHex(EncryptStr(AFieldValue))
End Sub
' from https://stackoverflow.com/questions/381596/how-do-i-post-data-to-a-remote-url-in-classic-asp
Function PostFormData(url, data)
' Response.Write BR & "postFormData: " & BR
'
' Response.Write data
' Response.Write BR & BR
Dim xhr : Set xhr = Server.CreateObject("MSXML2.ServerXMLHTTP.3.0")
xhr.open "POST", url, false
xhr.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xhr.send Data
If xhr.Status = 200 Then
postFormData = xhr.ResponseText
Else
Err.Raise 1001, "postFormData", "Post to " & url & " failed with " & xhr.Status
End If
End Function
' with help from restapi.asp in ITP Plates Function API_ReadRequest
Sub NetPayHandleResponse(AResponseJSONStr)
' instantiate the class
Set FoJSONRequest = New JSONobject
'oJSONRequest.debug = 1
FoJSONRequest.Parse(AResponseJSONStr)
End Sub
' returns given response value
Function NetPayGetResponseValue(AFieldName)
NetPayGetResponseValue = FoJSONRequest.Value(AFieldName)
End Function
' encrypts given string, returns encrypted value in hex
Function NetPayEncryptStr(AStr)
Dim LKey, LIV
LKey = Base64Encode(HexToASCII(GetNetPayEncryptionKey))
LIV = Base64Encode(HexToASCII(GetNetPayEncryptionIV))
NetPayEncryptStr = EncryptB64(AStr, LKey, LIV)
End Function
Function NetPayDecryptStr(AHexData)
Dim LKey, LIV, LDecryptStr, LResult
LKey = Base64Encode(HexToASCII(GetNetPayEncryptionKey))
LIV = Base64Encode(HexToASCII(GetNetPayEncryptionIV))
LDecryptStr = Base64Encode(HexToASCII(AHexData))
NetPayDecryptStr = DecryptB64(LDecryptStr, LKey, LIV)
End Function
Function HexToASCII(ByVal AHexText)
Dim y, num, Value
For y = 1 To Len(AHexText)
num = Mid(AHexText, y, 2)
Value = Value & Chr(CLng("&H" & num))
y = y + 1
Next
HexToASCII = Value
End Function
' from https://www.motobit.com/tips/detpg_Base64Encode/
Function Base64Encode(inData)
'rfc1521
'2001 Antonin Foller, Motobit Software, http://Motobit.cz
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim cOut, sOut, I
'For each group of 3 bytes
For I = 1 To Len(inData) Step 3
Dim nGroup, pOut, sGroup
'Create one long from this 3 bytes.
nGroup = &H10000 * Asc(Mid(inData, I, 1)) + _
&H100 * MyASC(Mid(inData, I + 1, 1)) + MyASC(Mid(inData, I + 2, 1))
'Oct splits the long To 8 groups with 3 bits
nGroup = Oct(nGroup)
'Add leading zeros
nGroup = String(8 - Len(nGroup), "0") & nGroup
'Convert To base64
pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)
'Add the part To OutPut string
sOut = sOut + pOut
'Add a new line For Each 76 chars In dest (76*3/4 = 57)
'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
Next
Select Case Len(inData) Mod 3
Case 1: '8 bit final
sOut = Left(sOut, Len(sOut) - 2) + "=="
Case 2: '16 bit final
sOut = Left(sOut, Len(sOut) - 1) + "="
End Select
Base64Encode = sOut
End Function
Function MyASC(OneChar)
If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function
Function EncryptB64(plaintext, aesKey, iv)
Dim LaesKeyBytes, LivBytes, LCipherBytes, LoAESEnc, LPlainBytes
LaesKeyBytes = B64Decode(aesKey)
LivBytes = B64Decode(iv)
Set LoAESEnc = FoAES.CreateEncryptor_2((LaesKeyBytes), (LivBytes))
LPlainBytes = FoUTF8.GetBytes_4(plaintext)
LCipherBytes = LoAESEnc.TransformFinalBlock((LPlainBytes), 0, LenB(LPlainBytes))
EncryptB64 = B64Encode(LCipherBytes)
End Function
Function DecryptB64(Ciphertext, aesKey, iv)
Dim LaesKeyBytes, LivBytes, LCipherBytes, LoAESDec, LPlainBytes
LaesKeyBytes = B64Decode(aesKey)
LivBytes = B64Decode(iv)
LCipherBytes = B64Decode(Ciphertext)
Set LoAESDec = FoAES.CreateDecryptor_2((LaesKeyBytes), (LivBytes))
LPlainBytes = LoAESDec.TransformFinalBlock((LCipherBytes), 0, LenB(LCipherBytes))
DecryptB64 = FoUTF8.GetString((LPlainBytes))
End Function
' Convert a Base64 string to a byte array.
'
' Arguments:
' b64Str (String): Base64 string.
'
' Returns:
' Byte(): A byte array that the Base64 string decodes to.
Function B64Decode(Ab64str)
Dim LBytes
LBytes = FoUTF8.GetBytes_4(Ab64str)
B64Decode = FoB64Dec.TransformFinalBlock((LBytes), 0, LenB(LBytes))
End Function
' Convert a byte array to a Base64 string representation of it.
'
' Arguments:
' bytes (Byte()): Byte array.
'
' Returns:
' String: Base64 representation of the input byte array.
Function B64Encode(ABytes)
Dim LResult ' (SS,10/9/20) I added
Dim LBlockSize, LOffset, LLength, LB64Block
LBlockSize = FoB64Enc.InputBlockSize
For LOffset = 0 To LenB(ABytes) - 1 Step LBlockSize
LLength = Min(LBlockSize, LenB(ABytes) - LOffset)
LB64Block = FoB64Enc.TransformFinalBlock((ABytes), LOffset, LLength)
LResult = LResult & FoUTF8.GetString((LB64Block))
Next
B64Encode = LResult
End Function
' (SS,10/9/20) my routine
Function B64ToHex(AB64Str)
' Response.Write BR & "B64ToHex: " & AB64Str & BR
Dim LBytes, i, LResult
LResult = ""
LBytes = B64Decode(AB64Str)
For i = 1 To LenB(LBytes)
'LResult = LResult & Hex(AscB(MidB(LBytes, i, 1)))
LResult = LResult & IntToHex(AscB(MidB(LBytes, i, 1)), 2) ' IntToHex ensures a leading zero
Next
' Response.Write BR & "B64ToHex result: " & LResult & BR
B64ToHex = LResult
End Function
' ----------------------
' End of NetPay routines
' ----------------------
' ----------------------------
' Start of Clover pay routines
' ----------------------------
' 9/6/2022
Function GetCloverStoreID
If GetCloverTestMode Then
GetCloverStoreID = "1120542761"
Else
GetCloverStoreID = FCloverStoreID ' "1110742125"
End If
End Function
Function GetCloverSharedSecret
If GetCloverTestMode Then
GetCloverSharedSecret = "vhgM]24<jD"
Else
GetCloverSharedSecret = FCloverSharedSecret ' "T\D7h#b8LT"
End If
End Function
Function GetCloverTestMode
GetCloverTestMode = FCloverTestMode
End Function
' (SS,23/6/22)
Function GetCloverShowAll
GetCloverShowAll = False
End Function
' (SS,23/6/22)
Function GetCloverShowVisaMastercard
GetCloverShowVisaMastercard = True
End Function
' (SS,23/6/22)
Function GetCloverShowAppleGooglePay
GetCloverShowAppleGooglePay = True
End Function
' (SS,23/6/22)
Function GetCloverApplePayOnlyIfApplicable
GetCloverApplePayOnlyIfApplicable = True
End Function
' (SS,23/6/22) new general payment setting used by HF to highlight preferred payment type with additional text or icon
Function GetPaymentHighlightPreferred
GetPaymentHighlightPreferred = False
End Function
Function GetCloverFieldValue(AFieldValue, AMaxLength)
Dim LFieldValue
LFieldValue = AFieldValue
' to encode "" or ' check behaviour
If AMaxLength > 0 Then LFieldValue = Left(LFieldValue, AMaxLength)
GetCloverFieldValue = LFieldValue
End Function
' (SS,23/6/22) added APaymentMethod which can be "" for all i.e. not set
' other values cpmAll, cpmApplePay, cpmGooglePay, cpmVisa, cpmMastercard
Sub SetUpCloverPayForm(AOrderNo, APaymentMethod)
Dim LChargeTotal, LCurrency, LStoreName, LTimeZone, LtxnDateTime, LtxnType, LSessionID
Dim LResponseFailURL, LResponseSuccessURL, LTransactionNotificationURL, LHashAlgorithm, LMode, LCheckoutOption
' amount is always GBP
LCurrency = "826" ' the numeric ISO code
LChargeTotal = Session("PaymentAmountGBP") ' amount in GBP
LStoreName = GetCloverStoreID
LTimeZone = "Europe/London"
' date time format - YYYY:MM:DD-hh:mm:ss
LtxnDateTime = GetSQLValueAsString("SELECT DATE_FORMAT(NOW(), '%Y:%m:%d-%H:%i:%s') AS txnDateTime")
LtxnType = "sale"
LSessionID = GetSessionID
'LResponseFailURL = "https://hyperflight.itpartnership.com/clover/clover.asp?result=fail"
'LResponseSuccessURL = "https://hyperflight.itpartnership.com/clover/clover.asp?result=success"
' (SS,23/6/22)
Dim LPaymentMethodQS
LPaymentMethodQS = ""
If APaymentMethod <> cpmAll Then
LPaymentMethodQS = "&pm=" & APaymentMethod
End If
LResponseSuccessURL = GetReturnFromPaymentURL & "&pt=" & ptClover & LPaymentMethodQS & "&success=true"
LResponseFailURL = GetReturnFromPaymentURL & "&pt=" & ptClover & LPaymentMethodQS & "&success=false"
LTransactionNotificationURL = GetStoreURL + "/clover-callback.asp"
LHashAlgorithm = "HMACSHA256"
LMode = "payonly"
' LMode = "payplus"
LCheckoutOption = "combinedpage"
'LCheckoutOption = "classic"
' payplus mode, adding billing address etc.
Dim Lbcompany, Lbname, Lbaddr1, Lbaddr2, Lbcity, Lbstate, Lbcountry, Lbzip, Lphone, Lfax, Lemail
Lbcompany = GetCloverFieldValue(Session("CompanyName"), 96)
Lbname = GetCloverFieldValue(GetNameForPaymentProvider(), 96)
Lbaddr1 = GetCloverFieldValue(Session("Address1"), 96)
Lbaddr2 = GetCloverFieldValue(Session("Address2"), 96)
Lbcity = GetCloverFieldValue(Session("Town"), 96)
Lbstate = GetCloverFieldValue(Session("County"), 96)
Lbcountry = GetCountryISOCode(Session("Country"))
Lbzip = GetCloverFieldValue(Session("Postcode"), 24)
Lphone = GetCloverFieldValue(Session("Telephone"), 32)
Lfax = "" ' (SS,22/6/22) removed sample number, not tested with blank
Lemail = GetCloverFieldValue(Session("Email"), 254)
' (SS,22/6/22)
' Dim LMobileMode
' LMobileMode = "true"
Dim LExtendedHash
FCloverExtendedHash = ""
If LMode = "payplus" Then
AddToCloverExtendedHash Lbaddr1
AddToCloverExtendedHash Lbaddr2
AddToCloverExtendedHash Lbcity
AddToCloverExtendedHash Lbcompany
AddToCloverExtendedHash Lbcountry
AddToCloverExtendedHash Lbname
AddToCloverExtendedHash Lbstate
AddToCloverExtendedHash Lbzip
End If
AddToCloverExtendedHash LChargeTotal
AddToCloverExtendedHash LCheckoutOption
AddToCloverExtendedHash LCurrency
If APaymentMethod <> cpmAll Then AddToCloverExtendedHash APaymentMethod ' (SS,23/6/22) customParam_paymentmethod, to pass back which method customer chose before going to Clover
AddToCloverExtendedHash LSessionID ' customParam_sessionid
If LMode = "payplus" Then AddToCloverExtendedHash Lemail
If LMode = "payplus" Then AddToCloverExtendedHash Lfax
AddToCloverExtendedHash LHashAlgorithm
AddToCloverExtendedHash LMode
AddToCloverExtendedHash AOrderNo
If APaymentMethod <> cpmAll Then AddToCloverExtendedHash APaymentMethod
If LMode = "payplus" Then AddToCloverExtendedHash Lphone
AddToCloverExtendedHash LResponseFailURL
AddToCloverExtendedHash LResponseSuccessURL
AddToCloverExtendedHash LStoreName
AddToCloverExtendedHash LTimeZone
AddToCloverExtendedHash LTransactionNotificationURL
AddToCloverExtendedHash LtxnDateTime
AddToCloverExtendedHash LtxnType
LExtendedHash = GetHMACSHA256Base64(FCloverExtendedHash, GetCloverSharedSecret)
Dim LActionURL
If GetCloverTestMode Then
LActionURL = "https://test.ipg-online.com/connect/gateway/processing"
Else
LActionURL = "https://www.ipg-online.com/connect/gateway/processing"
End If
' Response.Write "<br>String to Hash:<br>" & FCloverExtendedHash & "<br>"
' Response.Write "<br>Extended Hash:<br>" & LExtendedHash & "<br><br>"
' (SS,23/6/22) added id for finding element by ID using getElementById, to keep form unique for each payment method
%>
<form name="frmClover" id="frmClover<%=APaymentMethod%>" action="<%=LActionURL%>" method="post" class="nospace">
<input type="hidden" name="txntype" value="<%=LtxnType%>">
<input type="hidden" name="timezone" value="<%=LTimeZone%>">
<input type="hidden" name="txndatetime" value="<%=LtxnDateTime%>">
<input type="hidden" name="hash_algorithm" value="<%=LHashAlgorithm%>">
<input type="hidden" name="hashExtended" value="<%=LExtendedHash%>">
<input type="hidden" name="storename" value="<%=LStoreName%>">
<input type="hidden" name="mode" value="<%=LMode%>">
<input type="hidden" name="chargetotal" value="<%=LChargeTotal%>">
<input type="hidden" name="currency" value="<%=LCurrency%>">
<input type="hidden" name="oid" value="<%=AOrderNo%>">
<input type="hidden" name="responseFailURL" value="<%=LResponseFailURL%>">
<input type="hidden" name="responseSuccessURL" value="<%=LResponseSuccessURL%>">
<input type="hidden" name="transactionNotificationURL" value="<%=LTransactionNotificationURL%>">
<input type="hidden" name="checkoutoption" value="<%=LCheckoutOption%>"><%
If APaymentMethod <> cpmAll Then%>
<input type="hidden" name="paymentMethod" value="<%=APaymentMethod%>">
<input type="hidden" name="customParam_paymentmethod" value="<%=APaymentMethod%>"><%
End If%>
<input type="hidden" name="customParam_sessionid" value="<%=LSessionID%>"><%
If LMode = "payplus" Then%>
<input type="hidden" name="bcompany" value="<%=Lbcompany%>">
<input type="hidden" name="bname" value="<%=Lbname%>">
<input type="hidden" name="baddr1" value="<%=Lbaddr1%>">
<input type="hidden" name="baddr2" value="<%=Lbaddr2%>">
<input type="hidden" name="bcity" value="<%=Lbcity%>">
<input type="hidden" name="bstate" value="<%=Lbstate%>">
<input type="hidden" name="bcountry" value="<%=Lbcountry%>">
<input type="hidden" name="bzip" value="<%=Lbzip%>">
<input type="hidden" name="phone" value="<%=Lphone%>">
<input type="hidden" name="fax" value="<%=Lfax%>">
<input type="hidden" name="email" value="<%=Lemail%>">
<%
End If%>
</form>
<%
End Sub
Sub AddToCloverExtendedHash(AValue)
If FCloverExtendedHash <> "" Then FCloverExtendedHash = FCloverExtendedHash + "|"
FCloverExtendedHash = FCloverExtendedHash & AValue
End Sub
' AIsCallback is true if it's a server to server proper callback, false if it's just
Sub ProcessCloverCallback(AIsCallback)
' (SS,16/6/22) !!! debug
'SendWebLogEmail "ProcessCloverCallback"
Dim LSQL, LOrderNo, Lstatus, Lfail_reason, Lchargetotal, LipgTransactionId, Lresponse_hash, LcustomParam_sessionid
' get values from query/forms (passed on values) to save to callbacks table
LOrderNo = Trim(CleanRequestForm("oid"))
Lstatus = CleanRequestForm("status")
Lfail_reason = CleanRequestForm("fail_reason")
Lchargetotal = CleanRequestForm("chargetotal")
LipgTransactionId = CleanRequestForm("ipgTransactionId")
LcustomParam_sessionid = CleanRequestForm("customParam_sessionid")
If AIsCallback Then
Lresponse_hash = CleanRequestForm("notification_hash")
Else
Lresponse_hash = CleanRequestForm("response_hash")
End If
If LOrderNo = "" Then
Response.Write("<br><br>Order No must be specified.<br>")
Exit Sub
End If
LSQL = "INSERT INTO clover_callbacks SET " &_
" OrderNo='" & CleanSQLStrMax(LOrderNo, 20) & "'" &_
", DateTimeReceived=NOW()" &_
", CallbackType='" & IIF(AIsCallback, "Server", "Browser") & "'" &_
", SessionID='" & GetSessionID & "'" &_
", customParam_sessionid='" & CleanSQLStrMax(LcustomParam_sessionid, 20) & "'" &_
", status='" & CleanSQLStrMax(Lstatus, 20) & "'" &_
", approval_code='" & CleanSQLStrMax(CleanRequestForm("approval_code"), 50) & "'" &_
", fail_reason='" & CleanSQLStrMax(CleanRequestForm("fail_reason"), 50) & "'" &_
", fail_rc='" & CleanSQLStrMax(CleanRequestForm("fail_rc"), 20) & "'" &_
", endpointTransactionId='" & CleanSQLStrMax(CleanRequestForm("endpointTransactionId"), 20) & "'" &_
", currency='" & CleanSQLStrMax(CleanRequestForm("currency"), 3) & "'" &_
", processor_response_code='" & CleanSQLStrMax(CleanRequestForm("processor_response_code"), 20) & "'" &_
", schemeTransactionId='" & CleanSQLStrMax(CleanRequestForm("schemeTransactionId"), 50) & "'" &_
", paymentMethod='" & CleanSQLStrMax(CleanRequestForm("paymentMethod"), 20) & "'" &_
", txndate_processed='" & CleanSQLStrMax(CleanRequestForm("txndate_processed"), 20) & "'" &_
", ccbin='" & CleanSQLStrMax(CleanRequestForm("ccbin"), 20) & "'" &_
", oid='" & CleanSQLStrMax(CleanRequestForm("oid"), 20) & "'" &_
", txndatetime='" & CleanSQLStrMax(CleanRequestForm("txndatetime"), 20) & "'" &_
", timezone='" & CleanSQLStrMax(CleanRequestForm("txndatetime"), 20) & "'" &_
", chargetotal='" & CleanSQLStrMax(Lchargetotal, 20) & "'" &_
", expyear='" & CleanSQLStrMax(CleanRequestForm("expyear"), 10) & "'" &_
", expmonth='" & CleanSQLStrMax(CleanRequestForm("expmonth"), 10) & "'" &_
", cardnumber='" & CleanSQLStrMax(CleanRequestForm("cardnumber"), 50) & "'" &_
", cccountry='" & CleanSQLStrMax(CleanRequestForm("cccountry"), 20) & "'" &_
", bname='" & CleanSQLStrMax(CleanRequestForm("bname"), 50) & "'" &_
", ccbrand='" & CleanSQLStrMax(CleanRequestForm("ccbrand"), 20) & "'" &_
", terminal_id='" & CleanSQLStrMax(CleanRequestForm("terminal_id"), 20) & "'" &_
", ipgTransactionId='" & CleanSQLStrMax(LipgTransactionId, 20) & "'" &_
", hash_algorithm='" & CleanSQLStrMax(CleanRequestForm("hash_algorithm"), 20) & "'" &_
", response_hash='" & CleanSQLStrMax(Lresponse_hash, 50) & "'" &_
", response_code_3dsecure='" & CleanSQLStrMax(CleanRequestForm("response_code_3dsecure"), 10) & "'" &_
", txntype='" & CleanSQLStrMax(CleanRequestForm("txntype"), 10) & "'" &_
", tdate='" & CleanSQLStrMax(CleanRequestForm("tdate"), 20) & "'" &_
", refnumber='" & CleanSQLStrMax(CleanRequestForm("refnumber"), 20) & "'" &_
", installments_interest='" & CleanSQLStrMax(CleanRequestForm("installments_interest"), 20) & "'"
ExecuteQuery(LSQL)
' (SS,24/8/22) added following to update the InternalStatus field later
Dim LLastInsertID
LLastInsertID = GetSQLLastInsertID
SetCallbackOrderNoForPaymentLog LOrderNo ' tells AddToPaymentLog to use OrderNo from callback due to server to server
Dim LSuccess, LPaymentLog, LHashMatch, LInternalStatus
LSuccess = CloverCaptureResponse(AIsCallback, LPaymentLog, LHashMatch)
' (SS,24/6/22) detect duplicate
' prevents the customer from staying on same page and causing issues later because they didn't close the page and it was refreshed many days later
' as if they're just made another successful payment
Dim LDuplicateDetected
' to only detect duplicate if it was successful, i.e. we don't want it to redirect to home page successful more than once
If LSuccess Then
LDuplicateDetected = GetSQLRecordExists("SELECT OrderNo FROM clover_callbacks WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "' AND status = 'APPROVED'")
' check whether payment already received and only then mark as duplicate
If LDuplicateDetected Then
LDuplicateDetected = GetSQLRecordExists("SELECT OrderNo FROM orders WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "' AND PaymentReceived")
End If
Else
LDuplicateDetected = False
End If
' update InternalStatus and added to payment log if applicable
If LDuplicateDetected Then
LInternalStatus = "DUPLICATE"
ElseIf Not LHashMatch Then
LInternalStatus = "HASH MISMATCH"
ElseIf Not LSuccess Then
LInternalStatus = "FAILURE"
Else
LInternalStatus = ""
End If
If LInternalStatus <> "" Then
ExecuteQuery("UPDATE clover_callbacks SET InternalStatus = '" & CleanSQLStr(LInternalStatus) & "' WHERE ID = '" & LLastInsertID & "'")
LPaymentLog = LPaymentLog & "InternalStatus = " & LInternalStatus
End If
AddToPaymentLog "Clover", LPaymentLog
' if duplicate and not first browser redirect then redirect to home page to prevent this from occurring repeatedly
If LDuplicateDetected Then
' server to server callback may happen before browser to server
' if from browser then redirect to home page, only after 2 hours after
If AIsCallback Then
Exit Sub
Else ' i.e. from browser, only redirect if a browser callback has already been done because we want to at least show the thank you status at least once before redirecting
If GetSQLRecordExists("SELECT OrderNo FROM clover_callbacks WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "' AND status = 'APPROVED' AND CallbackType = 'Browser' AND ID <> " & LLastInsertID) Then
SetPageRedirection GetStoreURL
Exit Sub
End If
End If
End If
' if paid then mark the order as paid and send email and empty basket using LcustomParam_sessionid
If LSuccess And LOrderNo <> "" Then
' following will update the status, send email and empty basket
ProcessOrderThirdPartyPayment True, LOrderNo, LcustomParam_sessionid, ptClover, LipgTransactionId, PAYMENT_RECEIVED_STATUS, "", ParseFloat(Lchargetotal), "GBP", 0, 0
Else
If Not AIsCallback Then ' only if not a callback
' show error message and retry buttons if applicable
SetCreditCardPaymentProviderFailure ' flag the error
ShowPaymentFailureAlert Lstatus & ": " & Lfail_reason ' pass on the error status and reason
End If
End If
End Sub
' (SS,17/6/22) used by conversion via IsSuccessfulReturnFromPaymentProviderPage to check for successful payment when returning from payment provider
' actually used for tracking purchase conversion
Function CloverSuccessfulPayment
Dim LLog, LHashMatch
CloverSuccessfulPayment = CloverCaptureResponse(False, LLog, LHashMatch)
End Function
' (SS,16/6/22) capture the form collection posted, returns True if payment success, sets the ALog to the list of values posted
' (SS,24/6/22) added AHashMatch
Function CloverCaptureResponse(AIsCallback, ByRef ALog, ByRef AHashMatch)
Const ASeparator = "|"
Dim LLog, LName, LValue, LApprovalCode, LChargeTotal, LCurrency, LtxnDateTime, LReceivedHash, LStatus
LLog = ""
LApprovalCode = ""
LChargeTotal = ""
LCurrency = ""
LtxnDateTime = ""
LReceivedHash = ""
LStatus = ""
' added callback type to log as well
LLog = "CallbackType = " & IIF(AIsCallback, "Server", "Browser") & NL
For Each LName in Request.Form
LValue = Request.Form(LName)
LLog = LLog & LName & " = " & LValue & NL
If LName = "approval_code" Then
LApprovalCode = LValue
ElseIf LName = "chargetotal" Then
LChargeTotal = LValue
ElseIf LName = "currency" Then
LCurrency = LValue
ElseIf LName = "txndatetime" Then
LtxnDateTime = LValue
ElseIf LName = "response_hash" Or LName = "notification_hash" Then
LReceivedHash = LValue
ElseIf LName = "status" Then
LStatus = LValue
End If
Next
' hash check, success or failure redirect: approval_code|chargetotal|currency|txndatetime|storename
' callback: chargetotal|currency|txndatetime|storename|approval_code
FCloverExtendedHash = ""
If Not AIsCallback Then AddToCloverExtendedHash LApprovalCode
AddToCloverExtendedHash LChargeTotal
AddToCloverExtendedHash LCurrency
AddToCloverExtendedHash LtxnDateTime
AddToCloverExtendedHash GetCloverStoreID
If AIsCallback Then AddToCloverExtendedHash LApprovalCode
Dim LCalculatedHash
LCalculatedHash = GetHMACSHA256Base64(FCloverExtendedHash, GetCloverSharedSecret)
'Dim LResult
'LResult = "Received hash: " & LReceivedHash & BR
'LResult = LResult & "Calculated hash: " & LCalculatedHash & BR
'If LReceivedHash = LCalculatedHash Then
' LResult = LResult & "Hashes match" & BR & NL
'Else
' LResult = LResult & "Hashes don't match !!!" & BR & NL
'End If
'Response.Write LResult
AHashMatch = LReceivedHash = LCalculatedHash ' pass back the hash match check
CloverCaptureResponse = UCase(LStatus) = "APPROVED" AND AHashMatch
ALog = LLog ' pass back the log
End Function
' (SS,10/6/22) with help from
' https://github.com/as08/ClassicASP.PasswordHashing
' https://github.com/as08/ClassicASP.PasswordHashing/blob/master/Crypto.Class.asp
' https://www.excelhowto.com/macros/excel-vba-base64-hmac-sha256-and-sha1-encryption/
Function GetHMACSHA256Base64(ByVal ATextToHash, ByVal ASecretKey)
Dim LoHMACSHA256, LoUTF8, LoEncode
Set LoHMACSHA256 = CreateObject("System.Security.Cryptography.HMACSHA256")
Set LoUTF8 = CreateObject("System.Text.UTF8Encoding")
Set LoEncode = CreateObject("MSXML2.DomDocument").CreateElement("encode")
LoHMACSHA256.Key = LoUTF8.GetBytes_4(ASecretKey)
LoEncode.DataType = "bin.base64"
LoEncode.nodeTypedValue = LoHMACSHA256.ComputeHash_2(LoUTF8.GetBytes_4(ATextToHash))
GetHMACSHA256Base64 = LoEncode.Text
Set LoHMACSHA256 = Nothing
Set LoUTF8 = Nothing
Set LoEncode = Nothing
End Function
' --------------------------
' End of Clover pay routines
' --------------------------
' (SS,12/5/22)
Sub ShowDebug(AMessage)
If DEBUG_ENABLED Then
Response.Write "### " & AMessage & " ###" & BR
End If
End Sub
' --------------------------
' Start of GTM routines
' --------------------------
' (SS,18/10/23) removes VAT from value that may be including VAT, i.e. VAT exclusive value, surprised this function didn't exist before, perhaps it does under a different name
Function GetVATExcValue(AValue)
Dim LResult
' if prices already include VAT then deduct the VAT
If PricesEnteredIncludeVAT Then
LResult = AValue - GetVATAmount(AValue)
Else
LResult = AValue
End If
GetVATExcValue = Round2dp(LResult) ' also rounds to 2 dp
End Function
' (SS,17/10/23) adds item from shopping basket with correct qty to oGTM, call when adding to or removing from basket/cart
' this is necessary to lookup the code, name, price, options, brand, category and subcategory for the product
' a bit complex and messy, relies on calls to GetPricingFromProductRecord and GetProductPrice
' if AIsRemove then we ignore AQty because the item line will be removed later
' ? need separate one for add_shipping_info, add_payment_info and purchase together?
' *** not sure if AIsRemove is needed
' AIsBeginCheckout added to set the correct event for call from GTMAddBasket
Sub GTMSendBasketOperation(AItemID, AIsRemove, AQty, AIsBeginCheckout)
If not oGTM.Enabled Then Exit Sub
' following object used to fetch the options list, i.e. variant
Dim LobjOptionsDict
Set LobjOptionsDict = CreateObject("Scripting.Dictionary")
LobjOptionsDict.CompareMode = vbTextCompare ' makes the keys case insensitive
Dim LSQL
LSQL = GetOrderItemsQuery(FSessionID, False)
' if ItemID specified then filter to just this record
If AItemID <> "" Then
LSQL = ReplaceStr(LSQL, " WHERE ", " WHERE ItemID = '" + CleanSQLStr(AItemID) + "' AND ")
End If
OpenQuery(LSQL)
If Not EndOfQuery Then
Dim LQty
If AIsRemove Then
LQty = -GetQueryValue("Qty") ' NB. make positive a -ve
Else
LQty = AQty
End If
GetPricingFromProductRecord True
' choose appropriate event, add for positive, remove for negative
If AIsBeginCheckout Then
oGTM.EventBeginCheckout
ElseIf LQty < 0 Then
oGTM.EventRemoveFromCart
LQty = -LQty ' NB. make negative a +ve
Else
oGTM.EventAddToCart
End If
Dim LOptionsList, LItemID
LItemID = GetQueryValue("ItemID")
LOptionsList = GetOptionsListForBasketItem(LItemID, "", LobjOptionsDict)
'Response.Write "###GTMSendBasketOperation: " & LItemID & ", " & LQty & ", " & LOptionsList & "###" & BR
' GetVATExcValue necessary for sites like HF where prices include VAT
oGTM.AddItem GetQueryValue("ProductCode"), GetQueryValue("ProductName"), LOptionsList, GetVATExcValue(GetProductPrice), LQty, GetQueryValue("BrandName"), GetQueryValue("Category"), GetQueryValue("Subcategory")
End If
CloseQuery
Set LobjOptionsDict = Nothing
End Sub
' called when checkout begins and before order is actually created
' ? *** may need to rewrite in more efficient way because calling GTMSendBasketOperation isn't the most efficient
Sub GTMAddBasket
' oGTM.AddItem "BASKET", "Basket Check", "", 123.45, 1, "", "", ""
Dim LItemID, LQty
OpenQuery3(GetOrderItemsQuery(FSessionID, False))
Do While Not EndOfQuery3
LItemID = GetQueryValue3("ItemID")
LQty = GetQueryValue3("Qty")
GTMSendBasketOperation LItemID, False, LQty, True
NextQueryRecord3
Loop
CloseQuery3
' discount line
oGTM.DiscountCode = Session("VoucherCode")
If Session("DiscountPassToGTM") <> "" Then ' a bit messy passing it like this, otherwise will need to recalculate the discount
oGTM.AddItem "DISCOUNT", "Discount Voucher Code: " & Session("VoucherCode"), "", GetVATExcValue(Session("DiscountPassToGTM")), 1, "", "", ""
End If
End Sub
' called when order record is created, i.e. when shipping entered, also when payment is made i.e. purchase done
' (SS,19/10/23) rewrite of DoTrackPurchaseEvent for GTM
Sub GTMAddOrder
Dim LOrderNo
LOrderNo = Session("OrderNoPlaced")
' main transaction details
OpenQuery("SELECT o.*, v.VoucherCode FROM orders o LEFT JOIN vouchers v ON v.VoucherID = o.VoucherID WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'")
Dim LSubtotal, LDelivery, LVATIncluded, LVATDeducted, LTax, LDiscount, LVoucherCode
LSubtotal = GetFieldValue("Subtotal")
LDelivery = GetFieldValue("Delivery")
LDiscount = GetFieldValue("Discount") ' (SS,5/3/18) discount held as a negative
LVATIncluded = GetFieldValue("VATIncluded")
LVATDeducted = GetFieldValue("VATDeducted")
LTax = LVATIncluded
LVoucherCode = NB(GetFieldValue("VoucherCode"))
' if prices include VAT then deduct VAT from LSubTotal and LDelivery
LSubtotal = GetVATExcValue(LSubtotal)
LDelivery = GetVATExcValue(LDelivery)
LDiscount = GetVATExcValue(LDiscount)
LSubtotal = Round2dp(LSubtotal + LDiscount) ' remove discount from subtotal (+ because discount is negative)
CloseQuery
oGTM.TransactionID = LOrderNo
oGTM.PurchaseValue = LSubTotal
oGTM.PurchaseTax = Round2dp(LVATIncluded)
oGTM.Shipping = LDelivery
' individual item details, GetOrderDetailsFilter to filter out subproducts
Dim LSQL
LSQL = "SELECT od.*," &_
" b.BrandName, pc.Category, pc.Subcategory" &_
" FROM orderdetails od" &_
" LEFT JOIN products p ON p.ProductCode = od.ProductCode" &_
" LEFT JOIN brands b ON b.BrandID = p.BrandID" &_
" LEFT JOIN productcategories pc ON pc.ProductCode = p.ProductCode AND pc.Main = TRUE" &_
" WHERE OrderNo = '" & CleanSQLStr(LOrderNo) & "'" & GetOrderDetailsFilter & " ORDER BY OrderDetailID"
OpenQuery(LSQL)
Do While Not EndOfQuery
oGTM.AddItem GetFieldValue("ProductCode"), GetFieldValue("ProductName"), GetFieldValue("OptionsList"), GetVATExcValue(GetFieldValue("PriceEach")), GetFieldValue("Qty"), GetFieldValue("BrandName"), GetFieldValue("Category"), GetFieldValue("Subcategory")
NextQueryRecord
Loop
CloseQuery
' discount line
If LDiscount <> 0 Then
oGTM.DiscountCode = LVoucherCode
oGTM.AddItem "DISCOUNT", "Discount Voucher Code: " & LVoucherCode, "", LDiscount, 1, "", "", ""
End If
End Sub
' (SS,23/10/23) added enhanced conversion data
' **** to be continued
Sub GTMAddEnhancedConversionData
If FGoogleEnhancedConversionsEnabled Then
Dim LEmailAddress, LTelephone, LFirstName, LSurname, LPostcode, LCountryCode, LTown, LCounty
If GetEnhancedConversionValues(Session("OrderNoPlaced"), LEmailAddress, LTelephone, LFirstName, LSurname, LPostcode, LCountryCode, LTown, LCounty) Then
oGTM.AddEnchancedConversionData LEmailAddress, LTelephone, LFirstName, LSurname, LTown, LCounty, LPostcode, LCountryCode
End If
End If
End Sub
' to do
' #total value
' #variant missing for "add" and "remove"
' discount voucher
' remove debug text
' disable gtag if GTM used
' get whole basket for begin checkout (view_cart)
' get order items from order record purchase, also check ecommerce purchase code
' check routine Sub DoTrackPurchaseEvent(
' ecommerce checked
' *** for Steve DoOptinMonster to be put in GTM and needs to have conversion value
' tidy GA4 migration, links etc. (see dashboard notification in the header)
' Google Ads remarketing events
' https://support.google.com/google-ads/answer/7305793?hl=en-GB#:~:text=Dynamic%20remarketing%20events%20are%20meaningful,basket%20or%20completing%20a%20transaction.
' do item id need to always have a matching data feed item? what about discount line and other items not sent to the feed?
' check basket groups used by GSC
' nice to have:
' Search event and sign up events for GA4
' Look at remarketing tags
' ActivateGoogleAdWordsNewAccountConversion; sign up event
' enhanced conversions (include customerBillingEmail? see https://measureschool.com/google-ads-enhanced-conversions/ )
' https://support.google.com/google-ads/answer/13262500?hl=en-GB#zippy=%2Cset-up-automatic-enhanced-conversions-with-the-user-provided-data-event-tag%2Cfind-enhanced-conversions-variables%2Cidentify-enhanced-conversions-css-selectors-and-input-into-google-tag-manager%2Cidentify-and-define-your-enhanced-conversions-variables%2Cenable-enhanced-conversions-in-google-tag-manager-and-create-custom-javascript-variable
' consent stuff
' refunds
' (SS,23/10/23) contact form and also competiton, add to datalayer, to remove the following
' <script>_gaq.push(['_trackEvent', 'Form Submitted', 'Contact Us', 'Success']);</script>
' contact form also has onClick="_gaq.push(['_trackEvent', 'Links', 'Contact Us', 'mailto '%=GetStoreEmail%-']);">.%=GetStoreEmail%</a>
' --------------------------
' End of GTM routines
' --------------------------
' --------------------------
' Spam Detection Code
' (SS,5/11/24) added for HyperFlight to stop bot from create bogus order placed records
Function SpamDetection
' (SS,11/11/24) disabled for now
SpamDetection = False
Exit Function
Const MIN_SPEND_SUBTOTAL = 5 ' (SS/8/11/24) was 10
Dim LResult, LTelephone, LCounty, LSQL, LBasketDesc, LBasketGrandTotal, LBasketSubtotal, LEmailAddress, LDeliveryOption
LResult = False
LTelephone = Session("Telephone")
LCounty = Session("County")
LBasketDesc = GetBasketDescription
LBasketGrandTotal = GetBasketGrandTotal
LBasketSubtotal = GetBasketSubtotal
LEmailAddress = Session("Email")
LDeliveryOption = Session("DeliveryOption")
' if spam then log the details and return True
'If LTelephone = "9718884800" Or LTelephone = "9718848282" Then
' dsfdsfsd@fjioewrf.co
' Or (LDeliveryOption = "Collection") Or (LBasketGrandTotal <= 3)
' (InStr(LBasketDesc, "-SALE-100 x ") > 0) Or (LBasketDesc = "-SALE-100 x 1")
' Left(LTelephone, 5) = "97188" Or (Left(LTelephone, 3) = "971" And LCounty = "") Or _
If (LBasketSubtotal < MIN_SPEND_SUBTOTAL) Or (LEmailAddress = "dsfdsfsd@fjioewrf.co") Or (InStr(1, LEmailAddress, "@codexluna.co", vbTextCompare) > 0) Then
LResult = True
LSQL = "INSERT spam_detection SET " &_
"DateTimeDetected=NOW()" &_
", SessionID='" & GetSessionID & "'" &_
", IPAddress='" & CleanSQLStrMax(Request.ServerVariables("REMOTE_ADDR"), 20) & "'" &_
", FirstName='" & CleanSQLStrMax(Session("FirstName"), 100) & "'" &_
", Surname='" & CleanSQLStrMax(Session("Surname"), 100) & "'" &_
", CompanyName='" & CleanSQLStrMax(Session("CompanyName"), 100) & "'" &_
", AddressLine1='" & CleanSQLStrMax(Session("Address1"), 100) & "'" &_
", AddressLine2='" & CleanSQLStrMax(Session("Address2"), 100) & "'" &_
", Town='" & CleanSQLStrMax(Session("Town"), 100) & "'" &_
", County='" & CleanSQLStrMax(Session("County"), 100) & "'" &_
", Postcode='" & CleanSQLStrMax(Session("Postcode"), 20) & "'" &_
", Country='" & CleanSQLStrMax(Session("Country"), 50) & "'" &_
", Telephone='" & CleanSQLStrMax(Session("Telephone"), 100) & "'" &_
", EmailAddress='" & CleanSQLStrMax(Session("Email"), 100) & "'" &_
", DeliveryOption='" & CleanSQLStrMax(Session("DeliveryOption"), 255) & "'" &_
", BasketDescription='" & CleanSQLStrMax(GetBasketDescription, 300) & "'" &_
", BasketSubtotal='" & CleanSQLStrMax(GetBasketSubtotal, 100) & "'" &_
", BasketGrandTotal='" & CleanSQLStrMax(GetBasketGrandTotal, 100) & "'" &_
", UserAgent='" & CleanSQLStrMax(Request.ServerVariables("HTTP_USER_AGENT"), 1000) & "'"
ExecuteQuery LSQL
Session.Abandon
End If
SpamDetection = LResult
End Function
' --------------------------
%>