File: D:/web/circ.itp/woo-to-itp.asp
<!--#include file="dbfunctions.asp"-->
<%
' (SS,4/3/25) following excluded, only dbfunctions.asp used
' <!--#include file="apputils.asp"-->
' <!--#include file="customutils.asp"-->
' ===============
' woo-itp-asp.asp
' ===============
' Version 1.15 (03/06/26)
' ============
' HISTORY
' ============
' (SS,27/08/25) First release when new site went live at 11am
' (SS,27/08/25) Change to Sub WC_GetOrder to abort if no connection, i.e. blank number and order_key
' (SS,28/08/25) Fixed bug in Sub SyncToShoppingAdmin, cause by the second fetch of the same MEDIUMTEXT field returning a NULL on 2nd fetch, correct value returned on first fetch, possible ODBC driver bug/feature
' (SS,02/09/25) Fixed issue causing failure when DATETIMEPAID left blank, order shouldn't have been pushed to wc_orders, it was also a cancelled order, modified to validate for this and return an error message
' Also fixed Discount being positive, it now makes it negative if > 0, also check that subtotal+discount+delivery+vat equals grandtotal otherwise not exported
' (SS,03/09/25) Changes to Function ValidateRecord to validate date paid being after last sales export, also additional checks on the values including VAT
' (SS,04/09/25) Change to Private Function ValidateRecord to allow zero value orders (i.e. not abort when VAT matches GrandTotal where GrandTotal is 0)
' (SS,04/09/25) Change to Public Property Get IPAddress to return "Web Admin" when IP address is blank, prevents failure in Shopping Admin when no IP address asigned due to Web Admin orders
' (SS,10/09/25) Added missing feature to modify the "Last Used Despatch By Date", change to ImportRecords and added routines CustomSetLastUsedRadDespatchByDate, CustomGetLastUsedRadDespatchByDate, GetTokenText, SetTokenText
' Also added server name to log and removed bcc from status email sent
' (SS,17/09/25) Changes to Public Property Get PaymentMethod to detect "Stripe" and set to "STRIPE"
' (SS,30/09/25) Changes to not import of FOC exchange and GrandTotal not 0; check VAT is not zero for UK order (can happen when Recalculate not press in Web Admin)
' Allow import for orders with no items, i.e. delivery only, via a special product code "DELIVERY_CHARGE-ONLY"
' Changes to ImportRecords, ValidateRecord and new DeliveryCountryIsUK and AddSpecialDeliveryItem
' (SS,13/10/25) Change to Public Property Get Status to add "refunded"
' (SS,18/10/25) Added PriceEachBeforeDiscount (field added to wc_order_items)
' Added check for total of items before discount match subtotal in order header
' Added Private Function CheckAndAdjustPrices to ensure PriceEach is 0 for localmode zero value order, other set price each to price each before discount
' (SS,05/12/25) An issue occurred when an order with no items (delivery) was in "completed" status, it failed due to trying to save NULL in the PaymentReceived field.
' It fixed itself an hour or 2 later probably due to session expiring. Added StatusIsCompleted and allows this for setting PaymentReceived.
' Validation is now done to ensure "processing" or "completed" status.
' (SS,02/06/26) Added Function GetOrderDateCompleted and setting for despatch_date for Woo order via API (change to Sub DoWooCommerceSend)
' (SS,03/06/26) Clean payment method for WorldPay from "Pay with Card (World" to "WORLDPAY"
' Adjusted BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES from 20 to 10
%>
<%DisableCache%>
<%
' (SS,4/3/25)
' (SS,11/3/24) access to castironradcen to circ_penn database via following:
' GRANT ALL ON circ_penn.* TO castironradcen;
' This unit needs latest version of dbfunctions.asp - Version 2.08 (07/03/25)
'
' Useful references:
' https://stackoverflow.com/questions/54792800/creating-an-array-of-objects-in-classic-asp
' DoWooCommerceOrderToITP
%>
<%
' (SS,4/8/25) set to false to ensure no data is written to castironradcen database
' when Live mode is true then data is written the database
Const WOO_LIVE_MODE = True
' (SS,2/7/25) constants for ITP valid statues
Const ORDER_PLACED_STATUS = "ORDER PLACED"
Const AWAITING_PAYMENT_STATUS = "AWAITING PAYMENT"
Const PAYMENT_RECEIVED_STATUS = "PAYMENT RECEIVED"
Const ORDER_CANCELLED_STATUS = "CANCELLED"
Const PAYMENT_ON_ACCOUNT_STATUS = "PAYMENT ON ACCOUNT"
Const ORDER_COMPLETED_STATUS = "COMPLETED"
' (SS,25/3/25) special bundle discount, 0% off radiator, 20% of accessories, previously it was 10% of all items (set by StdPrice to SalePrice)
' constants used custom bundle calc from apputils
' (SS,31/7/25) copied from customutils.asp together with Function CustomBundleProductDiscountPercentage
Const BUNDLE_DISCOUNT_OVERRIDE = True
Const BUNDLE_DISCOUNT_PERCENTAGE_RADS = 0
' (SS,3/6/26) adjusted following from 20 to 10%
Const BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES = 10
' (SS,31/7/25) alsi in customutils.asp, used for paint finish price calc
Const PF_BASE_COAT_ONLY = "Base Coat only"
' (SS,15/8/25) send to woo types
Const WST_STATUS = "status"
Const WST_NOTE = "note"
Const WST_METADATA = "metadata"
Dim FoJSON, FoJSONArr
Sub DoWooCommerceOrderToITP(AMainOrderID)
' Response.Write "<h1>WooWooCommerce to ITP</h1>"
' Response.Write "### START ###" & BR & BR
Initialise
ApplicationInitialise
' Set oOrder = New cOrder
' oOrder.SetDefaults
' (SS,10/9/25)
oOrder.Log = "<p>Server Name: " & Request.ServerVariables("SERVER_NAME") & "</p>"
oOrder.MainOrderID = AMainOrderID
' (SS,4/8/25) replaced False with Not IsWooLiveMode
oOrder.TestMode = Not IsWooLiveMode
Dim LSalesTotalsLastExportEndDate
LSalesTotalsLastExportEndDate = GetSQLValue("SELECT DateValue FROM settings WHERE GroupName = 'SalesTotals' AND FieldName = 'LastExportEndDate'")
If IsNull(LSalesTotalsLastExportEndDate) Then
LSalesTotalsLastExportEndDate = 0
Else
LSalesTotalsLastExportEndDate = LSalesTotalsLastExportEndDate + 1 ' one date later
End If
' (SS,3/9/25)
oOrder.MinDateTimePaid = LSalesTotalsLastExportEndDate
' Response.Write "###LSalesTotalsLastExportEndDate: " & LSalesTotalsLastExportEndDate & "###" & BR
' oOrder.MinDateTimePaid =
oOrder.ImportMethod = IM_MYSQL
oOrder.ImportDatabaseName = "circ_penn"
oOrder.ImportTableName = "wc_orders"
oOrder.ImportItemsTableName = "wc_order_items"
'oOrder.ImportRecord
'oOrder.AppendRecord
oOrder.ImportRecords
' Response.Write ReplaceStr(oOrder.SQL, NL, BR) & BR
' Response.Write BR & "### END ###" & BR
Dim LTimer, LEmailBody
LEmailBody = oOrder.Log
ApplicationFinalise
Finalise
LTimer = NL & "<p>(" & GetTimer & ")</p>" & NL
Response.Write LTimer
LEmailBody = LEmailBody & LTimer
SendEmail "contactforms@itpartnership.com", "", "", "woo-to-itp@itpartnership.com", "New Order from WooCommerce Trigger", LEmailBody, True
End Sub
Dim FStartTimer, FEndTimer
Dim oOrder
' (SS,4/8/25)
Function IsWooLiveMode
IsWooLiveMode = WOO_LIVE_MODE
End Function
Sub Initialise
FStartTimer = Timer
OpenDatabase ' only one open is done, close is done in Finalise sub
End Sub
' eturns time taken in seconds to 3 dp, called from ShowTimer
Function GetTimer
FEndTimer = Timer
GetTimer = FormatNumber(FEndTimer - FStartTimer, 3, True) & " secs"
End Function
Sub Finalise
CloseDatabase
FinaliseDBFunctions
' Response.Write NL & "<p>(" & GetTimer & ")</p>" & NL
' Response.Write BR & "<span class=""d-print-none""><small> (" & GetTimer & ")</small></span>"
' Response.Write " <span class=""d-print-none""><small> (Version " & VERSION_NO & " - " & RELEASE_DATE & ")</small></span>"
End Sub
Sub ApplicationInitialise
Set oOrder = New cOrder
oOrder.SetDefaults
End Sub
Function ApplicationFinalise
' destroy the object created in ApplicationInitialise
Set oOrder = Nothing
End Function
Function NL
NL = vbCrLf
End Function
' import method
Const IM_MYSQL = 1
'Const IM_WOO_REST_API = 2
Class cOrder ' or OrderClass not sure about naming convention
Private FMainOrderID ' (SS,22/8/25)
Private FTestMode ' if true then no SQL is run to append rows
Private FImportMethod, FImportDatabaseName, FImportTableName, FImportItemsTableName
Private FSQL, FSQLFieldCount
Private FOrderNo, FWooCommerceOrderID
' not sure about following
Private FSessionID, FIPAddress, FCustomerID, FTitle
Private FFirstName, FSurname, FCompanyName, FAddressLine1, FAddressLine2, FTown, FCounty, FPostcode, FCountry, FTelephone, FAlternativePhone, FEmailAddress
Private FMessage
Private FDateTimeOrdered, FDateTimePaid
Private FDeliveryDate, FDeliveryWillCollect, FDeliveryAddressSameAsInvoice
Private FDeliveryName, FDeliveryCompanyName, FDeliveryAddressLine1, FDeliveryAddressLine2, FDeliveryTown, FDeliveryCounty, FDeliveryPostcode, FDeliveryCountry
' local mode used
Private FNotes, FLocalMode, FExchange, FExchangeReason
' fields update in apputils TryProcessOrder after details are added up
Private FTotalWeight, FSubtotal, FDiscount, FDelivery, FVATIncluded, FVATDeducted, FGrandTotal
Private FMessageToCustomer
Private FDeliveryInfo, FDespatchFromDate, FDespatchByDate, FDeliveryOption, FPriority
Private FPaymentMethod, FPaymentReference, FPaymentInfo, FPaymentReceived
Private FPaymentReceivedAmount, FPaymentReceivedCurrencyCode
Private FStatus
Private FCurrencyCode, FExchangeRate, FDefaultPaymentCurrencyCode, FDefaultPaymentCurrencyRate
' array of item objects holding order items/detail records
Private FItems
Private FValidationFailed, FValidationErrorMsg
Private FOrderCount, FSuccessCount, FFailureCount
Private FLog
Private FMinDateTimePaid ' (SS,3/9/25) minimum allowed date time paid (to ensure nothing exported with date before last date of sales export)
' need to ensure correct field type and length, UTF8 i.e. character set issues
Private Sub Class_Initialize
FTestMode = False
FImportMethod = IM_MYSQL
FImportDatabaseName = ""
FImportTableName = ""
FImportItemsTableName = ""
FOrderCount = 0
FSuccessCount = 0
FFailureCount = 0
FLog = ""
FMainOrderID = ""
FMinDateTimePaid = 0
ClearItems ' not really necessary
End Sub
Public Sub Class_Terminate
End Sub
Public Sub SetDefaults
End Sub
' (SS,22/8/25) the main WooCommerce OrderID passed via URL
Public Property Let MainOrderID(AValue)
FMainOrderID = AValue
End Property
Public Property Get MainOrderID
MainOrderID = FMainOrderID
End Property
Public Property Let TestMode(AValue)
FTestMode = AValue
End Property
Public Property Get TestMode
TestMode = Not IsWooLiveMode
End Property
Public Property Let OrderNo(AValue)
FOrderNo = AValue
End Property
Public Property Get OrderNo
' OrderNo = FOrderNo
'OrderNo = FOrderNo + 100000 ' adds 100,000 just for testing
' it's actually held in the WooCommerceOrderID field of wc_orders
OrderNo = FOrderNo
End Property
Public Property Let WooCommerceOrderID(AValue)
FWooCommerceOrderID = AValue
End Property
Public Property Get WooCommerceOrderID
WooCommerceOrderID = FWooCommerceOrderID
End Property
' (SS,2/7/25) removed, Session ID of this ASP session will be used
'Public Property Let SessionID(AValue)
' FSessionID = AValue
'End Property
Public Property Get SessionID
' SessionID = FSessionID
' (SS,2/7/25) replaced above
SessionID = Session.SessionID
End Property
Public Property Let IPAddress(AValue)
FIPAddress = AValue
End Property
Public Property Get IPAddress
' (SS,4/9/25) added if Null or "" then return "Web Admin", Shopping Admin doesn't like "" in this field
' because it fetches SessionID and IPAddress as authentication used for older non-woo orders when passing to ViewInBrowser
If NB(IPAddress) = "" Then
IPAddress = "Web Admin"
Else
IPAddress = FIPAddress
End If
End Property
Public Property Let CustomerID(AValue)
FCustomerID = AValue
End Property
Public Property Get CustomerID
CustomerID = FCustomerID
End Property
Public Property Let Title(AValue)
FTitle = AValue
End Property
Public Property Get Title
Title = FTitle
End Property
Public Property Let FirstName(AValue)
FFirstName = AValue
End Property
Public Property Get FirstName
FirstName = FFirstName
End Property
Public Property Let Surname(AValue)
FSurname = AValue
End Property
Public Property Get Surname
Surname = FSurname
End Property
Public Property Let CompanyName(AValue)
FCompanyName = AValue
End Property
Public Property Get CompanyName
CompanyName = FCompanyName
End Property
Public Property Let AddressLine1(AValue)
FAddressLine1 = AValue
End Property
Public Property Get AddressLine1
AddressLine1 = FAddressLine1
End Property
Public Property Let AddressLine2(AValue)
FAddressLine2 = AValue
End Property
Public Property Get AddressLine2
AddressLine2 = FAddressLine2
End Property
Public Property Let Town(AValue)
FTown = AValue
End Property
Public Property Get Town
Town = FTown
End Property
Public Property Let County(AValue)
FCounty = AValue
End Property
Public Property Get County
County = FCounty
End Property
Public Property Let Postcode(AValue)
FPostcode = AValue
End Property
Public Property Get Postcode
Postcode = FPostcode
End Property
Public Property Let Country(AValue)
FCountry = LookupCountry(AValue)
End Property
Public Property Get Country
Country = FCountry
End Property
' (SS,30/9/25) used to not to import if zero VAT and country is "United Kingdom"
Public Property Get DeliveryCountryIsUK
Dim LCountry
If DeliveryCounty <> "" Then
LCountry = DeliveryCounty
Else
LCountry = Country
End If
DeliveryCountryIsUK = LCountry = "United Kingdom"
End Property
Public Property Let Telephone(AValue)
FTelephone = AValue
End Property
Public Property Get Telephone
Telephone = FTelephone
End Property
Public Property Let AlternativePhone(AValue)
FAlternativePhone = AValue
End Property
Public Property Get AlternativePhone
AlternativePhone = FAlternativePhone
End Property
Public Property Let EmailAddress(AValue)
FEmailAddress = AValue
End Property
Public Property Get EmailAddress
EmailAddress = FEmailAddress
End Property
Public Property Let Message(AValue)
FMessage = AValue
End Property
Public Property Get Message
Message = FMessage
End Property
Public Property Let DateTimeOrdered(AValue)
FDateTimeOrdered = AValue
End Property
Public Property Get DateTimeOrdered
DateTimeOrdered = FDateTimeOrdered
End Property
Public Property Let DateTimePaid(AValue)
FDateTimePaid = AValue
End Property
Public Property Get DateTimePaid
Dim LVarType
LVarType = VarType(FDateTimePaid)
'Response.Write "###FDateTimePaid:" & LVarType& "###" & BR
If FDateTimePaid = "" Or LVarType = vbEmpty Or LVarType = vbNull Then
' DateTimePaid = vbNull
' *** null not allowed yet, default empty is 0000-00-00 currently, may change
' DateTimePaid = "0000-00-00 00:00:00"
' (Ss,2/9/25) replaced above with following, we're not allowing importing when DateTimePaid is null
DateTimePaid = Null
Else
DateTimePaid = FDateTimePaid
End If
End Property
Public Property Let DeliveryWillCollect(AValue)
FDeliveryWillCollect = AValue
End Property
Public Property Get DeliveryWillCollect
DeliveryWillCollect = FDeliveryWillCollect
End Property
Public Property Let DeliveryAddressSameAsInvoice(AValue)
FDeliveryAddressSameAsInvoice = AValue
End Property
Public Property Get DeliveryAddressSameAsInvoice
DeliveryAddressSameAsInvoice = FDeliveryAddressSameAsInvoice
End Property
Public Property Let DeliveryName(AValue)
FDeliveryName = AValue
End Property
Public Property Get DeliveryName
DeliveryName = FDeliveryName
End Property
Public Property Let DeliveryCompanyName(AValue)
FDeliveryCompanyName = AValue
End Property
Public Property Get DeliveryCompanyName
DeliveryCompanyName = FDeliveryCompanyName
End Property
Public Property Let DeliveryAddressLine1(AValue)
FDeliveryAddressLine1 = AValue
End Property
Public Property Get DeliveryAddressLine1
DeliveryAddressLine1 = FDeliveryAddressLine1
End Property
Public Property Let DeliveryAddressLine2(AValue)
FDeliveryAddressLine2 = AValue
End Property
Public Property Get DeliveryAddressLine2
DeliveryAddressLine2 = FDeliveryAddressLine2
End Property
Public Property Let DeliveryTown(AValue)
FDeliveryTown = AValue
End Property
Public Property Get DeliveryTown
DeliveryTown = FDeliveryTown
End Property
Public Property Let DeliveryCounty(AValue)
FDeliveryCounty = AValue
End Property
Public Property Get DeliveryCounty
DeliveryCounty = FDeliveryCounty
End Property
Public Property Let DeliveryPostcode(AValue)
FDeliveryPostcode = AValue
End Property
Public Property Get DeliveryPostcode
DeliveryPostcode = FDeliveryPostcode
End Property
Public Property Let DeliveryCountry(AValue)
If DeliveryAddressSameAsInvoice Then
FDeliveryCountry = ""
Else
FDeliveryCountry = LookupCountry(AValue)
End If
End Property
Public Property Get DeliveryCountry
DeliveryCountry = FDeliveryCountry
End Property
Public Property Let DeliveryInfo(AValue)
FDeliveryInfo = NB(AValue) ' (SS,10/9/25) added NB
End Property
Public Property Get DeliveryInfo
DeliveryInfo = FDeliveryInfo
End Property
Public Property Let DespatchFromDate(AValue)
FDespatchFromDate = AValue
End Property
Public Property Get DespatchFromDate
DespatchFromDate = FDespatchFromDate
End Property
Public Property Let DespatchByDate(AValue)
FDespatchByDate = AValue
End Property
Public Property Get DespatchByDate
DespatchByDate = FDespatchByDate
End Property
Public Property Let DeliveryOption(AValue)
FDeliveryOption = AValue
End Property
Public Property Get DeliveryOption
DeliveryOption = FDeliveryOption
End Property
Public Property Let PaymentMethod(AValue)
FPaymentMethod = AValue
End Property
Public Property Get PaymentMethod
' convert WooCommerce payment method to standard payment methods in Shoppng Admin
' i.e. credit/debit to STRIPE, Direct bank transfer to BANK TRANSFER, and if it contains paypal then to PAYPAL
Dim LPaymentMethod
LPaymentMethod = LCase(Trim(FPaymentMethod))
' (SS,17/9/25) added or "stripe" after noticed that it's sometimes set to "Stripe"
If LPaymentMethod = "credit / debit card" Or LPaymentMethod = "stripe" Then
PaymentMethod = "STRIPE"
ElseIf LPaymentMethod = "direct bank transfer" Then
PaymentMethod = "BANK TRANSFER"
ElseIf InStr(LPaymentMethod, "paypal") > 0 Then
PaymentMethod = "PAYPAL"
' (SS,3/6/26) added following for worldpay
ElseIf InStr(LPaymentMethod, "pay with card (world") > 0 Then
PaymentMethod = "WORLDPAY"
ElseIf LPaymentMethod = "other" Or LPaymentMethod = "" Then
PaymentMethod = "OTHER"
Else
PaymentMethod = FPaymentMethod
End If
End Property
Public Property Let PaymentReference(AValue)
FPaymentReference = AValue
End Property
Public Property Get PaymentReference
PaymentReference = FPaymentReference
End Property
Public Property Let PaymentInfo(AValue)
FPaymentInfo = AValue
End Property
Public Property Get PaymentInfo
PaymentInfo = FPaymentInfo
End Property
Public Property Let PaymentReceived(AValue)
FPaymentReceived = AValue
End Property
Public Property Get PaymentReceived
PaymentReceived = FPaymentReceived
End Property
Public Property Let PaymentReceivedAmount(AValue)
FPaymentReceivedAmount = AValue
End Property
Public Property Get PaymentReceivedAmount
PaymentReceivedAmount = FPaymentReceivedAmount
End Property
Public Property Let PaymentReceivedCurrencyCode(AValue)
FPaymentReceivedCurrencyCode = AValue
End Property
Public Property Get PaymentReceivedCurrencyCode
PaymentReceivedCurrencyCode = FPaymentReceivedCurrencyCode
End Property
Public Property Let Status(AValue)
FStatus = AValue
End Property
' converts from Woo order status to ITP status
' AWAITING PAYMENT, PAYMENT RECEIVED, COMPLETED, PAYMENT ON ACCOUNT, CANCELLED
' Pending payment, On hold, Processing, Completed, Failed, Draft, Canceled, Refunded
' (SS,13/10/25) added "refunded"
Public Property Get Status
' *** need to map the each status
Dim LStatus
LStatus = LCase(FStatus)
If LStatus = "processing" Then
LStatus = PAYMENT_RECEIVED_STATUS
ElseIf LStatus = "refunded" Then
' (SS,13/10/25) to allow order missed and added later but could be in a refunded status, treate as payment received, to later process the refund
LStatus = PAYMENT_RECEIVED_STATUS
ElseIf LStatus ="pending payment" Or LStatus = "on-hold" Then
LStatus = AWAITING_PAYMENT_STATUS
ElseIf LStatus = "cancelled" Or LStatus = "canceled" Then
LStatus = ORDER_CANCELLED_STATUS
ElseIf LStatus = "completed" Then
LStatus = ORDER_COMPLETED_STATUS
Else
ValidationError = "Invalid order status: " & LStatus
LStatus = ""
End If
Status = LStatus
End Property
Public Property Let CurrencyCode(AValue)
FCurrencyCode = AValue
End Property
Public Property Get CurrencyCode
CurrencyCode = FCurrencyCode
End Property
Public Property Let ExchangeRate(AValue)
FExchangeRate = AValue
End Property
Public Property Get ExchangeRate
ExchangeRate = FExchangeRate
End Property
Public Property Let DefaultPaymentCurrencyCode(AValue)
FDefaultPaymentCurrencyCode = AValue
End Property
Public Property Get DefaultPaymentCurrencyCode
DefaultPaymentCurrencyCode = FDefaultPaymentCurrencyCode
End Property
Public Property Let DefaultPaymentCurrencyRate(AValue)
FDefaultPaymentCurrencyRate = AValue
End Property
Public Property Get DefaultPaymentCurrencyRate
DefaultPaymentCurrencyRate = FDefaultPaymentCurrencyRate
End Property
Public Property Let Priority(AValue)
FPriority = AValue
End Property
Public Property Get Priority
Priority = FPriority
End Property
Public Property Let LocalMode(AValue)
FLocalMode = AValue
End Property
Public Property Get LocalMode
LocalMode = FLocalMode
End Property
Public Property Let Exchange(AValue)
FExchange = AValue
End Property
Public Property Get Exchange
Exchange = FExchange
End Property
Public Property Let ExchangeReason(AValue)
FExchangeReason = AValue
End Property
Public Property Get ExchangeReason
ExchangeReason = FExchangeReason
End Property
' === start of values to be calculated from order details ===
Public Property Let TotalWeight(AValue)
FTotalWeight = AValue
End Property
Public Property Get TotalWeight
TotalWeight = FTotalWeight
End Property
Public Property Let Subtotal(AValue)
FSubtotal = AValue
End Property
Public Property Get Subtotal
Subtotal = FSubtotal
End Property
Public Property Let Discount(AValue)
FDiscount = AValue
' (SS,2/9/25) make sure discount is negative
If FDiscount > 0 Then FDiscount = -FDiscount
End Property
Public Property Get Discount
Discount = FDiscount
End Property
Public Property Let Delivery(AValue)
FDelivery = AValue
End Property
Public Property Get Delivery
Delivery = FDelivery
End Property
Public Property Let VATIncluded(AValue)
FVATIncluded = AValue
End Property
Public Property Get VATIncluded
VATIncluded = FVATIncluded
End Property
Public Property Let GrandTotal(AValue)
FGrandTotal = AValue
End Property
Public Property Get GrandTotal
GrandTotal = FGrandTotal
End Property
' === end of values to be calculated from order details ===
' notes
' =====
'
' CleanSQLStr usage?
Public Property Let ImportMethod(AValue)
FImportMethod = AValue
End Property
Public Property Get ImportMethod
ImportMethod = FImportMethod
End Property
Public Property Let ImportDatabaseName(AValue)
FImportDatabaseName = AValue
End Property
Public Property Get ImportDatabaseName
ImportDatabaseName = FImportDatabaseName
End Property
Public Property Let ImportTableName(AValue)
FImportTableName = AValue
End Property
Public Property Get ImportTableName
ImportTableName = FImportTableName
End Property
Public Property Let ImportItemsTableName(AValue)
FImportItemsTableName = AValue
End Property
Public Property Get ImportItemsTableName
ImportItemsTableName = FImportItemsTableName
End Property
Private Function LookupCountry(ACountry)
' looks up country if it's two chars long, else returns the same
Dim LCountryName
LCountryName = LookupCountryForISO(ACountry)
If LCountryName = "" Then
' Err.Raise vbObjectError + 516, "cOrder.LookupCountry", "Country Code '" & ACountry & "' not found"
ValidationError = "invalid country code '" & ACountry & "'"
End If
LookupCountry = LCountryName
End Function
Public Sub ImportRecords
If FImportMethod = IM_MYSQL Then
If FImportDatabaseName = "" Then
'Err.Raise 513, "cOrder.ImportRecord", "Database name not assigned"
Err.Raise vbObjectError + 513, "cOrder.ImportRecord", "Database name not assigned"
ElseIf FImportTableName = "" Then
Err.Raise vbObjectError + 514, "cOrder.ImportRecord", "Table name not assigned"
ElseIf FImportItemsTableName = "" Then
Err.Raise vbObjectError + 515, "cOrder.ImportRecord", "Items table name not assigned"
End If
Else
Err.Raise "No such import method"
End If
' !!! will need to look at outstanding orders rather than latest like following does
' !!! added WHERE for test order 569746 which contains decent data
'OpenQuery("SELECT * FROM circ_penn.orders ORDER BY OrderNo LIMIT 1")
' Dim LTestOrderNo
' LTestOrderNo = 569746
' OpenQuery("SELECT * FROM circ_penn.orders WHERE OrderNo = " & LTestOrderNo)
' OpenQuery("SELECT * FROM circ_penn." + FImportTableName + " WHERE OrderNo = " & LTestOrderNo)
' all orders that haven't yet been imported in WooCommerceOrderID order
OpenQuery("SELECT * FROM circ_penn." + FImportTableName + " WHERE NOT Imported ORDER BY WooCommerceOrderID")
Do While Not EndOfQuery
' clear validation, ready for new record, ImportRecordFromMySQL may use ValidationError if country is invalid
StartValidation
ImportRecordFromMySQL
If ValidateRecord Then
ImportItemsMySQL
' (SS,30/9/25) if there are no items and there is a delivery charge then add the special delivery item
' because WC allows delivery only without item, no order item records might cause issue in Shopping Admin
If ItemCount = 0 And Round2dp(Subtotal) = 0 And Round2dp(Delivery) <> 0 Then
AddSpecialDeliveryItem
End If
If ValidateItems Then
' (SS,18/10/25) added following to sort subtotal, discount and price each for local mode FOC and to use PriceEachBeforeDiscount
CheckAndAdjustPrices
AppendRecord
' update the PrevStock fields for all products in this order
UpdatePrevStock OrderNo
' take order from stock
TakeProductsFromStock OrderNo, True
End If
End If
If IsValid Then
' set the import flag to true, to indicate imported, i.e. don't import again
MarkAsImported
' StatusFailedTest ' mark order as failed via API, just testing
' (SS,10/9/25) added following to update the Last Used Despatch By Date in tokens
' used to be maintained by website after order was processed to prevent availability going backwards when production rate increased and completed orders
CustomSetLastUsedRadDespatchByDate DespatchByDate
Else
' mark as failed, i.e. set the ImportError field
MarkAsFailed
End If
Log = WooCommerceOrderID & ", " & OrderNo & ", " & ValidationMessageHTML & BR
IncrementCount
NextQueryRecord
Loop
CloseQuery
Log = BR & "Orders: " & oOrder.OrderCount & BR
Log = "Successful: " & oOrder.SuccessCount & BR
Log = "Failed: " & oOrder.FailureCount & BR
End Sub
Public Property Let Log(AValue)
FLog = FLog & AValue
Response.Write AValue
End Property
Public Property Get Log
Log = FLog
End Property
Public Property Let MinDateTimePaid(AValue)
FMinDateTimePaid = AValue
Response.Write AValue
End Property
Private Property Get MinDateTimePaid
MinDateTimePaid = FMinDateTimePaid
End Property
Private Sub IncrementCount
FOrderCount = FOrderCount + 1
If IsValid Then
FSuccessCount = FSuccessCount + 1
Else
FFailureCount = FFailureCount + 1
End If
End Sub
Public Property Get OrderCount
OrderCount = FOrderCount
End Property
Public Property Get SuccessCount
SuccessCount = FSuccessCount
End Property
Public Property Get FailureCount
FailureCount = FFailureCount
End Property
Private Sub StartValidation
FValidationFailed = False
FValidationErrorMsg = ""
End Sub
Private Property Let ValidationError(AValue)
If FValidationErrorMsg <> "" Then FValidationErrorMsg = FValidationErrorMsg & ", "
FValidationErrorMsg = FValidationErrorMsg & AValue
FValidationFailed = True
End Property
Private Property Get ValidationMessage
If FValidationFailed Then
ValidationMessage = FValidationErrorMsg
Else
ValidationMessage = "Success"
End If
End Property
Private Property Get ValidationMessageHTML
If FValidationFailed Then
ValidationMessageHTML = "<span style=""color:red"">" & ValidationMessage & "</span>"
Else
ValidationMessageHTML = ValidationMessage
End If
End Property
Private Property Get IsValid
IsValid = Not FValidationFailed
End Property
Private Function ValidateRecord
' check if order already exists
' in test mode, delete record before adding
' check country valid, check other required fields
' !!! need to check and sort if invoice address same as delivery
' (SS,30/9/25) moved following here from below
Dim LGrandTotal
LGrandTotal = Round2dp(GrandTotal)
If OrderNo < 600000 Then
ValidationError = "order number too small"
ElseIf OrderAlreadyExists(OrderNo) Then
ValidationError = "order already exists"
' (SS,2/9/25) make sure date/time paid has been filled in
ElseIf Status = ORDER_CANCELLED_STATUS Then
ValidationError = "can't import cancelled order"
ElseIf IsNull(DateTimePaid) Then
ValidationError = "missing date/time paid"
' (SS,3/9/25) check date paid is after the minimum (to prevent sales accounts issues)
ElseIf DateTimePaid < MinDateTimePaid Then
ValidationError = "date/time paid is " & DateTimePaid & " it must before be >= " & MinDateTimePaid
' (SS,10/9/25) added following checks
ElseIf DeliveryInfo = "" Then
ValidationError = "missing DeliveryInfo"
ElseIf IsNull(DespatchFromDate) Then
ValidationError = "missing DespatchFromDate"
ElseIf IsNull(DespatchByDate) Then
ValidationError = "missing DespatchByDate"
' (SS,30/9/25) if FOC (Free of charge exchange) then make sure Grand Total is zero
ElseIf InStr(UCase(ExchangeReason), "(FOC)") > 0 And LGrandTotal <> 0 Then
ValidationError = "GrandTotal is " & LGrandTotal & ", it must be 0 for FOC exchange"
' (SS,5/12/2025)
ElseIf Not (StatusIsPaymentReceived Or StatusIsCompleted) Then
ValidationError = "Status must be 'processing' or 'completed'"
End If
' others checks to add:
' zero VAT check for UK orders
' delivery charge item when missing items
' (SS,3/9/25) check to ensure the figures are sensible
If IsValid Then
Dim LTotalExcVAT, LVATAmount, LTotalIncVAT, LVATPC
LTotalExcVAT = Round2dp(Subtotal + Discount + Delivery)
LVATAmount = Round2dp(VATIncluded)
LTotalIncVAT = Round2dp(LTotalExcVAT + LVATAmount)
If LVATAmount > 0 And LGrandTotal > 0 And LTotalExcVAT > 0 Then
LVATPC = Round2dp(LVATAmount / LTotalExcVAT * 100)
Else
LVATPC = 0
End If
If LTotalIncVAT <> LGrandTotal Then
ValidationError = "Subtotal+Discount+Delivery+VAT doesn't equal GrandTotal: " & LTotalIncVAT & " ≠ " & LGrandTotal
ElseIf LGrandTotal <> 0 And LVATAmount = LGrandTotal Then ' (SS,4/9/25) added LGrandTotal <> 0 to allow, otherwise it'll stop zero value orders from importing
ValidationError = "VAT amount same as grand total"
ElseIf LVATPC <> 0 And (LVATPC < 15 Or LVATPC > 25) Then
ValidationError = "VAT of " & LVATPC & "% seems wrong"
' (SS,30/9/25) added zero VAT check for UK orders when there's a Grand Total, can occur if "Recalculate" button not pressed in "Web Admin" mode
ElseIf LGrandTotal <> 0 And LVATAmount = 0 And DeliveryCountryIsUK Then
ValidationError = "VAT should not be zero for UK order"
End If
End If
ValidateRecord = IsValid
End Function
Private Function OrderAlreadyExists(AOrderNo)
OrderAlreadyExists = GetSQLRecordExists("SELECT OrderNo FROM orders WHERE OrderNo = " & AOrderNo)
End Function
Private Sub StatusFailedTest
' parameters: (AIsLocalTest, AOrderID, AStatus, AGetOnly)
DoWooCommerceSendOrderStatus False, OrderNo, "failed", False
End Sub
Private Sub ImportRecordFromMySQL
' OrderNo = GetQueryValue("WooCommerceOrderID")
OrderNo = GetQueryValue("OrderNumber")
WooCommerceOrderID = GetQueryValue("WooCommerceOrderID")
'*** to be completed, add a Imported flag, or ImportStatus
' SessionID = GetQueryValue("SessionID")
IPAddress = GetQueryValue("IPAddress")
' CustomerID not applicable leave as null for now
' CustomerID = GetQueryValue("IPAddress")
' not used in Shopping Admin, leave as null
' Title = GetQueryValue("Title")
FirstName = GetQueryValue("FirstName")
Surname = GetQueryValue("Surname")
CompanyName = GetQueryValue("CompanyName")
AddressLine1 = GetQueryValue("AddressLine1")
AddressLine2 = GetQueryValue("AddressLine2")
Town = GetQueryValue("Town")
County = GetQueryValue("County")
Postcode = GetQueryValue("Postcode")
Country = GetQueryValue("Country")
Telephone = GetQueryValue("Telephone")
AlternativePhone = GetQueryValue("AlternativePhone")
' following not used
' Mobile = GetQueryValue("Mobile")
EmailAddress = GetQueryValue("EmailAddress")
' following left out for now
'Subscribe = GetQueryValue("Subscribe")
'HearAboutUs = GetQueryValue("HearAboutUs")
'HearAboutUsOther = GetQueryValue("HearAboutUsOther")
'PurchaseOrderNo = GetQueryValue("PurchaseOrderNo")
' following is customer instructions message
Message = GetQueryValue("Message")
' followiing is internal notes, not sure if getting from Woo is applicable
' Notes = GetQueryValue("Notes")
' date fields default to '0000-00-00 00:00:00' perhaps NULL is a better default, will need to change schema to remove NOT NULL
DateTimeOrdered = GetQueryValue("DateTimeOrdered")
DateTimePaid = GetQueryValue("DateTimePaid")
' following is copied from Woo because it's completed in Shopping Admin
' DateTimeCompleted = GetQueryValue("DateTimeCompleted")
' ? do we assume that WooC has calculated correctly
'TotalWeight = GetQueryValue("TotalWeight")
' VoucherID, i.e. voucher not stored in Shopping Admin, Woo has it's now voucher codes
' VoucherID = GetQueryValue("VoucherID")
' Woo will need to populate the following correctly, or could calculate it from the detail records
' values need to be in GBP
Subtotal = GetQueryValue("Subtotal")
Discount = GetQueryValue("Discount")
Delivery = GetQueryValue("Delivery")
VATIncluded = GetQueryValue("VATIncluded")
' following will always be 0, due to VAT exclusive prices
'VATDeducted = GetQueryValue("VATDeducted")
GrandTotal = GetQueryValue("GrandTotal")
DeliveryWillCollect = GetQueryValue("DeliveryWillCollect")
' not used, could add if required
'DeliveryDate = GetQueryValue("DeliveryWillCollect")
' not show how Woo has an equivalent i.e. delivery name and address will always be populated
DeliveryAddressSameAsInvoice = GetQueryValue("DeliveryAddressSameAsInvoice")
' following is a single name instead of separate first name and surname
DeliveryName = GetQueryValue("DeliveryName")
DeliveryCompanyName = GetQueryValue("DeliveryCompanyName")
DeliveryAddressLine1 = GetQueryValue("DeliveryAddressLine1")
DeliveryAddressLine2 = GetQueryValue("DeliveryAddressLine2")
DeliveryTown = GetQueryValue("DeliveryTown")
DeliveryCounty = GetQueryValue("DeliveryCounty")
DeliveryPostcode = GetQueryValue("DeliveryPostcode")
DeliveryCountry = GetQueryValue("DeliveryCountry")
' holds the anticipated from and to despatch dates
DeliveryInfo = GetQueryValue("DeliveryInfo")
DespatchFromDate = GetQueryValue("DespatchFromDate")
DespatchByDate = GetQueryValue("DespatchByDate")
' followings populated with <b>Kerbside</b> Pallet for radiator orders, blank others, might not be required
'DeliveryOption = GetQueryValue("DeliveryOption")
' no of pallets I think, entered in Shopping Admin, not imported from Woo
' DeliveryItems = GetQueryValue("DeliveryOption")
' not used
' PackageSize = GetQueryValue("PackageSize")
PaymentMethod = GetQueryValue("PaymentMethod")
PaymentReference = GetQueryValue("PaymentReference")
' following manually entered by admin
'PaymentInfo = GetQueryValue("PaymentInfo")
' not used, always blank, only a couple of orders where it's enter in Shoppping Admin
' InvoiceNo = GetQueryValue("InvoiceNo")
' Status needs to be map from Woo's equivalent
Status = GetQueryValue("Status")
' set the payment received amount if payment received status, this field needs a value, don't think it's essential
' (SS,5/12/25) added Or StatusIsCompleted, to fix bug where it was tried to set PaymentReceived to NULL when status was completed
If StatusIsPaymentReceived Or StatusIsCompleted Then
' flag set to true (1) to indicate payment was received
PaymentReceived = GetQueryValue("PaymentReceived")
PaymentReceivedAmount = GrandTotal
PaymentReceivedCurrencyCode = CurrencyCode ' (SS,27/8/25)
End If
' amount received from payment provide not essential
'PaymentReceivedAmount = GetQueryValue("PaymentReceivedAmount")
' following currently always GBP for CIRC
'PaymentReceivedCurrencyCode = GetQueryValue("PaymentReceivedCurrencyCode")
' not required, does get filled in for PayPal payments, not essential
' PaymentProviderSurcharge = GetQueryValue("PaymentProviderSurcharge")
' PaymentProviderFee = GetQueryValue("PaymentProviderFee")
' currency of the sale, which currency the customer was charged
' might be best to default these to GBP and 1, especially if they're empty
CurrencyCode = GetQueryValue("CurrencyCode")
ExchangeRate = GetQueryValue("ExchangeRate")
' DefaultPaymentCurrencyCode = GetQueryValue("DefaultPaymentCurrencyCode")
' DefaultPaymentCurrencyRate = GetQueryValue("DefaultPaymentCurrencyRate")
' hasn't been entered/used since Brexit
'VATNumber = GetQueryValue("VATNumber")
' not longer applicable, since leaving the EC, default to 0
'IntraCommunitySupply = GetQueryValue("IntraCommunitySupply")
' required by non-UK i.e. international orders
' (SS,21/8/25) remoeved
'EORINumber = GetQueryValue("EORINumber")
'XIEORINumber = GetQueryValue("XIEORINumber")
' rarely used, only a handful of records on ShoppingAdmin,
'Courier = GetQueryValue("Courier")
'TrackingNo = GetQueryValue("TrackingNo")
' special despatched order message to customer, not passed from Woo, generated by ShoppingAdmin
'MessageToCustomer = GetQueryValue("MessageToCustomer")
' not necessary, also doesn't make sense because previous customers not in Woo, we check and populate with 1 if email address not used before
' NewCustomer = GetQueryValue("NewCustomer")
' following entered in ShoppingAdmin where applicable
'DeliveryAgentName = GetQueryValue("DeliveryAgentName")
'DeliveryAgentDate = GetQueryValue("DeliveryAgentDate")
'DeliveryAgentCost = GetQueryValue("DeliveryAgentCost")
'PackedBy = GetQueryValue("PackedBy")
'GrossWeight = GetQueryValue("GrossWeight") ' rarely filled in
'CN22TariffCode = GetQueryValue("CN22TariffCode") ' not used at all
'CommercialInvoiceInfo = GetQueryValue("CommercialInvoiceInfo")
' following not applicable
'ReviewRequestSentDate = GetQueryValue("ReviewRequestSentDate")
'CancelledOrderChasedDate = GetQueryValue("CancelledOrderChasedDate")
'PaymentLog = GetQueryValue("PaymentLog")
'DateTimePrinted = GetQueryValue("DateTimePrinted")
' following is an additional or custom field, might be entered in Woo, else we create it from various attributes e.g. whether exchange or not
Priority = GetQueryValue("Priority")
' filled in by ShoppingAdmin
'PickListID = GetQueryValue("PickListID")
'ReadyForDespatch = GetQueryValue("ReadyForDespatch")
' custom fields, hopefully supplied by Woo
LocalMode = GetQueryValue("LocalMode")
Exchange = GetQueryValue("Exchange")
ExchangeReason = GetQueryValue("ExchangeReason")
' not applicable
'LastUpdated = GetQueryValue("LastUpdated")
'Extras = GetQueryValue("Extras")
'Response.Write "OrderNo=" & OrderNo & ", FirstName=" & FirstName & ", Surname=" & Surname & BR
End Sub
' (SS,2/7/25)
Private Function StatusIsPaymentReceived
StatusIsPaymentReceived = Status = PAYMENT_RECEIVED_STATUS
End Function
' (SS,5/12/25)
Private Function StatusIsCompleted
StatusIsCompleted = Status = ORDER_COMPLETED_STATUS
End Function
Private Sub ClearSQL
FSQL = ""
FSQLFieldCount = 0
End Sub
Private Sub AddSQL(ASQL)
If FSQL <> "" Then FSQL = FSQL & NL
FSQL = FSQL & ASQL
End Sub
' ? do we need to ensure correct field length for strings via CleanSQLStrMax
Private Sub AddField(AFieldName, AValue)
Dim LValue, LVarType
FSQLFieldCount = FSQLFieldCount + 1
' if not first field then append comma
If FSQLFieldCount > 1 Then
FSQL = FSQL & ","
End If
FSQL = FSQL & NL ' added new line to make statement more readable
FSQL = FSQL & AFieldName & "="
LVarType = VarType(AValue)
If LVarType = vbEmpty Or LVarType = vbNull Then
LValue = "NULL"
ElseIf LVarType = vbInteger Or LVarType = vbLong Or LVarType = vbBoolean Then
LValue = CStr(AValue)
ElseIf LVarType = vbDouble Or LVarType = vbSingle Or LVarType = vbDecimal Then
LValue = CStr(AValue)
ElseIf LVarType = vbDate Then
LValue = ConvertUKToMySQLDateTime(AValue)
Else ' assume string, clean/escape it for SQL
LValue = "'" & CleanSQLStr(AValue) & "'"
End If
' LValue = AValue ' Trim(AValue)
' If ABlankToNull And LValue = "" Then
' FSQL = FSQL & "NULL"
' Else
' FSQL = FSQL & "'" & CleanSQLStr(LValue) & "'"
' End If
FSQL = FSQL & LValue
' FSQL = FSQL + " " + VarTypeAsString(AValue)
End Sub
' ? validation routine before
Public Sub AppendRecord
ClearSQL
AddSQL "INSERT INTO orders SET"
AddField "OrderNo", OrderNo
AddField "WooCommerceOrderID", WooCommerceOrderID ' (SS,30/7/25)
AddField "SessionID", SessionID
AddField "IPAddress", IPAddress
'AddFieldBN "CustomerID", CustomerID
AddField "CustomerID", CustomerID
' AddField "Title", Title
AddField "FirstName", FirstName
AddField "Surname", Surname
AddField "CompanyName", CompanyName
AddField "AddressLine1", AddressLine1
AddField "AddressLine2", AddressLine2
AddField "Town", Town
AddField "County", County
AddField "Postcode", Postcode
AddField "Country", Country
AddField "Telephone", Telephone
AddField "EmailAddress", EmailAddress
' AddField "Subscribe", Subscribe
' AddField "PurchaseOrderNo", PurchaseOrderNo
AddField "Message", Message
AddField "DateTimeOrdered", DateTimeOrdered
' AddField "DeliveryDate", DeliveryDate
AddField "DeliveryWillCollect", DeliveryWillCollect
AddField "DeliveryAddressSameAsInvoice", DeliveryAddressSameAsInvoice
AddField "DeliveryName", DeliveryName
AddField "DeliveryCompanyName", DeliveryCompanyName
AddField "DeliveryAddressLine1", DeliveryAddressLine1
AddField "DeliveryAddressLine2", DeliveryAddressLine2
AddField "DeliveryTown", DeliveryTown
AddField "DeliveryCounty", DeliveryCounty
AddField "DeliveryPostcode", DeliveryPostcode
AddField "DeliveryCountry", DeliveryCountry
AddField "Status", Status
AddField "CurrencyCode", CurrencyCode
AddField "ExchangeRate", ExchangeRate
AddField "DefaultPaymentCurrencyCode", DefaultPaymentCurrencyCode
AddField "DefaultPaymentCurrencyRate", DefaultPaymentCurrencyRate
' AddField "VATNumber", VATNumber
'AddField "EORINumber", EORINumber
'AddField "XIEORINumber", XIEORINumber
' AddField "IntraCommunitySupply", IntraCommunitySupply
' AddField "VoucherID", VoucherID
' AddField "PaymentLog", PaymentLog
' AddField "Notes", Notes
AddField "LocalMode", LocalMode
AddField "Exchange", Exchange
AddField "ExchangeReason", ExchangeReason
AddField "AlternativePhone", AlternativePhone ' , 100
'AddField "HearAboutUs", HearAboutUs ' , 100
'AddField "HearAboutUsOther", HearAboutUsOther ' , 100
' AddField "Extras", Extras
AddField "Subtotal", Subtotal
AddField "Discount", Discount
AddField "Delivery", Delivery
AddField "VATIncluded", VATIncluded
' AddField "VATDeducted", VATDeducted
AddField "GrandTotal", GrandTotal
AddField "TotalWeight", TotalWeight
' AddField "MessageToCustomer", MessageToCustomer
AddField "DeliveryInfo", DeliveryInfo
AddField "DespatchFromDate", DespatchFromDate
AddField "DespatchByDate", DespatchByDate
AddField "DeliveryOption", DeliveryOption
AddField "Priority", Priority
' from
'Sub UpdateOrderStatusForOrderPlaced
'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 & "')")
AddField "DateTimePaid", DateTimePaid
AddField "PaymentMethod", PaymentMethod
AddField "PaymentReference", PaymentReference
AddField "PaymentInfo", PaymentInfo
AddField "PaymentReceived", PaymentReceived
AddField "PaymentReceivedAmount", PaymentReceivedAmount
AddField "PaymentReceivedCurrencyCode", PaymentReceivedCurrencyCode
'PaymentReceivedAmount
'PaymentReceivedCurrencyCode
' NewCustomer
RunSQL SQL
' add the items in this order i.e orderdetails records
AppendItems
UpdateTotalWeight ' calculate and update the total weight in order record
End Sub
Private Property Get SQL
SQL = FSQL
End Property
Private Sub RunSQL(ASQL)
' Response.Write BR & ReplaceStr(SQL, NL, BR) & BR
If Not TestMode Then
ExecuteQuery ASQL
End If
End Sub
' === start of items ===
' following defined earlier
' Private FItems
' empty the items array ready for next oder
Private Sub ClearItems
FItems = Array()
End Sub
Private Property Get Items
Items = FItems
End Property
Private Property Set Items(AValue)
Set FItems = AValue
End Property
Private Sub AddItem(AValue)
ReDim Preserve FItems(UBound(FItems) + 1)
Set FItems(UBound(FItems)) = AValue
End Sub
Private Property Get ItemCount
' i.e. number of item lines
ItemCount = UBound(FItems) + 1
End Property
Private Function ImportItemsMySQL
ClearItems
Dim LItem
' OpenQuery("SELECT * FROM circ_penn.orderdetails WHERE OrderNo = " & FOrderNo & " ORDER BY OrderDetailID")
'OpenQuery("SELECT * FROM circ_penn." + FImportItemsTableName + " WHERE OrderNo = " & FOrderNo & " ORDER BY OrderDetailID")
' (SS,24/4/25) NB. WooCommerceOrderID used instead of OrderNo for the field name
' (SS,22/5/25) renamed OrderDetailID to OrderItemID, and IsBundle to PartOfBundle
' (SS,24/7/25) replaced WooCommerceOrderID with OrderNumber
OpenQuery2("SELECT * FROM circ_penn." + FImportItemsTableName + " WHERE OrderNumber = " & FOrderNo & " ORDER BY OrderItemID")
Do While Not EndOfQuery2
Set LItem = New cOrderItem
LItem.ProductCode = Trim(GetQueryValue2("ProductCode"))
LItem.ProductName = Trim(GetQueryValue2("ProductName"))
LItem.Qty = GetQueryValue2("Qty")
LItem.PriceEach = GetQueryValue2("PriceEach")
LItem.PriceEachBeforeDiscount = GetQueryValue2("PriceEachBeforeDiscount") ' (SS,18/10/25)
' up to 2 options held in same table
LItem.Option1Name = Trim(GetQueryValue2("Option1Name"))
LItem.Option1Value = Trim(GetQueryValue2("Option1Value"))
LItem.Option2Name = Trim(GetQueryValue2("Option2Name"))
LItem.Option2Value = Trim(GetQueryValue2("Option2Value"))
' (SS,30/7/25)
LItem.AccessoryPack = GetQueryValue2("AccessoryPack")
LItem.WooCommerceItemID = GetQueryValue2("WooCommerceItemID")
LItem.WooCommerceOrderID = GetQueryValue2("WooCommerceOrderID")
LItem.WooCommerceProductID = GetQueryValue2("ProductID")
LItem.WooCommerceProductVariationID = GetQueryValue2("ProductVariationID") ' (SS,18/8/25)
AddItem(LItem) ' add to the array holding items
' OrderNo = GetQueryValue("OrderNo")
'Response.Write "###" & "ProductCode: " & LItem.ProductCode & ", Qty: " & LItem.Qty & ", PriceEach: " & LItem.PriceEach & "###" & BR
NextQueryRecord2
Loop
CloseQuery2
End Function
' (SS,30/9/25) special delivery dummy item with zero value, ensures at least one item in order i.e. when only delivery is included
Private Function AddSpecialDeliveryItem
ClearItems
Dim LItem
Set LItem = New cOrderItem
LItem.ProductCode = "DELIVERY-CHARGE-ONLY"
LItem.ProductName = "Delivery Charge Only Order"
LItem.Qty = 1
LItem.PriceEach = 0
AddItem(LItem)
End Function
Private Function ValidateItems
' at least one item
' make sure each product code exists and not blank, also product name not blank
' also populates ProductID
' also populates the HasSubproducts property (used later to create subproducts)
' (SS,28/7/25) now populates the IsBundle property
' (SS,18/10/25) added check for Subtotal match with total of items before discount (LItemsTotal)
Dim LItem, LProductID, LHasSubproducts, LIsBundle, LItemsTotal
If ItemCount = 0 Then
ValidationError = "No items"
Else
LItemsTotal = 0 ' (SS,18/10/25)
For Each LItem in Items
If LItem.ProductCode = "" Then
ValidationError = "blank product code"
ElseIf LItem.ProductName = "" Then
ValidationError = "blank product name"
Else ' check product code is valid, for bespoke radiator (i.e. has subproducts), make sure options are valid
' (SS,28/7/28) added IsBundle, i.e. special products normally with "-BUND" suffix
If GetSQL3Values("SELECT ProductID, HasSubproducts, IsBundle FROM products WHERE ProductCode = '" & CleanSQLStr(LItem.ProductCode) & "'", LProductID, LHasSubproducts, LIsBundle) Then
LItem.ProductID = LProductID
LItem.HasSubproducts = IntToBool(LHasSubproducts) ' set this property, used later to check whether to create subproduct records
LItem.IsBundle = IntToBool(LIsBundle) ' (SS,28/7/25)
' get the option ID if applicable, will create error if option name assigned and not applicable
LItem.Option1ID = GetOptionID(LItem.ProductID, LItem.ProductCode, LItem.Option1Name)
LItem.Option2ID = GetOptionID(LItem.ProductID, LItem.ProductCode, LItem.Option2Name)
' *** !!! 0 for now, will need to lookup the value ID for some products but not custom options e.g. bespokes rads
LItem.Option1ValueID = 0
LItem.Option2ValueID = 0
LItem.Option1ValueIDRequired = False
LItem.Option2ValueIDRequired = False
If CheckRequiredOptionsEntered(LItem) Then
LItem.Option1ValueID = GetOptionValueID(LItem.ProductCode, LItem.Option1ID, LItem.Option1Name, LItem.Option1Value, LItem.Option1ValueIDRequired)
LItem.Option2ValueID = GetOptionValueID(LItem.ProductCode, LItem.Option2ID, LItem.Option2Name, LItem.Option2Value, LItem.Option2ValueIDRequired)
If IsValid And LItem.HasSubproducts Then
ValidateOptionsForBespokeRads LItem.ProductCode, LItem.Option1Name, LItem.Option1Value, LItem.Option2Name, LItem.Option2Value
End If
End If
Else
ValidationError = "invalid product code: " & LItem.ProductCode
End If
End If
LItemsTotal = Round2dp(LItemsTotal + (LItem.Qty * LItem.PriceEachBeforeDiscount)) ' (SS,18/10/25)
If Not IsValid Then Exit For
Next
' (SS,18/10/25) error if items total before discount doesn't match subtotal
If Subtotal <> LItemsTotal Then ValidationError = "subtotal " & Subtotal & " doesn't match items total " & LItemsTotal
End If
ValidateItems = IsValid
End Function
' (SS,18/10/25) checks if local mode order with subtotal equivalent to 0, i.e. subtotal same as -discount
' if so, then it sets subtotal and discount to zero and all prices to 0 i.e. it's a special FOC order (warranty exchange)
' otherwise it sets the PriceEach to be PriceEachBeforeDiscount because PriceEach will have discount applied, Shopping Admin only holds discount in the discount field
Private Function CheckAndAdjustPrices
Dim LSpecialZeroValueOrder, LItem
If LocalMode And Round2dp(Subtotal + Discount) = 0 Then
LSpecialZeroValueOrder = True
Subtotal = 0
Discount = 0
Else
LSpecialZeroValueOrder = False
End If
For Each LItem in Items
If LSpecialZeroValueOrder Then
LItem.PriceEach = 0
Else
LItem.PriceEach = Round2dp(LItem.PriceEachBeforeDiscount)
End If
Next
End Function
Private Function GetOptionID(AProductID, AProductCode, AOptionName)
GetOptionID = 0
If AOptionName <> "" Then
Dim LResult
LResult = GetSQLValueAsString("SELECT ProductOptionID, Required FROM product_options WHERE ProductID = '" & AProductID & "' AND OptionName = '" & CleanSQLStr(AOptionName) & "'")
If LResult = "" Then
ValidationError = "Option " & AOptionName & " not valid for " & AProductCode
Else
GetOptionID = CLng(LResult)
End If
End If
End Function
Private Function GetOptionValueID(AProductCode, AOptionID, AOptionName, AOptionValue, AOptionValueIDRequired)
GetOptionValueID = 0
If AOptionID <> 0 And AOptionValueIDRequired Then
Dim LResult
LResult = GetSQLValueAsString("SELECT ProductOptionValueID FROM product_option_values WHERE ProductOptionID = '" & AOptionID & "' AND OptionValue = '" & CleanSQLStr(AOptionValue) & "'")
If LResult = "" Then
ValidationError = AOptionName + " value '" & AOptionValue & "' not valid for " & AProductCode
Else
GetOptionValueID = CLng(LResult)
End If
End If
End Function
' check that all the required options for given product, are in supplied options
Private Function CheckRequiredOptionsEntered(AItem)
Dim LResult, LSQL
LResult = True
' for each required option call CheckRequiredOptionEntered
LSQL = "SELECT ProductOptionID, OptionName, InputType FROM product_options WHERE ProductID = '" & AItem.ProductID & "' AND Required"
OpenQuery2(LSQL)
Do While Not EndOfQuery2
If Not CheckRequiredOptionEntered(AItem, GetQueryValue2("ProductOptionID"), Trim(GetQueryValue2("OptionName")), GetQueryValue2("InputType")) Then
LResult = False
Exit Do
End If
NextQueryRecord2
Loop
CloseQuery2
CheckRequiredOptionsEntered = LResult
End Function
Private Function CheckRequiredOptionEntered(AItem, AOptionID, AOptionName, AInputType)
Dim LResult
If AItem.Option1ID = AOptionID Then
LResult = True
AItem.Option1ValueIDRequired = AInputType = "Combo Box"
ElseIf AItem.Option2ID = AOptionID Then
LResult = True
AItem.Option2ValueIDRequired = AInputType = "Combo Box"
Else
ValidationError = "Required option '" & AOptionName & "' missing for " & AItem.ProductCode
LResult = False
End If
CheckRequiredOptionEntered = LResult
End Function
Private Sub ValidateOptionsForBespokeRads(AProductCode, AOption1Name, AOption1Value, AOption2Name, AOption2Value)
If AOption1Name <> "Sections" Then
ValidationError = "Sections missing from first option for " + AProductCode
ElseIf AOption2Name <> "Paint Finish" Then
ValidationError = "Paint Finish missing from second option for " + AProductCode
ElseIf Not ValidSections(AOption1Value) Then
ValidationError = "Sections (" & AOption1Value & ") invalid for " + AProductCode
ElseIf Not ValidPaintFinish(AOption2Value) Then
ValidationError = "Paint Finish (" & AOption2Value & ") invalid for " + AProductCode
End If
End Sub
Private Function ValidSections(ASections)
' sections must be integer between 3 and 23
Dim LSections
ValidSections = False
If IsNumeric(ASections) Then
LSections = ParseInt(ASections)
If LSections >= 3 And LSections <= 23 Then
ValidSections = True
End If
End If
End Function
Private Function ValidPaintFinish(APaintFinish)
' paint finish must be one of the following: Gunmetal Grey, Matt Black, Satin Black, Antique Bronze, Cream White, Base Coat only
ValidPaintFinish = IsBlackPaintFinish(APaintFinish) Or IsWhitePaintFinish(APaintFinish)
End Function
Private Function IsBlackPaintFinish(APaintFinish)
Dim LAllowedPaintFinishes
LAllowedPaintFinishes = ",Gunmetal Grey,Matt Black,Satin Black,Antique Bronze,Base Coat only,"
IsBlackPaintFinish = InStr(LAllowedPaintFinishes, "," & APaintFinish & ",") > 0
End Function
Private Function IsWhitePaintFinish(APaintFinish)
Dim LAllowedPaintFinishes
LAllowedPaintFinishes = ",Cream White,"
IsWhitePaintFinish = InStr(LAllowedPaintFinishes, "," & APaintFinish & ",") > 0
End Function
Private Sub AppendItems
Dim LItem
For Each LItem in Items
AppendItem(LItem)
If LItem.IsBundle Then
' Response.Write "### Bundle Item ###: " & LItem.ProductCode & BR
AppendBundleProducts LItem ' LItem.ProductID, LItem.OrderDetailID, LItem.Qty
End If
Next
' Response.Write "VarType: " & VarTypeAsString(Items) & BR
End Sub
' (SS,29/7/25)
' *** not sure about PartOfBundle, rename to WithAccessoryPack or remove, test adding accessory pack on new site
Private Sub AppendItem(AItem)
ClearSQL
AddSQL "INSERT INTO orderdetails SET"
'AddField "OrderDetailID", OrderDetailID
AddField "OrderNo", OrderNo
AddField "ProductID", AItem.ProductID
AddField "ProductCode", AItem.ProductCode
AddField "ProductName", AItem.ProductName
AddField "OptionsList", AItem.OptionsList
AddField "Qty", AItem.Qty
' please in appropriate field depending on whether it's a bundle
If AItem.IsBundle Then
AddField "BundlePriceEach", AItem.PriceEach
Else
AddField "PriceEach", AItem.PriceEach
AddField "BundleProductOrderDetailID", AItem.BundleProductOrderDetailID
End If
' (SS,30/7/25)
AddField "AccessoryPack", AItem.AccessoryPack
AddField "WooCommerceItemID", AItem.WooCommerceItemID
AddField "WooCommerceOrderID", AItem.WooCommerceOrderID
AddField "WooCommerceProductID", AItem.WooCommerceProductID
AddField "WooCommerceProductVariationID", AItem.WooCommerceProductVariationID
' Response.Write "### APPEND ITEM SQL ###" & BR
' Response.Write BR
' Response.Write ReplaceStr(SQL, NL, BR) & BR
' Response.Write "VarType: " & VarTypeAsString(AItem) & BR
RunSQL SQL
AItem.OrderDetailID = GetSQLLastInsertID
' append options if applicable
If AItem.HasOptions Then
AppendOption AItem.ProductID, AItem.OrderDetailID, AItem.Option1Name, AItem.Option1ID, AItem.Option1Value, AItem.Option1ValueID
AppendOption AItem.ProductID, AItem.OrderDetailID, AItem.Option2Name, AItem.Option2ID, AItem.Option2Value, AItem.Option2ValueID
' create subproducts if applicable
If AItem.HasSubproducts Then
' (SS,26/8/25) added AItem.WooCommerceItemID and AItem.WooCommerceOrderID
AppendSubproducts AItem.ProductID, AItem.OrderDetailID, AItem.Qty, ParseInt(AItem.Option1Value), AItem.Option2Value, AItem.BundleProductOrderDetailID, AItem.WooCommerceItemID, AItem.WooCommerceOrderID
End If
End If
End Sub
Private Sub AppendOption(AProductID, AOrderDetailID, AOptionName, AOptionID, AOptionValue, AOptionValueID)
If AOptionName <> "" Then
ClearSQL
AddSQL "INSERT INTO order_detail_options SET"
AddField "OrderNo", OrderNo
AddField "OrderDetailID", AOrderDetailID
AddField "ProductOptionID", AOptionID
AddField "ProductOptionValueID", AOptionValueID
AddField "OptionName", AOptionName
AddField "OptionValue", AOptionValue
RunSQL SQL
End If
End Sub
' (SS,30/7/25) added ABundleProductOrderDetailID
' (SS,26/8/25) added AWooCommerceItemID, AWooCommerceOrderID (most parameters could really be passed by ItemID)
Private Sub AppendSubproducts(AProductID, AOrderDetailID, AQty, ASections, APaintFinish, ABundleProductOrderDetailID, AWooCommerceItemID, AWooCommerceOrderID)
' determine mid and leg sections
Dim LLegSections, LMidSections
' determine qty of leg and mid sections, then multiply by new qty
' following returns LLegSections and LMidSections for given qty and sections
GetLegMidSections AQty, ASections, LLegSections, LMidSections
' add the determined subproducts in appropriate amounts
' add each of the applicable subproducts i.e. the leg sections in the correct primer, and mid sections in the correct primer
Dim LSubproductID, LProductCode, LProductName
LSubproductID = GetSubproductIDForSection(AProductID, "Leg", APaintFinish, LProductCode, LProductName)
' call routine to add the order detail record
If LSubproductID <> 0 Then AppendSubproduct LSubproductID, LProductCode, LProductName, LLegSections, AOrderDetailID, ABundleProductOrderDetailID, AWooCommerceItemID, AWooCommerceOrderID
LSubproductID = GetSubproductIDForSection(AProductID, "Mid", APaintFinish, LProductCode, LProductName)
' call routine to add the order detail record
If LSubproductID <> 0 Then AppendSubproduct LSubproductID, LProductCode, LProductName, LMidSections, AOrderDetailID, ABundleProductOrderDetailID, AWooCommerceItemID, AWooCommerceOrderID
End Sub
' determines number of leg and mid sections for given qty and sections of a radiator
' similar routine exists in customutils (CustomGetLegMidSections)
Private Sub GetLegMidSections(ARadQty, ARadSections, ByRef ALegSections, ByRef AMidSections)
If ARadSections = 17 Or ARadSections >= 19 Then
ALegSections = 3
Else
ALegSections = 2
End If
AMidSections = ARadSections - ALegSections
ALegSections = ALegSections * ARadQty
AMidSections = AMidSections * ARadQty
End Sub
' similar routine exists in customutils (CustomAddSubproductToBasket), but this adds to orderdetails (not shoppingbaskets)
' (SS,30/7/25) added BundleProductOrderDetailID
' (SS,26/8/25) added AWooCommerceItemID, AWooCommerceOrderID (to help with restock), also added blank OptionsList (to keep same as before, otherwise it gets set to NULL)
Private Sub AppendSubproduct(AProductID, AProductCode, AProductName, AQty, AOrderDetailID, ABundleProductOrderDetailID, AWooCommerceItemID, AWooCommerceOrderID)
Dim LSQL
LSQL = "INSERT INTO orderdetails SET OrderNo = '" & OrderNo & "', ProductID = '" & AProductID & "', ProductCode = '" & CleanSQLStr(AProductCode) & "'" &_
", ProductName = '" & CleanSQLStr(AProductName) & "', Qty = " & AQty & ", SubproductOrderDetailID = '" & AOrderDetailID & "', OptionsList = ''" &_
", WooCommerceItemID = '" & CleanSQLStr(AWooCommerceItemID) & "', WooCommerceOrderID = '" & AWooCommerceOrderID & "'"
If Not IsNull(ABundleProductOrderDetailID) Then ' can't use <> Null but IsNull works, want to retain NULL in field if applicable
LSQL = LSQL & ", BundleProductOrderDetailID = '" & ABundleProductOrderDetailID & "'"
End If
RunSQL LSQL
End Sub
' returns the subproduct ID and the product code for given section type and primer for given product code
' routine to be used in two places. Also to build historical list in orderdetails
' similar routine exists in customutils (CustomGetSubproductIDForSection)
Private Function GetSubproductIDForSection(AProductID, ASectionType, APaintFinish, ByRef AProductCode, ByRef AProductName)
' 26 is section type, 27 is section primer
Const SECTION_TYPE_ATTRIBUTE_ID = 26
Const SECTION_PRIMER_ATTRIBUTE_ID = 27
Dim LSectionPrimer, LSQL, LSubproductID
LSectionPrimer = IIf(InStr(1, APaintFinish, "white", vbTextCompare) = 0, "Black", "White")
LSQL = "SELECT ps.SubproductID, p.ProductCode, p.ProductName" &_
" FROM product_subproducts ps" &_
" INNER JOIN products p ON p.ProductID = ps.SubproductID" &_
" INNER JOIN product_attributes pa1 ON pa1.ProductID = ps.SubproductID AND pa1.AttributeID = " & SECTION_TYPE_ATTRIBUTE_ID & " AND pa1.AttributeValue = '" & ASectionType & "'" &_
" INNER JOIN product_attributes pa2 ON pa2.ProductID = ps.SubproductID AND pa2.AttributeID = " & SECTION_PRIMER_ATTRIBUTE_ID & " AND pa2.AttributeValue = '" & LSectionPrimer & "'" &_
" WHERE ps.ProductID = '" & CleanSQLStr(AProductID) & "'"
' get the values, default to 0 and blanks if not found
If Not GetSQL3Values(LSQL, LSubproductID, AProductCode, AProductName) Then
LSubproductID = 0
AProductCode = ""
AProductName = ""
End If
GetSubproductIDForSection = LSubproductID
End Function
' (SS,30/7/25) add bundle products for givn bundle, based on code for Sub AddBundleProductsToBasket in apputils.asp
' (AProductID, AOrderDetailID, AQty)
Private Sub AppendBundleProducts(ABundleItem)
' select products from the bundle in ProductBundleID order, add each, setting the BundleProductItemID to AItemID of the main i.e. container bundle item ID
' Response.Write "AppendBundleProducts: AProductID = " & ABundleItem.ProductID & ", AOrderDetailID = " & ABundleItem.OrderDetailID & ", AQty = " & ABundleItem.Qty & BR
' if qty is zero then no need to add, just exit
If ABundleItem.Qty = 0 Then Exit Sub
Dim LSQL, LHasOptions, LBundleDiscountPercentage, LIsRadiator, LSections, LPaintFinish
Dim LItemID, LOptions, LValues
Dim LItem
Set LItem = New cOrderItem
' fields: ItemID, SessionID, ProductID, ProductCode, Qty, SubproductItemID, BundleProductItemID, LastUpdated
' (SS,18/10/24) replaced above with following to also check for options, CustomFlag holds True for radiator used to apply 20% for non rad products
LSQL = "SELECT pb.*, p.ProductCode, p.ProductName, p.HasSubproducts, p.StdPrice, p.SalePrice, p.CustomFlag, COALESCE(po.OptionCount, 0) AS OptionCount FROM product_bundles pb" &_
" INNER JOIN products p ON p.ProductID = pb.BundleProductID" &_
" LEFT JOIN (SELECT ProductID, COUNT(*) AS OptionCount FROM product_options GROUP BY ProductID) po ON po.ProductID = pb.BundleProductID" &_
" WHERE pb.ProductID = " & ABundleItem.ProductID & " ORDER BY ProductBundleID"
OpenQuery2(LSQL)
Do While Not EndOfQuery2
LItem.SetDefaults ' clear item ready for new
LItem.ProductID = GetQueryValue2("BundleProductID")
LItem.ProductCode = GetQueryValue2("ProductCode")
LItem.ProductName = GetQueryValue2("ProductName")
LItem.PriceEach = CDbl(GetQueryValue2("StdPrice")) ' (SS,31/7/25) CDbl used because otherwise it'll be vbDecimal which will cause Type mismatch error when using variable for a calculation
LItem.Qty = GetQueryValue2("Qty") * ABundleItem.Qty
LItem.HasSubproducts = GetQueryValue2("HasSubproducts")
LItem.BundleProductOrderDetailID = ABundleItem.OrderDetailID
' (SS,26/8/25) added following to help with restock of items in bundle
LItem.WooCommerceItemID = ABundleItem.WooCommerceItemID
LItem.WooCommerceOrderID = ABundleItem.WooCommerceOrderID
LIsRadiator = GetQueryValue2("CustomFlag")
' check for options and add then if applicable
LHasOptions = GetQueryValue2("OptionCount") > 0
If LHasOptions Then
GetBundleProductOptions ABundleItem, LItem
' calculate radiator price from sections and paint finish, PriceEach would have default to section price
If LIsRadiator Then
If LItem.Option1Name = "Sections" Then
LSections = CInt(LItem.Option1Value)
LPaintFinish = LItem.Option2Value
Else ' unlikely to be this way round
LSections = CInt(LItem.Option2Value)
LPaintFinish = LItem.Option1Value
End If
LItem.PriceEach = Round2dp(CustomGetRadiatorPrice(LItem.PriceEach, LSections) + CustomGetPaintFinishPrice(LPaintFinish, LSections))
End If
End If
' (SS,31/7/25) both CustomBundleProductDiscountPercentage and GetDiscountedPriceFromPercentage are in apputils.asp
LBundleDiscountPercentage = CustomBundleProductDiscountPercentage(LBundleDiscountPercentage, LItem.ProductID, LIsRadiator)
If LBundleDiscountPercentage <> 0 Then
LItem.PriceEach = GetDiscountedPriceFromPercentage(LItem.PriceEach, LBundleDiscountPercentage)
End If
' append the item, !!! need to calculate the prices
AppendItem LItem
NextQueryRecord2
Loop
CloseQuery2
Set LItem = Nothing
End Sub
' (SS,25/3/25) returns the special override discount percentage i.e. 0% for radiator and 20% for accessories, ACustomFlag will be True for radiator
' New constants (see up of this module) BUNDLE_DISCOUNT_OVERRIDE, BUNDLE_DISCOUNT_PERCENTAGE_RADS, BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES
' (SS,31/7/25) copied here from customs.asp
Private Function CustomBundleProductDiscountPercentage(ACalculatedDiscountPercentage, AProductID, ACustomFlag)
Dim LResult
If BUNDLE_DISCOUNT_OVERRIDE Then
If ACustomFlag Then ' if radiator
LResult = BUNDLE_DISCOUNT_PERCENTAGE_RADS
Else ' else acccessory
LResult = BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES
End If
Else ' as before
LResult = ACalculatedDiscountPercentage
End If
CustomBundleProductDiscountPercentage = LResult
End Function
' (SS,28/8/14)
' (SS,31/7/25) copied here from customutils.asp
Private Function CustomGetRadiatorPrice(ASectionPrice, ASections)
CustomGetRadiatorPrice = ASectionPrice * ASections
End Function
' (SS,28/8/14)
' *** !!! (SS,27/04/20) had to modify the Paint Costs report and paint_costs table, perhaps in future modify this function to use the paint_costs table will require less maintenance
' (SS,31/7/25) copied here from customutils.asp and simplified remove old redundant code (see customutil.asp) for full version
Private Function CustomGetPaintFinishPrice(APaintFinish, ASections)
Dim LPrice
If ASections = "" Or APaintFinish = PF_BASE_COAT_ONLY Then ' (SS,6/3/23) replaced PF_BLACK_PRIMER with PF_BASE_COAT_ONLY
LPrice = 0
ElseIf ASections > 0 Then
LPrice = ASections * 6.00 ' last modified 02/11/2022
Else ' i.e. nothing selected for paint finish (used by Ajax to get price)
LPrice = 0
End If
'Response.Write "CustomGetPaintFinishPrice: " & LPrice & BR
CustomGetPaintFinishPrice = LPrice
End Function
' (SS,21/10/24) returns discounted price using given price and discount percentage, rounded to 2 dp
' (SS,31/7/25) copied here from apputils.asp
Private Function GetDiscountedPriceFromPercentage(APrice, ADiscountPercentage)
GetDiscountedPriceFromPercentage = Round2dp(APrice * (1 - (ADiscountPercentage / 100)))
End Function
' (SS,16/10/24) add options to array for products in a bundle, based on ProductOptionsToArray
' (SS,30/7/25) based on BundleProductOptionsToArray but set the two main options into AItemID
' Private Sub BundleProductOptionsToArray(AProductID, ABundleProductID, ByRef LOptions, ByRef LValues)
Private Sub GetBundleProductOptions(ABundleItemID, AItemID)
Dim LSQL, LAttributeName, LAttributeValue, LProductOptionID, LOptionNo, LIsName, LIsValue
' go through each bundle option in "Bundle Option ? Name" match
' link using AttributeID for Bundle Option 1 Name, getting value from product_attributes where AttributeValue matches OptionName in product_options
LSQL = "SELECT pa.*, a.AttributeName, po.ProductOptionID FROM product_attributes pa" &_
" INNER JOIN attributes a ON a.AttributeID = pa.AttributeID" &_
" LEFT JOIN product_options po ON po.ProductID = " & AItemID.ProductID & " AND po.OptionName = pa.AttributeValue" &_
" WHERE pa.ProductID = " & ABundleItemID.ProductID & " AND AttributeName LIKE 'Bundle Option %'" &_
" ORDER BY pa.AttributeID"
OpenQuery3(LSQL)
Do While Not EndOfQuery3
' AttributeName will have e.g. Bundle Option 1 Name, Bundle Option 2 Name etc.
' we need to get the value for this from product attributes of the bundle container product i.e. Bundle Option 1 Value, Bundle Option 2 Value
LAttributeName = GetQueryValue3("AttributeName")
LAttributeValue = GetQueryValue3("AttributeValue")
LProductOptionID = GetQueryValue3("ProductOptionID")
If InStr(LAttributeName, " 2 ") > 0 Then
LOptionNo = 2
Else
LOptionNo = 1
End If
LIsName = InStr(LAttributeName, " Name") > 0
LIsValue = InStr(LAttributeName, " Value") > 0
If LOptionNo = 1 Then
If LIsName Then
AItemID.Option1Name = LAttributeValue
AItemID.Option1ID = LProductOptionID
ElseIf LIsValue Then
AItemID.Option1Value = LAttributeValue
End If
Else
If LIsName Then
AItemID.Option2Name = LAttributeValue
AItemID.Option2ID = LProductOptionID
ElseIf LIsValue Then
AItemID.Option2Value = LAttributeValue
End If
End If
' Response.Write LAttributeName & ", " & LAttributeValue & ", " & LProductOptionID & BR
' add options name and value to the array
NextQueryRecord3
Loop
CloseQuery3
End Sub
' (SS,22/8/25) calculate the total weight of order items and save to order
Private Sub UpdateTotalWeight
Dim LSQL, LTotalWeight
LSQL = "SELECT SUM(od.Qty * p.PostalWeight) AS TotalWeight FROM orderdetails od" &_
" INNER JOIN products p ON p.ProductID = od.ProductID" &_
" WHERE od.OrderNo = " & OrderNo & " AND NOT IsBundle AND NOT HasSubproducts"
LTotalWeight = GetSQLValueAsString(LSQL)
' ensure it's a number and 2dp
If LTotalWeight = "" Then
LTotalWeight = "0"
Else
LTotalWeight = Format2dpnc(LTotalWeight)
End If
LSQL = "UPDATE orders SET TotalWeight = '" & LTotalWeight & "' WHERE OrderNo = " & OrderNo
RunSQL LSQL
End Sub
' (SS,30/4/25) update the PrevStock field in order items from products (NumInStock)
Private Sub UpdatePrevStock(AOrderNo)
Dim LSQL
LSQL = "UPDATE orderdetails od, products p SET od.PrevStock = p.NumInStock" &_
" WHERE OrderNo = '" & CleanSQLStr(AOrderNo) & "'" & " AND od.ProductID = p.ProductID AND p.NumInStock IS NOT NULL"
RunSQL LSQL
End Sub
' (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
' (SS,27/4/25) copied from apputils.asp with just line "If ProductOptionsEnabled Then" commented out
Private 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"
RunSQL 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
' (SS,27/4/25) copied from apputils.asp
Private 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"
RunSQL LSQL
End Sub
' === end of items ===
Private Sub MarkAsImported
' (SS,18/8/25) updated WooCommerceOrderID to OrderNumber
RunSQL "UPDATE circ_penn." + FImportTableName + " SET Imported = TRUE, ImportError = '', DateTimeImported = NOW() WHERE OrderNumber = " & OrderNo
WooCommerceSendNote WooCommerceOrderID, "Succesfully imported by ShoppingAdmin"
End Sub
Private Sub MarkAsFailed
' (SS,18/8/25) updated WooCommerceOrderID to OrderNumber
' (SS,3/9/25) added LEFT(..,100) to truncate to length of field
RunSQL "UPDATE circ_penn." + FImportTableName + " SET Imported = FALSE, ImportError = LEFT('" & CleanSQLStr(ValidationMessage) & "', 100) WHERE OrderNumber = " & OrderNo
' only send note for the main order id (to prevent slow if many orders with failure exist)
If MainOrderID = WooCommerceOrderID Then
WooCommerceSendNote WooCommerceOrderID, "ShoppingAdmin import failure: " + ValidationMessage
End If
End Sub
' (SS,21/4/21) this gets called from TryProcessOrder to save the last used despatch date
' (SS,10/9/25) copied here from customutils.asp
Private Sub CustomSetLastUsedRadDespatchByDate(ADate)
' (SS,23/4/21) only save if after existing date
If ADate > CustomGetLastUsedRadDespatchByDate Then
' save to token, which is also fetched by CustomGetLastUsedRadDespatchByDate
SetTokenText "Radiator Last Used Despatch By Date", CStr(ADate)
End If
End Sub
' (SS,9/4/21) gets the last date used from token
' (SS,10/9/25) copied here from customutils.asp
Private Function CustomGetLastUsedRadDespatchByDate
Dim LResult, LLastSavedDate
LResult = CDate("27/05/2021") ' seemed like the appropriate value to use when going live on 21/4/21
' (SS,21/4/21) get last used date from token, use if valid
LLastSavedDate = Trim(GetTokenText("Radiator Last Used Despatch By Date"))
If LLastSavedDate <> "" Then
If IsDate(LLastSavedDate) Then
LResult = CDate(LLastSavedDate)
End If
End If
CustomGetLastUsedRadDespatchByDate = LResult
End Function
' (SS,4/8/15) used to get content of a given token, can be called from inc-template..
' (SS,10/9/25) from apputils.asp, modified to remove ComposeDescription, used by CustomGetLastUsedRadDespatchByDate
Private Function GetTokenText(ATokenName)
GetTokenText = NB(GetValueFromQuery("Text", "SELECT Text FROM sitedetails WHERE Type = 'Tokens' AND Name = '" & CleanSQLStr(ATokenName) & "'"))
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
' (SS,10/9/25) from apputils.asp, used by CustomSetLastUsedRadDespatchByDate
Private Sub SetTokenText(ATokenName, ATokenText)
Dim LSQL
LSQL = "UPDATE sitedetails SET Text = '" & CleanSQLStr(ATokenText) & "' WHERE Type = 'Tokens' AND Name = '" & CleanSQLStr(ATokenName) & "'"
ExecuteQuery LSQL
End Sub
End Class
' === order item class
Class cOrderItem
Dim FProductCode, FProductID, FProductName, FQty, FPriceEach, FPriceEachBeforeDiscount, FAccessoryPack
Dim FOption1Name, FOption1Value, FOption2Name, FOption2Value, FHasSubproducts, FIsBundle, FBundleProductOrderDetailID
Dim FOption1ID, FOption1ValueID, FOption2ID, FOption2ValueID
Dim FOption1ValueIDRequired, FOption2ValueIDRequired
Dim FWooCommerceItemID, FWooCommerceOrderID, FWooCommerceProductID ' (SS,30/7/25)
Dim FWooCommerceProductVariationID ' (SS,18/8/25)
Dim FOrderDetailID ' (SS,30/7/25)
' `OrderDetailID` INT(11) NOT NULL AUTO_INCREMENT,
' `OrderNo` INT(11) NOT NULL DEFAULT 0,
' `ProductID` INT(11) NOT NULL,
' `ProductCode` VARCHAR(20) NOT NULL DEFAULT '',
' `ProductName` VARCHAR(100) NOT NULL DEFAULT '',
' `OptionsList` VARCHAR(1000) NULL DEFAULT NULL,
' `Qty` INT(11) NOT NULL DEFAULT 0,
' `PriceEach` DOUBLE NOT NULL DEFAULT 0,
' `QtyRestocked` INT(11) NOT NULL DEFAULT 0 COMMENT 'Added 08/02/2022',
' `PrevStock` INT(11) NULL DEFAULT NULL,
' `SubproductOrderDetailID` INT(11) NULL DEFAULT NULL COMMENT 'Added 29/10/18, for CIRC, Schema 4',
' `BundleProductOrderDetailID` INT(11) NULL DEFAULT NULL COMMENT 'Added 08/10/2024',
' `BundlePriceEach` DOUBLE NOT NULL DEFAULT 0 COMMENT 'Added 21/10/2024',
' `LastUpdated` TIMESTAMP NOT NULL DEFAULT current_timestamp(),
' later added
' `Option1Name` VARCHAR(50) NULL DEFAULT NULL,
' `Option1Value` VARCHAR(150) NULL DEFAULT NULL,
' `Option2Name` VARCHAR(50) NULL DEFAULT NULL,
' `Option2Value` VARCHAR(150) NULL DEFAULT NULL,
' (SS,30/7/25) set default values
Private Sub Class_Initialize
SetDefaults
End Sub
' (SS,30/7/25)
Public Sub SetDefaults
FProductCode = ""
FProductID = 0
FProductName = ""
FQty = 0
FPriceEach = 0
PriceEachBeforeDiscount = 0
FOption1Name = ""
FOption1Value = ""
FOption1ID = 0
FOption1ValueID = 0
FOption2Name = ""
FOption2Value = ""
FOption2ID = 0
FOption2ValueID = 0
FAccessoryPack = False
FHasSubproducts = False
FIsBundle = False
FBundleProductOrderDetailID = Null
FWooCommerceItemID = Null
FWooCommerceOrderID = Null
FWooCommerceProductID = Null
FWooCommerceProductVariationID = Null
FOrderDetailID = Null
End Sub
Public Property Let ProductCode(AValue)
FProductCode = AValue
End Property
Public Property Get ProductCode
ProductCode = FProductCode
End Property
Public Property Let ProductID(AValue)
FProductID = AValue
End Property
Public Property Get ProductID
ProductID = FProductID
End Property
Public Property Let ProductName(AValue)
FProductName = AValue
End Property
Public Property Get ProductName
ProductName = FProductName
End Property
Public Property Let Qty(AValue)
FQty = AValue
End Property
Public Property Get Qty
Qty = FQty
End Property
Public Property Let PriceEach(AValue)
FPriceEach = AValue
End Property
Public Property Get PriceEach
PriceEach = FPriceEach
End Property
Public Property Let PriceEachBeforeDiscount(AValue)
FPriceEachBeforeDiscount = AValue
End Property
Public Property Get PriceEachBeforeDiscount
PriceEachBeforeDiscount = FPriceEachBeforeDiscount
End Property
Public Property Let AccessoryPack(AValue)
FAccessoryPack= AValue
End Property
Public Property Get AccessoryPack
AccessoryPack = FAccessoryPack
End Property
Public Property Let Option1Name(AValue)
FOption1Name = AValue
End Property
Public Property Get Option1Name
Option1Name = FOption1Name
End Property
Public Property Let Option1ID(AValue)
FOption1ID = AValue
End Property
Public Property Get Option1ID
Option1ID = FOption1ID
End Property
Public Property Let Option1Value(AValue)
FOption1Value = AValue
End Property
Public Property Get Option1Value
Option1Value = FOption1Value
End Property
Public Property Let Option1ValueID(AValue)
FOption1ValueID = AValue
End Property
Public Property Get Option1ValueID
Option1ValueID = FOption1ValueID
End Property
Public Property Let Option1ValueIDRequired(AValue)
FOption1ValueIDRequired = AValue
End Property
Public Property Get Option1ValueIDRequired
Option1ValueIDRequired = FOption1ValueIDRequired
End Property
Public Property Let Option2Name(AValue)
FOption2Name = AValue
End Property
Public Property Get Option2Name
Option2Name = FOption2Name
End Property
Public Property Let Option2ID(AValue)
FOption2ID = AValue
End Property
Public Property Get Option2ID
Option2ID = FOption2ID
End Property
Public Property Let Option2Value(AValue)
FOption2Value = AValue
End Property
Public Property Get Option2Value
Option2Value = FOption2Value
End Property
Public Property Let Option2ValueID(AValue)
FOption2ValueID = AValue
End Property
Public Property Get Option2ValueID
Option2ValueID = FOption2ValueID
End Property
Public Property Let Option2ValueIDRequired(AValue)
FOption2ValueIDRequired = AValue
End Property
Public Property Get Option2ValueIDRequired
Option2ValueIDRequired = FOption2ValueIDRequired
End Property
' (SS,30/7/25)
Public Property Let BundleProductOrderDetailID(AValue)
FBundleProductOrderDetailID = AValue
End Property
' (SS,30/7/25)
Public Property Get BundleProductOrderDetailID
BundleProductOrderDetailID = FBundleProductOrderDetailID
End Property
' (SS,30/7/25)
Public Property Let WooCommerceItemID(AValue)
FWooCommerceItemID = AValue
End Property
' (SS,30/7/25)
Public Property Get WooCommerceItemID
WooCommerceItemID = FWooCommerceItemID
End Property
' (SS,30/7/25)
Public Property Let WooCommerceOrderID(AValue)
FWooCommerceOrderID = AValue
End Property
' (SS,30/7/25)
Public Property Get WooCommerceOrderID
WooCommerceOrderID = FWooCommerceOrderID
End Property
' (SS,30/7/25)
Public Property Let WooCommerceProductID(AValue)
FWooCommerceProductID = AValue
End Property
' (SS,30/7/25)
Public Property Get WooCommerceProductID
WooCommerceProductID = FWooCommerceProductID
End Property
' (SS,18/8/25)
Public Property Let WooCommerceProductVariationID(AValue)
FWooCommerceProductVariationID = AValue
End Property
' (SS,18/8/25)
Public Property Get WooCommerceProductVariationID
WooCommerceProductVariationID = FWooCommerceProductVariationID
End Property
' (SS,30/7/25)
Public Property Let OrderDetailID(AValue)
FOrderDetailID = AValue
End Property
' (SS,30/7/25)
Public Property Get OrderDetailID
OrderDetailID = FOrderDetailID
End Property
Public Property Get OptionsList
' e.g. Sections: 10, Paint Finish: Gunmetal Grey
Dim LResult
LResult = ""
If HasOptions Then
If Option1Name <> "" Then
LResult = Option1Name & ": " & Option1Value
End If
If Option2Name <> "" Then
If LResult <> "" Then
LResult = LResult & ", "
End If
LResult = LResult & Option2Name & ": " & Option2Value
End If
End If
OptionsList = LResult
End Property
Public Property Get HasOptions
HasOptions = FOption1Name <> "" Or FOption2Name <> ""
End Property
Public Property Let HasSubproducts(AValue)
FHasSubproducts = AValue
End Property
Public Property Get HasSubproducts
HasSubproducts = FHasSubproducts
End Property
' (SS,28/7/25)
Public Property Let IsBundle(AValue)
FIsBundle = AValue
End Property
' (SS,28/7/25)
Public Property Get IsBundle
IsBundle = FIsBundle
End Property
End Class
' === end of order itme class
' (SS,13/3/25) returns variable as VarType string e.g. vbInteger, vbString, vbArray(vbString)
' see https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/vartype-function
Function VarTypeAsString(AVariable)
Dim LResult, LVarType, LIsArray, LVarTypeStr
LVarType = VarType(AVariable)
LIsArray = LVarType >= 8192
If LIsArray Then
LVarType = LVarType - 8192
LResult = "vbArray+"
Else
LResult = ""
End If
Select Case LVarType
Case vbEmpty ' 0
LVarTypeStr = "vbEmpty"
Case vbNull ' 1
LVarTypeStr = "vbNull"
Case vbInteger ' 2
LVarTypeStr = "vbInteger"
Case vbLong ' 3
LVarTypeStr = "vbLong"
Case vbSingle ' 4
LVarTypeStr = "vbSingle"
Case vbDouble ' 5
LVarTypeStr = "vbDouble"
Case vbCurrency ' 6
LVarTypeStr = "vbCurrency"
Case vbDate ' 7
LVarTypeStr = "vbDate"
Case vbString ' 8
LVarTypeStr = "vbString"
Case vbObject ' 9
LVarTypeStr = "vbObject"
Case vbError ' 10
LVarTypeStr = "vbError"
Case vbBoolean ' 11
LVarTypeStr = "vbBoolean"
Case vbVariant ' 12
LVarTypeStr = "vbVariant"
Case vbDataObject ' 13
LVarTypeStr = "vbDataObject"
Case vbDecimal ' 14
LVarTypeStr = "vbDecimal"
Case vbByte ' 17
LVarTypeStr = "vbByte"
Case 20 ' vbLongLong ' 20, only in 64-bit undefined in 32-bit?
LVarTypeStr = "vbLongLong"
Case vbUserDefinedType ' 36
LVarTypeStr = "vbUserDefinedType"
Case Else
LVarTypeStr = "Unknown"
End Select
LResult = LResult + LVarTypeStr + "(" & VarType(AVariable) & ")"
VarTypeAsString = LResult
End Function
' (SS,13/3/25) converts UK date time to MYSQL Date Time
Function ConvertUKToMySQLDateTime(ADateTime)
If IsNull(ADateTime) Or ADateTime = "" Then
ConvertUKToMySQLDateTime = "NULL" ' because blank date can only be saved as Null not empty string
Else
ConvertUKToMySQLDateTime = "'" & DatePart("yyyy", ADateTime) & "-" & Right("0" & DatePart("m", ADateTime), 2) & "-" & Right("0" & DatePart("d", ADateTime), 2) & " " & Right("0" & DatePart("h", ADateTime), 2) & ":" & Right("0" & DatePart("n", ADateTime), 2) & ":" & Right("0" & DatePart("s", ADateTime), 2) & "'"
End If
End Function
' (SS,23/8/17) new version which now calls SendEmailByCDO instead of SendEmailByDundas, previous SendMail renamed to SendEmailByDundas
' (SS,27/4/25) copied here from apputils.asp
Function SendEmail(AEmailAddress, ABCCEmailAddress, ABCCEmailAddress2, AFromEmailAddress, ASubject, ABody, AIsHTML)
SendEmail = SendEmailByCDO(AEmailAddress, ABCCEmailAddress, ABCCEmailAddress2, AFromEmailAddress, ASubject, ABody, "", AIsHTML, "", "")
End Function
' (SS,10/6/07) *** followings settings to be held in a common database
' (SS,27/4/25) copied here from apputils.asp
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,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
' (SS,27/4/25) copied here from apputils.asp
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
' from https://www.motobit.com/tips/detpg_Base64Encode/
' (SS,25/4/25) also in apputils.asp, perhaps move to dbfunctions.asp
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
' (SS,25/4/25) called from Base64Encode above
Function MyASC(OneChar)
If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function
' (SS,4/7/25)
Sub SaveJSONTest(AStr, ASaveToID)
Initialise
Dim LSQL, LStr
LStr = CleanSQLStr(AStr)
RunSQL "DELETE FROM test_json WHERE ID = " & ASaveToID
LSQL = "INSERT INTO test_json SET ID = " & ASaveToID &_
", JSON_longtext='" & LStr & "'" &_
", JSON_longtext_utf8='" & LStr & "'" &_
", JSON_json='" & LStr & "'"
RunSQL LSQL
Finalise
End Sub
' help from: https://www.access-programmers.co.uk/forums/threads/making-post-and-get-api-calls-to-receive-data.327701/
Sub DoWooCommerceSendOrderStatus(AIsLocalTest, AOrderID, AStatus, AGetOnly)
Dim LobjRequest, LURL, LKey, LSecret, LOrderID, LRequestBody, LResponse
LOrderID = ParseInt(AOrderID)
GetWooCommerceAPIDetails LURL, LKey, LSecret
LURL = LURL + "/wp-json/wc/v3/orders/" & LOrderID
Response.Write "URL=" & LURL & BR
Set LobjRequest = CreateObject("MSXML2.XMLHTTP")
' e.g. completed, failed
' "status": "completed"
If Not AGetOnly Then
Response.Write "status=" & AStatus & BR
LRequestBody = "{""status"": """ & AStatus & """}"
End If
With LobjRequest
.open "POST", LURL, False
.setRequestHeader "Content-type", "application/json"
.setRequestHeader "Authorization", "Basic " & Base64Encode(LKey + ":" + LSecret)
.send LRequestBody
LResponse = .responseText
End With
If AGetOnly Then
Response.Write BR & "response=" & BR
Response.Write LResponse
End If
Set LobjRequest = Nothing
End Sub
' (SS,22/8/25) shorter method to sent note calls DoWooCommerceSend
Sub WooCommerceSendNote(AOrderID, ANote)
DoWooCommerceSend AOrderID, WST_NOTE, ANote, ""
End Sub
' (SS,15/8/25) new version of above DoWooCommerceSendOrderStatus, can add a note, and a meta data property
' ASendType can be status, note, metadata
' (SS,2/6/26) change to add despatch_date (i.e. date completed) when status is set to completed
Sub DoWooCommerceSend(AOrderID, ASendType, AValue, AMetadataName)
Dim LobjRequest, LURL, LKey, LSecret, LOrderID, LRequestBody, LResponse
LOrderID = ParseInt(AOrderID)
GetWooCommerceAPIDetails LURL, LKey, LSecret
LURL = LURL + "/wp-json/wc/v3/orders/" & LOrderID
Set LobjRequest = CreateObject("MSXML2.XMLHTTP")
' e.g. completed, failed
' "status": "completed"
If ASendType = WST_STATUS Then
'Response.Write "status=" & AValue & BR
'LRequestBody = "{""status"": """ & AValue & """}"
' (SS,2/6/26) following replaces above
' (SS,2/6/26) added despatch date i.e. date completed of the order
Dim LDespatchDate
If LCase(AValue) = "completed" Then
LDespatchDate = GetOrderDateCompleted(LOrderID)
End If
If LDespatchDate <> "" Then
LRequestBody = "{" & _
"""status"": """ & JSON_EscapeCharacters(AValue) & """," & _
"""meta_data"": [" & _
"{" & _
"""key"": ""despatch_date""," & _
"""value"": """ & JSON_EscapeCharacters(LDespatchDate) & """" & _
"}" & _
"]" & _
"}"
Else
LRequestBody = "{""status"": """ & JSON_EscapeCharacters(AValue) & """}"
End If
ElseIf ASendType = WST_NOTE Then
Response.Write "note=" & AValue & BR
LRequestBody = "{""note"": """ & AValue & """}"
LURL = LURL & "/notes"
ElseIf ASendType = WST_METADATA Then
LRequestBody = "{" &_
"""meta_data"": [" &_
"{""key"": """ & AMetadataName & """," &_
"""value"": """ & JSON_EscapeCharacters(AValue) & """" &_
"}" &_
"]" &_
"}"
Response.Write BR & LRequestBody & BR
End If
Response.Write "URL=" & LURL & BR
With LobjRequest
.open "POST", LURL, False
.setRequestHeader "Content-type", "application/json"
.setRequestHeader "Authorization", "Basic " & Base64Encode(LKey + ":" + LSecret)
.send LRequestBody
LResponse = .responseText
End With
Set LobjRequest = Nothing
End Sub
' (SS,2/7/25)
Sub DoWooCommerceGetOrderList
DoWooCommerceGetRequest "orders", "", 1
End Sub
' (SS,4/7/25)
Sub DoWooCommerceGetTaxList
DoWooCommerceGetRequest "taxes", "", 1
End Sub
' (SS,4/7/25)
Sub DoWooCommerceGetProductList
DoWooCommerceGetRequest "products", "per_page=100", 1
End Sub
Sub DoWooCommerceGetProductVariation(AID)
DoWooCommerceGetRequest "products/" & AID & "/variations", "per_page=100", 2
End Sub
' (SS,4/7/25)
Sub DoWooCommerceGetList(ADataType)
DoWooCommerceGetRequest ADataType, "", 1
End Sub
' (SS,2/7/25)
Sub DoWooCommerceGetRequest(ADataType, AParameters, ASaveToID)
Dim LobjRequest, LURL, LKey, LSecret, LRequestBody, LResponse
GetWooCommerceAPIDetails LURL, LKey, LSecret
LURL = LURL + "/wp-json/wc/v3/" & ADataType
If AParameters <> "" Then LURL = LURL + "?" + AParameters
Response.Write "URL=" & LURL & BR
Set LobjRequest = CreateObject("MSXML2.XMLHTTP")
LRequestBody = ""
With LobjRequest
.open "GET", LURL, False
.setRequestHeader "Content-type", "application/json"
.setRequestHeader "Authorization", "Basic " & Base64Encode(LKey + ":" + LSecret)
.send LRequestBody
LResponse = .responseText
End With
' Response.Write BR & "response=" & BR
Response.Write LResponse
SaveJSONTest LResponse, ASaveToID
OpenJSONResponse LResponse
Response.Write "<hr>"
Dim Item, i, LTest
i = 0
Response.Write "For Each Loop (readability):<br>==============<br>"
For Each Item In FoJSONArr.Items
Response.Write "Index "
Response.Write i
Response.Write ": "
Set LTest = Item
If IsObject(Item) and TypeName(Item) = "JSONobject" then
' Response.Write BR & "JSONobject:" & BR
Item.write()
Else
' Response.Write BR & "###:" & BR
Response.Write item
End If
'Response.Write "<br>" & BR
Response.Write "<hr>"
i = i + 1
Next
Response.Write "<hr>"
CloseJSONResponse
End Sub
' uses common/asp/jsonObject.class.asp
Sub OpenJSONResponse(AResponseJSONStr)
' instantiate the class
Set FoJSON = New JSONobject
'oJSONRequest.debug = 1
'FoJSON.Debug = True
'FoJSON.Parse(AResponseJSONStr)
'Set FoJSONArr = New JSONArray
'FoJSONArr.Push FoJSON
Set FoJSONArr = FoJSON.Parse(AResponseJSONStr)
End Sub
Sub CloseJSONResponse
Set FoJSON = Nothing
Set FoJSONArr = Nothing
End Sub
' returns given response value
Function GetResponseJSONValue(AFieldName)
GetResponseJSONValue = FoJSON.Value(AFieldName)
End Function
' =============================================
' (SS,8/7/25)
Sub WC_GetData(ADataType)
' Initialise ' for database access
Dim LJSONResponse, LPageNo, LIsEnd, LTableName, LTableNameWithPrefix
LPageNo = 0
If InStr(ADataType, "variations") Then
LTableName = "product_variations"
Else
LTableName = ADataType
End If
LTableNameWithPrefix = "wc_json_" + LTableName
Do
LPageNo = LPageNo + 1
LJSONResponse = WC_GetPage(ADataType, LPageNo)
' Response.Write "<hr>" & NL
' Response.Write "Page: " & LPageNo & BR & NL
' Response.Write "<pre><code>" & NL
' Response.Write Left(LJSONResponse, 200) & NL
' Response.Write "</code></pre>" & NL
LIsEnd = LJSONResponse = "[]"
If Not LIsEnd Then WC_SaveArrayToTable LTableName, LJSONResponse
Response.Write "<hr>" & NL
Loop Until LIsEnd Or LPageNo = 100
Dim LSQL
LSQL = ""
' 9/7/25 extra some of the values into fields for products, JSON_QUERY used instead of JSON_VALUE if object or array
' later discovered JSON_EXTRACT, but used JSON_VALUE because JSON_EXTRACT returns quotes around the value
If ADataType = "products" Then
LSQL = "UPDATE " + LTableNameWithPrefix + " SET product_name = JSON_VALUE(json_data, '$.name')" &_
", sku = JSON_VALUE(json_data, '$.sku')" &_
", categories = JSON_EXTRACT(json_data, '$.categories')" &_
", attributes = JSON_EXTRACT(json_data, '$.attributes')" &_
", variations = JSON_EXTRACT(json_data, '$.variations')"
ElseIf LTableName = "product_variations" Then
LSQL = "UPDATE " + LTableNameWithPrefix + " SET product_name = JSON_VALUE(json_data, '$.name')" &_
", sku = JSON_VALUE(json_data, '$.sku')" &_
", parent_id = JSON_VALUE(json_data, '$.parent_id')"
ElseIf LTableName = "orders" Then
LSQL = "UPDATE " + LTableNameWithPrefix + " SET " &_
" number = JSON_VALUE(json_data, '$.number')" &_
", order_key = JSON_VALUE(json_data, '$.order_key')" &_
", created_via = JSON_VALUE(json_data, '$.created_via')" &_
", status = JSON_VALUE(json_data, '$.status')" &_
", date_created = JSON_VALUE(json_data, '$.date_created')" &_
", date_modified = JSON_VALUE(json_data, '$.date_modified')" &_
", date_paid = JSON_VALUE(json_data, '$.date_paid')" &_
", date_completed = JSON_VALUE(json_data, '$.date_completed')" &_
", total = JSON_VALUE(json_data, '$.total')" &_
", total = JSON_VALUE(json_data, '$.total')" &_
", total_tax = JSON_VALUE(json_data, '$.total_tax')" &_
", payment_method = JSON_VALUE(json_data, '$.payment_method')" &_
", customer_note = JSON_VALUE(json_data, '$.customer_note')" &_
", billing = JSON_EXTRACT(json_data, '$.billing')" &_
", shipping = JSON_EXTRACT(json_data, '$.shipping')" &_
", meta_data = JSON_EXTRACT(json_data, '$.meta_data')" &_
", line_items = JSON_EXTRACT(json_data, '$.line_items')" &_
", refunds = JSON_EXTRACT(json_data, '$.refunds')"
End If
If LSQL <> "" Then RunSQL LSQL
' Finalise ' due to earlier initialise
End Sub
' returns JSON text of given page
Function WC_GetPage(APageURL, APageNo)
Dim LobjRequest, LURL, LKey, LSecret, LRequestBody, LResponse
GetWooCommerceAPIDetails LURL, LKey, LSecret
LURL = LURL + "/wp-json/wc/v3/" & APageURL
If APageNo <> "" Then LURL = LURL + "?page=" & APageNo
Response.Write "URL=" & LURL & BR
Set LobjRequest = CreateObject("MSXML2.XMLHTTP")
LRequestBody = ""
With LobjRequest
.open "GET", LURL, False
.setRequestHeader "Content-type", "application/json"
.setRequestHeader "Authorization", "Basic " & Base64Encode(LKey + ":" + LSecret)
.send LRequestBody
LResponse = .responseText
End With
Set LobjRequest = Nothing
WC_GetPage = LResponse
End Function
Sub WC_SaveArrayToTable(ADataName, AJSONStr)
' parse array
Dim LoJSON, LoJSONArr, LItem, i
Set LoJSON = New JSONobject
Set LoJSONArr = LoJSON.Parse(AJSONStr)
Dim LSQL, LID, LTableName, LJSONStr
LTableName = "wc_json_" + ADataName
i = 0
Response.Write "Index: "
For Each LItem In LoJSONArr.Items
Response.Write i
LID = LItem.Value("id")
If LID <> "" Then
LJSONStr = LItem.Serialize()
RunSQL "DELETE FROM " + LTableName + " WHERE id = " & LID
LSQL = "INSERT INTO " + LTableName + " SET id = " & LID & ", json_data = '" & CleanSQLStr(LJSONStr) & "'"
RunSQL LSQL
End If
i = i + 1
Next
Response.Write BR & NL
Set LoJSONArr = Nothing
Set LoJSON = Nothing
End Sub
' go through each product already fetched into and get each variation
Sub WC_GetProductVariations_old
Dim LSQL, LVariations, LVariation, LVariationArray, i
OpenQuery "SELECT * FROM wc_json_products WHERE variations <> '[]' ORDER BY id"
Do While Not EndOfQuery
LVariations = GetQueryValue("Variations")
LVariations = ReplaceStr(LVariations, "[", "")
LVariations = ReplaceStr(LVariations, "]", "")
Response.Write "LVariations: " & LVariations & BR
LVariationArray = Split(LVariations, ",")
For i = LBound(LVariationArray) To UBound(LVariationArray)
LVariation = Trim(LVariationArray(i))
Response.Write "LVariation " & i & ":" & LVariation & BR
Next
Response.Write "<hr>"
NextQueryRecord
Loop
CloseQuery
End Sub
' go through each product already fetched into and get each variation
Sub WC_GetProductVariations
Dim LID, LVariations, i
OpenQuery "SELECT * FROM wc_json_products WHERE variations <> '[]' ORDER BY id"
Response.Write "<hr>"
Do While Not EndOfQuery
LID = GetQueryValue("id")
LVariations = GetQueryValue("Variations")
Response.Write "LVariations for " & LID & ": " & LVariations & BR
WC_GetData "products/" & LID & "/variations"
NextQueryRecord
Loop
Response.Write "<hr>"
CloseQuery
End Sub
' (SS,15/8/25) for escape JSON string from EscapeCharacters in jsonObject.class.asp
' Escapes special characters in the text
' @param text as String
Function JSON_EscapeCharacters(byval text)
dim vbback
vbback = Chr(8)
dim result
result = text
if not isNull(text) then
result = cstr(result)
result = replace(result, "\", "\\")
result = replace(result, """", "\""")
result = replace(result, vbcr, "\r")
result = replace(result, vblf, "\n")
result = replace(result, vbtab, "\t")
result = replace(result, vbback, "\b")
end if
JSON_EscapeCharacters = result
End Function
' (SS,19/8/25) separated here
Sub GetWooCommerceAPIDetails(ByRef AURL, ByRef AKey, ByRef ASecret)
' URL different for live mode
If OnLiveSite Then
AURL = "https://www.castironradiatorcentre.co.uk"
AKey = "ck_9d08cae5627593be6ec7a0cf0870192bdf001a52"
ASecret = "cs_71da609398188d34e86c8dc89da576eb9ee2f8b1"
Else
AURL = "https://pennstudiostaging.co.uk/cast-iron-radiators"
AKey = "ck_9d08cae5627593be6ec7a0cf0870192bdf001a52"
ASecret = "cs_71da609398188d34e86c8dc89da576eb9ee2f8b1"
End If
End Sub
' (SS,27/8/25) returns true for itp.castironradiatorcentre.co.uk, false otherwise
Function OnLiveSite
Dim LServerURL, LResult
LServerURL = Request.ServerVariables("SERVER_NAME")
' Response.Write BR & "LServerURL: " & LServerURL & BR
LResult = LServerURL = "itp.castironradiatorcentre.co.uk"
' Response.Write "LResult: " & LResult & BR & BR
OnLiveSite = LResult
End Function
' (SS,19/8/25) get order
Sub WC_GetOrder(AOrderID)
If AOrderID = "" Then
Response.Write "Order ID missing" & BR
Exit Sub
End If
Initialise ' for database access
Dim LJSONResponse, LTableName
LJSONResponse = WC_GetPage("orders/" & AOrderID, "")
'Response.Write "<hr>" & NL
'Response.Write "<pre><code>" & NL
'Response.Write Left(LJSONResponse, 200) & NL
'Response.Write "</code></pre>" & NL
LTableName = "wc_order_updates"
' save to table, deleting if it already exists
' RunSQL "DELETE FROM " + LTableName + " WHERE id = " & CleanSQLStr(AOrderID)
LSQL = "INSERT INTO " + LTableName + " SET order_id = " & CleanSQLStr(AOrderID) & ", DateTimeReceived = NOW(), json_data = '" & CleanSQLStr(LJSONResponse) & "'"
RunSQL LSQL
Dim LUpdateID ' unique autoinc ID for this update
LUpdateID = GetSQLLastInsertID
Response.Write "<hr>" & NL
Dim LSQL
' first step to the first level
LSQL = "UPDATE " + LTableName + " SET " &_
" number = JSON_VALUE(json_data, '$.number')" &_
", order_key = JSON_VALUE(json_data, '$.order_key')" &_
", created_via = JSON_VALUE(json_data, '$.created_via')" &_
", wc_status = JSON_VALUE(json_data, '$.status')" &_
", date_created = JSON_VALUE(json_data, '$.date_created')" &_
", date_modified = JSON_VALUE(json_data, '$.date_modified')" &_
", date_paid = JSON_VALUE(json_data, '$.date_paid')" &_
", date_completed = JSON_VALUE(json_data, '$.date_completed')" &_
", total = JSON_VALUE(json_data, '$.total')" &_
", total_tax = JSON_VALUE(json_data, '$.total_tax')" &_
", payment_method = JSON_VALUE(json_data, '$.payment_method')" &_
", PaymentReference = JSON_VALUE(json_data, '$.transaction_id')" &_
", customer_note = JSON_VALUE(json_data, '$.customer_note')" &_
", billing = JSON_EXTRACT(json_data, '$.billing')" &_
", shipping = JSON_EXTRACT(json_data, '$.shipping')" &_
", shipping_lines = JSON_EXTRACT(json_data, '$.shipping_lines')" &_
", meta_data = JSON_EXTRACT(json_data, '$.meta_data')" &_
", line_items = JSON_EXTRACT(json_data, '$.line_items')" &_
", refunds = JSON_EXTRACT(json_data, '$.refunds')" &_
" WHERE UpdateID = " & LUpdateID
RunSQL LSQL
' (SS,27/8/25) check update was received by looking for number and order_key having a value, otherwise empty data might get saved in Shopping Admin
If Not GetSQLRecordExists("SELECT number, order_key FROM " + LTableName + " WHERE UpdateID = " & LUpdateID & " AND COALESCE(number, '') <> '' AND COALESCE(order_key, '') <> ''") Then
Response.Write "Failed to receive update" & BR
Exit Sub
End If
' send step to break the billng address and shipping address into separate fields
LSQL = ""
'
' following
AddSQLFieldFromJSONStr LSQL, "FirstName", "billing", "first_name", 100
AddSQLFieldFromJSONStr LSQL, "Surname", "billing", "last_name", 100
AddSQLFieldFromJSONStr LSQL, "CompanyName", "billing", "company", 100
AddSQLFieldFromJSONStr LSQL, "AddressLine1", "billing", "address_1", 100
AddSQLFieldFromJSONStr LSQL, "AddressLine2", "billing", "address_2", 100
AddSQLFieldFromJSONStr LSQL, "Town", "billing", "city", 100
AddSQLFieldFromJSONStr LSQL, "County", "billing", "state", 100
AddSQLFieldFromJSONStr LSQL, "Postcode", "billing", "postcode", 20
AddSQLFieldFromJSONStr LSQL, "Country", "billing", "country", 50
AddSQLFieldFromJSONStr LSQL, "Telephone", "billing", "phone", 100
AddSQLFieldFromJSONStr LSQL, "EmailAddress", "billing", "email", 100
AddSQLFieldFromJSONStr LSQL, "Message", "json_data", "customer_note", 10000 ' actual medium text limit is 16MB
' following held in DeliveryName, temporarily in DeliveryFirstName and DeliverySurname
AddSQLFieldFromJSONStr LSQL, "DeliveryFirstName", "shipping", "first_name", 100
AddSQLFieldFromJSONStr LSQL, "DeliverySurname", "shipping", "last_name", 100
' combine first name and surname
LSQL = LSQL + ", DeliveryName = LEFT(TRIM(CONCAT(TRIM(DeliveryFirstName), ' ', TRIM(DeliverySurname))), 100)"
AddSQLFieldFromJSONStr LSQL, "DeliveryCompanyName", "shipping", "company", 100
AddSQLFieldFromJSONStr LSQL, "DeliveryAddressLine1", "shipping", "address_1", 100
AddSQLFieldFromJSONStr LSQL, "DeliveryAddressLine2", "shipping", "address_2", 100
AddSQLFieldFromJSONStr LSQL, "DeliveryTown", "shipping", "city", 100
AddSQLFieldFromJSONStr LSQL, "DeliveryCounty", "shipping", "state", 100
AddSQLFieldFromJSONStr LSQL, "DeliveryPostcode", "shipping", "postcode", 20
AddSQLFieldFromJSONStr LSQL, "DeliveryCountry", "shipping", "country", 50
' additonal fields from meta data
Dim LAlternativePhone
LAlternativePhone = GetMetaDataValue(LTableName, "UpdateID", LUpdateID, "_wc_billing\/circ\/alt_phone")
AddSQLField LSQL, "AlternativePhone", LAlternativePhone, 100
Dim LPriority
LPriority = GetMetaDataValue(LTableName, "UpdateID", LUpdateID, "priority")
If Not IsNumeric(LPriority) Then LPriority = "5" ' default to 5 in case GetMetaDataValue returns ""
AddSQLField LSQL, "Priority", LPriority, 1
Dim LExchangeReason
LExchangeReason = GetMetaDataValue(LTableName, "UpdateID", LUpdateID, "exchange_reason")
AddSQLField LSQL, "ExchangeReason", LExchangeReason, 100
AddSQLField LSQL, "Exchange", BoolToInt(LExchangeReason <> ""), 1
LSQL = "UPDATE " + LTableName + " SET " + LSQL + " WHERE UpdateID = " & LUpdateID
' Response.Write BR & "### LSQL: " & LSQL & BR
RunSQL LSQL
' (SS,23/8/25) get refund details if applicable
If GetSQLValueAsString("SELECT refunds FROM " + LTableName + " WHERE UpdateID = " & LUpdateID) <> "[]" Then
WC_GetOrderRefunds AOrderID, LUpdateID
End If
CleanAddressesInOrderUpdates LUpdateID
Response.Write BR & "Added to UpdateID: " & LUpdateID & NL
SyncToShoppingAdmin AOrderID, LUpdateID
Finalise ' due to earlier initialise
End Sub
' set's the DeliveryAddressSameAsInvoice flag when addresses are the same and empties the delivery address, also lookups the country from code
' also sets DeliveryWillCollect via GetDeliveryWillCollect
Sub CleanAddressesInOrderUpdates(AUpdateID)
Dim LDeliveryAddressSameAsInvoice, LCountry, LDeliveryCountry
LDeliveryAddressSameAsInvoice = True
OpenQuery "SELECT * FROM wc_order_updates WHERE UpdateID = " & AUpdateID
' (SS,27/8/25) added EndOfQuery check (prevents BOF/EOF error in test mode
If Not EndOfQuery Then
LDeliveryAddressSameAsInvoice = LDeliveryAddressSameAsInvoice AND CompareAddressFields("FirstName", "DeliveryFirstName")
LDeliveryAddressSameAsInvoice = LDeliveryAddressSameAsInvoice AND CompareAddressFields("Surname", "DeliverySurname")
LDeliveryAddressSameAsInvoice = LDeliveryAddressSameAsInvoice AND CompareAddressFields("CompanyName", "DeliveryCompanyName")
LDeliveryAddressSameAsInvoice = LDeliveryAddressSameAsInvoice AND CompareAddressFields("AddressLine1", "DeliveryAddressLine1")
LDeliveryAddressSameAsInvoice = LDeliveryAddressSameAsInvoice AND CompareAddressFields("AddressLine2", "DeliveryAddressLine2")
LDeliveryAddressSameAsInvoice = LDeliveryAddressSameAsInvoice AND CompareAddressFields("Town", "DeliveryTown")
LDeliveryAddressSameAsInvoice = LDeliveryAddressSameAsInvoice AND CompareAddressFields("County", "DeliveryCounty")
LDeliveryAddressSameAsInvoice = LDeliveryAddressSameAsInvoice AND CompareAddressFields("Postcode", "DeliveryPostcode")
LDeliveryAddressSameAsInvoice = LDeliveryAddressSameAsInvoice AND CompareAddressFields("Country", "DeliveryCountry")
' lookup country
LCountry = LookupCountryForISO(NB(GetQueryValue("Country")))
LDeliveryCountry = LookupCountryForISO(NB(GetQueryValue("DeliveryCountry")))
End If
CloseQuery
Dim LSQL
' clear the delivery address if the same and set flag
If LDeliveryAddressSameAsInvoice Then
LSQL = "DeliveryAddressSameAsInvoice = TRUE, DeliveryFirstName = '', DeliverySurname = '', DeliveryName = '', DeliveryCompanyName = ''" &_
", DeliveryAddressLine1 = '', DeliveryAddressLine2 = '', DeliveryTown = '', DeliveryCounty = '', DeliveryPostcode = ''" &_
", DeliveryCountry = '', Country = '" + CleanSQLStr(LCountry) + "'"
Else
LSQL = "DeliveryAddressSameAsInvoice = FALSE, Country = '" + CleanSQLStr(LCountry) + "', DeliveryCountry = '" + CleanSQLStr(LDeliveryCountry) + "'"
End If
' set DeliveryWillCollect
LSQL = LSQL + ", DeliveryWillCollect = " & IIf(GetDeliveryWillCollect(AUpdateID), "1", "0")
LSQL = "UPDATE wc_order_updates SET " + LSQL + " WHERE UpdateID = " & AUpdateID
RunSQL LSQL
End Sub
' returns true if given field names have the same value, used by CleanAddressesInOrderUpdates above
Function CompareAddressFields(AFieldName1, AFieldName2)
CompareAddressFields = NB(GetQueryValue(AFieldName1)) = NB(GetQueryValue(AFieldName2))
End Function
' (SS,19/8/25) following formats like " FirstName = LEFT(JSON_VALUE(billing, '$.first_name'), 100)"
Sub AddSQLFieldFromJSONStr(ByRef ASQL, ADestinFieldName, ASourceJSONField, ASourceFieldName, AMaxLength)
If ASQL <> "" Then ASQL = ASQL & ", "
ASQL = ASQL + ADestinFieldName + " = LEFT(JSON_VALUE(" + ASourceJSONField + ", '$." + ASourceFieldName + "'), " & AMaxLength & ")"
End Sub
' (SS,21/8/25) similar to AddSQLFieldFromJSONStr but adds just the given value to field
Sub AddSQLField(ByRef ASQL, ADestinFieldName, AValue, AMaxLength)
If ASQL <> "" Then ASQL = ASQL & ", "
ASQL = ASQL + ADestinFieldName + " = LEFT('" & AValue & "', " & AMaxLength & ")"
End Sub
' (SS,20/8/25) also used by class oOrder (from where this is taken)
Function LookupCountryForISO(ACountry)
' looks up country if it's two chars long, else returns the same
Dim LCountryName
LCountryName = ""
If Len(ACountry) = 2 Then
LCountryName = GetSQLValueAsString("SELECT Country FROM countries WHERE CodeA2 = '" & CleanSQLStr(ACountry) & "'")
End If
LookupCountryForISO = LCountryName
End Function
' (SS,21/8/25)
' (SS,24/8/25) added ATableName and AIDField, renamed AUpdateID to AID
Function GetMetaDataValue(ATableName, AIDField, AID, AKey)
Dim LSQL
LSQL = "SELECT md.value_ FROM " + ATableName &_
" CROSS JOIN JSON_TABLE(meta_data, '$[*]' COLUMNS (" &_
" id_ varchar(100) PATH '$.id'," &_
" key_ varchar(100) PATH '$.key'," &_
" value_ varchar(100) PATH '$.value'" &_
" )" &_
" ) AS md" &_
" WHERE " + AIDField + " = '" + CleanSQLStr(AID) + "' AND key_ = '" + CleanSQLStr(AKey) + "'"
GetMetaDataValue = GetSQLValueAsString(LSQL)
End Function
' (SS,22/8/25) returns true if shipping_lines contains method_id of pickup_location
Function GetDeliveryWillCollect(AUpdateID)
Dim LSQL
LSQL = "SELECT md.* FROM wc_order_updates" &_
" CROSS JOIN JSON_TABLE(shipping_lines, '$[*]' COLUMNS (" &_
" id_ varchar(100) PATH '$.id'," &_
" method_title varchar(100) PATH '$.method_title', " &_
" method_id varchar(100) PATH '$.method_id'" &_
" )" &_
" ) AS md" &_
" WHERE UpdateID = '" + CleanSQLStr(AUpdateID) + "' AND method_id = 'pickup_location'"
GetDeliveryWillCollect = GetSQLRecordExists(LSQL)
End Function
' (SS,19/8/25) modified copy of one from Class cOrder
Sub RunSQL(ASQL)
' Response.Write BR & ReplaceStr(ASQL, NL, BR) & BR
If IsWooLiveMode Then
ExecuteQuery ASQL
End If
End Sub
' (SS,21/8/25) update the changes from wc_order_updates to orders
Sub SyncToShoppingAdmin(AOrderID, AUpdateID)
Const FIELD_CHECK_LIST_1 = "FirstName,Surname,CompanyName,AddressLine1,AddressLine2,Town,County,Postcode,Country,Telephone,AlternativePhone,EmailAddress,Message"
Const FIELD_CHECK_LIST_2 = "DeliveryWillCollect,DeliveryAddressSameAsInvoice,DeliveryName,DeliveryCompanyName,DeliveryAddressLine1,DeliveryAddressLine2,DeliveryTown,DeliveryCounty,DeliveryPostcode,DeliveryCountry"
Const FIELD_CHECK_LIST_3 = "Priority,Exchange,ExchangeReason"
Const FIELD_CHECK_LIST_4 = "PaymentReference"
' "DeliveryInfo,DespatchFromDate,DespatchByDate,PaymentMethod,PaymentReference,PaymentReceived"
' LocalMode
' CONST FIELD_CHECK_LIST_4 = "Status"
' !!! need to check for cancelled order status as part of refund, does cancelled not check whether refunded given?
Dim LFieldList, LFieldListArray, i, LFieldName
LFieldList = FIELD_CHECK_LIST_1 + "," + FIELD_CHECK_LIST_2 + "," + FIELD_CHECK_LIST_3 + "," + FIELD_CHECK_LIST_4
Dim LSQL
LSQL = "SELECT * FROM orders WHERE WooCommerceOrderID = '" + CleanSQLStr(AOrderID) + "'"
' abort with error if order doesn't exist
If Not GetSQLRecordExists(LSQL) Then
Response.Write BR & BR &"ERROR! Sync failed because Order ID " & AOrderID & " doesn't exist " & BR
Exit Sub
End If
If Not IsWooLiveMode Then
Response.Write BR & "### In Test Mode - Sync Aborted ###" & BR
Exit Sub
End If
' open both datasets, used by HasFieldChanged, just the one record
OpenQuery LSQL
OpenQuery2 "SELECT * FROM wc_order_updates WHERE UpdateID = '" + CleanSQLStr(AUpdateID) + "'"
Dim LChangedFields, LUpdateSQL, LFieldValueOld, LFieldValueNew
LChangedFields = ""
LUpdateSQL = ""
'Response.Write BR & "###1a GetQueryValue2('Message') : " & GetQueryValue2("Message") & BR
'Response.Write BR & "###1b GetQueryValue2('Message') : " & GetQueryValue2("Message") & BR
' (SS,28/8/25) encounter a strange bug which would return Null the second time the same field is fetched from the recordset (above is test code commented out)
' first time it returns the actual string e.g. "123", second time GetQueryValue2 returns a Null, seems to occur on MEDIUMTEXT fields
' could potientially be a serious unexpected bug in MySQL ODBC driver (or undocumented feature)
' got around it by changing HasFieldChanged to also return the values to avoiding calling GetQueryValue2 twice for the same field
LFieldListArray = Split(LFieldList, ",")
For i = LBound(LFieldListArray) To UBound(LFieldListArray)
LFieldName = Trim(LFieldListArray(i))
' (SS,28/8/25) added LFieldValueOld, LFieldValueNew parameter to get around possible ODBC driver bug
If HasFieldChanged(LFieldName, LFieldValueOld, LFieldValueNew) Then
LChangedFields = LChangedFields + IIf(LChangedFields = "", "", ", ") + LFieldName
' (SS,28/8/25) replaced Trim(NB(GetQueryValue2(LFieldName)) in following with LFieldValueNew to fix bug
LUpdateSQL = LUpdateSQL + IIf(LUpdateSQL = "", "", ", ") + LFieldName + " = '" & CleanSQLStr(LFieldValueNew) & "'"
End If
' Response.Write "LFieldName " & i & ":" & LFieldName & BR
Next
CloseQuery2
CloseQuery
Dim LNote
If LChangedFields = "" Then
LNote = ""
Else
LNote = "Modified fields: " + LChangedFields
End If
If LUpdateSQL <> "" Then
LUpdateSQL = "UPDATE orders SET " + LUpdateSQL + " WHERE WooCommerceOrderID = '" + CleanSQLStr(AOrderID) + "'"
' Response.Write BR & "### LUpdateSQL: " & LUpdateSQL & BR & BR
RunSQL LUpdateSQL
End If
' (25/8/25) check for refund, create if applicable
Dim LOrderNo, LRefundNote
LOrderNo = GetOrderNoForWooCommerceOrderID(AOrderID)
If CreateShoppingAdminRefund(LOrderNo, AOrderID, AUpdateID, LRefundNote) Then
LNote = LNote + IIf(LNote = "", "", "; ") + LRefundNote
' if not already cancelled and refunded in full then cancel, routine also cancels the order if applicable
If CheckOrderRefundedInFullAndCancelled(LOrderNo) Then
LNote = LNote + "; status changed to CANCELLED"
End If
End If
' add notes
If LNote = "" Then LNote = "No changes"
CreateNoteShoppingAdmin LOrderNo, "Sync from WC - " + LNote
WooCommerceSendNote AOrderID, "Sync to ShoppingAdmin - " + LNote
Response.Write BR & "Sync - " & LNote & BR & BR
' increment sync count and date in circ_penn.wc_orders
RunSQL "UPDATE circ_penn.wc_orders SET SyncCount = SyncCount + 1, DateTimeLastSynced = NOW() WHERE WooCommerceOrderID = '" & CleanSQLStr(AOrderID) & "'"
End Sub
' (SS,28/8/25) added AFieldValueOld, AFieldValueNew to get around MEDIUMTEXT field returning NULL on second field fetch in calling code (bug in ODBC driver?)
Function HasFieldChanged(AFieldName, ByRef AFieldValueOld, ByRef AFieldValueNew)
Dim LFieldValueOld, LFieldValueNew, LChanged
' get both values as string and trimmed
AFieldValueOld = Trim(NB(GetQueryValue(AFieldName)))
AFieldValueNew = Trim(NB(GetQueryValue2(AFieldName)))
LChanged = AFieldValueOld <> AFieldValueNew
'If LChanged Then
' Response.Write BR & "AFieldName: " & AFieldName & " changed from #" & AFieldValueOld & "# to #" & AFieldValueNew & "# " & BR & BR
'End If
HasFieldChanged = LChanged
End Function
' (SS,22/8/25) get OrderNo for given AWooCommerceOrderID
Function GetOrderNoForWooCommerceOrderID(AWooCommerceOrderID)
GetOrderNoForWooCommerceOrderID = GetSQLValueAsString("SELECT OrderNo FROM orders WHERE WooCommerceOrderID = '" & CleanSQLStr(AWooCommerceOrderID) & "'")
End Function
' (SS,22/8/25) added note to new order_notes table in Shopping Admin
Sub CreateNoteShoppingAdmin(AOrderNo, ANote)
Dim LOrderNo
LOrderNo = CStr(AOrderNo)
If LOrderNo <> "" Then
RunSQL "INSERT INTO order_notes SET OrderNo = '" + CleanSQLStr(LOrderNo) + "', DateTimeAdded = NOW(), Note = '" + CleanSQLStr(ANote) + "'"
End If
End Sub
' (SS,23/8/25) fetch order refunds, first into order_refunds field of wc_order_updates
Sub WC_GetOrderRefunds(AOrderID, AUpdateID)
Dim LJSONResponse, LTableName, LSQL, LUpdateIDWhere
LUpdateIDWhere = " UpdateID = '" + CleanSQLStr(AUpdateID) + "'"
' save the refunds data array in wc_order_updates
LJSONResponse = WC_GetPage("orders/" & AOrderID & "/refunds", "")
RunSQL "UPDATE wc_order_updates SET order_refunds = '" + CleanSQLStr(LJSONResponse) + "' WHERE " + LUpdateIDWhere
' separate the refunds array into individual records in wc_order_refunds
' with help from example https://stackoverflow.com/questions/73315204/using-json-table-to-convert-list-into-rows
' used JSON instead of LONGTEXT which works else NULL is returned
LSQL = "INSERT INTO wc_order_refunds (UpdateID, DateTimeReceived, order_id, json_data)" &_
" SELECT UpdateID, NOW() AS DateTimeReceived, '" + CleanSQLStr(AOrderID) + "', d.*" &_
" FROM wc_order_updates," &_
" JSON_TABLE(wc_order_updates.order_refunds, '$[*]' COLUMNS (json_data JSON path '$')" &_
" ) d" &_
" WHERE " + LUpdateIDWhere
RunSQL LSQL
' separate json_data into separate fields, id saved in refund_id
LTableName = "wc_order_refunds"
LSQL = "UPDATE " + LTableName + " SET " &_
" refund_id = JSON_VALUE(json_data, '$.id')" &_
", date_created = JSON_VALUE(json_data, '$.date_created')" &_
", date_created_gmt = JSON_VALUE(json_data, '$.date_created_gmt')" &_
", amount = JSON_VALUE(json_data, '$.amount')" &_
", reason = JSON_VALUE(json_data, '$.reason')" &_
", refunded_by = JSON_VALUE(json_data, '$.refunded_by')" &_
", refunded_payment = JSON_VALUE(json_data, '$.refunded_payment')" &_
", meta_data = JSON_EXTRACT(json_data, '$.meta_data')" &_
", line_items = JSON_EXTRACT(json_data, '$.line_items')" &_
", tax_lines = JSON_EXTRACT(json_data, '$.tax_lines')" &_
", shipping_lines = JSON_EXTRACT(json_data, '$.shipping_lines')" &_
", fee_lines = JSON_EXTRACT(json_data, '$.fee_lines')" &_
" WHERE " + LUpdateIDWhere
RunSQL LSQL
' break the line_items into separate records in wc_order_refund_line_items
LTableName = "wc_order_refund_line_items"
LSQL = "INSERT INTO " + LTableName + " (OrderRefundsID, UpdateID, DateTimeReceived, order_id, refund_id, json_data)" &_
" SELECT OrderRefundsID, UpdateID, NOW() AS DateTimeReceived, order_id, refund_id, d.*" &_
" FROM wc_order_refunds," &_
" JSON_TABLE(wc_order_refunds.line_items, '$[*]' COLUMNS (json_data JSON path '$')" &_
" ) d" &_
" WHERE " + LUpdateIDWhere &_
" ORDER BY refund_id"
RunSQL LSQL
' separate json_data into separate fields, id saved in item_id
LSQL = "UPDATE " + LTableName + " SET " &_
" item_id = JSON_VALUE(json_data, '$.id')" &_
", product_name = JSON_VALUE(json_data, '$.name')" &_
", product_id = JSON_VALUE(json_data, '$.product_id')" &_
", variation_id = JSON_VALUE(json_data, '$.variation_id')" &_
", quantity = JSON_VALUE(json_data, '$.quantity')" &_
", subtotal = JSON_VALUE(json_data, '$.subtotal')" &_
", subtotal_tax = JSON_VALUE(json_data, '$.subtotal_tax')" &_
", total = JSON_VALUE(json_data, '$.total')" &_
", total_tax = JSON_VALUE(json_data, '$.total_tax')" &_
", taxes = JSON_EXTRACT(json_data, '$.taxes')" &_
", meta_data = JSON_EXTRACT(json_data, '$.meta_data')" &_
", sku = JSON_VALUE(json_data, '$.sku')" &_
", price = JSON_VALUE(json_data, '$.price')" &_
" WHERE " + LUpdateIDWhere
RunSQL LSQL
' get the refunded_item_id from meta_data for each record
Dim LOrderRefundLineItemID, LRefundedItemID
OpenQuery "SELECT OrderRefundLineItemID FROM " + LTableName + " WHERE " + LUpdateIDWhere
Do While Not EndOfQuery
LOrderRefundLineItemID = GetQueryValue("OrderRefundLineItemID")
LRefundedItemID = GetMetaDataValue(LTableName, "OrderRefundLineItemID", LOrderRefundLineItemID, "_refunded_item_id")
If LRefundedItemID <> "" Then
RunSQL "UPDATE " + LTableName + " SET refunded_item_id = '" + CleanSQLStr(LRefundedItemID) + "' WHERE OrderRefundLineItemID = " & LOrderRefundLineItemID
End If
NextQueryRecord
Loop
CloseQuery
' break the line_items into separate records in wc_order_refund_shipping_lines
LTableName = "wc_order_refund_shipping_lines"
LSQL = "INSERT INTO " + LTableName + " (OrderRefundsID, UpdateID, DateTimeReceived, order_id, refund_id, json_data)" &_
" SELECT OrderRefundsID, UpdateID, NOW() AS DateTimeReceived, order_id, refund_id, d.*" &_
" FROM wc_order_refunds," &_
" JSON_TABLE(wc_order_refunds.shipping_lines, '$[*]' COLUMNS (json_data JSON path '$')" &_
" ) d" &_
" WHERE " + LUpdateIDWhere &_
" ORDER BY refund_id"
RunSQL LSQL
' separate json_data into separate fields, id saved in item_id
LSQL = "UPDATE " + LTableName + " SET " &_
" item_id = JSON_VALUE(json_data, '$.id')" &_
", method_title = JSON_VALUE(json_data, '$.method_title')" &_
", method_id = JSON_VALUE(json_data, '$.method_id')" &_
", instance_id = JSON_VALUE(json_data, '$.instance_id')" &_
", total = JSON_VALUE(json_data, '$.total')" &_
", total_tax = JSON_VALUE(json_data, '$.total_tax')" &_
", taxes = JSON_EXTRACT(json_data, '$.taxes')" &_
", meta_data = JSON_EXTRACT(json_data, '$.meta_data')" &_
" WHERE " + LUpdateIDWhere
RunSQL LSQL
' get the refunded_item_id from meta_data for each record, this isn't really necessary becaus eno equivalent exists in Shopping Admin, added for completeness
Dim OrderRefundShippingLineID
OpenQuery "SELECT OrderRefundShippingLineID FROM " + LTableName + " WHERE " + LUpdateIDWhere
Do While Not EndOfQuery
OrderRefundShippingLineID = GetQueryValue("OrderRefundShippingLineID")
LRefundedItemID = GetMetaDataValue(LTableName, "OrderRefundShippingLineID", OrderRefundShippingLineID, "_refunded_item_id")
If LRefundedItemID <> "" Then
RunSQL "UPDATE " + LTableName + " SET refunded_item_id = '" + CleanSQLStr(LRefundedItemID) + "' WHERE OrderRefundShippingLineID = " & OrderRefundShippingLineID
End If
NextQueryRecord
Loop
CloseQuery
End Sub
' (SS,23/8/25) add the refund to Shopping Admin tables refunds, restocks and restock_details
Function CreateShoppingAdminRefund(AOrderNo, AOrderID, AUpdateID, ByRef ARefundNote)
Dim LNewRefund, LSQL, LInsertSQL, LSQL2, LUpdateSQL
ARefundNote = ""
' check if there's a new refund record in wc_order_refunds, join to orders to get original payment method
LSQL = "SELECT wor.*, o.PaymentMethod" &_
" FROM wc_order_refunds wor" &_
" LEFT JOIN refunds r ON r.WooCommerceRefundID = wor.refund_id" &_
" INNER JOIN orders o ON o.WooCommerceOrderID = wor.order_id" &_
" WHERE wor.UpdateID = '" & CleanSQLStr(AUpdateID) & "' AND r.WooCommerceRefundID IS NULL" &_
" ORDER BY refund_id"
LNewRefund = GetSQLRecordExists(LSQL)
If Not LNewRefund Then
CreateShoppingAdminRefund = False
Exit Function
End If
' determine next RefundNo to use
Dim LOrderRefundsID, LRefundNo, LAmount, LRefundAmount, LRefundNet, LRefundVAT, LHasItems, LRestockID
LRefundNo = GetSQLValueAsString("SELECT MAX(RefundNo) FROM refunds WHERE OrderNo = '" + CleanSQLStr(AOrderNo) + "'")
If LRefundNo = "" Then LRefundNo = 0
' add each new refund (same SQL as above)
OpenQuery LSQL
Do While Not EndOfQuery
LRefundNo = LRefundNo + 1
LOrderRefundsID = GetQueryValue("OrderRefundsID")
LAmount = GetQueryValue("amount") ' !!! this might be optional, to test when it's not supplied
If LAmount = "" Then
LAmount = 0
Else
LAmount = NZ(LAmount)
End If
' get refund RefundAmount, RefundNet, RefundVAT from lines
GetRefundTotals LOrderRefundsID, LRefundAmount, LRefundNet, LRefundVAT, LHasItems
' if zero from GetRefundTotals then use LAmount (not VAT)
If LRefundAmount = 0 Then
LRefundAmount = LAmount
LRefundNet = LRefundAmount
LRefundVAT = 0
End If
ARefundNote = ARefundNote & IIf(ARefundNote = "", "", " & ") & LRefundAmount
' add record to refunds, need to determine the PaymentMethod, VAT and Net later
LInsertSQL = "INSERT INTO refunds SET " &_
" OrderNo = '" & CleanSQLStr(AOrderNo) & "'" &_
", RefundNo = " & LRefundNo &_
", RefundDate = '" & ISODate(CDate(GetQueryValue("date_created"))) & "'" &_
", RefundAmount = '" & CleanSQLStr(LRefundAmount) & "'" &_
", RefundNet = '" & CleanSQLStr(LRefundNet) & "'" &_
", RefundVAT = '" & CleanSQLStr(LRefundVAT) & "'" &_
", RefundMethod = '" & CleanSQLStr(GetQueryValue("PaymentMethod")) & "'" &_
", RefundDetails = '" & CleanSQLStr(GetQueryValue("reason")) & "'" &_
", WooCommerceOrderID = '" & CleanSQLStr(AOrderID) & "'" &_
", WooCommerceRefundID = " & GetQueryValue("refund_id") &_
", OrderRefundsID = " & LOrderRefundsID
RunSQL LInsertSQL
' if item records exist then create the restock header and details records
If LHasItems Then
LInsertSQL = "INSERT INTO restocks SET " &_
" OrderNo = '" & CleanSQLStr(AOrderNo) & "'" &_
", RestockDateTime = NOW()" &_
", RestockNote = '" + CleanSQLStr("Restock for WC refund amount: " & LRefundAmount) & "'" &_
", WooCommerceRefundID = " & GetQueryValue("refund_id") &_
", OrderRefundsID = " & LOrderRefundsID
RunSQL LInsertSQL
' create the restock detail records
LRestockID = GetSQLLastInsertID
LInsertSQL = "INSERT INTO restock_details (RestockID, OrderDetailID, RestockQty, WooCommerceRefundedItemID, OrderRefundLineItemID)" &_
" SELECT " & LRestockID & ", od.OrderDetailID, -quantity, refunded_item_id, OrderRefundLineItemID" &_
" FROM wc_order_refund_line_items wl" &_
" INNER JOIN orderdetails od ON od.WooCommerceItemID = wl.refunded_item_id" &_
" WHERE OrderRefundsID = " & LOrderRefundsID &_
" ORDER BY OrderRefundLineItemID"
RunSQL LInsertSQL
' adjust the RestockQty to take subproducts and bundles into account
LSQL2 = "SELECT rd.*, od.Qty AS OriginalOrderQty," &_
" od.Qty DIV (COALESCE(odb.Qty, ods.Qty, od.Qty)) * RestockQty AS ActualRestockQty" &_
" FROM restock_details rd" &_
" INNER JOIN orderdetails od ON od.OrderDetailID = rd.OrderDetailID" &_
" LEFT JOIN orderdetails ods ON ods.OrderDetailID = od.SubproductOrderDetailID" &_
" LEFT JOIN orderdetails odb ON odb.OrderDetailID = od.BundleProductOrderDetailID" &_
" WHERE RestockID = " & LRestockID
OpenQuery2 LSQL2
Do While Not EndOfQuery2
LUpdateSQL = "UPDATE restock_details SET RestockQty = " & GetQueryValue2("ActualRestockQty") & " WHERE RestockDetailID = " & GetQueryValue2("RestockDetailID")
RunSQL LUpdateSQL
NextQueryRecord2
Loop
CloseQuery2
' add back into stock
RestockProducts LRestockID
End If
NextQueryRecord
Loop
CloseQuery
ARefundNote = "Refunded " & ARefundNote
CreateShoppingAdminRefund = LNewRefund
End Function
' (SS,26/8/25) taken from ShoppingAdmin procedure TfrmAddRestock.RestockProducts
' puts back into stock, i.e. updates the NumInStock field in the products table
Sub RestockProducts(ARestockID)
Dim LSQL
' restock the products
LSQL = "UPDATE products, " &_
"(SELECT ProductID, SUM(RestockQty) AS RestockQty" &_
" FROM orderdetails od" &_
" INNER JOIN restock_details rd ON rd.OrderDetailID = od.OrderDetailID" &_
" WHERE RestockID = " & ARestockID &_
" GROUP BY ProductID" &_
") AS t2" &_
" SET NumInStock = NumInStock + RestockQty" &_
" WHERE products.ProductID = t2.ProductID AND NumInStock IS NOT NULL"
RunSQL LSQL
' restock the product options (if applicable)
LSQL = "UPDATE product_option_values, " &_
"(SELECT odo.ProductOptionValueID, SUM(rd.RestockQty) AS RestockQty" &_
" FROM order_detail_options odo" &_
" INNER JOIN orderdetails od ON od.OrderDetailID = odo.OrderDetailID" &_
" INNER JOIN restock_details rd ON rd.OrderDetailID = od.OrderDetailID" &_
" WHERE odo.ProductOptionValueID <> 0" &_
" AND RestockID = " & ARestockID &_
" GROUP BY ProductOptionValueID" &_
") AS t2" &_
" SET NumInStock = NumInStock + RestockQty" &_
" WHERE product_option_values.ProductOptionValueID = t2.ProductOptionValueID AND NumInStock IS NOT NULL"
RunSQL LSQL
End Sub
' (SS,25/8/25)
Sub GetRefundTotals(AOrderRefundsID, ByRef ARefundAmount, ByRef ARefundNet, ByRef ARefundVAT, ByRef AHasItems)
Dim LSQL
' get the refund for lines
LSQL = "SELECT ROUND(SUM(total) * -1, 2) AS TotalNet, ROUND(SUM(total_tax) * -1, 2) AS TotalTax, COUNT(quantity) > 0 AS HasItems FROM wc_order_refund_line_items WHERE OrderRefundsID = " & AOrderRefundsID
If Not GetSQL3Values(LSQL, ARefundNet, ARefundVAT, AHasItems) Then
ARefundNet = 0
ARefundVAT = 0
AHasItems = False
Else
AHasItems = IntToBool(AHasItems)
End If
' get the refund for shipping lines, and add if found
Dim AShippingRefundNet, AShippingRefundVAT
LSQL = "SELECT ROUND(SUM(total) * -1, 2) AS TotalNet, ROUND(SUM(total_tax) * -1, 2) AS TotalTax FROM wc_order_refund_shipping_lines WHERE OrderRefundsID = " & AOrderRefundsID
If GetSQL2Values(LSQL, AShippingRefundNet, AShippingRefundVAT) Then
ARefundNet = Round2dp(NZ(ARefundNet) + NZ(AShippingRefundNet))
ARefundVAT = Round2dp(NZ(ARefundVAT) + NZ(AShippingRefundVAT))
End If
ARefundAmount = Round2dp(NZ(ARefundNet) + NZ(ARefundVAT))
End Sub
' (SS,26/8/25)
Function CheckOrderRefundedInFullAndCancelled(AOrderNo)
Dim LSQL
LSQL = "SELECT a.*, b.* FROM" &_
"(SELECT ROUND(SUM(RefundAmount), 2) AS TotalRefundAmount FROM refunds WHERE OrderNo = '" & AOrderNo & "') a" &_
"," &_
"(SELECT GrandTotal, Status FROM orders WHERE OrderNo = '" & AOrderNo & "') b" &_
" WHERE Status <> '" & ORDER_CANCELLED_STATUS & "' AND TotalRefundAmount >= GrandTotal"
If GetSQLRecordExists(LSQL) Then
ShoppingAdminChangeOrdersStatus AOrderNo, ORDER_CANCELLED_STATUS
CheckOrderRefundedInFullAndCancelled = True
Else
CheckOrderRefundedInFullAndCancelled = False
End If
End Function
' (SS,26/8/25) changes order status to AStatus, currently used to cancel, called from CheckOrderRefundedInFullAndCancelled
Sub ShoppingAdminChangeOrdersStatus(AOrderNo, AStatus)
RunSQL "UPDATE orders SET Status = '" + AStatus + "' WHERE OrderNo = '" & AOrderNo & "'"
End Sub
' (SS,2/6/26)
Function GetOrderDateCompleted(AOrderID)
Dim LSQL
LSQL = "SELECT DATE_FORMAT(DateTimeCompleted, '%Y-%m-%d') " &_
"FROM orders " &_
"WHERE WooCommerceOrderID = " & ParseInt(AOrderID)
GetOrderDateCompleted = GetSQLValueAsString(LSQL)
End Function
%>