<%option explicit%> <% dim my_to, my_toaddress,my_system,my_from,my_fromaddress,my_subject,mailtype dim mailer, my_attachment dim customeradmin '********************************************************** ' adds Review to Ratings table ' Version 6.50 Add review authorize ' March 26, 2004 '********************************************************* Dim sAction, dbtable,catalogid, dbc Dim Ratingstars, ratingtitle, ratingcomment, ratinglocation, ratingname, ratingemail dim ratings(10),ratingvalues(10),ratingcount dim body Dim productname sAction=Request("Action") if sAction="" then sAction=Request("Action.x") end if If getconfig("xallowRatingProducts")<>"Yes" then shoperror getlang("LangCustNotAllowed") end if dbtable="reviews" Serror="" catalogid=request("id") If catalogid="" then shoperror getlang("LangNoCatalogId") end if If not isnumeric(catalogid) then shoperror getlang("LangNoCatalogId") end if If sAction = "" Then ShopPageHeader DisplayForm ShopPageTrailer Else ValidateData() if sError = "" Then UpdateRating WriteInfo else ShopPageHeader DisplayForm ShopPageTrailer end if end if ShopClosedatabase dbc Sub DisplayForm() GetProductDetails Dim url if getconfig("xbreadcrumbs") = "Yes" then if ucase(getconfig("xCrossLinkurl"))="SHOPEXD.ASP" then url= xMYSITE & "shopexd.asp?id=" & catalogid else url= xMYSITE & "shopquery.asp?catalogid=" & catalogid end if response.write "" end if Response.Write "

" & getlang("LangRatingPrompt") & "

" Displayerrors SetRatingStars Response.Write("

") Response.Write "

" Response.Write(TableDef) Response.Write(tableRow & "" & getlang("LangRatingYourRating") & "" & "") GenerateSelectV ratings,ratingvalues,ratingstars,"ratingstars",ratingcount, "" Response.write "" CreateCustRow getlang("LangRatingTitle"), "ratingtitle", ratingtitle,"No" Response.Write(tableRow & "" & getlang("LangMenuComment") & "" & "") response.write "" Response.write "" & "" CreateCustRow getlang("LangRatingLocation"),"ratinglocation", ratinglocation,"No" CreateCustRow getlang("LangCustFirstname"), "ratingname", ratingname,"No" CreateCustRow getlang("LangCustEmail"), "ratingemail", ratingemail,"No" 'VP-ASP 6.50 - add a random string to email form to stop bots spamming it if getconfig("xprotectemailforms") = "Yes" then CreateCAPTCHA end if Response.Write(TableDefend) Response.Write "

" Response.Write "

" If Getconfig("xbuttoncontinue")="" then Response.Write("") else Response.Write("") end if Response.Write "

" Response.write "" addwebsessform response.write "

