<% ShopCheckAdmin "shopa_reports.asp" '*********************************************************** ' Version 6.50 Fix English words Oct 2, 2004 ' Sales Reports ' Modified to display summary report table ' Minor fixes for null values '************************************************************* 'VP-ASP 6.50 - Graphical reports dim summaryarray(50), maxorders, maxtotal dim howmanytoshow Dim dbtable Dim fields(10) Dim CapFields(10) dim fieldcount Dim File Dim ScriptResponder Dim Dbc dim Action dim fromdate dim todate dim datedelim Dim rs Dim Limit Dim Month 'VP-ASP 6.50 - allow filtering by payment type dim paymenttype Dim Year dim monthnames(12) 'dim database dim xdecimalpoint xdecimalpoint=getconfig("xdecimalpoint") const MaxShippingTypes=50 const cShipName=1 const cShipCost=2 const cShipCount=3 dim varrshipping() dim taxcount,totaltaxcost dim count dim total taxcount=0 totaltaxcost=0 dim ctgrssal1, ctgrssal2 dim ctprdsal1, ctprdsal2 dim ctshpcst1, ctshpcst2 dim cthdlfee1, cthdlfee2 dim cttax1, cttax2 dim ctgcprch1, ctgcprch2 dim ctgcrdm1, ctgcrdm2 dim ctdisapl1, ctdisapl2 dim ctcpnrdm1, ctcpnrdm2 dim ctproj1, ctproj2 xdecimalpoint=getconfig("xdecimalpoint") scriptresponder="shopa_formatorder.asp" mypagesize=GetSess("ReportLimit") mypage=request("Page") AdminPageHeader if mypage<>"" then sql=GetSess("Sqlquery") ' on recursive calls we stored sql in sessikon variable fromdate=GetSess("Fromdate") todate=GetSess("Todate") WriteReport else GetInput If Action = "" or Serror<>"" Then DisplayForm gethelp Else GenerateSQL WriteReport end if End If AdminPageTrailer '******************************** Sub GetInput Serror="" dbtable="Orders" limit=request("Limit") if limit="" then limit=100 end if SetSess "ReportLimit",limit mypagesize=limit action="" GetActionValues If action<> "" then GetDateValues end if end sub ' Sub GetActionValues action=request("summary") if action<>"" then action="SUMMARY" else action=request("Details") if action<>"" then action="DETAILS" end if end if end Sub ' Sub GetDateValues dim datevalue fromdate=request("fromdate") todate=request("todate") If fromdate<>"" then if todate="" then todate=date() end if ValidateDates exit sub end if ' Try month Month=Request("month") Year=Request("Year") 'VP-ASP 6.50 - allow filtering by payment type paymenttype = request("saletype") If month>"0" then FormatMonth exit sub end if If Year>"0" then FormatYear exit sub end if ' Try Radio Buttons datevalue=request("DateSelect") datevalue=ucase(datevalue) 'debugwrite "datevalue=" & datevalue if datevalue="" then Serror=getlang("langReportDate") exit sub end if If datevalue="TODAY" then fromdate=date() todate=date() exit sub end if If datevalue="YESTERDAY" then fromdate=dateadd("d",-1, date()) todate=fromdate exit sub end if end sub Sub FormatMonth If lcase(getconfig("xenvironment"))="chillisoft" then formatmonthchilli exit sub end if month=cint(month) if Year="0" then Year=Datepart("yyyy",date()) else Year=clng(year) end if fromdate= month & "/" & Year month=month+1 if month = 13 then month=1 Year=Year+1 end if Todate= month & "/" & Year fromdate=cdate(fromdate) todate=cdate(todate) todate = dateadd("d",-1, todate) end sub ' Sub formatYear If lcase(getconfig("xenvironment"))="chillisoft" then formatyearchilli exit sub end if Year=clng(year) month=1 fromdate= month & "/" & Year Year=Year+1 Todate= month & "/" & Year fromdate=cdate(fromdate) todate=cdate(todate) todate=dateadd("d",-1,todate) end sub ' Sub ValidateDates If not Isdate(fromdate) then serror=getlang("langReportInvalidDate") & fromdate end if If not Isdate(todate) then Serror="
" & getlang("langReportInvalidDate") & todate end if end sub Sub GenerateSQL dim datesql Dim newsql mypage=1 ' first time through Sql="select * from orders where " datesql = " odate>= " & DateDelimit(fromdate) datesql = datesql & " AND odate<= " & datedelimit(todate) 'VP-ASP 6.50 - option to show processed orders only if request("processedonly") = "true" then if (ucase(xdatabasetype)="SQLSERVER") or (getconfig("xmysql")="Yes") OR (instr(ucase(xdatabasetype), "MYSQL") > 0) then datesql = datesql & " AND oprocessed = 1" else datesql = datesql & " AND oprocessed = TRUE " end if end if 'VP-ASP 6.50 - allow filtering by payment type if paymenttype > "" then select case paymenttype case "valid" datesql = datesql & "AND ocardtype IN (" if instr(getconfig("xendofordervalidpayments"), ",") > 0 then dim payments, ii payments = split(getconfig("xendofordervalidpayments"),",") for ii = 0 to ubound(payments) datesql = datesql & "'" & payments(ii) & "'," next datesql = left(datesql, len(datesql) - 1) & ")" else datesql = datesql & "'" & getconfig("xendofordervalidpayments") & "')" end if case "cancel" if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR ucase(xdatabasetype) = "SQLSERVER" then datesql = datesql & " AND ((ocardtype IS NULL) OR (canceled = 1)) " else datesql = datesql & " AND ((ocardtype IS NULL) OR (canceled = TRUE)) " end if case else datesql = datesql & " AND ocardtype = '" & paymenttype & "' " end select end if 'Added for summary reports to make cycling through records easier If Action="SUMMARY" then datesql=datesql & " order by odate" end if sql = sql & datesql newSql= replace (SQL, ".", "/") Sql=NewSql SetSess "Fromdate",fromdate SetSess "todate",Todate if Getconfig("xdebug")="Yes" then debugwrite sql end if end sub ' Sub WriteReport ' Generate table GetMonthnames monthnames OpenOrderDB dbc ShopOpenRecordSet SQL,RS, mypagesize, mypage GenerateDisplayHeader getlang("langreport02") GenerateDisplayBodyHeader response.write "

