<% '************************************************************ ' VP-ASP 6.50 ' mails orders to individual manufacturers/ ' Uses new table suppliers created with createsuppliers.ap ' If manufacturer e-mail address cannot be found or ' supplier field is not filled in for product, the e-mail goes to ' the address above ' myconn is current connection ' If suppliers are in another database, this will now work if use xotherdatabase ' Sept 19, 2004 fix split orders database '************************************************************* dim supplierids(100) ' manufacturers dim suppliercount dim supplierMessages(100) ' which item belongs to manufacturer dim supplierprices(100) dim supplierOrder dim supplierid, prevsupplierid dim supplieremailformat dim mailname, mailaddress Dim Supplierdbc Dim xSupplierinOtherdatabase dim supplierdbcflag ' Sub ShopMailToSuppliers supplierdbcflag=false ' note this is a non standard config option xSupplierinOtherdatabase=Getconfig("Xsupplierinotherdatabase") If xsupplierinotherdatabase="Yes" then EditOpenDatabase supplierdbc, database, "suppliers" supplierdbcflag=true else if getconfig("xorderdb")<>"" then shopopendatabase supplierdbc supplierdbcflag=true end if end if dim i, Message, mailtemplate GetListofsuppliers ' get all manufactuers If getconfig("xdebug")="Yes" then Debugwrite "count of manufacturers=" & suppliercount end if for i = 1 to suppliercount supplierid=supplierids(i) GetsupplierAddress supplierid,mailname,mailaddress, mailtemplate FormatMailMessage supplierMessages(i), Message, supplierprices(i), mailtemplate if getconfig("xdebug")="Yes" then debugwrite "mailing to " & mailname & " at " & mailaddress & " amount=" & formatcurrency(supplierprices(i),2) debugwrite message end if mailPerson mailname, mailaddress, getconfig("xemailname"), getconfig("xemail"), getconfig("xemailsubject"), Message,"No" ' debugwrite message next If supplierdbcflag=True then shopclosedatabase supplierdbc end if end sub Sub GetSupplierAddress (supplierid, mailname, mailaddress, mailtemplate) dim strSql, supplierRS mailaddress=getconfig("xemail") mailname=getconfig("xemailname") mailtemplate=Getconfig("xsupplieremail") if isnull(supplierid) then exit sub end if strsql = "select * from suppliers where supplierid=" & supplierid If supplierdbcflag=True Then Set supplierRS = supplierdbc.Execute(strSQL) ' get the record st for order and order items else Set supplierRS = myconn.Execute(strSQL) ' get the record st for order and order items end if If not supplierRs.eof then mailaddress=supplierrs("email") mailname=supplierrs("name") mailtemplate=supplierrs("template") if isnull(mailtemplate) then mailtemplate=getconfig("xsupplieremail") end if end if supplierrs.close set supplierrs=nothing ' in shopmailformattemplate SetupEmailformat mailtemplate,Supplieremailformat setsess "emailformat",ucase(supplieremailformat) end Sub Sub GetListofsuppliers '***************************************** ' store manufacture names and their products '******************************************* dim strsql, prodid, supplier dim rsitem, supplieritems oid=getsess("oid") if oid="" then oid=request("oid") 'VP-ASP 6.09 - security fix if not isnumeric(oid) then shoperror "Order ID must be numeric" end if end if prevsupplierid="" strsql = "select * from oitems " strsql=strsql & " where orderid=" & oid & " order by supplierid" Set supplierItems = myconn.Execute(strSQL) ' now we have items in order and products table Do While Not supplieritems.EOF supplier=SupplierItems("supplierid") If isNull(supplierid) then supplierid=0 end if Formatsupplier supplier, supplierItems supplierItems.MoveNext Loop supplieritems.close set supplieritems=nothing End sub Sub Formatsupplier (supplierid, rsitems) dim i dim found found=false dim body Dim CR CR="
" LocateSupplier supplierid dim price, quantity price=rsitems("unitprice") quantity=rsitems("numitems") price=price*quantity body = body & rsitems("itemname") &CR body = body & getlang("langproductquantity") & ": " & rsitems("numitems") & cr body = body & getlang("langproductprice") & ": " & shopformatcurrency(rsitems("unitprice"),getconfig("xdecimalpoint")) & cr & cr suppliermessages(suppliercount)=suppliermessages(suppliercount) & body supplierprices(suppliercount)=supplierprices(suppliercount)+price 'debugwrite "supplier=" & supplierid & "
" & suppliermessages(suppliercount) end sub Sub LocateSupplier (supplierid) dim found, i, ucsupplier If supplierid=Prevsupplierid then exit sub PrevSupplierid=supplierid suppliercount=suppliercount+1 supplierids(suppliercount)=supplierid end sub Sub FormatMailMessage (supplierMessages, body, price,filename) '*************** Formats mail to Merchant and Customer ' Total rewrite for version 2.40 ' Fix formatting add discount June 3 '****************************************************************** dim textarray(500), textcount,CR,i CR=GetMailCR ShopTemplateArray Filename, rsOrder, TextArray, TextCount Merchant="" for i = 0 to Textcount-1 If supplieremailformat="HTML" then Merchant= Merchant & TextArray(i) else Merchant= Merchant & TextArray(i) & CR end if next If Supplieremailformat="HTML" then CR="
" end if Merchant=Merchant & CR & getlang("LangMailProducts") & CR & CR Body=Merchant & supplierMessages Body=Body & CR & getlang("LangProducttotal") & " " & shopformatcurrency(price,getconfig("xdecimalpoint")) & CR If Supplieremailformat<>"HTML" then body=Removehtml(body, CR) end if end sub %>