<%OPTION EXPLICIT
'注意以下二项可以在确认被CC攻击等严重情况下开启
Const isref = false 'true为开启防刷新
Const isforwarded = false 'true为禁止代理访问
If isref=true then
If DateDiff("s",session("ref"),Now())<2 Then '防刷新开始
Response.Write "防刷新和快速连续操作，请 点击进入"
Response.End
End IF
session("ref")=Now()
end if
If isforwarded=true then
If Request.ServerVariables("HTTP_X_FORWARDED_FOR")<>"" then
Response.Write "对不起，本站禁止了代理上网用户的访问！"
Response.End
end if
end if
Response.buffer=true
Response.Charset="gb2312"'输出是采用的gb2312 简体中文
Dim conn,Kill_fresh
Const Webi=2 'Hzpzs:1 hqbjp:2 qgyyzs:0 hmyyw:3 17zs:7
Const seti=1 '为0表本地，否则为远程库
Const CookieName="bzzs保健品网" '注： /inc/getcode.asp 文件 也要手工改下同步CookieName和codeName_yzm 两个变量
Const CodeName_yzm="bzzsyzm" '验证码名称，经常改变防机器人注册
Const Msg_App_maxi=49 '只保留Msg_App_maxi条在线监控消息
const shenghe_flag=1'为1 表审核后再放出，为0表不需审核，直接放出
call killsql()
sub killsql()
'----实现get请求的注入的拦截-----
dim sql_injdata,sql_injdata2,Sql_Inj,Sql_Inj2,SQL_Get,Sql_DATA,Sql_Post,Xh_Cookie
SQL_injdata = "'|exec|insert|select|delete|update|count |count%20|chr|mid|master|truncate|char|declare|set|0x4400|varchar|script|net%20user|xp_cmdshell|/add|net%20localgroup%20administrators|Asc |request"
SQL_inj = split(SQL_Injdata,"|") 'SQL_injdata 针对form 和 querystring
If 1=2 and Request.QueryString<>"" Then
For Each SQL_Get In Request.QueryString
For SQL_Data=0 To Ubound(SQL_inj)
if instr(Request.QueryString(SQL_Get),Sql_Inj(Sql_DATA))>0 Then
Response.Write "querystring请检查你的字符，有非法字符"
Response.end
end if
next
Next
End If
'----我们还要过滤post请求，所以我们还得继续考虑request.form,这个也是以数组形式存在的，我们只需要再进一次循环判断即可-----
If Instr(LCase(Request.ServerVariables("SCRIPT_NAME")),"upload2.asp")<=0 and Instr(LCase(Request.ServerVariables("SCRIPT_NAME")),"joe_savenew.asp")<=0 and Instr(LCase(Request.ServerVariables("SCRIPT_NAME")),"joe_addnew.asp")<=0 and Instr(LCase(Request.ServerVariables("SCRIPT_NAME")),"savecom.asp")<=0 then
If Request.Form<>"" Then
For Each Sql_Post In Request.Form
For SQL_Data=0 To Ubound(SQL_inj)
if instr(Lcase(Request.Form(Sql_Post)),Lcase(Sql_Inj(Sql_DATA)))>0 Then
Response.Write "form请检查你的字符，有非法字符"
If Not isobject(conn) Then linkdata
Call Log("sys99_username","form有非法字符:"&Request.Form(Sql_Post)&"")'记录
CloseData
Response.end
end if
next
next
end if
end if
end sub
Sub LinkData()
dim SqlUsername,SqlLocalName,SqlPassword,SqlDatabaseName,connstr
If seti=0 then
SqlLocalName ="(local)" '连接IP
SqlUsername ="sa" '本地用户名
SqlPassword ="123" '本地用户密码
SqlDatabaseName="qgyyzsbb" '数据库名
else
SqlLocalName ="202.91.244.49" '连接IP
SqlUsername ="hqbj2pu3" '远程用户名
SqlPassword ="172#ab%66" '远程用户密码
SqlDatabaseName="hq2bjpdb" '数据库名
end if
connstr = "Provider=Sqloledb; User ID=" & SqlUsername & "; Password=" & SqlPassword & "; Initial Catalog = " & SqlDatabaseName & "; Data Source=" & SqlLocalName & ";"
On Error Resume Next
Set conn = Server.CreateObject("ADODB.Connection")
conn.open ConnStr
If Err Then
err.Clear
Set Conn = Nothing
Response.Write "数据库连接出错，请检查连接字串。"
Response.End
End If
' Response.write("连数据库 ")
End Sub
Sub LinkDataOpinion()
Dim lqdb,lqConnStr
lqdb = "lq/facetodb.mdb"
lqConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(lqdb)
On Error Resume Next
Set Conn = Server.CreateObject("ADODB.Connection")
Conn.Open lqConnStr
If Err Then
err.Clear
Set Conn = Nothing
Response.Write "数据库连接出错，请检查连接字串。"
Response.End
End If
End Sub
Sub LinkDataZh(i)
Dim lqdb,lqConnStr
If i=0 then
lqdb = "zhdbok.mdb"
else
lqdb = "../zhdbok.mdb"
end if
lqConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(lqdb)
On Error Resume Next
Set Conn = Server.CreateObject("ADODB.Connection")
Conn.Open lqConnStr
If Err Then
err.Clear
Set Conn = Nothing
Response.Write "数据库连接出错，请检查连接字串。"
Response.End
End If
End Sub
Sub LinkDataCount()
dim SqlUsername,SqlLocalName,SqlPassword,SqlDatabaseName,connstr
SqlLocalName ="202.91.244.49" '连接IP
SqlUsername ="cnhzp_db7" '用户名
SqlPassword ="#edc120" '用户密码#edc120
SqlDatabaseName="cnhzp_countren" '数据库名
connstr = "Provider=Sqloledb; User ID=" & SqlUsername & "; Password=" & SqlPassword & "; Initial Catalog = " & SqlDatabaseName & "; Data Source=" & SqlLocalName & ";"
On Error Resume Next
Set conn = Server.CreateObject("ADODB.Connection")
conn.open ConnStr
If Err Then
err.Clear
Set Conn = Nothing
Response.Write "count数据库连接出错，请检查连接字串。"
Response.End
End If
End Sub
Sub CloseData()
if IsObject(conn) then
conn.Close:set conn=nothing
' Response.write("关闭数据库 ")
end if
End Sub
Function FetchEmploymentStatusList(SQL)
Dim cmd,RsFe
Set cmd = Server.CreateObject("ADODB.Command"):Set cmd.ActiveConnection=Conn
cmd.CommandText="proc_exesql":cmd.CommandType=4:cmd("@sqlStr")=Sql
set RsFe=cmd.Execute
set cmd=nothing
if RsFe.Eof then
RsFe.Close:Set RsFe = Nothing
Exit Function
End if
FetchEmploymentStatusList = RsFe.GetRows(-1)
RsFe.Close:Set RsFe = Nothing
End Function
Function GetUserTrueIP()
dim strIPAddr
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" OR InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Else
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
GetUserTrueIP = filt_badstr(Trim(Mid(strIPAddr, 1, 30)))
End Function
'针对中文日期格式的服务器
Function FormatData(dtDateTime)
FormatData = year(dtDateTime) & "-"&(Month(dtdateTime)) & "-"& (Day(dtdateTime)) & " "& (Hour(dtdateTime)) & ":"& (Minute(dtdateTime)) & ":"& ( Second(dtdateTime))
End function
Private sub DelUserip()
Const KillTime=100'多少秒内，Request.Cookies(CookieName & "Kill")("kill")值有效,不重新比对IP库。
Const WriteLog="1"'为1表记录屏弊IP入日志库
Dim KillIPTime,UserTrueIP,NowTime
NowTime=FormatData(Now())
UserTrueIP = GetUserTrueIP()
KillIPTime=Request.Cookies(CookieName & "Kill")("Time")
If KillIpTime<>"" and IsDate(KillIPTime) Then
' KillIPTime=formatdatetime(KillIPTime,0)
If DateDiff("s",KillIPTime,NowTime)3 Then Exit Sub
For i= 0 to UBound(locklist)
locklist(i)=Trim(locklist(i))
If locklist(i)<>"" Then
StrKillIP = Split(locklist(i),".")
If Ubound(StrKillIP)<>3 Then Exit For
IPlock = True
If (StrUserIP(0) <> StrKillIP(0)) And Instr(StrKillIP(0),"*")=0 Then IPlock=False
If (StrUserIP(1) <> StrKillIP(1)) And Instr(StrKillIP(1),"*")=0 Then IPlock=False
If (StrUserIP(2) <> StrKillIP(2)) And Instr(StrKillIP(2),"*")=0 Then IPlock=False
If (StrUserIP(3) <> StrKillIP(3)) And Instr(StrKillIP(3),"*")=0 Then IPlock=False
If IPlock Then Exit For
End If
Next
If IPlock Then
Response.Cookies(CookieName & "Kill")("kill") = "1"
Response.Cookies(CookieName & "Kill")("Time")=NowTime
If WriteLog="1" Then
If Not isobject(conn) Then linkdata
If Request.Cookies(CookieName)("user")<>"" then
Call Log(Htmlencode(Request.Cookies(CookieName)("user")),UserTrueIP&"屏IP"&"|"&left(Request.ServerVariables("HTTP_USER_AGENT"),170))
else
Call Log("sys99_username",UserTrueIP&"屏IP"&"|"&left(Request.ServerVariables("HTTP_USER_AGENT"),180))
end if
Closedata
End if
'----------在线监控
Application.Lock
Application(CookieName&"_Msgshow")="("&formatdatetime(NowTime,3)&")时"&UserTrueIP&"被禁止进入网站！ "&application(CookieName&"_Msgshow")
application.unlock
'----------在线监控
Call Err2(""&UserTrueIP&"被禁止进入网站！",3):REsponse.End()
Else
Response.Cookies(CookieName & "Kill")("kill") = "0"
Response.Cookies(CookieName & "Kill")("Time")=NowTime
End If
End sub
function HTMLEncode(fString)
fString=replace(fString,";",";")
fString=replace(fString,"<","<")
fString=replace(fString,">",">")
fString=replace(fString,"\","\")
fString=replace(fString,"--","--")
fString=replace(fString,CHR(9)," ")
fString=replace(fString,CHR(10)," ")
fString=replace(fString,CHR(13),"")
fString=replace(fString,CHR(22),"")
fString=replace(fString,CHR(32)," ")'空格
'fString=replace(fString,CHR(32)," ")'空格
fString=replace(fString,"'","’")'单引号
fString=replace(fString,CHR(34),""")'双引号
fString=replace(fString,CHR(39),"'")'单引号
HTMLEncode=fString
end function
Function filt_badstr(sSql)
If IsNull(sSql) Then Exit Function
sSql = Trim(sSql)
If sSql = "" Then Exit Function
sSql = Replace(sSql, Chr(0), "")
sSql = Replace(sSql, "<","＜")
sSql = Replace(sSql, ">","＞")
sSql = Replace(sSql, "'", "’")
sSql = Replace(sSql,";","；")
sSql = Replace(sSql,"%","％")
sSql = Replace(sSql,"char(","")
filt_badstr = sSql
End Function
function killbad(strchar)
if not isnull(strchar) then
strchar=replace(strchar,"?","？")
strchar=replace(strchar,"*","＊")
strchar=replace(strchar,"☆","")
strchar=replace(strchar,"◇","")
strchar=replace(strchar,"⊙","")
strchar=replace(strchar,"※","")
strchar=replace(strchar,"◎","")
strchar=replace(strchar,"★","")
strchar=replace(strchar,"■","")
strchar=replace(strchar,"◆","")
strchar=replace(strchar,"▲","")
strchar=replace(strchar,"▼","")
strchar=replace(strchar,"〓","")
strchar=replace(strchar,"◥","")
strchar=replace(strchar,"◣","")
strchar=replace(strchar,"●","")
killbad=strchar
end if
end function
Function RegExpfind(patrn, strng)
Dim regEx ' 建立变量。
Set regEx = New RegExp ' 建立正则表达式。
regEx.Pattern = patrn ' 设置模式。
regEx.IgnoreCase = True ' 设置是否区分大小写。
regEx.Global = false ' 设置全局可用性。
RegExpfind = regEx.Test(strng) ' 执行搜索测试。
End Function
Function check_word(patrn,sSql)
If IsNull(sSql) Then Exit Function
sSql = Trim(sSql)
If sSql = "" Then Exit Function
if RegExpfind(patrn, sSql) then
check_word=true
else
check_word=false
end if
End Function
sub Log(Username,Message)
If open_Application_IsLog=true then
Conn.Execute("insert into [User_Log] (UserName,IPAddress,UserAgent,HttpVerb,PathAndQuery) values ('"&Username&"','"&GetUserTrueIP()&"','"&Getvos&" "&GetBrowser&"','"&Request.ServerVariables("request_method")&"','"&Message&"')")
End if
end sub
Public function GetBrowser()
Dim thesoft,vsoft
thesoft=Request.ServerVariables("HTTP_USER_AGENT")
' 浏览器
If instr(thesoft,"NetCaptor") then
vsoft="NetCaptor"
ElseIf instr(thesoft,"Opera") then
vsoft="Opera"
ElseIf instr(thesoft,"Netscape") then
vsoft="Netscape"
ElseIf instr(thesoft,"MSIE 9") then
vsoft="MSIE 9.x"
ElseIf instr(thesoft,"MSIE 8") then
vsoft="MSIE 8.x"
ElseIf instr(thesoft,"MSIE 7") then
vsoft="MSIE 7.x"
ElseIf instr(thesoft,"MSIE 6") then
vsoft="MSIE 6.x"
ElseIf instr(thesoft,"MSIE 5") then
vsoft="MSIE 5.x"
ElseIf instr(thesoft,"MSIE 4") then
vsoft="MSIE 4.x"
ElseIf instr(thesoft,"Firefox") then
vsoft="Firefox"
ElseIf instr(thesoft,"Lynx") then
vsoft="Lynx"
ElseIf instr(thesoft,"Konqueror") then
vsoft="Konqueror"
ElseIf instr(thesoft,"Mozilla/5.0") then
vsoft="Mozilla"
else
vsoft="Other"
End If
if instr(thesoft,"360SE") then
vsoft=vsoft&" 360SE"
Elseif instr(thesoft,"Maxthon") then
vsoft=vsoft&" 傲游"
end if
GetBrowser=vsoft
End function
Public function Getvos()
dim thesoft,vos
thesoft=Request.ServerVariables("HTTP_USER_AGENT")
' 操作系统
If InStr(thesoft,"NT 6.1")>0 Then
vOS="Win 7"
elseIf InStr(thesoft,"NT 6.0")>0 Then
vOS="Windows Vista"
elseIf InStr(thesoft,"NT 5.2")>0 Then
vOS="Windows 2003"
ElseIf InStr(thesoft,"Windows CE")>0 Then
vOS="Windows CE"
ElseIf instr(thesoft,"Windows NT 5.1") then
vOs="Win XP"
ElseIf instr(thesoft,"Windows NT 5.0") then
vOS="Win 2000"
ElseIf instr(thesoft,"4.9") then
vOS="Windows ME"
ElseIf instr(thesoft,"Windows NT") then
vOs="Win NT"
ElseIf instr(thesoft,"Windows 9") then
vOs="Win 9x"
ElseIf instr(thesoft,"unix") or instr(thesoft,"linux") or instr(thesoft,"SunOS") or instr(thesoft,"BSD") or instr(thesoft,"BeOS") then
vOs="类Unix"
ElseIf instr(thesoft,"Mac") then
vOs="Mac"
ElseIf instr(thesoft,"OS/2") then
vOs="OS/2"
ElseIf instr(thesoft,"PC") then
vOs="Macintosh"
ElseIf instr(thesoft,"AIX") then
vOs="AIX"
else
vOs="其它"
End If
Getvos=vos
End function
Private function GetSearcher()
'----------------------识别搜索引擎
Dim botlist,Searcher,IsSearch
Dim vibo_soft,i
IsSearch=False
vibo_soft=Lcase(Request.ServerVariables("HTTP_USER_AGENT"))
BotList = "Google,Isaac,SurveyBot,Sosospider,dotnetdotcom.org,Sogou,YoudaoBot,YodaoBot,slurp,Baiduspider,yahoo,yisou,3721,msnbot,Lycos,ia_archiver,P.Arthur,FAST-WebCrawler,Java,Microsoft-ATL-Native,TurnitinBot,WebGather,Sleipnir"
Botlist=split(Botlist,",")
For i=0 to UBound(Botlist)
If InStr(vibo_soft,Lcase(Botlist(i)))>0 Then
Searcher=Lcase(Botlist(i))
If Searcher="slurp" then Searcher="Yahoo"
If Searcher="baiduspider" then Searcher="百度"
If Searcher="ia_archiver" then Searcher="Alex"
If Searcher="youdaobot" then Searcher="有道"
If Searcher="yodaobot" then Searcher="YodaoBot"
If Searcher="sosospider" then Searcher="SoSo"
IsSearch=True
Exit For
End If
Next
If IsSearch Then
GetSearcher=Searcher&""
else
GetSearcher="unknown"
End if
End function
Private sub fun_Kill_bot(Killbot_list_str,islog)'屏敝网络爬虫
'Killbot_list_str:爬虫的关键字特征
'islog: 为1表记录日志入库，其余不记录
dim v_agent,i
v_agent=Lcase(Request.ServerVariables("HTTP_USER_AGENT"))
Killbot_list_str=split(Killbot_list_str,"|")
for i = 0 to ubound(Killbot_list_str)
if instr(v_agent&"",Lcase(Killbot_list_str(i))&"") > 0 then
Application.Lock'----------在线监控
Application(CookieName&"_Msgshow")="("&formatdatetime(now(),3)&")时 爬虫："&Killbot_list_str(i)&" "&session.SessionID&"被禁止进入网站！ "&application(CookieName&"_Msgshow")
If islog then
If Not isobject(conn) Then linkdata
Call Log("sys99_username","爬虫屏弊"&Killbot_list_str(i)&"|"&session.SessionID&"|"&Left(v_agent,160))'记录其它操作系统日志
closedata
end if
application.unlock '----------在线监控
Call Err2("爬虫："&Killbot_list_str(i)&"被禁止进入网站！",3):REsponse.End()
end if
next
End Sub
Function ChkLogin(user)
ChkLogin=false
Dim rs,sql
user=filt_badstr(user)
If user="" or isnull(user) Then Exit Function
If Session(CookieName & "UserID")<>empty Then'Session验证直接通过,否则读库进一步验证。防止cookies骗
Dim iUserInfo
iUserInfo = Session(CookieName & "UserID")
iUserInfo=split(iUserInfo,"|||")
If iUserInfo(0)=user and iUserInfo(1)=cstr(HzpzsFlag) Then
ChkLogin=True
Exit Function
Else'被人修改cookie过
Response.Cookies(CookieName)("user")=""
If Not isobject(conn) Then Linkdata
Call Log(user,"跨权："&iUserInfo(0)&"|"&iUserInfo(1))'记录登陆日志
closedata
Call Err2(""&user&"跨权操作！",3):REsponse.End()
End if
else
sql="select top 1 id,flag,pwd from [username] where username='"&user&"'"
If Not isobject(conn) Then Linkdata
Set Rs=Conn.Execute(SQL)
if Rs.eof or Rs.bof then
Response.Cookies(CookieName)("user")=""
else
if trim(Request.Cookies(CookieName)("userpass"))<> CodeCookie(Rs("pwd")) then Response.Cookies(CookieName)("user")=""
If cstr(Rs("flag"))<>cstr(HzpzsFlag) Then'锁定用户后，由于flag变成4，则会激活此,免费用户登陆后，后台再升级其为高级用户，也会激活此
Response.Cookies(CookieName)("user")=""
If HzpzsFlag<>"" Then Call Log(user,"越权："&rs("flag")&"|"&HzpzsFlag)'记录登陆日志
end if
end if
rs.close:set rs=nothing
If Request.Cookies(CookieName)("user")<>"" Then '表明session丢失，而cookie仍存在，且真实有效
Dim StrLog,LastTime
StrLog="S丢失"
LastTime=Request.Cookies(CookieName)("lastTime")
StrLog=StrLog&"|"&LastTime
' Response.write (strlog)
' If HzpzsFlag="1" Then Call Log(user,StrLog)'记录session丢失，重验证的session生命期时间段
End if
If Request.Cookies(CookieName)("user")="" Then
ChkLogin=false
Call CleanCookies()
closedata'可以去掉此行，因为cklogin.asp里，如果chklogin为false,则调用closedata
else
Session(CookieName & "UserID")=user&"|||"&HzpzsFlag&"|||"&"0"'arr(2) 表是否登陆查看代理信息密码,为1表是。为0表否
ChkLogin=True'conn还处于连接状态
end if
end if
End Function
Function BuildFile(ByVal sFile, ByVal sContent)
Dim oFSO, oStream
Set oFSO = server.CreateObject("Scripting.FileSystemObject")
'Response.Write "目录1：" & sFile & " "
Set oStream = oFSO.CreateTextFile(sFile, True)
oStream.Write sContent
oStream.Close
Set oStream = Nothing
Set oFSO = Nothing
End Function
Function UserMenu(UserID)
If IsNull(UserID) Then Exit Function
Dim Str
Str="→查看会员信息
')"" style=cursor:default>"
UserMenu=Str
End Function
sub Err2(ErrMsg,var)
Response.write" "
Response.write"
"
Response.write"
"
Response.write" "
Response.write"
"
Response.write"
"
End Sub
function ToURL(strValue)
if IsNull(strValue) then strValue = ""
ToURL = Server.URLEncode(strValue)
end function
Function CleanAllCookies()
Dim objCookie
For Each objCookie In Request.Cookies
ResponseCookies objCookie,"",1
Next
End Function
Function CleanCookies()
ResponseCookies CookieName,"",1
ResponseCookies "HzpzsDim","",1
ResponseCookies "HzpzsDim2","",1
End Function
Function ResponseCookies(Key,Value,Expires)
Response.Cookies(Key) = ""&Value&""
if int(Expires)>0 then Response.Cookies(Key).Expires=DateAdd("S",Expires,now())
End Function
Function CodeCookie(str)
Dim i
Dim StrRtn
For i = Len(Str) to 1 Step -1
StrRtn = StrRtn & Ascw(Mid(Str,i,1))
If (i <> 1) Then StrRtn = StrRtn & "a"
Next
CodeCookie = StrRtn
End Function
Function DecodeCookie(Str)
Dim i
Dim StrArr,StrRtn
StrArr = Split(Str,"a")
For i = UBound(StrArr) - LBound(StrArr) to 0 Step -1
If isNumeric(StrArr(i)) = True Then
StrRtn = StrRtn & Chrw(StrArr(i))
Else
StrRtn = Str
Exit Function
End If
Next
DecodeCookie = StrRtn
End Function
Function CodeNum(sSql)
If IsNull(sSql) Then Exit Function
sSql = Trim(sSql)
If sSql = "" Then Exit Function
sSql = Replace(sSql, "0","l")
sSql = Replace(sSql, "1", "y")
sSql = Replace(sSql,"2","r")
sSql = Replace(sSql,"3","s")
CodeNum = sSql
End Function
Function DeCodeNum(sSql)
If IsNull(sSql) Then Exit Function
sSql = Trim(sSql)
If sSql = "" Then Exit Function
sSql = Replace(sSql, "l","0")
sSql = Replace(sSql, "y", "1")
sSql = Replace(sSql,"r","2")
sSql = Replace(sSql,"s","3")
DeCodeNum = sSql
End Function
Public Sub LoadTypeData()
If Not isobject(Application(CookieName&"_typelist")) then
Dim Rs
Set Rs=conn.Execute("select ClassNum,ClassID,ClassName from [Class] order by ClassID asc")
Application.Lock
Set Application(CookieName&"_typelist")=RecordsetToxml(rs,"class","item")'缓存xml片段
Response.write("读库")
Call Log("sys99_username","招商类别数")'记录重新缓存时间,系统日志的标志为：用户名为sys99_username
application.unlock
Rs.Close:Set Rs= Nothing
end if
End Sub
Rem xmlroot跟节点名称 row记录行节点名称
'这个函数的功能还是比较简单的，主要就是建立一个FreeThreadedDOMDocument对象，其根节点是xmlroot，下边子节点row，然后将Recordset对象中的各字段及其值以属性的方式保存在row节点中。
Public Function RecordsetToxml(Recordset,row,xmlroot)
Dim i,node,rs2,j,DataArray,sNode
If xmlroot="" Then xmlroot="xml"
If row="" Then row="row"
Set RecordsetToxml=Server.CreateObject("msxml2.FreeThreadedDOMDocument.3.0")
RecordsetToxml.appendChild(RecordsetToxml.createElement(xmlroot))
If Not Recordset.EOF Then
DataArray=Recordset.GetRows(-1)
For i=0 To UBound(DataArray,2)
Set Node=RecordsetToxml.createNode("element",row,"")
'node.setAttribute(RecordsetToxml.createNode(2,"display_name",""))=DataArray(2,i)
'setNamedItem(name) 把给定节点名的节点添加到当前节点集中，如果改名字节点已经存在，替换
node.attributes.setNamedItem(RecordsetToxml.createNode("attribute","display_name","")).text= DataArray(2,i)
node.attributes.setNamedItem(RecordsetToxml.createNode("attribute","display_id","")).text= DataArray(1,i)
node.attributes.setNamedItem(RecordsetToxml.createNode(2,"classnum","")).text= DataArray(0,i)
RecordsetToxml.documentElement.appendChild(Node)
'生成小类-----------------------------------------------------------------------------
Set Rs2=conn.Execute("select NClassID,nClassName from [nClass] where ClassID='"&DataArray(1,i)&"' order by nClassID asc")
Do while not rs2.eof
Set sNode=RecordsetToxml.createNode("element","subclass","")
sNode.Text =rs2(0)
snode.attributes.setNamedItem(RecordsetToxml.createNode(2,"display_name","")).text= rs2(1)
RecordsetToxml.documentElement.selectSingleNode(row&"[@display_id="&DataArray(1,i)&"]").appendChild(sNode)
rs2.movenext
Loop
Rs2.close
'生成小类-----------------------------------------------------------------------------
Next
Set rs2=nothing
End If
DataArray=Null
'Response.Write(RecordsetToxml.documentElement.selectSingleNode(row).getAttribute("ClassNum"))
End Function
Sub SubName(subtypeid,BigtypeID,IsBig,IsSmall) 'IsBig是否显示大类名称,IsSamll是否显示小类名称
dim objRootsite,AllNodeNum,ii,iii
set objRootsite=Application(CookieName&"_typelist").selectsinglenode("//item")
AllNodenum = objRootsite.childNodes.length -1
for ii=0 to AllNodeNum
If objRootsite.ChildNodes(ii).getAttribute("display_id") = Cstr(BigtypeID) Then
If IsBig=True Then Response.Write(objRootsite.childNodes(ii).getAttribute("display_name"))'显示大类名称
If IsSmall=True Then
for iii=0 to ObjRootsite.childNodes(ii).childNodes.length-1
If objRootsite.ChildNodes(ii).ChildNodes(iii).text = cstr(subtypeid) Then
Response.Write("_"&objRootsite.childNodes(ii).ChildNodes(iii).getAttribute("display_name"))'显示小类名称
exit sub
end if
next
End if
End if
next
set objrootsite=nothing
End sub
Sub SubName_Link(subtypeid,BigtypeID,IsBig,IsSmall) '大类名称带链接的。 IsBig是否显示大类名称,IsSamll是否显示小类名称
dim objRootsite,AllNodeNum,ii,iii
set objRootsite=Application(CookieName&"_typelist").selectsinglenode("//item")
AllNodenum = objRootsite.childNodes.length -1
for ii=0 to AllNodeNum
If objRootsite.ChildNodes(ii).getAttribute("display_id") = Cstr(BigtypeID) Then
If IsBig=True Then Response.Write(""&objRootsite.childNodes(ii).getAttribute("display_name")&"")'显示大类名称
If IsSmall=True Then
for iii=0 to ObjRootsite.childNodes(ii).childNodes.length-1
If objRootsite.ChildNodes(ii).ChildNodes(iii).text = cstr(subtypeid) Then
Response.Write(" / "&objRootsite.childNodes(ii).ChildNodes(iii).getAttribute("display_name")&"")'显示小类名称
exit sub
end if
next
End if
End if
next
set objrootsite=nothing
End sub
Function BigTName_dl_Link(BigtypeID) '返回大类名称函数
Dim objRootsite,AllNodeNum,ii,typestr2
set objRootsite=Application(CookieName&"_typelist").selectsinglenode("//item")
AllNodenum = objRootsite.childNodes.length -1
for ii=0 to AllNodeNum
If objRootsite.ChildNodes(ii).getAttribute("display_id") = Cstr(BigtypeID) Then
typestr2=""&objRootsite.childNodes(ii).getAttribute("display_name")&"代理商"'显示大类名称
exit for
End if
next
set objrootsite=nothing
BigTName_dl_Link=typestr2
End function
Function BigTName(BigtypeID) '返回大类名称函数
Dim objRootsite,AllNodeNum,ii,typestr2
set objRootsite=Application(CookieName&"_typelist").selectsinglenode("//item")
AllNodenum = objRootsite.childNodes.length -1
for ii=0 to AllNodeNum
If objRootsite.ChildNodes(ii).getAttribute("display_id") = Cstr(BigtypeID) Then
typestr2=objRootsite.childNodes(ii).getAttribute("display_name")'显示大类名称
exit for
End if
next
set objrootsite=nothing
BigTName=typestr2
End function
'显示某大类下的二级分类列表：SmallTypeID 小类id, BigtypeID 大类ID，Bigshow 显示大类名称, SmallShow 显示小类名称,Fsize 大类字体
Sub show_sublist2(SmallTypeID,BigtypeID,BigShow,SmallShow,Fsize,htmlcode)
dim objRootsite,AllNodeNum,ii,iii,t
set objRootsite=Application(CookieName&"_typelist").selectsinglenode("//item")
AllNodenum = objRootsite.childNodes.length -1
for ii=0 to AllNodeNum
If objRootsite.ChildNodes(ii).getAttribute("display_id") = Cstr(BigtypeID) Then
t=0
Response.Write("
")
Response.Write("")
Call Subname(SmallTypeID,BigtypeID,BigShow,SmallShow)
Response.Write(""&htmlcode&"")
for iii=0 to ObjRootsite.childNodes(ii).childNodes.length-1
Response.Write(""&objRootsite.childNodes(ii).ChildNodes(iii).getAttribute("display_name")&" ")'显示小类名称
t=t+1
'If t=10 Then Response.Write(" "):t=0
next
Response.Write("
")
Exit for
End if
next
set objrootsite=nothing
End sub
Function show_news(inum,s_key)
dim rsnews,sql,link,str
Set rsnews = Server.CreateObject("ADODB.Recordset")
sql="SELECT top "&inum&" Artcle_id,Artcle_title,Artcle_hit,Artcle_date,Artcle_link,FromTj FROM [New_artcle] "
If s_key<>"" and s_key<>"0" then sql=sql&" where Artcle_title like '%"&s_key&"%' or Artcle_key like '%"&s_key&"%' "
sql=sql&" ORDER BY Artcle_date desc "
rsnews.open sql,conn,1,1
If rsnews.bof and rsnews.eof then
str="无相关新闻"
else
do while not rsnews.eof
link=rsNews(4)
link=Replace(link,"../","")
If rsNews("FromTj")="1" Then link="/user/"&link
str=str&"
Email：sales@hqbjp.net