" & largeInfofont & getlang("langReport01") response.write "" & day(fromdate) & " " & ucase(left(monthname(datepart("m",fromdate)),3)) & " " & datepart("yyyy", fromdate) & "" response.write " to " response.write "" & day(todate) & " " & ucase(left(monthname(datepart("m",todate)),3)) & " " & datepart("yyyy", todate) & "" response.write Largeinfoend & "
" & reportinfofontend 'VP-ASP 6.09 - for print friendly reports response.write "

" if rs.eof then Response.write "
" shopwriteerror getlang("langReportNoSales") response.write "" else If Action="SUMMARY" then ProduceSummary else ProduceDetail end if end if GenerateDisplayBodyFooter end sub ' Sub ProduceSummary 'Based on original summary report and modified 'to calculate monthly reports including 'number of orders and monthly sales total dim nopayment dim monthtotal,monthorders dim curyear,curmonth dim tmpmonth dim bigdate,littledate %><% if datepart("m",fromdate)=datepart("m",todate) and datepart("yyyy",fromdate)=datepart("yyyy",todate) then bigdate="m" littledate="d" displaysummaryheader "Month", "Day" else bigdate="yyyy" littledate="m" displaysummaryheader "Year", "Month" end if %><% count=0 total=0 nopayment=0 Inittotals 'VP-ASP 6.50 - Graphical reports dim colcolor colcolor=0 While Not rs.EOF tmpmonth=datepart(littledate,rs("odate")) curyear=datepart(bigdate,rs("odate")) curmonth=datepart(littledate,rs("odate")) monthtotal=0 monthorders=0 while tmpmonth=curmonth count=count+1 monthorders=monthorders+1 if not isnull(rs("orderamount")) then total=total+rs("orderamount") monthtotal=monthtotal+rs("orderamount") end if AddToTotals rs rs.movenext if Not rs.eof then tmpmonth=datepart(littledate,rs("odate")) else tmpmonth=999 'end loop end if wend 'VP-ASP 6.50 - Graphical reports summaryarray(colcolor) = """" & curyear & """,""" & curmonth & """,""" & monthorders & """,""" & monthtotal & """,""" & colcolor & """" if monthorders > maxorders then maxorders = monthorders end if if monthtotal > maxtotal then maxtotal = monthtotal end if 'displaysummaryrow curyear,curmonth,monthorders,monthtotal,colcolor colcolor = colcolor + 1 wend 'VP-ASP 6.50 - Graphical reports dim summary for each summary in summaryarray if summary > "" then execute("displaysummaryrow " & summary & "," & maxtotal & "," & maxorders) 'response.write "displaysummaryrow " & summary & "
" end if next formattableend rs.close set rs=nothing shopclosedatabase dbc response.write "

