<%option explicit%>
[an error occurred while processing this directive]
<%
'*******************************************************
' VP-ASP 5.00 Gift subroutines
' May 30, 2003
' Sept 26 2003 fix case
'*******************************************************
Dim lngGiftid
Dim datGiftissuedate
Dim datGiftexpirydate
Dim curGiftamount
Dim strGifttoname
Dim strGiftfromname
Dim strGifttoemail
Dim strGiftfromemail
Dim strGiftmessage
Dim strGiftother
Dim datGiftused
Dim lngGiftusedcustomerid
Dim lngGiftusedorder
Dim strGiftauthorized
dim curGiftAmountremaining
dim stremails, Giftcount
Dim Giftnums(50),giftarray(50)
'*********************************************************************
' add Gift records to database for a specific order
' VP-ASP 5.00
' Feb 4, 2003
'*******************************************************************
sub GiftAddToDatabase
dim i
Shopopendatabase dbc
oid=Getsess("oid")
GenerateGiftNumbers
For i = 0 to giftcount-1
AddGiftRecord giftnums(i), giftarray(i), i
next
shopclosedatabase dbc
OpenOrderDb dbc
UpdateOrderDatabase
ShopCloseDatabase dbc
end sub
'
Sub AddGiftRecord (certificate, email, i )
if getconfig("xMYSQL")="Yes" then
MYSQLAddGiftRecord certificate, email, i
exit sub
end if
Dim giftexpires, today
Dim DoUpdate
DoUpdate=""
today=date()
giftexpires=dateadd("d",date(),getconfig("xgiftexpirydays"))
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.open "Gifts", dbc, adOpenKeyset, adLockOptimistic, adCmdTable
objRS.AddNew
updategiftfield "giftnumber", certificate
updategiftfield "giftissuedate", date()
updategiftfield "giftexpirydate", giftexpires
updategiftfield "giftamount", getsess("giftamount")
if i = 0 then
updategiftfield "gifttoname", getsess("gifttoname")
else
updategiftfield "gifttoname", email
end if
updategiftfield "giftfromname", getsess("giftfromname")
updategiftfield "gifttoemail", email
updategiftfield "giftfromemail", getsess("giftfromemail")
updategiftfield "giftmessage", getsess("giftmessage")
updategiftfield "giftorderid", getsess("oid")
updategiftfield "giftcustomerid", getsess("customerid")
updategiftfield "giftamountremaining", getsess("giftamount")
objRS.Update
objRS.close
set objrs=nothing
SetSess "GiftId",oid
end sub
'
Sub UpdateGiftField (fieldname,fieldvalue)
on error resume next
if fieldvalue="" then
exit sub
end if
If getconfig("xdebug")="Yes" then
Debugwrite fieldname & " " & fieldvalue & " "
end if
objRS(fieldname)=fieldvalue
end Sub
Sub UpdateOrderDatabase
if getconfig("xMYSQL")="Yes" then
MYSQLUpdateOrderDatabase
exit sub
end if
dim i
Dim strSQl, nameincart
NameinCart= getlang("LangGiftCertificate")
for i = 0 to Giftcount
nameincart=nameincart & " " & Giftnums(i)
next
strSQL = "select * FROM oitems where orderid = " & Getsess("oid")
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.open strsql, dbc, adOpenKeyset, adLockOptimistic, adCmdText
If Not objrs.eof then
objrs("itemname")=NameinCart
objrs("numitems")=Giftcount
end if
objrs.update
objrs.close
set objrs=nothing
end sub
Sub GenerateGiftNumbers
dim prefix, hh,mm,ss,oid, giftnum, stremails, mytime
prefix=getconfig("xGiftPrefix")
oid=Getsess("Oid")
mytime=now()
hh=hour(mytime)
mm=hour(mytime)
ss=Second(mytime)
Giftcount=1
Giftnum=prefix &"-" & hh &mm &ss & "0" & "-" & Oid
Giftnums(0)=Giftnum
Giftarray(0)=Getsess("GifttoEmail")
stremails=getsess("Giftotheremails")
if strEmails="" then
exit sub
end if
dim words(20),wordcount, delimiter,i
delimiter=","
ParseRecord stremails,words,wordcount,delimiter
For i = 0 to wordcount-1
Giftnum=prefix &"-" & hh &mm &ss & Giftcount &"-" & Oid
Giftnums(giftcount)=Giftnum
Giftarray(giftcount)=words(i)
giftcount=giftcount+1
next
end sub
'**********************************************************************
' Delete Gift records
'**********************************************************************
Sub GiftDeleteCertificates
dim oid, dbc
Shopopendatabase dbc
oid=Getsess("oid")
if oid="" then exit sub
dbc.execute "delete from gifts where giftorderid = " & clng(getsess("oid"))
shopclosedatabase dbc
end sub
Sub GiftAddToCart
dim strdualprice
dim Price, arrcart,scartitem, count, totalprice, nameincart
Price=Getsess("Giftamount")
Count=Getsess("Giftcount")
NameinCart= getlang("LangGiftCertificate")
arrCart = GetSessA("CartArray")
scartitem=1
SetSess "CartCount",scartitem
arrCart(cProductid,scartItem) = getconfig("xGiftProductId")
arrCart(cProductCode,scartItem) = 1
arrCart(cProductname,scartItem) = NameInCart
arrCart(cQuantity,scartItem) = giftcount
arrCart(cOriginalPrice,scartItem) = Price
arrCart(cUnitPrice,scartItem) = Price
if getconfig("XdualPrice")="Yes" then
Convertcurrency Price, strDualPrice
arrCart(cDualPrice,scartItem) = strDualprice
else
arrCart(cDualPrice,scartItem) = 0
end if
arrCart(cDelivery,scartItem) = ""
SetSessA "CartArray",arrCart
TotalPrice=Price*count
SetSess "Ordertotal",totalprice
SetSess "OrderProducttotal",totalprice
end sub
'************************************************************
' mail to all gift holders for this order
' database is assumed opened with dbc=open database
'************************************************************
Sub ShopGiftMail (orderid)
Dim oid, giftsql, giftmessage, gifts(50), i, giftcount
dim template,giftid, giftrs, myconn
dim attachyesno
attachyesno="No"
Shopopendatabase myconn
template=getconfig("xgifttemplate")
if template="" then exit sub
Oid=orderid
giftcount=0
giftsql="select * from gifts where giftorderid=" & oid
set giftrs=myconn.execute(Giftsql)
do while not giftrs.eof
FormatOtherMail template, giftrs, GiftMessage
strgifttoname = giftrs("gifttoname")
strgiftfromname = giftrs("giftfromname")
strgifttoemail = giftrs("gifttoemail")
strgiftfromemail = giftrs("giftfromemail")
mailPerson strGiftToname, strgifttoemail, strgiftfromname, strgiftfromemail, getlang("LangGiftCertificate"), GiftMessage,attachyesno
'Debugwrite strGifttoname & " " & Giftmessage
If getconfig("xdebug")="Yes" then
Debugwrite "Gift certificate send to " & strGifttoemail & " from " & strgiftfromemail
end if
gifts(giftcount)=giftrs("giftid") ' save for autoenable
giftcount=giftcount+1
giftrs.movenext
loop
giftrs.close
set giftrs=nothing
If getconfig("xGiftAutoEnable")="Yes" Then
for i = 0 to giftcount-1
giftsql="update gifts set giftauthorized = 'Yes' where giftid="
giftsql=giftsql & Gifts(i)
myconn.execute(giftsql)
next
end if
shopclosedatabase myconn
end sub
Sub GiftDecrementAmountUsed(certificate,amountused, msg)
'************************************************************************
' Update gift certificate amount tto reflect amount used
' Giftused=certificate
' Giftusedamount=amount used"
'************************************************************************
if getconfig("xmysql")="Yes" then
MYSQLGiftDecrementAmountUsed certificate,amountused, msg
exit sub
end if
Dim myconn, customerid
dim strSql
msg=""
dim giftnumber, giftusedamount, amount, giftusedtrace, giftusedcount
Dim orderid, giftrace
Giftnumber=certificate
GiftUsedamount=amountused
customerid=getsess("Customerid")
orderid=getsess("oid")
Shopopendatabase myconn
'debugwrite "updating " & certificate & " " & amountused
strSQL = "select * FROM gifts where giftnumber='" & Giftnumber & "'"
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.open strsql, myconn, adOpenKeyset, adLockOptimistic, adCmdText
If Not objrs.eof then
amount=objrs("giftamountremaining")
giftrace=objrs("giftusedtrace")
giftusedcount=objrs("giftusedcount")
If amount>= amountused then
amount=amount-GiftUsedamount
objrs("giftamountremaining")=amount
objrs("giftusedlastamount")=giftusedamount
objrs("giftuseddate")=date()
objrs("giftusedcustomerid")=customerid
objrs("giftusedorderid")=orderid
giftusedcount=giftusedcount+1
objrs("GiftUsedcount")=giftusedcount
If isnull(giftrace) then
Giftrace=""
else
Giftrace=giftrace & ";"
end if
Giftrace=Giftrace & orderid & "," & giftusedamount
objrs("giftusedtrace")=giftrace
objrs.update
else
msg= getlang("LangGiftPartlyUsed")
msg=msg & " " & shopformatcurrency(amount,getconfig("xdecimalpoint"))
end if
else
msg= getlang("LangGiftNotFound")
end if
objrs.close
set objrs=nothing
Shopclosedatabase myconn
End sub
Sub GiftRestoreAmountUsed(certificate,amountused)
'************************************************************************
' Update gift certificate amount tto reflect amount used
' Giftused=certificate
' Giftusedamount=amount used"
'************************************************************************
if getconfig("xMYSQL")="Yes" then
MYSQLGiftRestoreAmountUsed certificate,amountused
exit sub
end if
dim myconn
dim strSql
dim giftnumber, giftusedamount, amount
Giftnumber=certificate
GiftUsedamount=amountused
Shopopendatabase myconn
strSQL = "select * FROM gifts where giftnumber='" & Giftnumber & "'"
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.open strsql, myconn, adOpenKeyset, adLockOptimistic, adCmdText
If Not objrs.eof then
amount=objrs("GiftAmountRemaining")
amount=amount+GiftUsedamount
objrs("giftamountremaining")=amount
objrs("giftusedlastamount")=giftusedamount
objrs("giftuseddate")=date()
objrs.update
end if
objrs.close
set objrs=nothing
Shopclosedatabase myconn
End sub
Sub ShopValidateGiftCertificate (gift,msg)
dim objrs, strsql, normexpiry, normtoday
dim today, dbc
Shopopendatabase dbc
strSQL = "select * FROM gifts where giftnumber='" & replace(Gift,"'","") & "'"
set objrs=dbc.execute(strsql)
if objrs.eof then
msg= getlang("LangGiftNotFound") &" "
else
strGiftauthorized=objrs("giftauthorized")
datgiftexpirydate=objrs("giftexpirydate")
curGiftAmountRemaining=objrs("giftamountremaining")
end if
objrs.close
set objrs=nothing
shopclosedatabase dbc
if msg<>"" then exit sub
If isnull(strGiftAuthorized) then
msg= getlang("LangGiftNotAuthorized") & " "
exit sub
end if
normexpiry=Datedelimit(datgiftexpirydate)
normtoday=Datedelimit(date())
If normtoday>normexpiry then
msg= getlang("LangGiftExpired") & " "
end if
If CurGiftamountremaining<=0 then
msg= getlang("LangGiftUsed")
exit sub
end if
SetSess "giftamountmax",curgiftamountremaining
SetSess "giftcertificate",gift
end sub
%>
<%
Sub ConvertCurrency (iamount, oamount)
' VP-ASP 5.0 Feb 4, 2003
'
' Convert currency
dim ydualconversionrate
ydualconversionrate=getconfig("xdualconversionrate")
if not isnumeric(ydualconversionrate) then
exit sub
end if
if ydualconversionrate<>"" then
ydualconversionrate=cdbl(ydualconversionrate)
oamount=iamount*ydualconversionrate
else
oamount=iamount
end if
end sub
%>
<%
dim sAction
'*******************************************************************
' Prompt customer for gift details and add to cart
' VP-ASP 5.00
' Jan 2, 2003
'********************************************************************
if getconfig("xGiftCertificates")<>"Yes" then
shoperror getlang("LangCustNotAllowed")
end if
Shopinit
GiftCount=0
sAction=Request("Action")
if sAction="" then
sAction=Request("Action.x")
end if
If sAction = "" Then
ShopPageHeader
DisplayForm
ShopPageTrailer
Else
ValidateData()
if sError = "" Then
UpdateGift
Response.redirect "shopgift2.asp"
else
ShopPageHeader
DisplayForm
ShopPageTrailer
end if
end if
Sub DisplayForm()
Displayerrors
shopwriteheader getlang("LangGiftEasy")
Response.Write(""
end sub
'
Sub AddTo
shopwriteheader getlang("LangGiftWho")
Response.Write(TableDef)
CreateCustRow "To Name(optional) ", "strgifttoname", strgifttoname,""
CreateCustRow "Email ", "strgifttoemail", strgifttoemail,"Yes"
Response.write tabledefend & " "
end sub
Sub AddFrom
shopwriteheader getlang("LangGiftFrom")
Response.Write(TableDef)
CreateCustRow "From Name (optional) ", "strgiftfromname", strgiftfromname,""
CreateCustRow "Email ", "strgiftfromemail", strgiftfromemail,"Yes"
Response.write tabledefend & " "
end sub
Sub AddAmount
dim caption, fieldname,fieldvalue
caption="Amount"
fieldname="CurGiftamount"
Fieldvalue=curgiftamount
shopwriteheader getlang("LangGiftToAmount")
Response.Write(TableDef)
response.write tablerow & tablecolumn &Caption & tablecolumnend & tablecolumn
%>
<%
response.write tablecolumnend & tablerowend
Response.write ""
end sub
Sub AddMessage
shopwriteheader getlang("LangGiftMessage")
Response.write ""
end sub
Sub AddAddresses
shopwriteheader getlang("LangGiftEmailPrompt")
Response.write ""
end sub
Sub ValidateData
curGiftamount = Request.Form("curGiftamount")
strGifttoname = Request.Form("strGifttoname")
strGifttoemail = Request.Form("strGifttoemail")
strGiftfromname = Request.Form("strGiftfromname")
strGiftfromemail = Request.Form("strGiftfromemail")
strGiftmessage = Request.Form("strGiftmessage")
stremails=request("stremails")
If curGiftamount = "" Then
sError = sError & getlang("LangGiftTOAmount") & " "
Else
ValidateAmount
end if
If strGifttoemail = "" Then
sError = sError & getlang("LangGiftToemail") & " "
Else
validateemail strGifttoemail
End If
If strGiftfromemail = "" Then
sError = sError & getlang("LangGiftFromEmail") & " "
Else
validateemail strGiftfromemail
End If
If stremails <>"" Then
validateemails
End If
If len(strGiftmessage)> 255 Then
sError = sError & getlang("LangGiftMessageLimit") & len(strgiftMessage) & " "
End If
end sub
Sub WriteInfo
ShoppageHeader
If getsess("customeradmin")="" then
shopwriteheader getlang("LangMailListinfomsg")
else
shopwriteheader getlang("LangEdit03")
end if
ShopPageTrailer
End Sub
Sub DisplayErrors
if sError<> "" then
response.write errorfontstart & SError & errorfontend & " "
Serror=""
end if
end Sub
Sub ValidateAmount
Dim Numamount
dim numLimit
If not isnumeric(curGiftamount) then
Serror=Serror & getlang("LangUserPriceError") & " " & curgiftamount &" "
exit sub
end if
If curgiftamount<0 then
curgiftamount=abs(curgiftamount)
end if
If getconfig("Xgiftlimit")<> "" then
numamount=csng(curGiftamount)
numLimit=csng(getconfig("xgiftlimit"))
If Numamount>numlimit then
Serror=Serror & getlang("LangGiftLimit") & " " & getconfig("xgiftlimit") &" "
end if
end if
end sub
Sub UpdateGift
dim orderamount
GiftCount=GiftCount+1
SetSess "Giftamount", curGiftamount
If strGiftToname="" then
strGiftToName= getlang("LangGiftUnknown")
end if
SetSess "Gifttoname", strGifttoname
If strGiftFromname="" then
strGiftFromName= getlang("LangGiftunknown")
end if
SetSess "Giftfromname", strGiftfromname
SetSess "Gifttoemail", strGiftToemail
SetSess "Giftfromemail", strGiftfromemail
SetSess "Giftmessage", strGiftmessage
SetSess "GiftOtheremails",stremails
SetSess "GiftCount",GiftCount
Orderamount=curgiftamount
orderamount=Orderamount*giftcount
SetSess "Ordertotal",orderamount
SetSess "OrderProducttotal",orderamount
GiftAddToCart ' in shopgiftdb.asp
end sub
Sub ValidateEmails
dim words(20),wordcount, delimiter,i
delimiter=","
ParseRecord stremails,words,wordcount,delimiter
For i = 0 to wordcount-1
validateemail words(i)
next
GiftCount=GiftCount+WordCount
end sub
Sub ValidateEmail (stremail)
If Not InStr(strEmail, "@") > 1 Then
Serror=Serror & getlang("LangInvalidEmail") & " " & stremail & " "
end if
End sub
%>