" End Sub Sub ValidateData 'VP-ASP 6.50 - precautionary security fix RatingStars = cleanchars(Request.Form("RatingStars")) RatingTitle = cleanchars(Request.Form("RatingTitle")) RatingComment = cleanchars(Request.Form("RatingComment")) RatingLocation = cleanchars(Request.Form("RatingLocation")) RatingName = cleanchars(Request.Form("RatingName")) RatingEmail = cleanchars(Request.Form("Ratingemail")) If RatingTitle = "" Then sError = sError & getlang("LangRatingTitle") &getlang("Langcustrequired")& "
" End If If RatingComment = "" Then sError = sError & getlang("LangMenucomment") & getlang("Langcustrequired")& "
" End If If RatingLocation = "" Then sError = sError & getlang("LangCustAddress") &getlang("Langcustrequired")& "
" End If If RatingName = "" Then sError = sError & getlang("LangYourName") &getlang("Langcustrequired")& "
" End If 'VP-ASP 6.50 - add a random string to email form to stop bots spamming it if getconfig("xprotectemailforms") = "Yes" then %><% If blnCAPTCHAcodeCorrect Then 'Fine Else sError = sError & getlang("langcaptchawrong") & "
" End If End if 'VP-ASP 6.50 - validate email address If Not InStr(RatingEmail, "@") > 1 Then Serror=Serror & getlang("langInvalidEmail") & "
" end if End Sub Sub WriteInfo If Getconfig("xratingauthorize")="Yes" then Responseredirect "shopreviewlist.asp?id=" & catalogid & "&msg=Yes" else Responseredirect "shopreviewlist.asp?id=" & catalogid end if End Sub Sub DisplayErrors if sError<> "" then shopwriteError SError Serror="" end if end Sub Sub UpdateRating shopopendatabase dbc '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 mysqlupdaterating shopclosedatabase dbc exit sub end if dim whereok dim doupdate, templastname Set objRS = Server.CreateObject("ADODB.Recordset") objRS.open dbtable, dbc, adOpenKeyset, adLockOptimistic, adCmdTable objRS.AddNew objRS("catalogid") = catalogid objRS("rating") = ratingstars objRS("title") = ratingtitle objRS("comment") = ratingcomment objRS("location") = ratinglocation objRS("name") = ratingname objrs("reviewdate")=date() 'VP-ASP 6.09 - added formatdatetime objrs("reviewtime")=formatdatetime(time(), vbshorttime) If getconfig("xratingauthorize")<>"Yes" then objrs("authorized")= getlang("LangcommonYes") end if If ratingemail<>"" then objRS("email") = ratingemail end if objRS.Update SendMailToMerchant objRS objRS.close ' version 2.4 set objrs=nothing shopclosedatabase dbc end sub ' Sub UpdateCustFieldXxx (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 ValidateEmail If Not InStr(strEmail, "@") > 1 Then Serror=Serror & getlang("LangInvalidEmail") & "
" end if End sub Sub SendMailToMerchant (objrs) dim emailformat, acount If getconfig("XRatingMailtoMerchant")<>"Yes" then exit sub FormatOtherMail getconfig("xRatingTemplate"), objRS, Body Setupemailformat getconfig("xRatingTemplate"), emailformat mailtype=getconfig("xemailtype") my_from=Ratingname If ratingemail="" then my_fromaddress=getconfig("xemail") else my_fromaddress=ratingemail end if my_toaddress=getconfig("xemail") my_to=getconfig("xemailname") my_system=getconfig("xemailsystem") my_subject= getlang("LangRatingPrompt") acount=0 ExecuteMail mailtype,My_from,my_fromaddress,my_to,my_toaddress,my_subject,body,emailformat,my_attachment,acount end sub Sub SetRatingStars dim i,j ratingcount=0 j=0 for i = 5 to 1 step -1 ratings(j)= i If i=5 Then ratings(j)=ratings(j) & " (" & getlang("LangRatingBest") & ")" ratingstars=ratings(j) end if if i=1 then ratings(j)=ratings(j) & " (" & getlang("LangRatingWorst") & ")" end if ratingvalues(j)=I ratingcount=ratingcount+1 j=j+1 next Ratings(j)="No Rating" ratingcount=ratingcount+1 ratingvalues(j)=0 end sub Sub GetProductDetails dim conn shopopendatabaseP conn dim rs, psql psql="select * from products where catalogid=" & catalogid set rs=conn.execute(psql) if not rs.eof then productname=rs("cname") productname=translatelanguage(conn, "products", "cname","catalogid", catalogid, productname) end if rs.close set rs=nothing shopclosedatabase conn end sub 'VP-ASP 6.50 - add a random string to email form to stop bots spamming it Sub CreateCAPTCHA if getconfig("xprotectemailforms") <> "Yes" then exit sub Response.write tablerow & tablecolumn Response.write "*" & getlang("langcaptchaenter") & TablecolumnEnd Response.write tablecolumn getCAPTCHA Response.write tablecolumnend & tableRowend End Sub %>