" & largeinfofont 'displayshipping varrshipping response.write largeinfoend & "

" displayTotals end sub ' Sub ProduceDetail dim nopayment FormatTableStart limit=clng(mypagesize) While Not rs.EOF and ctgrssal1" & rs("orderid") & "" end if response.write ReportDetailColumn & fieldvalue & ReportDetailColumnEnd next response.write ReportRowEnd end sub ' ' Sub Displayform GenerateDisplayHeader getlang("langreport02") GenerateDisplayBodyHeader Response.write "

" Response.write largeinfofont & getlang("langReport03") & largeinfoend response.write "

" if sError<> "" then response.write "" shopwriteerror sError Serror="" response.write "" end if %> <% GenerateDisplayBodyFooter end sub Sub FormattableStart dim i Fields(0)="ORDERID" Fields(1)="ORDERAMOUNT" Fields(2)="Odate" Fields(3)="ofirstname" Fields(4)="olastname" 'Fields(5)="oaddress" Fields(5)="oCity" Fields(6)="ostate" Fields(7)="ocountry" fieldcount=7 CapFields(0)=getlang("langProductOrderNumber") CapFields(1)=getlang("langProductTotal") CapFields(2)=getlang("langStatusDate") CapFields(3)=getlang("langCustFirstName") CapFields(4)=getlang("langCustLastName") 'CapFields(5)=getlang("langCustAddress") CapFields(5)=getlang("langCustCity") capFields(6)=getlang("langCustState") capFields(7)=getlang("langCustCountry") response.write "" response.write "" for i = 0 to fieldcount response.write "

