<%option explicit%>
<%
const Xorderfailed="No"
const xorderfailedtemplate="tmp_orderfail.txt"
shopcheckadmin "shopa_displayorders.asp"
'**********************************************************
' Cancel order and restore stock
' Send message to customer disabled
' VP-ASP 6.50
' March 31, 2004
'*********************************************************
'
dim ordernumber
dim my_system
dim my_from
dim my_fromAddress
dim my_subject
dim my_to
dim my_toAddress
Dim attachmentarray(20),attachmentcount
dim htmlformat
dim mailtype
dim body
Dim merchant
Dim customer
Dim Merchantemailformat,customeremailformat
Dim maillist(20)
Dim Maillistcount
Dim Textarray(500)
Dim TextCount
dim orderfail, cardfail, confirmmail
dim myconn
dim mailaction, cancelaction, orderid, confirmcancel
mailaction=Request("Mail")
cancelaction=Request("cancel")
confirmcancel=request("Confirm")
orderfail=request("Orderfail")
cardfail=request("Cardfail")
confirmmail=request("confirmmail")
dim dbc
Serror=""
AdminPageHeader
If Mailaction="" and cancelaction="" and confirmcancel="" and orderfail="" and cardfail ="" and confirmmail="" Then
orderid=request("oid")
'VP-ASP 6.09 - Precautionary Security Fix
if orderid > "" then
If not isnumeric(orderid) then
shoperror "Order ID must be numeric"
end if
end if
DisplayForm
Else
ValidateData()
if sError = "" Then
ProcessRequest
orderid=""
DisplayForm
else
DisplayForm
end if
end if
AdminPageTrailer ' Write admin trailer
'*******************************************************************
' Display any errors, then basic information nad then generate
'*****************************************************************
Sub DisplayForm()
%>
<%
Displayerrors
GenerateDisplayHeaderFlat
GenerateDisplayBodyHeader
Response.Write(""
GenerateDisplayBodyFooter
End Sub
Sub ProcessRequest
if cancelaction<>"" then
ProcessCancel
exit sub
end if
If Orderfail<>"" then
ProcessOrderfail
exit sub
end if
end sub
Sub ValidateData
'******************************************************************
' make sure we have what we need
'*****************************************************************
orderid=request("orderid")
ordernumber=orderid
if orderid<>"" then
if not isnumeric(orderid) then
serror=getlang("LangStatusError01") & " "
end if
else
serror=getlang("LangStatusOrderNumber") & " " & getlang("langcustrequired")
end if
End Sub
Sub DisplayErrors
if sError<> "" then
shopwriteerror SError
Serror=""
end if
end Sub
Sub Processcancel
'*********************************************************************
' set stock stock level, set oprocess=yes and ocanceled=Yes
'*********************************************************************
dim rc
CheckexistingOrder rc
if rc>0 then
shopwriteerror getlang("LangFormatNone") & " " & orderid
exit sub
end if
OpenOrderdb dbc ' Open the database
cancelUpdateStock dbc
UpdateOrderFields dbc, orderid
shopwriteheader getlang("LangCheckoutCancelled") & " " & getlang("LangStatusOrderNumber") & " " & orderid
end sub
Sub cancelupdatestock (dbc)
If getconfig("xstockcontrol")<>"Yes" then exit sub
dim stockconn
'VP-ASP 6.50 - stop stock from being updated if order is already cancelled
dim ors
dim catalogid
dim quantity, strsql, items
ShopOpendatabaseP stockconn
strSQL = "select * FROM oitems where orderid = " & Orderid
Set Items = dbc.Execute(strSQL)
Do While Not Items.EOF
'VP-ASP 6.50 - stop stock from being updated if order is already cancelled
set ors = dbc.execute("select canceled, ocardtype FROM orders WHERE orderid = " & orderid)
if not ors.eof then
quantity=Items("numitems")
catalogid=items("catalogid")
if (ors("canceled") = True) OR (isNull(ors("ocardtype"))) then
'don't change stock
else
UpdateStockLevels catalogid, quantity, stockconn
end if
end if
closerecordset ors
Items.MoveNext
Loop
closerecordset items
Shopclosedatabase stockconn
end sub
'
Sub UpdateStockLevels (catalogid, quantity, stockconn)
dim rsproduct
dim myconn
dim stock
'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set
if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then
mysqlupdatestocklevels catalogid, quantity, stockconn
exit sub
end if
Set rsproduct = Server.CreateObject ("adodb.recordset")
sql ="select cstock from products where catalogid=" & catalogid
rsproduct.Open SQL, stockconn, adOpenKeyset, adLockOptimistic , adcmdText
If not rsproduct.eof then
stock=rsproduct("cstock")
stock=stock+quantity
rsproduct("cstock")=stock
rsproduct.update
shopwriteheader getlang("LangAddUpdate") & "=" & catalogid & " " & getlang("LangProductStock") &"=" & stock
end if
closerecordset rsproduct
end sub
Sub UpdateOrderfields(dbc, orderid)
dim sql
sql="Update orders set oprocessed=1, canceled=1"
sql=sql & " where orderid=" & orderid
dbc.execute(sql)
end sub
'***********************************************************************
' See if order really exists
' if yes rc=0 else rc=4
'********************************************************************
Sub CheckexistingOrder (rc)
rc=4
dim rs, sql, dbc
openorderdb dbc
sql ="select * from orders where orderid=" & orderid
set rs=dbc.execute(sql)
if rs.eof then
rc=4
else
rc=0
end if
rs.close
set rs=nothing
shopclosedatabase dbc
end sub
Sub MailPerson (toname, toaddress, fromname, fromaddress, subject, tobody,attachmentYesNo)
dim acount
SetSess "mailerror",""
my_system=getconfig("xemailsystem") ' mail.mysystem.com
mailtype=getconfig("xemailtype") ' aspmail, jmail, cdonts
my_subject=subject
my_to=toname
my_toAddress=toaddress
my_from=fromname
my_fromAddress=fromaddress
if my_toAddress= "" then
exit sub
end if
if my_from = "" then
my_from="Unknown"
end if
if my_fromAddress="" then
my_fromAddress="unknown@unknown.com"
end if
body=tobody
if getconfig("xDebug")="Yes" then
debugwrite "mailing to " & toname & " " & toaddress
end if
htmlformat=Getsess("EmailFormat")
If attachmentYesNo="Yes" then
acount=attachmentcount
else
acount=0
end if
ExecuteMail mailtype,My_from,my_fromaddress,my_to,my_toaddress,my_subject,body,htmlformat,attachmentarray,acount
end sub
Sub DoesOrderExist (dbc, orderid,rc, orderrs)
rc=4
dim sql
sql ="select * from orders where orderid=" & orderid
set orderrs=dbc.execute(sql)
if orderRs.eof then
closerecordset OrderRs
rc=4
else
rc=0
end if
end sub
'*********************************************************************
' Development stopped On Sept 3
' Not fully implemented
'**********************************************************************
Sub Addmailingbuttons
If Xorderfailed<>"Yes" Then exit sub
dim template, msg
response.write "
"
msg="Your order did not go through"
Response.Write("")
response.write "
"
end sub
Sub ProcessOrderfail
dim template, subject
template=getconfig("xorderfailTemplate")
if template="" then
template="tmp_orderfail.txt"
end if
Subject=getconfig("xemailsubject")
mailgeneric ordernumber, template, subject
end sub
Sub mailgeneric (orderid, template, subject)
dim rc, emailformat, customer, stremail, trackingname
dim name, emailaddress, RSOrder
dim newsubject
dim filename, cr, i
Openorderdb myconn
Doesorderexist myconn, orderid, rc, RsOrder
If rc> 0 then
serror=getlang("langformatnone") & " " & orderid & " "
shopclosedatabase myconn
exit sub
end if
filename=template
SetupEmailformat filename,emailformat
setsess "emailformat",ucase(merchantemailformat)
ShopTemplateArray Filename, RsOrder, TextArray, TextCount
customer=""
CR=GetMailCR
for i = 0 to Textcount-1
customer= customer & TextArray(i) & CR
next
customer=Removehtml(customer, CR)
trackingname=rsorder("olastname")
stremail=rsorder("oemail")
name=rsorder("ofirstname") & " " & rsorder("olastname")
newsubject=subject & getlang("langmailordernumber") & " " & orderid
MailPerson rsorder("olastname"), rsorder("oemail"), getconfig("xemailname"),getconfig("xemail"),newsubject, Customer,"No"
response.write getconfig("xfont") & "Mail sent to " & name & " " & stremail & " "
response.write subject & " "
closerecordset rsorder
shopclosedatabase myconn
end sub
%>
