<%
'This code is copyright (c) Internet Business Solutions SL, all rights reserved.
'The contents of this file are protect under law as the intellectual property
'of Internet Business Solutions SL. Any use, reproduction, disclosure or copying
'of any kind without the express and written permission of Internet Business
'Solutions SL is forbidden.
'Author: Vince Reid, vince@virtualred.net
Dim gasaReferer,gasaThisSite,datedelim
Dim splitUSZones,countryCurrency,useEuro,storeurl,stockManage,delAfter,handling,adminCanPostUser,packtogether,origZip,shipType,saveLCID,delccafter,adminTweaks,currRate1,currSymbol1,currRate2,currSymbol2,currRate3,currSymbol3,upsUser,upsPw
Dim origCountry,origCountryCode,uspsUser,uspsPw,upsAccess,adminUnits,adminlanguages,adminlangsettings,useStockManagement,adminProdsPerPage,countryTax,currLastUpdate,currConvUser,currConvPw,emailAddr,sendEmail,emailObject,themailhost,theuser,thepass
incfunctionsdefined=true
function ip2long(ip2lip)
ipret = -1
iparr = split(ip2lip, ".")
if isarray(iparr) then
if UBOUND(iparr)=3 then
if isnumeric(iparr(0)) AND isnumeric(iparr(1)) AND isnumeric(iparr(2)) AND isnumeric(iparr(3)) then
ipret = (iparr(0) * 16777216) + (iparr(1) * 65536) + (iparr(2) * 256) + (iparr(3))
end if
end if
end if
ip2long = ipret
end function
if Trim(request.querystring("PARTNER"))<>"" OR Trim(request.querystring("REFERER"))<>"" then
if expireaffiliate = "" then expireaffiliate=30
if Trim(request.querystring("PARTNER"))<>"" then thereferer=Trim(request.querystring("PARTNER")) else thereferer=Trim(request.querystring("REFERER"))
response.write ""
end if
if mysqlserver=true then sqlserver=true
if sqlserver=true then datedelim = "'" else datedelim = "#"
codestr="2952710692840328509902143349209039553396765"
if emailencoding="" then emailencoding="iso-8859-1"
if adminencoding="" then adminencoding="iso-8859-1"
if Session("languageid") <> "" then languageid=Session("languageid")
function getadminsettings()
if NOT alreadygotadmin then
if saveadmininapplication AND Application("getadminsettings")<>"" then
splitUSZones = Application("splitUSZones")
saveLCID = Application("saveLCID")
Session.LCID = saveLCID
countryCurrency = Application("countryCurrency")
useEuro = Application("useEuro")
storeurl = Application("storeurl")
stockManage = Application("adminStockManage")
useStockManagement = Application("useStockManagement")
adminProdsPerPage = Application("adminProdsPerPage")
countryTax = Application("countryTax")
delAfter = Application("delAfter")
delccafter = Application("delccafter")
handling = Application("handling")
adminCanPostUser = Application("adminCanPostUser")
packtogether = Application("packtogether")
origZip = Application("origZip")
shipType = Application("shipType")
origCountry = Application("origCountry")
origCountryCode = Application("origCountryCode")
uspsUser = Application("uspsUser")
uspsPw = Application("uspsPw")
upsUser = Application("upsUser")
upsPw = Application("upsPw")
upsAccess = Application("upsAccess")
adminUnits = Application("adminUnits")
emailObject = Application("emailObject")
themailhost = Application("themailhost")
theuser = Application("theuser")
thepass = Application("thepass")
emailAddr = Application("emailAddr")
sendEmail = Application("sendEmail")
adminTweaks = Application("adminTweaks")
adminlanguages = Application("adminlanguages")
adminlangsettings = Application("adminlangsettings")
currRate1 = Application("currRate1")
currSymbol1 = Application("currSymbol1")
currRate2 = Application("currRate2")
currSymbol2 = Application("currSymbol2")
currRate3 = Application("currRate3")
currSymbol3 = Application("currSymbol3")
currConvUser = Application("currConvUser")
currConvPw = Application("currConvPw")
currLastUpdate = Application("currLastUpdate")
else
sSQL = "SELECT adminEmail,emailObject,smtpserver,emailUser,emailPass,adminEmailConfirm,adminTweaks,adminProdsPerPage,adminStoreURL,adminHandling,adminPacking,adminDelUncompleted,adminDelCC,adminUSZones,adminStockManage,adminShipping,adminCanPostUser,adminZipCode,adminUnits,adminUSPSUser,adminUSPSpw,adminUPSUser,adminUPSpw,adminUPSAccess,adminlanguages,adminlangsettings,currRate1,currSymbol1,currRate2,currSymbol2,currRate3,currSymbol3,currConvUser,currConvPw,currLastUpdate,countryLCID,countryCurrency,countryName,countryCode,countryTax FROM admin INNER JOIN countries ON admin.adminCountry=countries.countryID WHERE adminID=1"
rs.Open sSQL,cnn,0,1
splitUSZones = (Int(rs("adminUSZones"))=1)
if orlocale<>"" then
Session.LCID = orlocale
elseif rs("countryLCID")<>0 then
Session.LCID = rs("countryLCID")
end if
saveLCID = Session.LCID
countryCurrency = rs("countryCurrency")
if orcurrencyisosymbol<>"" then countryCurrency=orcurrencyisosymbol
useEuro = (countryCurrency="EUR")
storeurl = rs("adminStoreURL")
stockManage = rs("adminStockManage")
useStockManagement = (rs("adminStockManage")<>0)
adminProdsPerPage = rs("adminProdsPerPage")
countryTax=cDbl(rs("countryTax"))
delAfter = Int(rs("adminDelUncompleted"))
delccafter = Int(rs("adminDelCC"))
handling = cDbl(rs("adminHandling"))
adminCanPostUser = trim(rs("adminCanPostUser"))
packtogether = Int(rs("adminPacking"))=1
origZip = rs("adminZipCode")
shipType = Int(rs("adminShipping"))
origCountry = rs("countryName")
origCountryCode = rs("countryCode")
uspsUser = rs("adminUSPSUser")
uspsPw = rs("adminUSPSpw")
upsUser = upsdecode(rs("adminUPSUser"), "")
upsPw = upsdecode(rs("adminUPSpw"), "")
upsAccess = rs("adminUPSAccess")
if Int(rs("adminUnits"))=0 then adminUnits="KGS" else adminUnits="LBS"
emailObject = rs("emailObject")
themailhost = Trim(rs("smtpserver")&"")
theuser = Trim(rs("emailUser")&"")
thepass = Trim(rs("emailPass")&"")
emailAddr = rs("adminEmail")
sendEmail = Int(rs("adminEmailConfirm"))=1
adminTweaks = Int(rs("adminTweaks"))
adminlanguages = Int(rs("adminlanguages"))
adminlangsettings = Int(rs("adminlangsettings"))
currRate1=cDbl(rs("currRate1"))
currSymbol1=trim(rs("currSymbol1")&"")
currRate2=cDbl(rs("currRate2"))
currSymbol2=trim(rs("currSymbol2")&"")
currRate3=cDbl(rs("currRate3"))
currSymbol3=trim(rs("currSymbol3")&"")
currConvUser=rs("currConvUser")
currConvPw=rs("currConvPw")
currLastUpdate=rs("currLastUpdate")
rs.Close
if saveadmininapplication=TRUE then
Application.Lock()
Application("splitUSZones") = splitUSZones
Application("saveLCID") = saveLCID
Application("countryCurrency") = countryCurrency
Application("useEuro") = useEuro
Application("storeurl") = storeurl
Application("adminStockManage") = stockManage
Application("useStockManagement") = useStockManagement
Application("adminProdsPerPage") = adminProdsPerPage
Application("countryTax") = countryTax
Application("delAfter") = delAfter
Application("delccafter") = delccafter
Application("handling") = handling
Application("adminCanPostUser") = adminCanPostUser
Application("packtogether") = packtogether
Application("origZip") = origZip
Application("shipType") = shipType
Application("origCountry") = origCountry
Application("origCountryCode") = origCountryCode
Application("uspsUser") = uspsUser
Application("uspsPw") = uspsPw
Application("upsUser") = upsUser
Application("upsPw") = upsPw
Application("upsAccess") = upsAccess
Application("adminUnits") = adminUnits
Application("emailObject") = emailObject
Application("themailhost") = themailhost
Application("theuser") = theuser
Application("thepass") = thepass
Application("emailAddr") = emailAddr
Application("sendEmail") = sendEmail
Application("adminTweaks") = adminTweaks
Application("adminlanguages") = adminlanguages
Application("adminlangsettings") = adminlangsettings
Application("currRate1") = currRate1
Application("currSymbol1") = currSymbol1
Application("currRate2") = currRate2
Application("currSymbol2") = currSymbol2
Application("currRate3") = currRate3
Application("currSymbol3") = currSymbol3
Application("currConvUser") = currConvUser
Application("currConvPw") = currConvPw
Application("currLastUpdate") = currLastUpdate
Application("getadminsettings")=TRUE
Application.UnLock()
end if
end if
end if
' Overrides
if orstoreurl<>"" then storeurl=orstoreurl
if (left(LCase(storeurl),7) <> "http://") AND (left(LCase(storeurl),8) <> "https://") then storeurl = "http://" & storeurl
if Right(storeurl,1) <> "/" then storeurl = storeurl & "/"
if oremailaddr<>"" then emailAddr=oremailaddr
getadminsettings = TRUE
end function
function strip_tags2(mistr)
Set toregexp = new RegExp
toregexp.pattern = "<[^>]+>"
toregexp.ignorecase = TRUE
toregexp.global = TRUE
mistr = toregexp.replace(mistr, "")
Set toregexp = Nothing
strip_tags2 = replace(mistr, """", """)
end function
function cleanforurl(surl)
Set toregexp = new RegExp
toregexp.pattern = "<[^>]+>"
toregexp.ignorecase = TRUE
toregexp.global = TRUE
surl = replace(lcase(toregexp.replace(surl, ""))," ","_")
toregexp.pattern = "[^a-z_0-9]"
cleanforurl = toregexp.replace(surl, "")
end function
function getlangid(col, bfield)
if languageid="" or languageid=1 then
getlangid = col
else
if (adminlangsettings AND bfield)<>bfield then getlangid = col else getlangid = col & languageid
end if
end function
function upsencode(thestr, propcodestr)
if propcodestr="" then localcodestr=codestr else localcodestr=propcodestr
newstr=""
for index=1 to Len(localcodestr)
thechar = Mid(localcodestr,index,1)
if NOT IsNumeric(thechar) then
thechar = asc(thechar) MOD 10
end if
newstr = newstr & thechar
next
localcodestr = newstr
do while Len(localcodestr) < 40
localcodestr = localcodestr & localcodestr
loop
newstr=""
for index=1 to Len(thestr)
thechar = Mid(thestr,index,1)
newstr=newstr & Chr(asc(thechar)+Int(Mid(localcodestr,index,1)))
next
upsencode=newstr
end function
function upsdecode(thestr, propcodestr)
if propcodestr="" then localcodestr=codestr else localcodestr=propcodestr
newstr=""
for index=1 to Len(localcodestr)
thechar = Mid(localcodestr,index,1)
if NOT IsNumeric(thechar) then
thechar = asc(thechar) MOD 10
end if
newstr = newstr & thechar
next
localcodestr = newstr
do while Len(localcodestr) < 40
localcodestr = localcodestr & localcodestr
loop
if IsNull(thestr) then
upsdecode=""
else
newstr=""
for index=1 to Len(thestr)
thechar = Mid(thestr,index,1)
newstr=newstr & Chr(asc(thechar)-Int(Mid(localcodestr,index,1)))
next
upsdecode=newstr
end if
end function
function VSUSDate(thedate)
if mysqlserver=true then
VSUSDate = DatePart("yyyy",thedate) & "-" & DatePart("m",thedate) & "-" & DatePart("d",thedate)
else
VSUSDate = DatePart("m",thedate) & "/" & DatePart("d",thedate) & "/" & DatePart("yyyy",thedate)
end if
end function
function VSUSDateTime(thedate)
if mysqlserver=true then
VSUSDateTime = DatePart("yyyy",thedate) & "-" & DatePart("m",thedate) & "-" & DatePart("d",thedate) & " " & DatePart("h",thedate) & ":" & DatePart("n",thedate) & ":" & DatePart("s",thedate)
else
VSUSDateTime = DatePart("m",thedate) & "/" & DatePart("d",thedate) & "/" & DatePart("yyyy",thedate) & " " & DatePart("h",thedate) & ":" & DatePart("n",thedate) & ":" & DatePart("s",thedate)
end if
end function
function FormatEuroCurrency(amount)
if overridecurrency=true then
if orcpreamount=true then
FormatEuroCurrency = orcsymbol & FormatNumber(amount,orcdecplaces)
else
FormatEuroCurrency = FormatNumber(amount,orcdecplaces) & orcsymbol
end if
else
if useEuro then
FormatEuroCurrency = FormatNumber(amount,2) & " €"
else
FormatEuroCurrency = FormatCurrency(amount,-1,-2,0,-2)
end if
end if
end function
function FormatEmailEuroCurrency(amount)
if overridecurrency=true then
if orcpreamount=true then
FormatEmailEuroCurrency = orcemailsymbol & FormatNumber(amount,orcdecplaces)
else
FormatEmailEuroCurrency = FormatNumber(amount,orcdecplaces) & orcemailsymbol
end if
else
if useEuro then
FormatEmailEuroCurrency = FormatNumber(amount,2) & " Euro"
else
FormatEmailEuroCurrency = FormatCurrency(amount,-1,-2,0,-2)
end if
end if
end function
Sub do_stock_management(smOrdId)
smOrdId = Trim(smOrdId)
If NOT IsNumeric(smOrdId) OR smOrdId="" then smOrdId=0
Set rsl = Server.CreateObject("ADODB.RecordSet")
if stockManage <> 0 then
sSQL="SELECT cartID,cartProdID,cartQuantity,pSell FROM cart INNER JOIN products ON cart.cartProdID=products.pID WHERE (cartCompleted=0 OR cartCompleted=2) AND cartOrderID=" & smOrdId
rsl.Open sSQL,cnn,0,1
do while NOT rsl.EOF
if ((rsl("pSell") AND 2) = 2) then
sSQL = "SELECT coOptID FROM cartoptions INNER JOIN (options INNER JOIN optiongroup ON options.optGroup=optiongroup.optGrpID) ON cartoptions.coOptID=options.optID WHERE (optType=2 OR optType=-2) AND coCartID=" & rsl("cartID")
rs.Open sSQL,cnn,0,1
do while NOT rs.EOF
sSQL = "UPDATE options SET optStock=optStock-"&rsl("cartQuantity")&" WHERE optID="&rs("coOptID")
cnn.Execute(sSQL)
rs.MoveNext
loop
rs.Close
else
sSQL = "UPDATE products SET pInStock=pInStock-"&rsl("cartQuantity")&" WHERE pID='"&rsl("cartProdID")&"'"
cnn.Execute(sSQL)
end if
rsl.MoveNext
loop
rsl.Close
end if
set rsl = nothing
End Sub
Sub productdisplayscript(doaddprodoptions)
if currSymbol1<>"" AND currFormat1="" then currFormat1="%s " & currSymbol1 & ""
if currSymbol2<>"" AND currFormat2="" then currFormat2="%s " & currSymbol2 & ""
if currSymbol3<>"" AND currFormat3="" then currFormat3="%s " & currSymbol3 & ""
%>
<%
End Sub
Sub updatepricescript(doaddprodoptions) %>
<%
End Sub
function checkDPs(currcode)
if currcode="JPY" then checkDPs=0 else checkDPs=2
end function
Sub checkCurrencyRates(currConvUser,currConvPw,currLastUpdate,byRef currRate1,currSymbol1,byRef currRate2,currSymbol2,byRef currRate3,currSymbol3)
ccsuccess = true
if currConvUser<>"" AND currConvPw<>"" AND currLastUpdate < Now()-1 then
sstr = ""
if currSymbol1<>"" then sstr = sstr & "&curr=" & currSymbol1
if currSymbol2<>"" then sstr = sstr & "&curr=" & currSymbol2
if currSymbol3<>"" then sstr = sstr & "&curr=" & currSymbol3
if sstr="" then
cnn.Execute("UPDATE admin SET currLastUpdate="&datedelim&Now()&datedelim)
Application.Lock()
Application("getadminsettings")=""
Application.UnLock()
exit sub
end if
sstr = "?source=" & countryCurrency & "&user=" & currConvUser & "&pw=" & currConvPw & sstr
set objHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
objHttp.open "POST", "http://www.ecommercetemplates.com/currencyxml.asp" & sstr, false
objHttp.Send "X"
if (objHttp.status <> 200 ) then
' HTTP error handling
else
Set xmlDoc = objHttp.responseXML
Set t2 = xmlDoc.getElementsByTagName("currencyRates").Item(0)
for j = 0 to t2.childNodes.length - 1
Set n = t2.childNodes.Item(j)
if n.nodename="currError" then
response.write n.firstChild.nodeValue
ccsuccess = false
elseif n.nodename="selectedCurrency" then
currRate = 0
for i = 0 To n.childNodes.length - 1
Set e = n.childNodes.Item(i)
if e.nodeName="currSymbol" then
currSymbol = e.firstChild.nodeValue
elseif e.nodeName="currRate" then
currRate = e.firstChild.nodeValue
end if
next
saveLCID = Session.LCID
Session.LCID = 1033
if currSymbol1 = currSymbol then
currRate1 = cDbl(currRate)
cnn.Execute("UPDATE admin SET currRate1="&currRate&" WHERE adminID=1")
end if
if currSymbol2 = currSymbol then
currRate2 = cDbl(currRate)
cnn.Execute("UPDATE admin SET currRate2="&currRate&" WHERE adminID=1")
end if
if currSymbol3 = currSymbol then
currRate3 = cDbl(currRate)
cnn.Execute("UPDATE admin SET currRate3="&currRate&" WHERE adminID=1")
end if
Session.LCID = saveLCID
end if
next
if ccsuccess then cnn.Execute("UPDATE admin SET currLastUpdate="&datedelim&VSUSDate(Now())&datedelim)
Application.Lock()
Application("getadminsettings")=""
Application.UnLock()
end if
set objHttp = nothing
end if
End Sub
function IIfVr(theExp,theTrue,theFalse)
if theExp then IIfVr=theTrue else IIfVr=theFalse
end function
function getsectionids(thesecid, delsections)
secid = thesecid
iterations = 0
iteratemore = true
if Session("clientLoginLevel")<>"" then minloglevel=Session("clientLoginLevel") else minloglevel=0
if delsections then nodel = "" else nodel = "sectionDisabled<="&minloglevel&" AND "
do while iteratemore AND iterations<10
sSQL2 = "SELECT DISTINCT sectionID,rootSection FROM sections WHERE " & nodel & "(topSection IN ("&secid&") OR (sectionID IN ("&secid&") AND rootSection=1))"
secid = ""
iteratemore = false
rs2.Open sSQL2,cnn,0,1
addcomma = ""
do while NOT rs2.EOF
if rs2("rootSection")=0 then iteratemore = true
secid = secid & addcomma & rs2("sectionID")
addcomma = ","
rs2.MoveNext
loop
rs2.Close
iterations = iterations + 1
loop
if secid="" then getsectionids = "0" else getsectionids = secid
end function
if Trim(Session("clientUser"))="" then
clientUser = Trim(Replace(Request.Cookies("WRITECLL"),"'",""))
if clientUser<>"" then
Set clientRS = Server.CreateObject("ADODB.RecordSet")
Set clientCnn=Server.CreateObject("ADODB.Connection")
clientCnn.open sDSN
sSQL = "SELECT clientUser,clientActions,clientLoginLevel,clientPercentDiscount FROM clientlogin WHERE clientUser='"&clientUser&"' AND clientPW='"&Trim(Replace(Request.Cookies("WRITECLP"),"'",""))&"'"
clientRS.Open sSQL,clientCnn,0,1
if NOT clientRS.EOF then
Session("clientUser")=clientRS("clientUser")
Session("clientActions")=clientRS("clientActions")
Session("clientLoginLevel")=clientRS("clientLoginLevel")
Session("clientPercentDiscount")=(100.0-cDbl(clientRS("clientPercentDiscount")))/100.0
end if
clientRS.Close
clientCnn.Close
set clientRS = nothing
set clientCnn = nothing
end if
end if
function callxmlfunction(cfurl, cfxml, byref res, cfcert, cxfobj, byref cferr, settimeouts)
set objHttp = Server.CreateObject(cxfobj)
if settimeouts then objHttp.setTimeouts 30000, 30000, 0, 0
objHttp.open "POST", cfurl, false
objHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
' if cfcert<>"" then objHttp.setOption 3, "LOCAL_MACHINE\My\" & cfcert
if cfcert<>"" then objHttp.SetClientCertificate("LOCAL_MACHINE\My\" & cfcert)
' response.write Replace(Replace(cfxml,"<")&""
' on error resume next
err.number=0
objHttp.Send cfxml
If err.number <> 0 OR objHttp.status <> 200 Then
cferr = "Error, couldn't connect to server " & err.number
callxmlfunction = FALSE
Else
res = objHttp.responseText
callxmlfunction = TRUE
' response.write Replace(Replace(objHttp.responseText,"<")&""
End If
set objHttp = nothing
end function
function getpayprovdetails(ppid,ppdata1,ppdata2,ppdemo,ppmethod)
sSQL = "SELECT payProvData1,payProvData2,payProvDemo,payProvMethod FROM payprovider WHERE payProvEnabled=1 AND payProvID=" & ppid
rs.Open sSQL,cnn,0,1
if NOT rs.EOF then
ppdata1 = rs("payProvData1")
ppdata2 = rs("payProvData2")
ppdemo=(Int(rs("payProvDemo"))=1)
ppmethod=Int(rs("payProvMethod"))
getpayprovdetails = TRUE
else
getpayprovdetails = FALSE
end if
rs.Close
end function
sub writehiddenvar(hvname,hvval)
response.write "" & vbCrLf
end sub
function ppsoapheader(username, password)
ppsoapheader = "" & _
"" & _
" " & _
" " & _
" " & _
" " & username & "" & _
" " & password & "" & _
" " & _
" " & _
" "
end function
if enableclientlogin=true then
if Session("clientUser")<>"" then
elseif request.form("checktmplogin")="1" AND request.form("sessionid")<>"" then
Set clientRS = Server.CreateObject("ADODB.RecordSet")
Set clientCnn=Server.CreateObject("ADODB.Connection")
clientCnn.open sDSN
sSQL = "SELECT tmploginname FROM tmplogin WHERE tmploginid=" & request.form("sessionid")
clientRS.Open sSQL,clientCnn,0,1
if NOT clientRS.EOF then
Session("clientUser")=clientRS("tmploginname")
clientRS.Close
clientCnn.Execute("DELETE FROM tmplogin WHERE tmploginid=" & request.form("sessionid"))
sSQL = "SELECT clientActions,clientLoginLevel,clientPercentDiscount FROM clientlogin WHERE clientUser='"&Session("clientUser")&"'"
clientRS.Open sSQL,clientCnn,0,1
if NOT clientRS.EOF then
Session("clientActions")=clientRS("clientActions")
Session("clientLoginLevel")=clientRS("clientLoginLevel")
Session("clientPercentDiscount")=(100.0-cDbl(clientRS("clientPercentDiscount")))/100.0
end if
end if
clientRS.Close
clientCnn.Close
set clientRS = nothing
set clientCnn = nothing
elseif Request.Cookies("WRITECLL")<>"" then
Set clientRS = Server.CreateObject("ADODB.RecordSet")
Set clientCnn=Server.CreateObject("ADODB.Connection")
clientCnn.open sDSN
sSQL = "SELECT clientUser,clientActions,clientLoginLevel FROM clientlogin WHERE clientUser='"&Request.Cookies("WRITECLL")&"' AND clientPW='"&Request.Cookies("WRITECLP")&"'"
clientRS.Open sSQL,clientCnn,0,1
if NOT clientRS.EOF then
Session("clientUser")=clientRS("clientUser")
Session("clientActions")=clientRS("clientActions")
Session("clientLoginLevel")=clientRS("clientLoginLevel")
end if
clientRS.Close
clientCnn.Close
set clientRS = nothing
set clientCnn = nothing
end if
if requiredloginlevel<>"" then
if Session("clientLoginLevel")Session("clientLoginLevel") then Response.redirect "clientlogin.asp?refurl=" & server.urlencode(request.servervariables("URL") & IIfVr(request.servervariables("QUERY_STRING")<>"" ,"?"&request.servervariables("QUERY_STRING"), ""))
end if
end if
end if
%>