File: D:/web/circ.itp/2025-09-02/woo-to-itp - Copy.asp
<!--#include file="dbfunctions.asp"-->
<%
' (SS,4/3/25) following excluded, only dbfunctions.asp used
' <!--#include file="apputils.asp"-->
' <!--#include file="customutils.asp"-->
%>
<%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 databse
' when Live mode is true then data is written the database
Const WOO_LIVE_MODE = False
' (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
Const BUNDLE_DISCOUNT_PERCENTAGE_ACCESSORIES = 20
' (SS,31/7/25) alsi in customutils.asp, used for paint finish price calc
Const PF_BASE_COAT_ONLY = "Base Coat only"
Dim FoJSON, FoJSONArr
Sub DoWooCommerceOrderToITP
' Response.Write "<h1>WooWooCommerce to ITP</h1>"
' Response.Write "### START ###" & BR & BR
Initialise
ApplicationInitialise
' Set oOrder = New cOrder
' oOrder.SetDefaults
' (SS,4/8/25) replaced False with Not IsWooLiveMode
oOrder.TestMode = Not IsWooLiveMode
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", "surinder@ssbsoft.co.uk", "", "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 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 FSubscribe, FHearAboutUs, FHearAboutUsOther, FPurchaseOrderNo, FMessage
Private FDateTimeOrdered, FDateTimePaid
Private FDeliveryDate, FDeliveryWillCollect, FDeliveryAddressSameAsInvoice
Private FDeliveryName, FDeliveryCompanyName, FDeliveryAddressLine1, FDeliveryAddressLine2, FDeliveryTown, FDeliveryCounty, FDeliveryPostcode, FDeliveryCountry
Private FVATNumber, FEORINumber, FXIEORINumber, FIntraCommunitySupply, FVoucherID, FPaymentLog
' 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
' 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 = ""
ClearItems ' not really necessary
End Sub
Public Sub Class_Terminate
End Sub
Public Sub SetDefaults
End Sub
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
IPAddress = FIPAddress
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
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 PurchaseOrderNo(AValue)
FPurchaseOrderNo = AValue
End Property
Public Property Get PurchaseOrderNo
PurchaseOrderNo = FPurchaseOrderNo
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"
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 = AValue
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
PaymentMethod = FPaymentMethod
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
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 ="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 EORINumber(AValue)
FEORINumber = AValue
End Property
Public Property Get EORINumber
EORINumber = FEORINumber
End Property
Public Property Let XIEORINumber(AValue)
FXIEORINumber = AValue
End Property
Public Property Get XIEORINumber
XIEORINumber = FXIEORINumber
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
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
LookupCountry = ACountry
Dim LCountryName
LCountryName = ""
If Len(ACountry) = 2 Then
LCountryName = GetSQLValueAsString("SELECT Country FROM countries WHERE CodeA2 = '" & CleanSQLStr(ACountry) & "'")
End If
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
If ValidateItems Then
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
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
Private Property Let Log(AValue)
FLog = FLog & AValue
Response.Write AValue
End Property
Public Property Get Log
Log = FLog
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
If OrderNo < 600000 Then
ValidationError = "order number too small"
End If
If OrderAlreadyExists(OrderNo) Then
ValidationError = "order already exists"
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
If StatusIsPaymentReceived Then
' flag set to true (1) to indicate payment was received
PaymentReceived = GetQueryValue("PaymentReceived")
PaymentReceivedAmount = GrandTotal
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
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
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
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")
' 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")
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
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
Dim LItem, LProductID, LHasSubproducts, LIsBundle
If ItemCount = 0 Then
ValidationError = "No items"
Else
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
If Not IsValid Then Exit For
Next
End If
ValidateItems = IsValid
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
' 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
AppendSubproducts AItem.ProductID, AItem.OrderDetailID, AItem.Qty, ParseInt(AItem.Option1Value), AItem.Option2Value, AItem.BundleProductOrderDetailID
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
Private Sub AppendSubproducts(AProductID, AOrderDetailID, AQty, ASections, APaintFinish, ABundleProductOrderDetailID)
' 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
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
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
Private Sub AppendSubproduct(AProductID, AProductCode, AProductName, AQty, AOrderDetailID, ABundleProductOrderDetailID)
Dim LSQL
LSQL = "INSERT INTO orderdetails SET OrderNo = '" & OrderNo & "', ProductID = '" & AProductID & "', ProductCode = '" & CleanSQLStr(AProductCode) & "'" &_
", ProductName = '" & CleanSQLStr(AProductName) & "', Qty = " & AQty & ", SubproductOrderDetailID = '" & AOrderDetailID & "'"
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
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,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
Private Sub MarkAsImported
RunSQL "UPDATE circ_penn." + FImportTableName + " SET Imported = TRUE, ImportError = '' WHERE WooCommerceOrderID = " & OrderNo
End Sub
Private Sub MarkAsFailed
RunSQL "UPDATE circ_penn." + FImportTableName + " SET Imported = FALSE, ImportError = '" & CleanSQLStr(ValidationMessage) & "' WHERE WooCommerceOrderID = " & OrderNo
End Sub
' === end of items ===
End Class
' === order item class
Class cOrderItem
Dim FProductCode, FProductID, FProductName, FQty, FPriceEach, 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 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
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
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 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,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)
If AIsLocalTest Then
LURL = "https://woo.castironradiatorcentre.co.uk"
LKey = "ck_b81331b5bcd470ce01d0dcddefbe58adf161296f"
LSecret = "cs_1b4dcfc5ece776165f0ff4fe9b856987ab7e7c64"
Else
LURL = "https://pennstudiostaging.co.uk/cast-iron-radiators"
LKey = "ck_9d08cae5627593be6ec7a0cf0870192bdf001a52"
LSecret = "cs_71da609398188d34e86c8dc89da576eb9ee2f8b1"
LOrderID = LOrderID - 600000
End If
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,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
LURL = "https://pennstudiostaging.co.uk/cast-iron-radiators"
LKey = "ck_9d08cae5627593be6ec7a0cf0870192bdf001a52"
LSecret = "cs_71da609398188d34e86c8dc89da576eb9ee2f8b1"
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
LURL = "https://pennstudiostaging.co.uk/cast-iron-radiators"
LKey = "ck_9d08cae5627593be6ec7a0cf0870192bdf001a52"
LSecret = "cs_71da609398188d34e86c8dc89da576eb9ee2f8b1"
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
%>