<%Option Explicit%> [an error occurred while processing this directive] <% Sub Displayrandomproducts '*************************************************************** ' Subroutine to di displays of products base on shop ' configuration options ' add no product logic and getconfig("xfrontpagerandomfield") '' VP-ASP 6.50 ' Nov 12 2005 added mysql get recordcount fix '****************************************************** dim sql, colcount, totalcolumncount, maxrecords, count dim template, maxcolumns, randomselectfield, decimalpoint, randomrs, randomselectvalue shopopendatabaseP conn If conn.state<>adStateOpen then shopclosedatabase conn exit sub end if template="tmp_frontpage.htm" count=0 maxcolumns=getconfig("xfrontpagemaxcolumns") maxrecords=getconfig("xfrontpagemaxrecords") 'VP-ASP 6.50 - added following to stop error if xfrontpagemaxrecords is set to 0 If cint(maxrecords) = 0 Then exit sub randomselectfield=getconfig("xfrontpagerandomfield") ' new randomselectvalue=getconfig("xfrontpagerandomvalue") 'randomselectfield="pother1" If maxrecords<>"" and isnumeric(maxrecords) then maxrecords=clng(maxrecords) else maxrecords=6 end if If maxcolumns<>"" and isnumeric(maxcolumns) then maxcolumns=clng(maxcolumns) else maxcolumns=3 end if ' dim selectfield, selectvalue selectfield=getconfig("xfrontpagefield") selectvalue=getconfig("xfrontpagevalue") decimalpoint=getconfig("xdecimalpoint") dim conn If ucase(selectvalue)="RANDOM" then FrontpageGetrandomproducts conn, maxrecords, sql, randomselectfield, randomselectvalue else Generatefrontpagesql selectfield, selectvalue, sql end if If sql="" then shopclosedatabase conn exit sub end if set randomrs=conn.execute(sql) Formatfrontpageheader colcount=0 totalcolumncount=0 'main loop do While Not randomrs.EOF and count" CloseRecordSet randomrs shopclosedatabase conn end sub '********************************************************************** ' Template file is tmp_frontpage.htm '********************************************************************* Sub FormatFrontpageTemplate(template,colcount,totalcolumncount,objrs, maxcolumns) dim rc if colcount=0 then Response.write FrontRow & vbcrlf end if response.write FrontColumn ShopTemplateWrite template, objRs, rc Response.write FrontColumnEnd & vbcrlf colcount=colcount+1 totalcolumncount=totalcolumncount+1 if colcount>= MaxColumns then response.write frontrowend & vbcrlf colcount=0 end if End Sub '************************************* Sub FormatFrontpageheader ' displays header for categories response.write FrontTable & vbcrlf end sub '******************************************************************* ' Generate the sql '******************************************************************* Sub GenerateFrontpagesql (selectfield,selectvalue, sql) dim wherestr, sortstr sortstr=getconfig("xsortproducts") wherestr="where hide=0" If selectfield<>"" and selectvalue<>"" then wherestr=wherestr & " and " & selectfield & "='" & selectvalue & "'" end if sql="select * from products " & wherestr If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then sql=sql & " and (clanguage='" & getsess("language") & "'" sql=sql & " or clanguage is null)" end if 'inventory sql = sql & " AND (highercatalogid is null)" 'VP-ASP 6.50 - added extra criteria to this statement sql = sql & " AND ((hassubproduct <> 'Yes') OR (hassubproduct = '') OR (hassubproduct IS NULL))" 'VP-ASP 6.5.1 - stock control if getconfig("xstocklow")<>"" then lngcstock= clng(getconfig("xstocklow")) sql = sql & " and cstock> " & lngcstock end if If sortstr<>"" then sql=sql & " order by " & sortstr end if If getconfig("xdebug")="Yes" then debugwrite sql end if end sub '*********************************************************************** ' make sure any columns are filled '************************************************************************* Sub FrontpageFillRemainingColumns (colcount, totalcolumncount, maxcolumns) If colcount=0 then exit sub If totalcolumncount< maxcolumns then response.write FrontRowEnd exit sub end if Do While Colcount0) then 'do nothing - limit added later in code else 'VP-ASP 6.50 - customise limit of products to choose random products from if getconfig("xrandomproductlimit") > "" then sqlstr= sqlstr & " TOP " & getconfig("xrandomproductlimit") & " " end if end if sqlstr= sqlstr &" catalogid FROM products where hide=0" If randomselectfield<>"" and (randomselectvalue="" or Ucase(randomselectvalue)="NULL") then sqlstr=sqlstr & " and " & randomselectfield & "<>NULL" elseif randomselectfield<>"" then sqlstr=sqlstr & " and " & randomselectfield & "='" & Replace(randomselectvalue, "'", "''") & "'" end if If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then sqlstr=sqlstr & " and (clanguage='" & getsess("language") & "'" sqlstr=sqlstr & " or clanguage is null)" end if 'VP-ASP 6.5.1 - stock control if getconfig("xstocklow")<>"" then lngcstock= clng(getconfig("xstocklow")) sqlstr = sqlstr & " and cstock> " & lngcstock end if 'VP-ASP 6.09 - only show product matching products if getconfig("xproductmatch")="Yes" then sqlstr=sqlstr & " and (productmatch='" & xproductmatch & "'" sqlstr=sqlstr & " or productmatch is null)" end if 'VP-ASP 6.09 - only show customer matching products if getconfig("xproductmatchcustomer")="Yes" then if GetSess("CustomerProductGroup")<>"" then sqlstr=sqlstr & " and (customermatch like '%" & getsess("customerProductgroup") & "%'" sqlstr=sqlstr & " or customermatch is null)" else sqlstr=sqlstr & " and customermatch is null" end if end if 'inventory sqlstr = sqlstr & " AND (highercatalogid is null)" 'VP-ASP 6.50 - customise limit of products to choose random products from if getconfig("xrandomproductlimit") > "" then if ucase(xdatabasetype) = "MYSQL" OR (instr(lcase(xdatabasetype), "mysql")>0) then sqlstr= sqlstr & " LIMIT 0," & getconfig("xrandomproductlimit") end if end if 'debugwrite sqlstr rs.Open sqlstr,conn,3,3 If rs.eof then closerecordset rs sql="" exit sub end if Dim arrData ' Array to Store Data Dim arrSequence ' Array to Hold Random Sequence Dim iArrayLooper ' Integer for Looping Dim iArraySize ' Size of Data Array 'VP-ASP 6.08a - Changed CINT below to CLNG If getconfig("xmysql")<>"Yes" AND (instr(lcase(xdatabasetype), "mysql") = 0) then iarraysize=clng(rs.recordcount) else 'VP-ASP 6.09 - MYSQL issue with random value 'iarraysize=clng(GetRecordcount (conn)) iarraysize=clng(GetRecordcount (conn,randomselectfield,randomselectvalue)) end if redim arrdata(iarraysize) for i = 0 to iarraysize-1 arrData(i)=rs(0) rs.movenext next RS.close Set RS = Nothing If iarraysize"" then plist=plist & "," end if plist=plist & catalogid Next sql="select * from products where hide=0 and catalogid In (" & plist & ")" sortstr=getconfig("xsortproducts") If sortstr<>"" then sql=sql & " order by " & sortstr end if If getconfig("xdebug")="Yes" then debugwrite sql end if end sub Function ResequenceArray(iArraySize) Dim arrTemp() Dim I Dim iLowerBound, iUpperBound Dim iRndNumber Dim iTemp ' Set array size ReDim arrTemp(iArraySize - 1) Randomize iLowerBound = LBound(arrTemp) iUpperBound = UBound(arrTemp) For I = iLowerBound To iUpperBound arrTemp(I) = I Next ' Loop through the array once, swapping each value ' with another in a random location within the array. For I = iLowerBound to iUpperBound iRndNumber = Int(Rnd * (iUpperBound - iLowerBound + 1)) ' Swap Ith element with iRndNumberth element iTemp = arrTemp(I) arrTemp(I) = arrTemp(iRndNumber) arrTemp(iRndNumber) = iTemp Next 'I ' Return our array ResequenceArray = arrTemp End Function '*********************************************************************** ' get record count for mysql '************************************************************************ 'VP-ASP 6.09 - MySQL issue with randomvalue 'Function GetrecordCount (conn) Function GetrecordCount (conn,randomselectfield,randomselectvalue) dim sqlstr, rs, rcount sqlstr="select count(catalogid) FROM products where hide=0" If randomselectfield<>"" and (randomselectvalue="" or Ucase(randomselectvalue)="NULL") then sqlstr=sqlstr & " and " & randomselectfield & "<>NULL" elseif randomselectfield<>"" then sqlstr=sqlstr & " and " & randomselectfield & "='" & Replace(randomselectvalue, "'", "''") & "'" end if If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then sqlstr=sqlstr & " and (clanguage='" & getsess("language") & "'" sqlstr=sqlstr & " or clanguage is null)" end if sqlstr = sqlstr & " AND (highercatalogid is null)" set rs=conn.execute(sqlstr) if rs.eof then rcount=0 else rcount=rs(0) end if 'VP-ASP 6.5.1 - limit random products If Not IsNumeric(getconfig("xrandomproductlimit")) Then rcount = 200 Else If CInt(rcount) > CInt(getconfig("xrandomproductlimit")) Then rcount=CInt(getconfig("xrandomproductlimit")) End If End If closerecordset rs Getrecordcount=rcount End function %> <% '********************************************************************************** ' 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","default.asp" 'contentid = request("contentid") if contentid > "" then if NOT isnumeric(contentid) then HandleError "Content ID must be a numeric value" end if end if shopopendatabase contentdbc generatecontentsql sql OpenRecordSet contentdbc, crs, sql InitializeSystem shoppageheader 'debugwrite sql If crs.eof then handleerror "No content record assigned to homepage" else messagetype = crs("messagetype") WriteImpressions 'VP-ASP 6.08a - Generate Dynamic Meta tags setupdynamiccontent contentdbc, contentid, messagetype 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="" 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 ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR ucase(xdatabasetype) = "SQLSERVER" then sql="select * from content where homepage=1" else sql="select * from content where homepage=TRUE" end if end sub 'VP-ASP 6.08 - Impressions weren't writing correctly.