File: D:/web/circ.itp/chat-gpt-sales-from-woo..asp
<%
Option Explicit
%>
<!--#include virtual="common/asp/jsonObject.class.asp"-->
<%
' to prevent timeout because it takes a while to run
' (SS,6/1/25) increased from 600 to 1200 because it was timing out
Server.ScriptTimeout = 1200
Response.LCID = 2057 ' UK locale for numeric parsing
' =====================================================
' WooCommerce Orders + Refunds Import (Classic ASP)
' Compatible with jsonObject.class.asp v2.4.0
' Includes: order_number, payment_date, payment_method,
' proper net calculation, refund logic fix
' =====================================================
' === WooCommerce API credentials ===
Dim storeURL, ck, cs
storeURL = "https://www.castironradiatorcentre.co.uk/wp-json/wc/v3"
'storeURL = "https://pennstudiostaging.co.uk/cast-iron-radiators/wp-json/wc/v3"
ck = "ck_9d08cae5627593be6ec7a0cf0870192bdf001a52"
cs = "cs_71da609398188d34e86c8dc89da576eb9ee2f8b1"
' === Date range ===
Dim afterDate, beforeDate
' afterDate = "2025-06-01T00:00:00"
' (SS,2/2/26) get out of memory error, adjusted after date to November 2025
' one issue could be recent refunds for orders before Novemeber 2025 won't be fetched
' (SS,2/2/26) modifed to run in quarters, query string quarter=1
' if quarter 1 used then it also truncates the woo_orders_refunds table
Dim FQuarter
FQuarter = CleanRequest("quarter")
If FQuarter = "" Then
Response.Write "Missing quarter"
Response.End ' ends the script (like Exit Sub)
ElseIf FQuarter = "1" Then
afterDate = "2025-06-01T00:00:00"
beforeDate = "2025-12-31T23:59:59"
ElseIf FQuarter = "2" Then
afterDate = "2026-01-01T00:00:00"
beforeDate = "2026-03-31T23:59:59"
ElseIf FQuarter = "3" Then
afterDate = "2026-04-01T00:00:00"
beforeDate = "2026-06-30T23:59:59"
ElseIf FQuarter = "4" Then
afterDate = "2026-07-01T00:00:00"
beforeDate = "2026-09-30T23:59:59"
End If
' === MySQL connection ===
Dim dbHost, dbUser, dbPass, dbName, conn
dbHost = "localhost"
dbUser = "castironradcen"
dbPass = "castironpan760"
dbName = "castironradcen"
Set conn = Server.CreateObject("ADODB.Connection")
conn.Open "Driver={MySQL ODBC 8.0 ANSI Driver};Server=" & dbHost & ";Database=" & dbName & ";User=" & dbUser & ";Password=" & dbPass & ";Option=3;"
' (SS,2/2/25) empty table if quarter is 1
If FQuarter = "1" Then
conn.Execute "TRUNCATE woo_orders_refunds"
End If
' === HTTP client ===
Dim http, authHeader
Set http = Server.CreateObject("MSXML2.XMLHTTP")
authHeader = "Basic " & Base64Encode(ck & ":" & cs)
Dim page, ordersURL, ordersJSON, parser, parsed, order, insertCount
page = 1
insertCount = 0
Do
ordersURL = storeURL & "/orders?after=" & afterDate & "&before=" & beforeDate & "&per_page=50&page=" & page
http.Open "GET", ordersURL, False
http.setRequestHeader "Authorization", authHeader
http.Send
ordersJSON = http.responseText
Set parser = New JSONobject
Set parsed = parser.Parse(ordersJSON) ' returns a JSONarray
If parsed Is Nothing Then Exit Do
If parsed.length = 0 Then Exit Do
Dim i
For i = 0 To parsed.length - 1
Set order = parsed.ItemAt(i)
ProcessOrder order, conn, storeURL, authHeader, http, insertCount
Next
page = page + 1
Loop
Response.Write "<p>✅ Import complete — " & insertCount & " records inserted.</p>"
conn.Close
Set conn = Nothing
' =====================================================
' === Subroutines and helpers ===
' =====================================================
Sub ProcessOrder(order, conn, storeURL, authHeader, http, ByRef insertCount)
Dim orderID, orderNumber, orderDate, paymentDate, paymentMethod, status, gross, net, discount, tax, shipping
orderID = order("id")
orderNumber = Replace(order("number"), "'", "''")
orderDate = Replace(Left(order("date_created"), 19), "T", " ")
' === Payment date ===
If Not IsNull(order("date_paid")) And Trim(order("date_paid") & "") <> "" Then
paymentDate = Replace(Left(order("date_paid"), 19), "T", " ")
Else
paymentDate = ""
End If
' === Payment method ===
If Not IsNull(order("payment_method_title")) And Trim(order("payment_method_title") & "") <> "" Then
paymentMethod = Replace(order("payment_method_title"), "'", "''")
ElseIf Not IsNull(order("payment_method")) And Trim(order("payment_method") & "") <> "" Then
paymentMethod = Replace(order("payment_method"), "'", "''")
Else
paymentMethod = ""
End If
status = Replace(order("status"), "'", "''")
' === Totals ===
gross = SafeDbl(order("total")) ' includes tax + shipping
net = 0
discount = 0 : tax = 0 : shipping = 0
' Calculate net from line items (items-only subtotal excluding tax/shipping)
Dim items, li, lii
Set items = order("line_items")
If Not items Is Nothing And items.length > 0 Then
For lii = 0 To items.length - 1
Set li = items.ItemAt(lii)
net = net + SafeDbl(li("total"))
tax = tax + SafeDbl(li("total_tax")) ' also collect tax
Next
End If
' === Discounts ===
Dim coupons, ci, c
Set coupons = order("coupon_lines")
If Not coupons Is Nothing And coupons.length > 0 Then
For ci = 0 To coupons.length - 1
Set c = coupons.ItemAt(ci)
discount = discount + Abs(SafeDbl(c("discount")))
Next
End If
' === Shipping ===
Dim shippingLines, s, si
Set shippingLines = order("shipping_lines")
If Not shippingLines Is Nothing And shippingLines.length > 0 Then
For si = 0 To shippingLines.length - 1
Set s = shippingLines.ItemAt(si)
shipping = shipping + SafeDbl(s("total"))
tax = tax + SafeDbl(s("total_tax"))
Next
End If
' === Refunds ===
Dim refunds, ri, refund, refundID, refundURL, refundJSON, refundParser, refundObj
Set refunds = order("refunds")
If Not refunds Is Nothing And refunds.length > 0 Then
For ri = 0 To refunds.length - 1
Set refund = refunds.ItemAt(ri)
refundID = refund("id")
refundURL = storeURL & "/orders/" & orderID & "/refunds/" & refundID
http.Open "GET", refundURL, False
http.setRequestHeader "Authorization", authHeader
http.Send
refundJSON = http.responseText
Set refundParser = New JSONobject
Set refundObj = refundParser.Parse(refundJSON)
Dim refundDate, refundReason
Dim refundTotal, refundItems, refundTax, refundShipping
refundDate = Replace(Left(refundObj("date_created"), 19), "T", " ")
refundReason = Replace(refundObj("reason"), "'", "''")
' Total amount refunded (includes tax + shipping)
refundTotal = Abs(SafeDbl(refundObj("amount")))
refundItems = 0
refundTax = 0
refundShipping = 0
' Refund line items (items-only subtotal)
Dim rliArray, rli, rlii
Set rliArray = refundObj("line_items")
If Not rliArray Is Nothing And rliArray.length > 0 Then
For rlii = 0 To rliArray.length - 1
Set rli = rliArray.ItemAt(rlii)
refundItems = refundItems + Abs(SafeDbl(rli("total")))
refundTax = refundTax + Abs(SafeDbl(rli("total_tax")))
Next
End If
' Refund shipping lines
Dim rsArray, rs, rsi
Set rsArray = refundObj("shipping_lines")
If Not rsArray Is Nothing And rsArray.length > 0 Then
For rsi = 0 To rsArray.length - 1
Set rs = rsArray.ItemAt(rsi)
refundShipping = refundShipping + Abs(SafeDbl(rs("total")))
refundTax = refundTax + Abs(SafeDbl(rs("total_tax")))
Next
End If
' Defensive fallback if WooCommerce "amount" missing
If refundTotal = 0 Then refundTotal = refundItems + refundTax + refundShipping
' Insert refund data
Dim sql
sql = "INSERT INTO woo_orders_refunds " & _
"(order_id, order_number, order_date, payment_date, payment_method, status, gross, net, discount, tax, shipping, " & _
"refund_id, refund_date, refund_gross, refund_net, refund_tax, refund_shipping, refund_reason) VALUES " & _
"(" & orderID & ", '" & orderNumber & "', '" & orderDate & "', " & IIf(paymentDate = "", "NULL", "'" & paymentDate & "'") & ", '" & paymentMethod & "', '" & status & "', " & gross & ", " & net & ", " & discount & ", " & tax & ", " & shipping & ", " & _
refundID & ", '" & refundDate & "', " & refundTotal & ", " & refundItems & ", " & refundTax & ", " & refundShipping & ", '" & refundReason & "')"
conn.Execute sql
insertCount = insertCount + 1
Next
Else
' Insert order without refund
Dim sqlNoRefund
sqlNoRefund = "INSERT INTO woo_orders_refunds (order_id, order_number, order_date, payment_date, payment_method, status, gross, net, discount, tax, shipping) VALUES " & _
"(" & orderID & ", '" & orderNumber & "', '" & orderDate & "', " & IIf(paymentDate = "", "NULL", "'" & paymentDate & "'") & ", '" & paymentMethod & "', '" & status & "', " & gross & ", " & net & ", " & discount & ", " & tax & ", " & shipping & ")"
conn.Execute sqlNoRefund
insertCount = insertCount + 1
End If
End Sub
' === Helper: Base64 encode ===
Function Base64Encode(inData)
Dim xml, node
Set xml = CreateObject("MSXML2.DOMDocument")
Set node = xml.CreateElement("base64")
node.DataType = "bin.base64"
node.nodeTypedValue = Stream_StringToBinary(inData)
Base64Encode = Replace(node.Text, vbLf, "")
Set node = Nothing
Set xml = Nothing
End Function
Function Stream_StringToBinary(Text)
Const adTypeText = 2
Const adTypeBinary = 1
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Type = adTypeText
BinaryStream.Charset = "us-ascii"
BinaryStream.Open
BinaryStream.WriteText Text
BinaryStream.Position = 0
BinaryStream.Type = adTypeBinary
Stream_StringToBinary = BinaryStream.Read
Set BinaryStream = Nothing
End Function
' === Helper: safely convert to number ===
Function SafeDbl(val)
If IsNull(val) Or IsEmpty(val) Or Trim(val & "") = "" Then
SafeDbl = 0
Else
On Error Resume Next
SafeDbl = CDbl(val)
If Err.Number <> 0 Then SafeDbl = 0
On Error GoTo 0
End If
End Function
' === Helper: IIf() replacement for Classic ASP ===
Function IIf(condition, truePart, falsePart)
If condition Then
IIf = truePart
Else
IIf = falsePart
End If
End Function
' ============================================================================================================================================
' (SS,2/2/26) following from dbfunctions.asp
' cleans the string, replacing quote and apostrophe with escape char
' also converts \ with \\ so it doesn't cause problems
' with SQL statements, works with MySQL, might not with other SQL Servers
' see MySQL manual page 432 (6.1.1.1)
' (SS,14/7/09) added code for ASCII control codes etc
Function CleanSQLStr(AValue)
Dim LNewValue
If IsNull(AValue) Then
LNewValue = "" ' (SS,27/6/05) added this to prevent invalid use of null error, (SS,13/6/12) changed from AValue to LNewValue
Else
LNewValue = CStr(AValue) ' (SS,13/6/12) added CStr to ensure it converts to a string, probably not necessary, also moved to else of if
End If
' (SS,13/6/12) added "if" to only do the following if value isn't blank
If LNewValue <> "" Then
LNewValue = Replace(LNewValue, "\", "\\")
LNewValue = Replace(LNewValue, "'", "\'")
LNewValue = Replace(LNewValue, """", "\""")
' (SS,14/7/09) added following to cope with ASCII control codes (also added to CleanSQLStr in itpssutils.pas)
' see http://dev.mysql.com/doc/refman/5.0/en/string-syntax.html for escape character details
LNewValue = Replace(LNewValue, Chr(0), "\0") ' An ASCII NUL (0x00) character.
LNewValue = Replace(LNewValue, Chr(8), "\b") ' A backspace character.
LNewValue = Replace(LNewValue, Chr(9), "\t") ' A tab character.
LNewValue = Replace(LNewValue, Chr(10), "\n") ' A newline (linefeed) character.
LNewValue = Replace(LNewValue, Chr(13), "\r") ' A carriage return character.
LNewValue = Replace(LNewValue, Chr(26), "\Z") ' ASCII 26 (Control-Z).
' (SS,21/7/09) removed following because they only work for wildcard search using LIKE,
' created new function called CleanSQLStrForLike which will allow search literal % and _ in LIKE query
' problem occurred when user with underscore in email tried logging in
' it tried to search for \_ and obviously failed
' LNewValue = Replace(LNewValue, "%", "\%") ' A “%” character.
' LNewValue = Replace(LNewValue, "_", "\_") ' A “_” character.
End If
CleanSQLStr = LNewValue
End Function
' (SS,16/11/18) replace all < and > with < and >
Function EscapeHTMLAngleBrackets(AText)
Dim LResult
LResult = Replace(AText, "<", "<")
LResult = Replace(LResult, ">", ">")
EscapeHTMLAngleBrackets = LResult
End Function
' (SS,25/10/23) checks to see if a file is being posted to prevent referring to form.collection from causing a binary read error
' this is used to bypass any checks on form collection using Request.Form from interfering
' Upload is enabled when querystring has a cmd=upload
Function IsUploadMode
' (SS,2/2/26) modified for use here by adding following
IsUploadMode = False
Exit Function
If gnUploadMode = -1 Then
If Request.QueryString("cmd") = "upload" Then
gnUploadMode = 1
Else
gnUploadMode = 0
End If
End If
IsUploadMode = gnUploadMode = 1
End Function
' (SS,16/11/18)
' form field values to be fetched using CleanRequestForm which strips HTML tags and converts < and > to HTML entity
' This should now be called instead of Request.Form to fetch a form field.
' (SS,25/10/23) modified to not fetch the form field when in upload mode
Function CleanRequestForm(AFieldName)
' CleanRequestForm = StripHTMLTags(Request.Form(AFieldName))
'Response.Write "###" & "CleanRequestForm called with " & AFieldName & BR
' (SS,25/10/23) modified to return a blank and not check the form collection in upload mode because it'll interfere with the upload
If Not IsUploadMode Then
CleanRequestForm = EscapeHTMLAngleBrackets(Request.Form(AFieldName))
Else
CleanRequestForm = ""
End If
End Function
' (SS,20/11/18) same as CleanRequestForm but using Request.QueryString
Function CleanRequestQueryString(AFieldName)
CleanRequestQueryString = EscapeHTMLAngleBrackets(Request.QueryString(AFieldName))
End Function
' (SS,20/11/18) same as CleanRequestForm but similar to Request (only checks Request.QueryString and then Request.Form in that order)
' it doesn't check Cookies and ServerVariables like Request does
' (SS,25/10/23) modified to not fetch the form field when in upload mode
Function CleanRequest(AFieldName)
Dim LResult
'Response.Write "###" & "CleanRequest called with " & AFieldName & BR
' check the querystring first, then form
LResult = Request.QueryString(AFieldName)
If IsEmpty(LResult) Then
'Response.Write "###" & "Request.Form used " & AFieldName & BR
' (SS,25/10/23) modified to return a blank and not check the form collection in upload mode because it'll interfere with the upload
If Not IsUploadMode Then
LResult = Request.Form(AFieldName)
End If
End If
If IsEmpty(LResult) Then
CleanRequest = LResult
Else
CleanRequest = EscapeHTMLAngleBrackets(LResult)
End If
End Function
' ============================================================================================================================================
%>