<%Option explicit%> <% Const RestoreRedirectUrl="shopaddtocart.asp" 'Const RestoreRedirectUrl="" ' if set to "" then only message is produced Dim customerid CustCheckAdmin Customerid '********************************************************* ' VP-ASP 6.50 ' called by shopstatus to view or restore an order ' If status has not verified the customer details, displays ' are suppressed ' We are only restoring info from oitems table so category is not ' restored. ' June 15, 2003 Validate order, add real restore links ' xdownloadreallinks=Yes ' Jan 23, 2004 ' SEpt 18, 2008 Fix split products database ' April 26, 2005 add translate cname ' Nov 22, 2006 HK Support RMA '************************************************************ Dim RestOrders, dbc, restoreRealLinks, proddbc Dim View, restore, Restoid Dim restdbc dim Downloadflag 'VP-ASP 6.50 - precautionary security fix Restore=cleanchars(Request("Restore")) View=cleanchars(Request("View")) RestOid=request("oid") If not isnumeric(restoid) then shoperror getlang("langOrderNone") & "
" end if OpenOrderdb dbc LocateOrder restoid, customerid If Serror="" then If Restore<>"" then PerformRestoreOrder restoid shoppageheader else FormatRestore Formatdownloads ShopFormatOrder dbc,restoid, "" end if else ShopPageHeader end if If Serror<>"" then DisplayErrors end if ShopPageTrailer Shopclosedatabase dbc ' '************************************************************ ' see if order exists ' If yes see if downloads allowed '************************************************************** Sub LocateOrder (oid, cid) dim sql strsql = "select * from orders where orderid=" & oid & " AND ocustomerid=" & cid set Orders=dbc.execute(strsql) If Orders.eof then Serror=getlang("langOrderNone") & "
" end if If serror="" Then validatePurchase orders,rc if rc=0 then downloadflag=true else downloadflag=false end if end if CloseRecordset Orders end sub Sub DisplayErrors shopwriteerror SError end sub Sub PerformRestoreOrder (oid) shopopendatabaseP proddbc strsql = "select * from orders where orderid=" & oid set RestOrders=dbc.execute(strsql) RestoreItems oid, proddbc If Serror<>"" then restorders.close set restorders=nothing shopclosedatabase proddbc exit sub end if GetCustomerSessionData RestoreShipping RestOrders UpdateCustomerSessionData Restorders.close Set Restorders=nothing shopclosedatabase proddbc If RestoreRedirecturl<>"" then shopclosedatabase dbc Responseredirect RestoreRedirectUrl end if Serror=getlang("langCartRestored") & " " & oid end sub Sub RestoreItems (oid, proddbc) Dim scartitem, arrcart, nameincart, quantity dim catalogid, dualprice, strsql, category Dim ProductAddress, DeliveryArray, weight, image dim catsql, catrs, originalprice, cname, stock dim rsupplierid, rfeatures dim pos strSQL = "select * FROM oitems where orderid = " & oid Set Items = dbc.Execute(strSQL) if Items.EOF then items.close set items=nothing Serror=getlang("langFormatMissing") exit sub end if arrCart = GetSessA("CartArray") scartItem = GetSess("CartCount") Do While Not Items.EOF nameincart= items("itemname") productaddress=items("address") pos=instr(nameincart,getlang("langGiftCertificate")) if pos>0 then SError=getlang("langGiftFail") items.close set items=nothing exit sub end if quantity=items("numitems") 'VP-ASP 6.09 - fix for restore order retaining old price, rather than getting it from the products table 'unitprice=items("unitprice") catalogid=items("catalogid") dualprice=items("dualprice") rsupplierid=items("supplierid") rfeatures=items("features") category=0 catsql="select * from products where catalogid=" & catalogid Set catrs=proddbc.execute(catsql) if not catrs.eof then 'VP-ASP 6.09 - fix for restore order retaining old price, rather than getting it from the products table unitprice=catrs("cprice") category=catrs("ccategory") weight=catrs("weight") image=catrs("cimageurl") cname=catrs("cname") cname=translatelanguage(dbc, "products", "cname","catalogid", catalogid, cname) stock=catrs("cstock") 'VP-ASP 6.09 - fix for restore order retaining old price, rather than getting it from the products table 'end if closerecordset catrs originalprice=unitprice GetOriginalprice proddbc, catalogid, originalprice scartitem=scartitem+1 arrCart(cProductid,scartItem) = catalogID arrCart(cProductCode,scartItem) = "" arrCart(cProductname,scartItem) = NameInCart arrCart(cQuantity,scartItem) = Clng(quantity) arrCart(cOriginalPrice,scartItem) = Originalprice arrCart(cUnitPrice,scartItem) = UnitPrice arrCart(cProductimage,scartItem) = Image arrCart(cProductweight,scartItem) = Weight arrCart(cProductMininame,scartItem) = cname arrCart(cStocklevel,scartItem) = Stock if getconfig("XdualPrice")="Yes" then arrCart(cDualPrice,scartItem) = Dualprice else arrCart(cDualPrice,scartItem) = 0 end if If getconfig("XDeliveryAddress")="Yes" and Not isnull(ProductAddress) then ConvertDeliveryToArray Deliveryarray, Productaddress arrCart(cDelivery,scartItem) = DeliveryArray end if 'VP-ASP 6.09 - fix for restore order retaining old price, rather than getting it from the products table 'items.movenext arrCart(cCategory,scartItem) = category arrCart(cDiscount,scartItem) = "" arrcart(cProductfeatures,scartItem) = rfeatures arrCart(csupplierid,scartItem) = rsupplierid 'VP-ASP 6.09 - fix for restore order retaining old price, rather than getting it from the products table else serror = serror & getlang("langnolongeravailable") & "