" & capfields(i) & ReportHeadColumnEnd next response.write ReportRowEnd end sub Sub FormatTableEnd response.write ReportTableEnd end sub sub displaysummaryheader(bigdatename,littledatename) 'VP-ASP 6.50 - Graphical reports response.write "" response.write "" response.write ReportHeadColumn & bigdatename & ReportHeadColumnEnd response.write ReportHeadColumn & littledatename & ReportHeadColumnEnd response.write ReportHeadColumn & "" & ReportHeadColumnEnd 'response.write ReportHeadColumn & bigdatename & ReportHeadColumnEnd 'response.write ReportHeadColumn & littledatename & ReportHeadColumnEnd 'response.write ReportHeadColumn & "Orders" & ReportHeadColumnEnd response.write ReportHeadColumn & "Total" & ReportHeadColumnEnd 'response.write ReportRowEnd end sub 'VP-ASP 6.50 - Graphical reports sub displaysummaryrow(y,m,numorders,monthtotal, colcolor, maxtotal, maxorders) dim monthenum,monthname 'if request("month")<>"0" then if datepart("m",fromdate)=datepart("m",todate) and datepart("yyyy",fromdate)=datepart("yyyy",todate) then monthname=m else monthname=monthnames(m-1) end if 'VP-ASP 6.50 - Graphical reports dim linecounter if colcolor mod 2 = 0 then%> <%else%> <%end if%> <%if colcolor mod 2 = 0 then%> <%else%> <%end if%> <%if colcolor mod 2 = 0 then%> <%else%> <%end if%> <% 'response.write ReportDetailRow 'response.write ReportDetailColumn & y & ReportDetailColumnEnd 'response.write ReportDetailColumn & monthname & ReportDetailColumnEnd 'response.write ReportDetailColumn & numorders & ReportDetailColumnEnd 'response.write ReportDetailColumn & shopformatcurrency(monthtotal,Getconfig("xdecimalpoint")) & ReportDetailColumnEnd 'response.write ReportRowEnd end sub Sub Getmonthnames (monthnames) dim i , name If getconfig("xlcid")<>"" then session.lcid=getconfig("xlcid") end if for i=1 to 12 Monthindex=I name=monthname(monthindex) monthnames(i-1)=name next end sub '******************************************************************** ' Count 1 field in record '******************************************************************** Sub Addtocounters(count, amount, fieldvalue) if fieldvalue<>"" and fieldvalue<>0 then amount=amount+fieldvalue count=count+1 end if end sub '******************************************************************** ' Count 1 field in record '******************************************************************** Sub Addtocountersspecial(count, amount, fieldvalue, quantity) if fieldvalue<>"" and fieldvalue<>0 then amount=amount+fieldvalue count=count+quantity end if end sub Sub Addshippingsummary(shipcost,shippingmethod,arrshipping) dim i i=1 do while ((i"") and (arrshipping(i,cShipName)<>shippingmethod)) 'Find shipping method or empty slot in shipping methods array i=i+1 loop arrshipping(i,cShipName)=shippingmethod arrshipping(i,cShipCost)=arrshipping(i,cShipCost)+shipcost arrshipping(i,cShipCount)=arrshipping(i,cShipCount)+1 end sub Sub DisplayTotals response.write "
" shopwriteheader getlang("LangReport02") WriteReportHeader "", getlang("LangStatusAmount"), getlang("LangAffNumOrders") WriteReportrow "" & getlang("LangProductTax") & "",cttax2, cttax1 WriteReportrow "" & getlang("LangProductHandling") & "",cthdlfee2, cthdlfee1 WriteReportrow "" & getlang("LangAdminShipping") & "",ctshpcst2, ctshpcst1 WriteReportrow "" & getlang("LangProductDiscount") & "",ctdisapl2, ctdisapl1 WriteReportrow "" & getlang("LangGiftBuy") & "",ctgcprch2, ctgcprch1 WriteReportrow "" & getlang("LangGiftRedeem") & "",ctgcrdm2, ctgcrdm1 WriteReportrow "" & getlang("LangAdminPayments") & "",ctproj2, ctproj1 WriteReportrow "" & getlang("LangCouponDiscount") & "",ctcpnrdm2, ctcpnrdm1 WriteReportrow "" & getlang("LangProductCost") & "",ctprdsal2, ctprdsal1 WriteReportrowEmpty "" & "" & "",ctprdsal2, ctprdsal1 WriteReportrow "" & getlang("LangReportTotal") & "",ctgrssal2, ctgrssal1 response.write ReportTableEnd & "" end sub Sub Displayshipping(arrshipping) dim total, counttotal total=0 counttotal=0 dim i i=1 shopwriteheader getlang("LangProductShippingCost") WriteReportHeader "Shipping Method", "Shipping Cost", "Shipping Count" do while arrshipping(i,cShipName)<>"" and i" & getlang("LangProductTotal") & "",total, counttotal response.write ReportTableEnd end sub Sub WriteReportrow (caption, amount, counttotal) If counttotal=0 then exit sub response.write ReportDetailRow response.write "

<%=y%>

<%=monthname%>

<% response.write "

" if clng(numorders) = clng(maxorders) then for linecounter = 0 to numorders if linecounter < 200 then response.write "

" else exit for end if next else howmanytoshow = 100/maxorders howmanytoshow = numorders * howmanytoshow if maxorders > 200 then howmanytoshow = (howmanytoshow/100) * 200 else howmanytoshow = (howmanytoshow/100) * maxorders end if 'response.write howmanytoshow & "
" for linecounter = 0 to howmanytoshow response.write "

" next end if response.write "

" response.write "

" & numorders & " Orders" %>

<% response.write "

