<%Option Explicit%>
<%
'**********************************************************************************
' Version 6.50 Content management
' shopcontent.asp?type=news
' shopcontent.asp?type=news&template=xxx
' Allows you to add content using the content table
' VP-ASP 6.50 June 28, 2004
'*********************************************************************************
Dim CatalogId, dbtable, idfield, contentdbc, dbc, crs, contentid
Dim messagetype
Dim template
'VP-ASP 6.08a - moved down below generate meta tags
'shoppageheader
setSess "CurrentURL","shopcontent.asp"
messagetype=GetTextfield("type")
'--------------------------------------
' VP-ASP Security Patch - 8 July 2008
'--------------------------------------
contentid = cleanchars(request("contentid"))
if contentid > "" then
if NOT isnumeric(contentid) then
contentid=""
shoppageheader
HandleError "Content ID must be a numeric value"
shoppagetrailer
response.end
end if
end if
if messagetype="" and contentid = "" then
shoppageheader
HandleError getlang("LangRecordNotFound")
shoppagetrailer
response.end
end if
shopopendatabase contentdbc
WriteImpressions
'VP-ASP 6.08a - Generate Dynamic Meta tags
setupdynamiccontent contentdbc, contentid, messagetype
shoppageheader
generatecontentsql sql
'debugwrite sql
OpenRecordSet contentdbc, crs, sql
If crs.eof then
handleerror getlang("LangRecordNotFound") & " " & messagetype
else
if crs("loggedin") <> true then
Formatcontent crs
else
if Getsess ("login") > "" then
Formatcontent crs
else
shopwriteerror getlang("langcustadminloginrequired")
end if
end if
end if
closerecordset crs
shopclosedatabase contentdbc
shoppagetrailer
'****************************************************
' write a message
'***************************************************
sub handleError (msg)
shopwriteError msg
end sub
'
'***************************************************************
' Use temaplte or just displaye it
'**************************************************************
Sub Formatcontent (crs)
dim message, message2, image
'message=crs("message")
if contentid = "" then
dim getcontentsql, getcontentrs
getcontentsql = "select contentid from content WHERE messagetype = '" & messagetype & "'"
OpenRecordSet contentdbc, getcontentrs, getcontentsql
if getcontentrs.eof then
shoperrror "There has been an error retrieving the ID for this content."
else
contentid = getcontentrs("contentid")
end if
closerecordset getcontentrs
end if
message=translatelanguage(contentdbc, "content", "message","contentid", contentid, crs("message"))
'message2=crs("message2")
message2=translatelanguage(contentdbc, "content", "message2","contentid", contentid, crs("message2"))
contentid=crs("contentid")
image=crs("contentimage")
If isnull(image) then image=""
'VP-ASP 6.09 - Add breadcrumb / VP-ASP 6.50 - added config option to turn breadcrumb on/off
if getconfig("xbreadcrumbs") = "Yes" then
'VP-ASP 6.50 - advanced session handling
Response.write ""
end if
Gettemplate crs, template
if template<>"" then
ShopMergetemplate "content", template, contentid, "contentid"
If serror<>"" then
handleError serror
end if
exit sub
end if
If image<>"" then
Formatimage image
end if
response.write "" & message & "
"
response.write message2
end sub
Sub GetTemplate (crs, template)
dim dbtemplate, suffix
template=gettextfield("template")
dbtemplate=crs("template")
If template="" then
if not isnull(dbtemplate) then
template=dbtemplate
end if
end if
if template="" then exit sub
suffix=right(template,3)
if lcase(suffix)<>"htm" then
template=""
end if
end sub
Sub formatimage (image)
Response.write ""
response.write "![]()
"
response.write "
"
end sub
'************************************************************************
' get last non hidden news or whatever
'***********************************************************************
Sub GenerateContentsql (sql)
if contentid > "" then
sql="select * from content where contentid=" & contentid
else
sql="select * from content where messagetype='" & messagetype & "'"
end if
sql=sql & " and hide=0 "
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
sql=sql & " and (contentlanguage='" & getsess("language") & "'"
sql=sql & " or contentlanguage is null)"
end if
sql=sql & " order by contentid desc"
end sub
'VP-ASP 6.08 - Impressions weren't writing correctly.
Sub WriteImpressions
contentdbc.execute("UPDATE content SET impressions = 0 WHERE impressions IS NULL")
if contentid <> "" then
'increment content impressions
contentdbc.execute("UPDATE content SET impressions = impressions + 1 WHERE contentid = " & contentid)
Else
If messagetype <> "" Then
contentdbc.execute("UPDATE content SET impressions = impressions + 1 WHERE messagetype LIKE '" & messagetype &"'")
End If
End If
End Sub
'VP-ASP 6.09 - added function to clean HTML from message to be used in breadcrumb
Function Removehtml(itemname, CR)
dim workrecord, firstchar, morefields, pos, endpos, length
dim token
If ucase(Getsess("emailformat"))="HTML" then
Removehtml=itemname
exit function
end if
'VP-ASP 6.50 - check that itemname has data in it before replacing
if itemname > "" then
workrecord=replace(itemname,"
",CR)
workrecord=replace(itemname,"
",CR)
end if
If getconfig("xemailremovehtml")<>"Yes" then
Removehtml=workrecord
exit function
end if
pos=1
morefields = True
Do While morefields = True
pos=1
pos = InStr(pos, workrecord, "<")
If pos > 0 Then
endpos = InStr(pos, workrecord, ">")
If endpos=0 then
morefields=false
else
length = endpos - pos + 1
token = Mid(workrecord, pos, length)
workrecord=replace(workrecord,token,"")
end if
else
morefields=false
end if
loop
Removehtml=workrecord
end function %>