" & getlang("langcommonviewcart") & "" end if items.movenext ' debugwrite "category=" & category Loop SetSessA "CartArray",arrCart SetSess "CartCount",scartitem items.close set items=nothing end sub ' Sub RestoreShipping (RS) strshipname=rs("oshipname") strshipaddress=rs("oshipaddress") strshiptown=rs("oshiptown") strshipzip=rs("oshipzip") strshipstate=rs("oshipstate") strshipcountry=rs("oshipcountry") strshipcompany=rs("oshipcompany") strshipmethodtype=rs("oshipmethodtype") strshipcost=rs("oshipcost") end sub ' Sub FormatRestore ShopPageHeader if getconfig("xallowRestoreOrder")<>"Yes" then exit sub %> <%=getlang("langrestoreorder")%> <% if getconfig("xRMAallowed")="Yes" then response.write " " response.write "" & getlang("langrma") & "" end if Response.write "
" end sub Sub Formatdownloads dim rs, sql, oirs, productcatalogid, downloadcount if getconfig("xdownloads")<>"Yes" then exit sub If downloadflag=false then exit sub Restorereallinks=getconfig("xdownloadreallinks") downloadcount=0 shopopendatabaseP proddbc strSQL = "select * FROM oitems where orderid = " & restoid Set oiRS = dbc.Execute(strSQL) ' Do While Not oiRS.EOF Productcatalogid=oirs("catalogid") GenerateSecureHyperlink proddbc,Productcatalogid, downloadcount, restoid, getsess("customerid"),oirs oiRS.MoveNext Loop closerecordset oirs shopclosedatabase proddbc response.write "
" end sub '**************************************************************************** ' generate secure hyperlink to shopdownload.asp '************************************************************************** Sub GenerateSecureHyperlink (myconn,catalogid, count, orderid, customerid, oitems) dim productlink, oid, link dim item, features, featurename productlink=getconfig("xendoforderhyperlinkfield") dim productsql, rs, cname, filename If catalogid= 0 then exit sub Productsql="select * from products where catalogid=" & catalogid set rs=proddbc.execute(productsql) if rs.eof then closeRecordset rs exit sub end if link=rs(productlink) If isnull(link) then closerecordset rs exit sub end if cname=rs("cname") cname=translatelanguage(dbc, "products", "cname","catalogid", catalogid, cname) item=oitems("orderitemid") If getconfig("xdownloadfeature")="Yes" then features=oitems("features") If not isnull(features) then featurename=Getfeaturename(proddbc, features) cname = cname & " " & featurename end if end if Restorereallinks=getconfig("xdownloadreallinks") If RestorerealLinks="Yes" then filename="shopdownloadreal.asp?oid=" & orderid & "&catalogid=" & catalogid & "&item=" & item else filename="shopdownload.asp?oid=" & orderid & "&catalogid=" & catalogid & "&item=" & item end if If count=0 then shopwriteheader getlang("LangdownloadFiles") end if %>
<%=cname%>
<% CloseRecordset rs count=count+1 end sub '****************************************************************** ' Get original price '****************************************************************** Sub Getoriginalprice (proddbc, catalogid, price) dim rs, sql if getconfig("xquantityprices")="No" then exit sub sql="select * from products where catalogid=" & catalogid set rs=proddbc.execute(sql) if not rs.eof then price=rs("cprice") end if closerecordset rs end sub Sub ValidatePurchase (orderRS, rc) '******************************************************* ' See if payment type matches any of the valid payments allowed ' '******************************************************* Dim cardtype, cardarray(20),cardcount,paymenttype,i rc=0 CardType=Getconfig("xendofordervalidpayments") paymenttype =ucase(orderrs("ocardtype")) If cardtype="" then exit sub end if parserecord cardtype, cardarray,cardcount,"," for i = 0 to cardcount-1 If ucase(cardarray(i))=paymenttype then exit sub end if next rc=4 end sub Function getfeaturename(myconn, strfeatures) dim features(10), featurecount, frs, fsql, featurename parserecord strfeatures, features, featurecount,"," fsql="select * from prodfeatures where id=" & features(0) set frs=myconn.execute(fsql) featurename=frs("featurename") closerecordset frs getfeaturename=featurename end function %>