<%option explicit%> <% const MailListKey="Registration" const MailUnsubscribekey="Remove" '******************************************************************** ' Used to authorize joining mailling list ' comes back with a key provided by us ' VP-ASP 6.50 ' Mar 10, 2003 '********************************************************************* Dim infomsg, authkey, rc Shoppageheader If getconfig("xmaillistauthorize")<>"Yes" Then Shoperror getlang("LangCustNotAllowed") end if authkey=Request.querystring("authcode") cleansemessage authkey,rc if rc> 0 then authkey="" end if If authkey="" then adderror getlang("LangAdminPasswordMissing") & "
" end if If Serror="" then updatemaillist end if If Serror<>"" then Displayerrors else Writeinfo end if shoppagetrailer Sub WriteInfo shopwriteheader infomsg End Sub ' Sub DisplayErrors if sError<> "" then shopwriteerror SError Serror="" end if end Sub '******************************************************************** ' relocates customer record and updates it '******************************************************************** sub updatemaillist dim dbc, whereok dim doupdate, templastname dim dbtable, tsql dbtable=getconfig("xmaillisttable") OpenCustomerDb dbc templastname=replace(authkey,"'","") SQL = "SELECT * FROM " & dbtable & " WHERE " whereok="" SQL = SQL & whereok & " contactreason='" & templastname & "'" Set objrs=dbc.execute(sql) If objrs.eof then adderror getlang("LangRecordNotFound") closerecordset objrs shopclosedatabase dbc exit sub end if if left(authkey,1)="a" then tsql="set maillist=1,contactreason='" & maillistkey & "'" Infomsg= getlang("LangMaillistinfomsg") & "
" else tsql="set maillist=0,contactreason='" & MailUnsubscribekey & " " & date & "'" infomsg= getlang("LangmaillistRemoved") & "
" end if SQL = "update " & dbtable & " " & tsql SQL = SQL & " where contactreason='" & templastname & "'" dbc.execute(sql) shopclosedatabase dbc end sub Sub adderror (msg) serror=serror & msg & "
" end sub %>