" if clng(monthtotal) = clng(maxtotal) then for linecounter = 0 to monthtotal if linecounter < 200 then response.write "

" else exit for end if next else howmanytoshow = 100/maxtotal howmanytoshow = monthtotal * howmanytoshow if maxtotal > 200 then howmanytoshow = (howmanytoshow/100) * 200 else howmanytoshow = (howmanytoshow/100) * maxtotal end if 'response.write howmanytoshow & "
" for linecounter = 0 to howmanytoshow response.write "

" next end if response.write "

" response.write "

" & shopformatcurrency(monthtotal,Getconfig("xdecimalpoint")) & "" %>

" & caption & ReportDetailColumnEnd response.write "

" & ShopFormatCurrency(amount,getconfig("xdecimalpoint")) & ReportDetailColumnEnd response.write "

" & counttotal & ReportDetailColumnEnd response.write ReportRowEnd end sub Sub WriteReportrowEmpty (caption, amount, counttotal) response.write ReportDetailRow response.write ReportDetailColumn & caption & ReportDetailColumnEnd response.write ReportDetailColumn & " " & ReportDetailColumnEnd response.write ReportDetailColumn & " " & ReportDetailColumnEnd response.write ReportRowEnd end sub Sub WriteReportHeader (caption, amount, counttotal) response.write "" response.write "" response.write ReportHeadColumn & caption & ReportHeadColumnEnd response.write ReportHeadColumn & amount & ReportHeadColumnEnd response.write ReportHeadColumn & counttotal & ReportHeadColumnEnd response.write ReportRowEnd end sub ' Sub GetProductSaleDetails (oid) dim i dim oidSql, oidrs, price, quantity oidSql="select * from oitems where orderid=" & oid set oidrs=dbc.execute(oidsql) do while not oidrs.eof quantity=oidrs("numitems") price=oidrs("unitprice") price=price*quantity addToCountersspecial ctprdsal1, ctprdsal2,price, quantity AddSpecialitems oidrs oidrs.movenext loop closerecordset oidrs end sub '****************************************************************************** ' add to totals '*********************************************************************** Sub AddToTotals (rs) ctgrssal1=ctgrssal1+1 ' total orders ctgrssal2=ctgrssal2+rs("orderamount") ' total amount addToCounters cttax1, cttax2,rs("otax") addToCounters ctshpcst1, ctshpcst2,rs("oshipcost") addToCounters cthdlfee1, cthdlfee2,rs("ohandling") addToCounters ctcpnrdm1, ctcpnrdm2,rs("coupondiscount") addToCounters ctdisapl1, ctdisapl2,rs("odiscount") addToCounters ctgcrdm1, ctgcrdm2,rs("giftamountused") if not isnull(rs("oshipmethodtype")) then ' addshippingsummary rs("oshipcost"),rs("oshipmethodtype"),varrshipping end if GetProductSaleDetails rs("orderid") end sub Sub InitTotals ctgrssal1=0 ctgrssal2=0 ctprdsal1=0 ctprdsal2=0 ctshpcst1=0 ctshpcst2=0 cthdlfee1=0 cthdlfee2=0 ctshpcst1=0 ctshpcst2=0 cttax1=0 cttax2=0 ctgcprch1=0 ctgcprch2=0 ctgcrdm1=0 ctgcrdm2=0 ctdisapl1=0 ctdisapl2=0 ctcpnrdm1=0 ctcpnrdm2=0 nopayment=0 ctproj1=0 ctproj2=0 end sub ' Sub addspecialitems (Oidrs) dim catalogid, projectcatalogid, quantity projectcatalogid=clng(getconfig("xprojectcatalogid")) catalogid=oidrs("catalogid") quantity=oidrs("numitems") price=oidrs("unitprice") price=price*quantity 'debugwrite "catalogid=" & catalogid & " gift=" & getconfig("xgiftproductid") if catalogid=projectcatalogid then addToCountersspecial ctproj1, ctproj2,price, quantity end if if catalogid=clng(getconfig("xgiftproductid")) then addToCountersspecial ctgcprch1, ctgcprch2,price, quantity end if end sub %>