"
end if
For i = 1 to RowNum
sTrCol=Split(sTrRow(i),"|||")
'Response.write strrow(i)
if Cint(sTrCol(4))>=2 then
sLink=sTrCol(3)
else
sLink=Cl.WebDir & sTrCol(2) & "/Index.asp"
end if
if Cint(strcol(0))= sChannelID then
sTemp = sTemp & "
"
next
ShowChannelMenu=replace(sTemp,"'",chr(34))
End Function
'===添加结束
Public Function ShowChannel(sChannelID)
Name="Channel"
sChannelID=Clng(sChannelID)
If ObjIsEmpty() Then Load_Channel()
dim sTemp,sTrRow,sTrCol,i,RowNum,sLink
sTrRow=Split(replace(value,"{%webdir%}",WebDir),"$$$")
RowNum=UBound(sTrRow)-1
sTrCol=Split(sTrRow(0),"|||")
sTemp=""
'if Cint(sTrCol(4))=2 or Cint(sTrCol(0))=0 then
' sLink=sTrCol(3)
'else
sLink=Cl.WebDir & "Index.asp"
'end if
if Cint(sTrCol(5))=1 then
sTemp=sTemp & "" & sTrCol(1)& ""
else
sTemp=sTemp & " class=""ochannel"">" & sTrCol(1)& ""
end if
For i = 1 to RowNum
sTrCol=Split(sTrRow(i),"|||")
'ChannelID=0,ChannelName=1,ChannelDir=2,LinkUrl=3,ChannelType=4,OpenType=5
sTemp=sTemp & Cl.mainhtml(15)
if Cint(sTrCol(4))=2 then
sLink=sTrCol(3)
else
sLink=Cl.WebDir & sTrCol(2) & "/Index.asp"
end if
if Cint(sTrCol(5))=1 then
sTemp=sTemp & "" & sTrCol(1)& ""
else
sTemp=sTemp & " class=""ochannel"">" & sTrCol(1)& ""
end if
next
ShowChannel=sTemp
End Function
Public Function GetChannelName(sChannelID)
sChannelID = Clng(sChannelID)
if sChannelID < 0 then
GetChannelName = "所有频道" : Exit Function
end if
Name="Channel"
If ObjIsEmpty() Then Load_Channel()
dim sTrRow,sTrCol,i
sTrRow=Split(value,"$$$")
For i = 0 to UBound(sTrRow)-1
sTrCol=Split(sTrRow(i),"|||")
if Cint(sTrCol(0))=sChannelID then
GetChannelName = sTrCol(1)
Exit For
end if
Next
End Function
Public Function NoChkSqlInFiles()
NoChkSqlInFiles=False
if UserTrueIP="127.0.0.1" or ServerName="localhost" or Page_Admin or InStr(ScriptName,"install.asp")>0 then NoChkSqlInFiles=True : Exit Function
If Instr(Lcase(CacheData(14,0)),ScriptName)>0 then NoChkSqlInFiles=True
End Function
Public Sub ReloadSetup()
Dim SQL,Rs
SQL = "Select ID,Web_Info,Web_Setting,Web_StyleID,Web_CssID,Web_Version,Web_Pack,Badwords,rBadword,LockIP,Regword,UpLoad_Setting,Product_Setting,SqlInword,NoChkSqlInFiles,Web_Css from [Cl_Setup]"
Set Rs = Execute(SQL)
value = Rs.GetRows(1)
Set Rs = Nothing
End Sub
'装载模板
Public Sub LoadTemplates(ModuleNames)
Dim Style_Pic,Main_Style,TempStyle,sCssTemp
TempStyle = Split(CacheData(15,0),"@@@")
sCssTemp = Split(TempStyle(1),"|||")
If CssID>=UBound(sCssTemp) Then CssID = 0
Web_CSS = sCssTemp(CssID)
Web_PicUrl = Split(TempStyle(2),"|||")(CssID)
Name = "StyleName" & StyleID
If ObjIsEmpty() Then TemplatesToCache ("StyleName")
StyleName=value
Name = "Main_Style" & StyleID
If ObjIsEmpty() Then TemplatesToCache ("Main_Style")
Main_Style = Replace(value,"{%picurl%}",WebDir&Web_PicUrl)
Main_Style = Replace(Main_Style,"{%webdir%}",WebDir)
If ModuleNames<>"" Then
Name="module_" & ModuleNames & StyleID
If ObjIsEmpty() Then TemplatesToCache ("module_"&ModuleNames)
Template.value = Replace(value,"{%webdir%}",WebDir)
End If
Main_Style = Split(Main_Style,"@@@")
mainhtml = Split(Main_Style(0),"|||")
lanstr = Split(Main_Style(1),"|||")
mainpic = Split(Main_Style(2),"|||")
mainsetting = Split(mainhtml(0),"||")
Web_CSS = Replace(Web_CSS,"{%picurl%}",WebDir & Web_PicUrl)
Web_CSS = replace(Web_CSS,"{%webdir%}",WebDir)
'Title = replace(lanstr(0),"创力网站管理系统官方站",Web_Info(0))
End Sub
Public Sub TemplatesToCache(ModuleNames)
Dim Rs,SQL
SQL = "Select "&ModuleNames&" from [Cl_Style] where id = " & Clng(StyleID)
Set Rs = Execute(SQL)
If Not Rs.EOF Then
value=Rs(0)&""
Else
Call FixSetupsid()
End If
Set Rs = Nothing
End Sub
Private Sub FixSetupsid()
Dim Rs,SQL
SQL = "Select Top 1 ID from [Cl_Style] Order by ID"
Set Rs = Execute(SQL)
If Rs.EOF Then
Response.Write "模板数据是空的，无任何可用风格，请添加后再运行网站。"
Response.End
Else
if ChannelID="" or Not IsNumeric(ChannelID) then
Execute("Update Cl_Setup Set Web_StyleID="&Rs(0)&",Web_CssID=0")
else
Execute("Update Cl_Channel Set StyleID="&Rs(0)&",CssID=0 where ChannelID="&ChannelID&"")
end if
End If
Set rs=Nothing
End Sub
'读取模板列表
Public Sub ReloadTemplateslist()
Dim Rs,SQL,tmpdata
SQL = "Select ID,StyleName from Cl_Style"
Set Rs = Execute(SQL)
tmpdata = Rs.GetString(,,"|||","@@@","")
tmpdata = Left(tmpdata,Len(tmpdata)-3)
Set Rs = Nothing
value=tmpdata
End Sub
Public Function Head()
dim sTemp
sTemp = mainhtml(1)
if ChannelID>0 and ChannelID<>6 then sTemp = sTemp & vbNewLine & mainhtml(2)
sTemp = Replace(sTemp,"{%webcss%}",""&VbNewline&"{%webcss%}")
if Cl.Web_Info(15) = "1" or CreateHtmlIng=True then
sTemp = Replace(sTemp,"{%webcss%}","")
sTemp = Replace(sTemp,"{%showchannel%}",Cl.ShowChannel(ChannelID))
'sTemp = Replace(sTemp,"{%showchannel%}","")
else
sTemp = Replace(sTemp,"{%webcss%}","")
sTemp = Replace(sTemp,"{%showchannel%}",Cl.ShowChannel(ChannelID))
end if
Head = sTemp
End Function
Public Function Bottom()
dim sTemp,Powered
Powered = lanstr(2) & ""&Web_Version(1)&""
if SysTemVersion>1 then
sTemp=Replace(mainhtml(3),"{%powered%}","")
else
sTemp=Replace(mainhtml(3),"{%powered%}",Powered)
end if
if Web_Setting(44)="Yes" then sTemp = sTemp & VbNewLine & ""
Bottom = sTemp
End Function
Public Function GetClassMenu(sChannelID)
GetChannelSetting(sChannelID)
Dim sTemp, TopNum, ModNum, SettingStr
SettingStr = Split(Channel_Setting(25),",")
TopNum = Clng(SettingStr(0))
ModNum = Clng(SettingStr(1))
If TopNum > 0 then
TopNum = "Top "&TopNum&""
Else
TopNum = ""
End if
If ModNum = 0 then ModNum=10
sTemp = "" & vbcrlf
sTemp = sTemp & ""
sTemp=Empty
End Function
Public Function GetChildMenu(ID,ShowType,sChannelID)
dim SQL,Rs,k,sTemp
if pNum=1 then
sTemp = "stm_bp('p" & pNum & "',[1,4,0,0,2,3,6,7,100,'progid:DXImageTransform.Microsoft.Fade(overlap=.5,enabled=0,Duration=0.43)',-2,'',-2,67,2,3,'#999999','#ffffff','',3,1,1,'#aca899']);" & vbcrlf
else
if ShowType=0 then
sTemp = "stm_bpx('p" & pNum & "','p" & pNum2 & "',[1,4,0,0,2,3,6]);" & vbcrlf
else
sTemp = "stm_bpx('p" & pNum & "','p" & pNum2 & "',[1,2,-2,-3,2,3,0]);" & vbcrlf
end if
end if
SQL="select ClassID,ClassName,ParentPath,ClassDir,ParentDir,Depth,NextID,Child,Readme,IsOuter,LinkUrl From Cl_Class where ChannelID="&Cint(sChannelID)&" and ParentID=" & ID & " and ShowOnTop="&TrueType&" order by OrderID asc"
Set Rs = Execute(SQL)
if Not (Rs.Bof and Rs.Eof) THen
SQL = Rs.GetRows(-1)
For k=0 to Ubound(SQL,2)
if SQL(9,k)=1 then
if SQL(7,k) > 0 then
sTemp = sTemp & "stm_aix('p"&pNum&"i"&k&"','p"&pNum2&"i0',[0,'" & SQL(1,k) & "','','',-1,-1,0,'" & SQL(10,k) & "','_blank','" & SQL(10,k) & "','" & SQL(8,k) & "','','',6,0,0,'"&WebDir&"images/arrow_r.gif','"&WebDir&"images/arrow_w.gif',7,7,0,0,1,'#ffffff',0,'#cccccc',0,'','',3,3,0,0,'#fffff7','#000000','#000000','#ffffff','9pt 宋体']);" & vbcrlf
pNum=pNum+1 : pNum2=pNum2+1
sTemp = sTemp & GetChildMenu(SQL(0,k),1,sChannelID)
else
sTemp = sTemp & "stm_aix('p"&pNum&"i"&k&"','p"&pNum2&"i0',[0,'" & SQL(1,k) & "','','',-1,-1,0,'" & SQL(10,k) & "','_blank','" & SQL(10,k) & "','" & SQL(8,k) & "','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',0,'','',3,3,0,0,'#fffff7','#ff0000','#000000','#cc0000','9pt 宋体']);" & vbcrlf
end if
else
if SQL(7,k) > 0 then
sTemp = sTemp & "stm_aix('p"&pNum&"i"&k&"','p"&pNum2&"i0',[0,'" & SQL(1,k) & "','','',-1,-1,0,'" & WebDir & GetClassUrl(Channel_Setting(11),HtmlDir,Channel_Setting(4),SQL(2,k),SQL(0,k),SQL(4,k),SQL(3,k),Channel_Setting(10),Channel_Setting(13)) & "','_self','" & WebDir & GetClassUrl(Channel_Setting(11),HtmlDir,Channel_Setting(4),SQL(2,k),SQL(0,k),SQL(4,k),SQL(3,k),Channel_Setting(10),Channel_Setting(13)) & "','" & SQL(8,k) & "','','',6,0,0,'"&WebDir&"images/arrow_r.gif','"&WebDir&"images/arrow_w.gif',7,7,0,0,1,'#ffffff',0,'#cccccc',0,'','',3,3,0,0,'#fffff7','#000000','#000000','#ffffff','9pt 宋体']);" & vbcrlf
pNum=pNum+1 : pNum2=pNum2+1
sTemp = sTemp & GetChildMenu(SQL(0,k),1,sChannelID)
else
sTemp = sTemp & "stm_aix('p"&pNum&"i"&k&"','p"&pNum2&"i0',[0,'" & SQL(1,k) & "','','',-1,-1,0,'" & WebDir & GetClassUrl(Channel_Setting(11),HtmlDir,Channel_Setting(4),SQL(2,k),SQL(0,k),SQL(4,k),SQL(3,k),Channel_Setting(10),Channel_Setting(13)) & "','_self','" & WebDir & GetClassUrl(Channel_Setting(11),HtmlDir,Channel_Setting(4),SQL(2,k),SQL(0,k),SQL(4,k),SQL(3,k),Channel_Setting(10),Channel_Setting(13)) & "','" & SQL(8,k) & "','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',0,'','',3,3,0,0,'#fffff7','#ff0000','#000000','#cc0000','9pt 宋体']);" & vbcrlf
end if
end if
Next
SQL=Empty
End if
Rs.Close : Set Rs=Nothing
GetChildMenu = sTemp & "stm_ep();" & vbcrlf
sTemp=Empty
End Function
Public Function ShowUserLogin(Byval sType)
dim sTemp,sTemp2
if sType="1" then
sTemp2=Split(Cl.mainhtml(5),"||")
else
sTemp2=Array(mainhtml(4),mainhtml(6),mainhtml(7), _
mainhtml(8),mainhtml(9),mainhtml(13))
end if
if UserID=0 Or UserLevel=5 then
sTemp=Replace(sTemp2(0),"{%webname%}",Web_Info(0))
if Cl.Web_Setting(39)="Yes" then
sTemp=Replace(sTemp,"{%getcode%}",Replace(sTemp2(5),"{%getcode%}",Cl.GetCode("GetCode")))
else
sTemp=Replace(sTemp,"{%getcode%}","")
end if
Else
if Cint(User_Info(21))=1 then
sTemp=Replace(sTemp2(2),"{%webname%}",Web_Info(0))
else
sTemp=Replace(sTemp2(1),"{%webname%}",Web_Info(0))
end if
if Cint(User_Info(24))=1 then
sTemp=Replace(sTemp,"{%userinfo%}",sTemp2(3))
if clng(User_Info(22))>10 then
sTemp=Replace(sTemp,"{%color2%}",mainsetting(3))
else
sTemp=Replace(sTemp,"{%color2%}",mainsetting(4))
end if
else
sTemp=Replace(sTemp,"{%userinfo%}",sTemp2(4))
if clng(User_Info(40))>10 then
sTemp=Replace(sTemp,"{%color3%}",mainsetting(5))
else
sTemp=Replace(sTemp,"{%color3%}",mainsetting(6))
end if
end if
if Cint(SendMsgNum)>0 and Web_Setting(36)="Yes" then
sTemp=sTemp & vbNewLine & mainhtml(10)
sTemp=Replace(sTemp,"{%inceptid(1)%}",SendMsgID)
sTemp=Replace(sTemp,"{%inceptid(2)%}","")
sTemp=Replace(sTemp,"{%newincept%}",""&SendMsgNum&"")
else
sTemp=Replace(sTemp,"{%newincept%}",""&SendMsgNum&"")
end if
sTemp=Replace(sTemp,"{%username%}",User_Info(5))
sTemp=Replace(sTemp,"{%userpoint%}",User_Info(22))
sTemp=Replace(sTemp,"{%usermoney%}",User_Info(23))
sTemp=Replace(sTemp,"{%moneyitemname%}",Cl.Web_Setting(26))
sTemp=Replace(sTemp,"{%moneyitemunit%}",Cl.Web_Setting(27))
sTemp=Replace(sTemp,"{%pointitemname%}",Cl.Web_Setting(28))
sTemp=Replace(sTemp,"{%pointitemunit%}",Cl.Web_Setting(29))
sTemp=Replace(sTemp,"{%userlevel%}",User_Info(31))
sTemp=Replace(sTemp,"{%uservalidday%}",User_Info(40))
sTemp=Replace(sTemp,"{%color1%}",mainsetting(2))
if clng(User_Info(23))>10 then
sTemp=Replace(sTemp,"{%color4%}",mainsetting(7))
else
sTemp=Replace(sTemp,"{%color4%}",mainsetting(8))
end if
end if
ShowUserLogin=sTemp
sTemp=Empty : sTemp2=Empty
End Function
Public Function newincept(sName)
'if UserTableType="Dvbbs" then
newincept=Cl.Execute_U("Select Count(id) From " & Db.MessageTable & " Where flag=0 and issend=1 and delR=0 And incept='"&sName&"'")(0)
'else
' newincept=Cl.Execute("Select Count(id) From " & Db.MessageTable & " Where flag=0 and issend=1 and delR=0 And incept='"&sName&"'")(0)
'end if
if Isnull(newincept) or Not IsNumeric(newincept) then newincept=0
End function
'更新用户短信通知信息（新短信条数||新短讯ID||发信人名）
Public Sub Update_User_Msg(sName)
Dim msginfo,sMewMsgN,UP_UserInfo
sMewMsgN=newincept(sName)
If sMewMsgN>0 Then
msginfo=sMewMsgN & "||" & inceptid(1,sName) & "||" & inceptid(2,sName)
Else
msginfo="0||0||null"
End If
Cl.Execute_U("Update " & Db.UserTable & " Set " & Db.UserMsg & "='"&Cl.CheckStr(msginfo)&"' Where " & Db.UserName & "='"&Cl.CheckStr(sName)&"'")
If Trim(sName)=Trim(Cl.User_Info(5)) Then
UP_UserInfo=Session(CacheName & "UserID")
UP_UserInfo(30)=msginfo
Session(CacheName & "UserID")=UP_UserInfo
Else
Call NeedUpdateList(sName,1)
End If
End Sub
Public Function inceptid(stype,iusername)
Dim Rs
Set Rs=Cl.Execute_U("Select top 1 id,sender From " & Db.MessageTable & " Where flag=0 And issend=1 And DelR=0 And incept='"& iusername &"'")
If not rs.eof Then
If stype=1 Then
inceptid=Rs(0)
Else
inceptid=Rs(1)
End If
Else
If stype=1 Then
inceptid=0
Else
inceptid="null"
End If
End If
Rs.Close : Set Rs=Nothing
End Function
Public Function Execute(Command)
If Not IsObject(Conn) Then OpenConn
On Error Resume Next
Set Execute = Conn.Execute(Command)
If Err Then
Conn.Close : Set Conn = Nothing
Response.Write "执行查询代码时发现错误，请检查您的查询代码是否正确。" & Err.Description &" " & Command
err.Clear
Response.End
End If
SqlQueryNum=SqlQueryNum+1
End Function
Public Function Execute_U(Command)
If Not IsObject(Conn_U) Then OpenConn_U
On Error Resume Next
Set Execute_U = Conn_U.Execute(Command)
If Err Then
err.Clear
Conn_U.Close : Set Conn_U = Nothing
Response.Write "执行查询代码时发现错误，请检查您的查询代码是否正确。" & Err.Description &" " & Command
Response.End
End If
SqlQueryNum=SqlQueryNum+1
End Function
Public Function Execute_L(Command)
If Not IsObject(Conn_L) Then OpenConn_L
On Error Resume Next
Set Execute_L = Conn_L.Execute(Command)
If Err Then
err.Clear
Conn_L.Close : Set Conn_L = Nothing
Response.Write "执行查询代码时发现错误，请检查您的查询代码是否正确。" & Err.Description &" " & Command
Response.End
End If
SqlQueryNum=SqlQueryNum+1
End Function
'记录错误事件
Public Sub SaveSQLLOG(sSqlType,sCommand)
Dim StrType,sTemp,ErrNum
ErrNum=Session("ErrNum")
if Not IsNumeric(ErrNum) then
ErrNum=1
else
ErrNum=Clng(ErrNum)+1
end If
Session("ErrNum")=ErrNum
if ErrNum >= 3 then
Dim IPstr
IPstr=Cstr(UserTrueIP)
If IPstr<>"" And Trim(CacheData(9,0))<>"" Then
CacheData(9,0)=Replace(Trim(CacheData(9,0)),IPstr,"")
CacheData(9,0)=Replace(CacheData(9,0),"||","|")
IPstr=CacheData(9,0) & "|" & Replace(IPstr,"|","")
End If
if IPstr<>"" and ErrNum<5 then
Execute("update Cl_Setup set LockIP='"&replace(IPstr,"'","''")&"'")
Load_Setup
end if
Session("ErrNum")=5
Response.write "您执行了非法操作次数已经超过3次，IP已封！"
Response.write ""
Response.end
end if
Select Case Cint(sSqlType)
Case 2 : StrType="SQL注入(POST)"
Case 3 : StrType="SQL注入(GET)"
Case 3 : StrType="SQL注入(Cookies)"
Case Else : StrType="非法查询管理员表"
End Select
Execute_L("insert into [Cl_SqlLog] (ScriptName,S_Info,ip,Type) values ('"&Server.URLEnCode(Request.ServerVariables("PATH_INFO"))&"','"&Checkstr(Server.HTMLEnCode(Left(sCommand,250)))&"','"&UserTrueIP&"','"&StrType&"')")
sTemp="您执行了非法操作，操作已被禁止并作了如下记录↓ "
sTemp=sTemp & "操作ＩＰ："&UserTrueIP&" "
sTemp=sTemp & "操作时间："&Now&" "
sTemp=sTemp & "操作页面："&Request.ServerVariables("PATH_INFO")&" "
sTemp=sTemp & "操作方式："&StrType&" "
sTemp=sTemp & "提交数据："&sCommand
Response.write sTemp
Response.end
End Sub
'过滤非法的SQL字符
Public Function ReplaceBadChar(Byval strChar)
strChar=replace(replace(strChar," ",""),"'","")
strChar=replace(replace(strChar,".",""),"<","")
strChar=replace(replace(strChar,")",""),"(","")
strChar=replace(replace(strChar,"?",""),"*","")
strChar=replace(replace(strChar,"/",""),"\","")
ReplaceBadChar=replace(strChar,Chr(0),"")
End Function
Public Function ChkBadWords(Byval Str)
If IsNull(Str) Then Exit Function
Dim i
For i = 0 To Ubound(BadWords)
If i > UBound(rBadWord) Then
Str = Replace(Str,BadWords(i),"*")
Else
Str = Replace(Str,BadWords(i),rBadWord(i))
End If
Next
ChkBadWords = Str
End Function
'求字符串长度。汉字算两个字符，英文算一个字符。
Public Function strLength(Byval str)
If isNull(str) Or Str = "" Then
StrLength = 0:Exit Function
End If
Dim WINNT_CHINESE
WINNT_CHINESE=(len("例子")=2)
If WINNT_CHINESE Then
Dim l,t,c,i
l=len(str):t=l
For i=1 To l
c=asc(mid(str,i,1))
If c<0 Then c=c+65536
If c>255 Then t=t+1
Next
strLength=t
Else
strLength=len(str)
End If
End Function
Public Function Checkstr(Byval Str)
If Isnull(Str) Then
CheckStr = ""
Exit Function
End If
Str = Replace(Str,Chr(0),"")
CheckStr = Replace(Str,"'","''")
End Function
'截字符串，汉字一个算两个字符，英文算一个字符（str）原字符串 （strlen）截取长度
Public Function GotTopic(Byval str,Byval strlen)
dim l, t, c, i
if str="" then gotTopic="" : Exit function
str = replace(replace(str," "," "),""",chr(34))
str = replace(replace(str,">",">"),"<","<")
l = len(str) : t = 0
strlen = Clng(strlen)
for i=1 to l
c=Abs(Asc(Mid(str,i,1)))
if c>255 then
t=t+2
else
t=t+1
end if
if t >= strlen then
'if Abs(Asc(right(str,1)))>255 then
gotTopic=left(str,i) & "..."
exit for
else
gotTopic=str
end if
next
End Function
Public Function FormatNum(Byval num,Byval n)
If Not IsNumeric(num) or num="" Then num=0
If num<1 and num>0 Then
FormatNum = Cdbl("0" & FormatNumber(num,n))
Else
FormatNum = Cdbl(FormatNumber(num,n))
End If
End Function
'时间格式处理
Public Function Format_Time(Byval Tvar,Byval sType)
dim Tt,sYear,sMonth,sDay,sHour,sMinute,sSecond
If Not IsDate(Tvar) or sType=0 Then Format_Time = "" : Exit Function
Tt = Tvar
sYear = Year(Tt)
sMonth = Right("0" & Month(Tt),2)
sDay = Right("0" & Day(Tt),2)
sHour = Right("0" & Hour(Tt),2)
sMinute = Right("0" & Minute(Tt),2)
sSecond = Right("0" & Second(Tt),2)
Select Case sType
Case 1 '2005-10-01 23:45:45
Format_Time = sYear & "-" & sMonth & "-" & sDay & " " & sHour & ":" & sMinute & ":" & sSecond
Case 2 '年-月-日 时:分:秒
Format_Time = sYear & "年" & sMonth & "月" & sDay & "日 " & sHour & "时" & sMinute & "分" & sSecond & "秒"
Case 3 '2005-10-01
Format_Time = sYear & "-" & sMonth & "-" & sDay
Case 4 '2005\10\01
Format_Time = sYear & "\" & sMonth & "\" & sDay
Case 5 '10-01 23:45
Format_Time = sMonth & "-" & sDay & " " & sHour & ":" & sMinute
Case 6 '2005年10月01日
Format_Time = sYear & "年" & sMonth & "月" & sDay & "日"
Case 7 '10-01
Format_Time = sMonth & "-" & sDay
Case 8 '20051001234545
Format_Time = sYear & sMonth & sDay & sHour & sMinute & sSecond
Case Else
Format_Time = Tt
End Select
End Function
Public Function GetTitleFont(Byval sValue,Byval sType)
Select Case ChkClng(sType)
Case 0 : GetTitleFont = sValue
Case 1 : GetTitleFont = "" & sValue & ""
Case 2 : GetTitleFont = "" & sValue & ""
Case 3 : GetTitleFont = "" & sValue & ""
Case 4 : GetTitleFont = "" & sValue & ""
Case 5 : GetTitleFont = "" & sValue & ""
Case 6 : GetTitleFont = "" & sValue & ""
Case 7 : GetTitleFont = "" & sValue & ""
Case Else : GetTitleFont = sValue
End Select
End Function
Public Function FormatColor(Byval sValue,Byval sColor)
sColor=Trim(sColor)
if Isnull(sColor) or sColor="" then FormatColor=sValue : Exit Function
FormatColor = "" & sValue & ""
End Function
'写入客人session
Public Sub LetGuestSession()
Dim statID,GuestSID
GuestSID = checkStr(Trim(Request.Cookies(Web_Cookies)("GuestSID")))
If Not IsNumeric(GuestSID) or GuestSID = "" Then
statID = Split(UserTrueIP,".")
GuestSID = ""
for i=0 to Ubound(statID)
GuestSID=GuestSID&right("00"&statID(i),3)
next
randomize
GuestSID=GuestSID&int(600*rnd+369)
If Not IsNumeric(GuestSID) Then GuestSID = int(10089657999*rnd+25789657939)
'GuestSID = Ccur(GuestSID) & int(600*rnd+369) '随机验证码
End If
GuestSID = Ccur(GuestSID)
Response.Cookies(Web_Cookies).Expires=DateAdd("s",3600,Now())
Response.Cookies(Web_Cookies)("GuestSID") = GuestSID
'客人=SessionID+活动时间+IP
GuestSID = GuestSID & "_" & Now & "_" & Now & "_" & ScriptName
User_Info=Split(GuestSID,"_")
Session(CacheName & "UserID") = User_Info
End Sub
'检查用户是否登录
Public Function ChkUserLogin()
Dim NeedToUpdate,ToUpdate,sUserMsg
ChkUserLogin=False
if UserID=0 Or UserLevel=5 or MemberName="" or MemberWord="" then
UserLevel=5 : UserID=0
If Not IsArray(Session(CacheName & "UserID")) Then Call LetGuestSession()
Exit Function
end if
ToUpdate=False
Name="NeedToUpdate"
If Not ObjIsEmpty() Then
NeedToUpdate=","&Value&","
If InStr(NeedToUpdate,","&MemberName&",")>0 Then
Call NeedUpdateList(MemberName,0)
ToUpdate=True
End If
End If
If Not IsArray(Session(CacheName & "UserID")) or Toupdate Then
GetCacheUserInfo
if Ubound(User_Info)<39 then Exit Function
else
User_Info = Session(CacheName & "UserID")
if Ubound(User_Info)<39 then
GetCacheUserInfo
if Ubound(User_Info)<39 then Exit Function
end if
end if
UserID = Clng(User_Info(4))
MemberName = Trim(User_Info(5))
UserLevel = Clng(User_Info(21))
User_IM = Split(User_Info(13),"|||")
sUserMsg = Split(User_Info(30),"||")
User_Purview= Split(User_Info(34),",")
If Ubound(sUserMsg)=2 Then
SendMsgNum = sUserMsg(0)
SendMsgID = sUserMsg(1)
SendMsgUser = sUserMsg(2)
End If
ChkUserLogin=True
End Function
Public Sub GetCacheUserInfo()
dim RsLogin,SqlLogin,RsGroup,sUserInfo,sValidDays,i
SqlLogin="Select " & Db.UserID & "," & Db.UserName & "," & Db.UserPassWord & ","&Db.UserReName&"," & Db.UserEmail & "," & Db.UserSex & "," & Db.UserFace & "," & Db.UserFaceWidth & "," & Db.UserFaceHeight & "," & Db.UserIM & "," & Db.UserJoinDate & "," & Db.UserLastLogin & "," & Db.UserLogins & "," & Db.UserQuestion & "," & Db.UserAnswer & "," & Db.UserLastIP & "," & Db.UserDataNum & "," & Db.UserLevel & "," & Db.UserPoint & "," & Db.UserMoney & "," & Db.ChargeType & "," & Db.BeginDate & "," & Db.ValidNum & "," & Db.UserTPassWord & "," & Db.WaitReceive & "," & Db.Received & "," & Db.UserMsg & "," & Db.UserLock & " From " & Db.UserTable & " where " & Db.UserID & "=" & UserID
Set RsLogin=Execute_U(sqlLogin)
if RsLogin.bof and RsLogin.eof then
UserLevel=5 : UserID=0 : EmptyCookies : LetGuestSession
RsLogin.Close : Set RsLogin = Nothing : Exit Sub
else
if UserLevel<>rsLogin(17) or RsLogin(27)<>0 or MemberName<>rsLogin(1) or MemberWord<>rsLogin(2) then
UserLevel=5 : UserID=0 : EmptyCookies : LetGuestSession
RsLogin.Close : Set RsLogin = Nothing : Exit Sub
end if
Set RsGroup=Cl.Execute("Select GroupName,GroupImg,LoginPoint,Purview,Purview_Other,arrClassView,arrClassInput,arrClassCheck,arrClassMaster From Cl_UserGroup Where ID="&UserLevel&"")
if RsGroup.Bof and RsGroup.Eof then
UserLevel=5 : UserID=0 : EmptyCookies : LetGuestSession
RsLogin.Close : Set RsLogin = Nothing
RsGroup.Close : Set RsGroup = Nothing : Exit Sub
End if
sValidDays = rsLogin(22)-DateDiff("D",RsLogin(21),now())
if sValidDays<0 then sValidDays=0
sUserInfo = "ClCMS@@@"& Now & "@@@" & Now & "@@@" & ScriptName
For i=0 to 26
sUserInfo = sUserInfo & "@@@" & RsLogin(i)
Next
For i=0 to 8
sUserInfo = sUserInfo & "@@@" & RsGroup(i)
Next
sUserInfo = sUserInfo & "@@@" & sValidDays & "@@@ClCMS"
User_Info = Split(sUserInfo,"@@@")
Session(CacheName & "UserID") = User_Info
RsGroup.Close : Set RsGroup = Nothing
End if
RsLogin.Close : Set RsLogin = Nothing
End Sub
'检查管理员是否登录
Public Function ChkAdminLogin()
ChkAdminLogin=False
if Not ChkUserLogin then Exit Function
Admin_Info = Session(CacheName & "AdminInfo")
if Not IsArray(Admin_Info) then
Dim AdminName,AdminPass,AddUser,rsGetAdmin
AdminName = Trim(Checkstr(session("AdminName")))
AdminPass = Trim(Checkstr(session("AdminPass")))
AddUser = Trim(User_Info(5))
if AdminName="" or AdminPass="" or AddUser="" then Exit Function
'0(ID),1(用户),2(密码),3(权限),4(前台用户)
Set rsGetAdmin=Execute("select ID,UserName,Password,Purview,Purview_Other,arrClassMaster,arrClassCheck,arrClassInput,AddUser from Cl_Admin where UserName='" & AdminName & "' And AddUser='"&AddUser&"'")
if rsGetAdmin.bof and rsGetAdmin.eof then
Set rsGetAdmin=Nothing : Exit Function
ElseIf rsGetAdmin(2) <> AdminPass then
Set rsGetAdmin=Nothing : Exit Function
End if
Admin_Info = Split(rsGetAdmin.GetString(,1, "@@","",""),"@@")
Set rsGetAdmin = Nothing
Session(CacheName & "AdminInfo") = Admin_Info
ElseIF Ubound(Admin_Info)<8 then
Session(CacheName & "AdminInfo") = Empty
ChkAdminLogin = False : Exit Function
End if
Admin_Purview = Split(Admin_Info(3),",")
ChkAdminLogin = True
End Function
Public Function ChkSchoolUser()
Dim rs_IP, sqlIP
Dim sPurview, sarrClassID, sBeginDate, sUseDayNum, sIsClose, sIsLogin
Dim C_sValidDays
ChkSchoolUser=0
set rs_IP = Cl.Execute("select SchoolIP,SchoolName,Purview,arrClassID,BeginDate,UseDayNum,IsClose,IsLogin from [Cl_SchoolIP] Where SchoolIP='"&Cl.UserTrueIP&"'")
if rs_IP.Bof and rs_IP.Eof then
rs_IP.close:set rs_IP=nothing : Exit Function
end if
sPurview = rs_IP(2) : sarrClassID = rs_IP(3)
sBeginDate = rs_IP(4) : sUseDayNum = rs_IP(5)
sIsClose = rs_IP(6) : sIsLogin = rs_IP(7)
rs_IP.close : set rs_IP=nothing
if sIsClose=True then Exit Function
if sIsLogin=True and Not Cl.ChkUserLogin then Exit Function
C_sValidDays=Clng(sUseDayNum - datediff("d",sBeginDate,now))
if C_sValidDays <= 0 then
Cl.Execute("Update Cl_SchoolIP Set IsClose="&TrueType&" Where SchoolIP='"&Cl.UserTrueIP&"'")
Exit Function
end if
if sPurview=1 then
ChkSchoolUser=True
else
Dim Prs,sPPath,n
Set Prs=Cl.Execute("Select ParentPath From Cl_Class Where ClassID=" & Clng(sClassID))
If Not (Prs.Bof And Prs.Eof) then
sPPath=Split(Prs(0) & "," & sClassID,",")
For n=1 to Ubound(sPPath)
If Instr(","&sarrClassID&",",","&sPPath(n)&",")>0 then
IsSchoolUser=True
Exit For
End if
if n>=20 then Exit For '防止进入死循环
Next
End if
Set Prs=Nothing
end if
End Function
Public Function IsTrueSchoolUser(Byval sClassID)
Dim rs_IP, sqlIP
Dim sPurview, sarrClassID, sBeginDate, sUseDayNum, sIsClose, sIsLogin
Dim C_sValidDays
IsSchoolUser=False
set rs_IP = Cl.Execute("select SchoolIP,SchoolName,Purview,arrClassID,BeginDate,UseDayNum,IsClose,IsLogin from [Cl_SchoolIP] Where SchoolIP='"&Cl.UserTrueIP&"'")
if rs_IP.Bof and rs_IP.Eof then
rs_IP.close:set rs_IP=nothing : Exit Function
end if
sPurview = rs_IP(2) : sarrClassID = rs_IP(3)
sBeginDate = rs_IP(4) : sUseDayNum = rs_IP(5)
sIsClose = rs_IP(6) : sIsLogin = rs_IP(7)
rs_IP.close : set rs_IP=nothing
if sIsClose=True then Exit Function
if sIsLogin=True and Not Cl.ChkUserLogin then Exit Function
C_sValidDays=Clng(sUseDayNum - datediff("d",sBeginDate,now))
if C_sValidDays <= 0 then
Cl.Execute("Update Cl_SchoolIP Set IsClose="&TrueType&" Where SchoolIP='"&Cl.UserTrueIP&"'")
Exit Function
end if
if sPurview=1 then
IsSchoolUser=True
else
Dim Prs,sPPath,n
Set Prs=Cl.Execute("Select ParentPath From Cl_Class Where ClassID=" & Clng(sClassID))
If Not (Prs.Bof And Prs.Eof) then
sPPath=Split(Prs(0) & "," & sClassID,",")
For n=1 to Ubound(sPPath)
If Instr(","&sarrClassID&",",","&sPPath(n)&",")>0 then
IsSchoolUser=True
Exit For
End if
if n>=20 then Exit For '防止进入死循环
Next
End if
Set Prs=Nothing
end if
End Function
Public Function GetCookies(sName)
GetCookies=Trim(Request.Cookies(Web_Cookies)(sName))
End Function
Public Sub SetCookies(sName,sValue)
Response.Cookies(Web_Cookies)(sName)=Trim(sValue)
End Sub
Public Sub EmptyCookies()
Response.Cookies(Web_Cookies)("UserID") = Empty
Response.Cookies(Web_Cookies)("UserName") = Empty
Response.Cookies(Web_Cookies)("Password") = Empty
Response.Cookies(Web_Cookies)("UserLevel") = Empty
Response.Cookies(Web_Cookies)("TruePassWord") = Empty
Response.Cookies(Web_Cookies & "Kill")("kill") = Empty
Response.Cookies(Web_Cookies) = Empty
Session(CacheName & "UserID") = Empty
End Sub
'更新验证码
Public Sub SetTruePassWord(UserIDStr)
if isnull(UserIDStr) or not isnumeric(UserIDStr) then Exit Sub
Dim NewTruePassWord
NewTruePassWord=Createpass(16)
Response.Cookies(Web_Cookies)("TruePassWord")=NewTruePassWord
if Checkstr(Trim(Request.Cookies(Web_Cookies)("TruePassWord")))=NewTruePassWord then
Execute_U("Update "&Db.UserTable&" Set " & Db.UserTPassWord & "='"&NewTruePassWord&"' where UserID="&Clng(UserIDStr))
User_Info = Session(CacheName & "UserID")
User_Info(27)=NewTruePassWord
Session(CacheName & "UserID")=User_Info
end if
End Sub
'更新用户资料
Public Sub NewUserInfo(Number,strData)
if not isnumeric(Number) then Exit Sub
Dim str_Info
str_Info=Session(CacheName & "UserID")
If Not IsArray(str_Info) Then Exit Sub
if Ubound(str_Info)<28 then Exit Sub
str_Info(Cint(Number))=Trim(strData)
Session(CacheName & "UserID")=str_Info
End Sub
Public Sub NeedUpdateList(username,act)
Dim Tmpstr,TmpUsername
Name="NeedToUpdate"
If ObjIsEmpty() Then Value=""
Tmpstr=Value
TmpUsername=","&username&","
Tmpstr=Replace(Tmpstr,TmpUsername,",")
Tmpstr=Replace(Tmpstr,",,",",")
IF act=1 Then
'If IsONline(username,0) Then
If Tmpstr="" Then
Tmpstr=TmpUsername
Else
Tmpstr=Tmpstr&TmpUsername
End If
'End If
End If
Tmpstr=Replace(Tmpstr,",,",",")
Value=Tmpstr
End Sub
'系统分配随机密码
Public Function Createpass(Byval LengthNum)
Dim Ran,i
if Not IsNumeric(LengthNum) then LengthNum=16
Createpass=""
For i=1 To LengthNum
Randomize
Ran = CInt(Rnd * 2)
Randomize
Select Case Ran
Case 0
Ran = CInt(Rnd * 25) + 97
Createpass =Createpass& UCase(Chr(Ran))
Case 1
Ran = CInt(Rnd * 9)
Createpass = Createpass & Ran
Case 2
Ran = CInt(Rnd * 25) + 97
Createpass =Createpass& Chr(Ran)
End Select
Next
End Function
Public Function GetUserSex(strSex)
'if UserTableType = "Bbsxp" then
' if strSex="male" then
' GetUserSex="男"
' else
' GetUserSex="女"
' end if
'else
Select Case ChkClng(strSex)
Case 0 : GetUserSex="女"
Case 1 : GetUserSex="男"
Case Else : GetUserSex="保密"
End Select
'end if
End Function
Public Function GetPaymentName(Byval str)
Select Case ChkClng(str)
Case 0 : GetPaymentName="账户支付"
Case 1 : GetPaymentName="在线支付"
Case 2 : GetPaymentName="银行汇款"
Case 3 : GetPaymentName="邮政汇款"
Case Else : GetPaymentName="其它支付"
End Select
End Function
'检查用户权限
Public Function ChkUserLevel(Byval sPurview,Byval sLevel)
ChkUserLevel=False
if Instr(","&sPurview&",",",5,")>0 then
ChkUserLevel=True : Exit Function
end if
if Instr(","&sPurview&",",","&sLevel&",")>0 then ChkUserLevel=True
End Function
'======================================================
'sPurview-----1(Master),2(Check),3(Input)
'======================================================
Public Function TrueChannelPurview(Byval sPurview,Byval sChannelID)
TrueChannelPurview = True
If Cint(Cl.Admin_Purview(0)) = 1 Then Exit Function
If Not IsNumeric(sPurview) or Not IsNumeric(sChannelID) then
TrueChannelPurview = False : Exit Function
end if
If Ubound(Cl.Admin_Purview) < sChannelID Then
TrueChannelPurview = False : Exit Function
Else
if Cint(Cl.Admin_Purview(sChannelID)) <= sPurview Then Exit Function
End if
TrueChannelPurview = False
End Function
Public Function TrueClassPurview(Byval sPurview,Byval sChannelID,Byval sClassID)
TrueClassPurview = True
If Cint(Cl.Admin_Purview(0)) = 1 Then Exit Function
If Not IsNumeric(sPurview) or Not IsNumeric(sChannelID) or Not IsNumeric(sClassID) then
TrueClassPurview = False : Exit Function
end if
If Ubound(Cl.Admin_Purview) < sChannelID Then
TrueClassPurview = False : Exit Function
Else
if Cint(Cl.Admin_Purview(sChannelID)) < 3 Then Exit Function
if Cint(Cl.Admin_Purview(sChannelID)) >= 4 Then TrueClassPurview = False : Exit Function
End if
if Instr(","&Cl.Admin_Info(5)&",",","&sClassID&",")>0 Then
Exit Function
ElseIf sPurview <= 1 Then
TrueClassPurview = False : Exit Function
End If
If Instr(","&Cl.Admin_Info(6)&",",","&sClassID&",")>0 Then
Exit Function
ElseIf sPurview <= 2 Then
TrueClassPurview = False : Exit Function
End If
If Instr(","&Cl.Admin_Info(7)&",",","&sClassID&",")>0 Then
Exit Function
End IF
TrueClassPurview = False
End Function
Public Function TrueOtherPurview(Byval sPurview)
TrueOtherPurview = True
If Cint(Cl.Admin_Purview(0)) = 1 Then Exit Function
if Instr("," & Lcase(Cl.Admin_Info(4)) & ",","," & Lcase(sPurview) & ",")>0 then Exit Function
TrueOtherPurview = False
End Function
'======================================================
'User:sPurview-----1(Master),2(Check),3(Input),4(View)
'======================================================
Public Function TrueChannelPurview_U(Byval sPurview,Byval sChannelID)
TrueChannelPurview_U = True
if UserID=0 or UserLevel=5 then TrueChannelPurview_U = False : Exit Function
If Cint(Cl.User_Purview(0)) = 1 Then Exit Function
If Cint(Cl.User_Purview(0)) > 2 Then TrueChannelPurview_U = False : Exit Function
If Ubound(Cl.User_Purview) < sChannelID Then TrueChannelPurview_U = False : Exit Function
if Cint(Cl.User_Purview(sChannelID)) <= sPurview Then Exit Function
TrueChannelPurview_U = False
End Function
Public Function TrueClassPurview_U(Byval sPurview,Byval sChannelID,Byval sClassID)
TrueClassPurview_U = True
if UserID=0 or UserLevel=5 then TrueClassPurview_U = False : Exit Function
If Cint(Cl.User_Purview(0)) = 1 Then Exit Function
If Cint(Cl.User_Purview(0)) > 2 Then TrueClassPurview_U = False : Exit Function
If Not IsNumeric(sPurview) or Not IsNumeric(sChannelID) or Not IsNumeric(sClassID) then
TrueClassPurview_U = False : Exit Function
end if
If Ubound(Cl.User_Purview) < sChannelID Then TrueClassPurview_U = False : Exit Function
Select Case Cint(Cl.User_Purview(sChannelID))
Case 1
Exit Function
Case 2
If sPurview >= 2 Then Exit Function
Case 3
If Instr(","&Cl.User_Info(39)&",",","&sClassID&",")>0 Then
TrueClassPurview_U = True : Exit Function
ElseIf sPurview <= 1 Then
TrueClassPurview_U = False : Exit Function
End If
If Instr(","&Cl.User_Info(38)&",",","&sClassID&",")>0 Then
Exit Function
ElseIf sPurview <= 2 Then
TrueClassPurview_U = False : Exit Function
End If
If Instr(","&Cl.User_Info(37)&",",","&sClassID&",")>0 Then
Exit Function
ElseIf sPurview <= 3 Then
TrueClassPurview_U = False : Exit Function
End If
If Instr(","&Cl.User_Info(36)&",",","&sClassID&",")>0 Then
Exit Function
End IF
Case 4, 5
If sPurview >= 3 Then Exit Function
Case 6
If sPurview >= 4 Then Exit Function
End Select
TrueClassPurview_U = False
End Function
Public Function TrueOtherPurview_U(Byval sPurview)
TrueOtherPurview_U = True
if UserID=0 or UserLevel=5 then TrueOtherPurview_U = False : Exit Function
If Cint(Cl.User_Purview(0)) = 1 Then Exit Function
if Instr("," & Lcase(Cl.User_Info(35)) & ",","," & Lcase(sPurview) & ",")>0 then Exit Function
TrueOtherPurview_U = False
End Function
Public Function TrueBrowsePurview()
TrueBrowsePurview=False
Select Case BrowsePurview
Case 0 : TrueBrowsePurview=True
Case 1
if TrueChannelPurview_U(1,ChannelID) then
TrueBrowsePurview=True
else
Dim sTr,i
sTr=Split(ParentPath & "," & ClassID,",")
for i=1 to Ubound(sTr)
TrueBrowsePurview=TrueClassPurview_U(4,ChannelID,sTr(i))
if TrueBrowsePurview=True then Exit For
Next
end if
Case 2
if Instr("|"&VipUser&"|","|"&MemberName&"|")>0 or UserLevel=1 then
TrueBrowsePurview=True
end if
End Select
End Function
'取得用户级别
Public Function GetUserGroupName(Byval sLevel)
Name="UserGroup"
if ObjIsEmpty then LoadUserGroup
Dim sGroup,sRow,sGL,n
sGroup=Split(Value,"@@")
If IsNull(sLevel) or sLevel="" then Exit Function
if Instr(sLevel,",")>0 then
Dim sL
sLevel=Split(sLevel,","):sGL=","
for sL=0 to Ubound(sLevel)
for n=0 to Ubound(sGroup)-1
sRow=Split(sGroup(n),"||")
if ChkClng(sRow(0))=ChkClng(sLevel(sL)) then
sGL=sGL & "," & sRow(1) : Exit For
end if
Next
Next
sGL=Replace(sGL,",,","")
else
for n=0 to Ubound(sGroup)-1
sRow=Split(sGroup(n),"||")
if ChkClng(sRow(0))=ChkClng(sLevel) then
sGL=sRow(1):Exit For
end if
Next
end if
GetUserGroupName=sGL
End Function
Public Function UserGroup_Option(Byval sLevel)
Name="UserGroup"
if ObjIsEmpty then LoadUserGroup
Dim sGroup,sRow,n,sTemp
sGroup=Split(Value,"@@"):sTemp=""
for n=0 to Ubound(sGroup)-1
sRow=Split(sGroup(n),"||")
if Instr(","&sLevel&",",","&sRow(0)&",")>0 then
sTemp=sTemp & ""
else
sTemp=sTemp & ""
end if
Next
UserGroup_Option=sTemp
End Function
'缓存用户级别
Public Sub LoadUserGroup()
Dim rs
Set rs=Execute("Select ID,GroupName,GroupImg,Purview,Purview_Other,arrClassView,arrClassInput,arrClassCheck,arrClassMaster from Cl_UserGroup Order by ID")
if rs.bof and rs.eof then
Value=""
else
Value=rs.GetString(,,"||","@@","")
end if
End Sub
Public Function GetClassUrl(Byval sPathType, Byval sHtmlDir, Byval sChannelDir, Byval sParentPath, _
Byval sClassID, Byval sParentDir, Byval sClassDir, Byval sIsCreate, Byval sCreateFileExt)
if Clng(sIsCreate)=1 and CBool(Channel_Setting(14)) then
GetClassUrl=GetItemPath(sPathType, sHtmlDir, sChannelDir, sParentPath, sClassID, sParentDir, sClassDir) & sClassID &"_Index." & sCreateFileExt
else
GetClassUrl=sChannelDir &"/ShowClass.asp?ClassID="&sClassID
end if
End Function
Public Function GetItemPath(Byval sPathType, Byval sHtmlDir, Byval sChannelDir, _
Byval sParentPath, Byval sClassID, Byval sParentDir, Byval sClassDir)
Select Case Clng(sPathType)
Case 0 'HtmlDir/频道/大类/小类/文件
GetItemPath = sHtmlDir & sChannelDir & "/" & sParentDir & sClassDir & "/"
Case 1 'HtmlDir/频道/大类(ClassID)/小类(ClassID)/文件
GetItemPath = sHtmlDir & sChannelDir & "/" & GetClassIDPath(sParentPath, sClassID) & "/"
Case 2 'HtmlDir/频道/栏目(英文)/文件
GetItemPath = sHtmlDir & sChannelDir & "/" & sClassDir & "/"
Case 3 'HtmlDir/频道/栏目(ClassID)/文件
GetItemPath = sHtmlDir & sChannelDir & "/" & "Class" & sClassID&"/"
Case 4 'HtmlDir/频道/文件
GetItemPath = sHtmlDir & sChannelDir & "/"
Case 5 'HtmlDir/频道/年月/文件
GetItemPath = sHtmlDir & sChannelDir & "/" & Year(Now()) & Right("0" & Month(Now()),2) & "/"
Case 6 'HtmlDir/频道/年/月/文件
GetItemPath = sHtmlDir & sChannelDir & "/" & Year(Now()) & "/" & Right("0" & Month(Now()),2) & "/"
Case 7 '频道/Html目录/大类(英文目录)/小类(英文目录)/文件
GetItemPath = sChannelDir & "/" & sHtmlDir & sParentDir & sClassDir & "/"
Case 8 '频道/Html目录/大类(ClassID)/小类(ClassID)/文件
GetItemPath = sChannelDir & "/" & sHtmlDir & GetClassIDPath(sParentPath, sClassID) & "/"
Case 9 '频道/大类(英文目录)/小类(英文目录)/文件
GetItemPath = sChannelDir & "/" & sParentDir & sClassDir & "/"
Case 10 '频道/大类(ClassID)/小类(ClassID)/文件
GetItemPath = sChannelDir & "/" & GetClassIDPath(sParentPath, sClassID) & "/"
Case 11 '频道/Html目录/栏目(英文目录)/文件
GetItemPath = sChannelDir & "/" & sHtmlDir & "/" & sClassDir & "/"
Case 12 '频道/Html目录/栏目(ClassID)/文件
GetItemPath = sChannelDir & "/" & sHtmlDir & "/" & "Class" & sClassID & "/"
Case 13 '频道/栏目(英文目录)/文件
GetItemPath = sChannelDir & "/" & sClassDir & "/"
Case 14 '频道/栏目(ClassID)/文件
GetItemPath = sChannelDir & "/" & "Class" & sClassID&"/"
Case 15 '频道/Html目录/文件
GetItemPath = sChannelDir & "/" & sHtmlDir & "/"
Case 16 '频道/Html目录/年月/文件
GetItemPath = sChannelDir & "/" & sHtmlDir & "/" & Year(Now()) & Right("0" & Month(Now()),2) & "/"
Case 17 '频道/Html目录/年/月/文件
GetItemPath = sChannelDir & "/" & sHtmlDir & "/" & Year(Now()) & "/" & Right("0" & Month(Now()),2) & "/"
Case Else
GetItemPath = sHtmlDir & sChannelDir & "/" & sParentDir & sClassDir & "/"
End Select
GetItemPath = Replace(GetItemPath, "//", "/")
if Not CheckFolder(Webdir&GetItemPath,False) then
dim objFSO,sPath,tPath,i
Set objFSO = Server.CreateObject(Trim(Cl.Web_Info(13)))
tPath = Split(GetItemPath,"/")
sPath = WebDir
For i=0 to Ubound(tPath)-1
If objFSO.FolderExists(Server.MapPath(sPath & tPath(i)))=False Then
objFSO.CreateFolder Server.MapPath(sPath & tPath(i))
End If
sPath = sPath & tPath(i) & "/"
Next
Set objFSO = Nothing
end if
End Function
Public Function GetItemFileName(ByVal sType, ByVal sClassID, ByVal sInfoID, ByVal sInfoTime)
Select Case Clng(sType)
Case 0 'ID + 时间(20051001234545)
GetItemFileName = sInfoID & Format_Time(sInfoTime,8)
Case 1 'ID
GetItemFileName = sInfoID
Case 2 'ID + 时间(20051001234545)
GetItemFileName = Format_Time(sInfoTime,8)
Case 3 '栏目ID + _ + ID + 时间(20051001234545)
GetItemFileName = sClassID & "_" & sInfoID & Format_Time(sInfoTime,8)
Case 4 '栏目ID + _ + ID
GetItemFileName = sClassID & "_" & sInfoID
Case 5 '栏目ID + _ + 时间(20051001234545)
GetItemFileName = sClassID & "_" & Format_Time(sInfoTime,8)
Case Else 'ID
GetItemFileName = sInfoID
End Select
End Function
Public Function GetItemIndexPath(ByVal sPathType, ByVal sHtmlDir, ByVal sChannelDir)
Select Case Clng(sPathType)
Case 0, 1, 2, 3, 4, 5, 6 'HtmlDir/频道/
GetItemIndexPath = sHtmlDir & sChannelDir & "/"
Case 7, 8, 11, 12, 15, 16, 17 '频道/Html目录/
GetItemIndexPath = sChannelDir & "/" & sHtmlDir & "/"
Case 9, 10, 13, 14 '频道/
GetItemIndexPath = sChannelDir & "/"
Case Else
GetItemIndexPath = sHtmlDir & sChannelDir & "/"
End Select
GetItemIndexPath = Replace(GetItemIndexPath, "//", "/")
if Not CheckFolder(Webdir&GetItemIndexPath&"Special/",False) then
dim objFSO,sPath,tPath,i
Set objFSO = Server.CreateObject(Trim(Cl.Web_Info(13)))
tPath = Split(GetItemIndexPath,"/")
sPath = WebDir
For i=0 to Ubound(tPath)-1
If objFSO.FolderExists(Server.MapPath(sPath & tPath(i)))=False Then
objFSO.CreateFolder Server.MapPath(sPath & tPath(i))
End If
sPath = sPath & tPath(i) & "/"
Next
objFSO.CreateFolder Server.MapPath(sPath&"Special/")
objFSO.CreateFolder Server.MapPath(sPath&"Update/")
objFSO.CreateFolder Server.MapPath(sPath&"Elite/")
objFSO.CreateFolder Server.MapPath(sPath&"Hot/")
Set objFSO = Nothing
end if
End Function
Public Sub CreateFolder(Byval sFolder)
On Error Resume Next
Dim objFSO
err=0
sFolder=Server.MapPath(sFolder)
Set objFSO = Server.CreateObject(Trim(Cl.Web_Info(13)))
If Not objFSO.FolderExists(sFolder) Then
objFSO.CreateFolder sFolder
End If
Set objFSO = Nothing
err=0
End Sub
Public Sub DelFolder(Byval sFolder)
On Error Resume Next
Dim objFSO
err=0
sFolder=Server.MapPath(sFolder)
Set objFSO = Server.CreateObject(Trim(Cl.Web_Info(13)))
If objFSO.FolderExists(sFolder) Then
objFSO.DeleteFolder sFolder,True
End If
Set objFSO = Nothing
err=0
End Sub
Public Function MoveFolder(Byval oFolder,Byval nFolder)
On Error Resume Next
Dim objFSO
err=0
MoveFolder=False
oFolder=Server.MapPath(oFolder)
nFolder=Server.MapPath(nFolder)
Set objFSO = Server.CreateObject(Trim(Cl.Web_Info(13)))
If objFSO.FolderExists(nFolder) Then
MoveFolder=False
Else
objFSO.MoveFolder oFolder,nFolder
MoveFolder=True
End If
Set objFSO = Nothing
err=0
End Function
'检查目录是否存在！(sFolderPath,sIsCreate 不存在是否创建)
Public Function CheckFolder(byval sFolder,byval sIsCreate)
On Error Resume Next
Dim objFSO
CheckFolder=False:err=0
sFolder=Server.MapPath(sFolder)
Set objFSO = Server.CreateObject(Trim(Cl.Web_Info(13)))
If objFSO.FolderExists(sFolder) Then
CheckFolder=True
ElseIf sIsCreate=True then
objFSO.CreateFolder sFolder
if err=0 then CheckFolder=True
End If
Set objFSO = Nothing
err=0
End Function
'按月份自动分类（By梅傲风）
Public Function CreatePath(Byval sTopPath,Byval sSort)
Dim objFSO,sPath,tPath,i
if Not IsNumeric(sSort) then sSort=0
sTopPath=Replace(sTopPath&"/","//","/")
Select Case sSort
Case 1 : sPath = year(now) '以年分类，格式：2005
Case 2 : sPath = year(now)&"-"&month(now) '以年-月分类，格式：2005-9
Case 3 : sPath = year(now)&"/"&month(now) '以年/月分类，格式：2005/9
Case 4 : sPath = year(now)&"-"&month(now)&"-"&day(now) '以年-月-日分类，格式：2005-9-28
Case 5 : sPath = year(now)&"-"&month(now)&"/"&day(now) '以年-月/日分类，格式：2005-9/28
Case 6 : sPath = year(now)&"/"&month(now)&"/"&day(now) '以年/月/日分类，格式：2005/9/28
Case Else : sPath = year(now)
End Select
On Error Resume Next
Err.Number = 0
Set objFSO = Server.CreateObject(Trim(Cl.Web_Info(13)))
If objFSO.FolderExists(Server.MapPath(sTopPath))=False Then
objFSO.CreateFolder Server.MapPath(sTopPath)
End If
If Err.Number = 0 Then
tPath = Split(sPath,"/")
For i=0 to Ubound(tPath)
If objFSO.FolderExists(Server.MapPath(sTopPath & tPath(i)))=False Then
objFSO.CreateFolder Server.MapPath(sTopPath & tPath(i))
End If
sTopPath = sTopPath & tPath(i) & "/"
Next
Else
Err.Clear
End If
Set objFSO = Nothing
CreatePath = sTopPath
End Function
'取得文件路径
Public Function GetClassIDPath(sParentPath, sClassID)
Dim P,tPath
GetClassIDPath="":tPath=sParentPath
if Instr(tPath,",")>0 or Instr(tPath,"|")>0 then
tPath=Split(Replace(tPath,"|",","),",")
for p=1 to Ubound(tPath)
GetClassIDPath=GetClassIDPath & "Class" & tPath(p)&"/"
next
end if
GetClassIDPath=GetClassIDPath & "Class" & sClassID&"/"
End Function
Public Function Getstar(starNum)
Getstar = ""
starNum = ChkClng(starNum)
if starNum<1 or starNum>5 then Exit Function
Getstar = ""
End Function
'显示验证码
Public Function GetCode(CodeType)
GetCode=""
End Function
'检查验证码是否正确
Public Function CodeIsTrue(CodeStr,CodeType)
'Dim CodeStr
CodeType=Trim(CodeType):CodeStr=Trim(CodeStr)
If CStr(Session(CodeType)&"")=CStr(CodeStr&"") And CodeStr<>"" Then
CodeIsTrue=True
Session(CodeType)=Empty
Else
CodeIsTrue=False
Session(CodeType)=Empty
End If
End Function
'检查Email地址合法性
Public Function ChkEmail(email)
dim names, name, i, c
ChkEmail = true : names = Split(email, "@")
if UBound(names) <> 1 then ChkEmail = false : Exit Function
for each name in names
if Len(name) <= 0 then ChkEmail = false:exit function
for i = 1 to Len(name)
c = Lcase(Mid(name, i, 1))
if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
ChkEmail = false:Exit Function
end if
next
if Left(name, 1) = "." or Right(name, 1) = "." then
ChkEmail = false:Exit Function
end if
next
if InStr(names(1), ".") <= 0 then ChkEmail = false:exit function
i = Len(names(1)) - InStrRev(names(1), ".")
if i <> 2 and i <> 3 then ChkEmail = false : Exit function
if InStr(email, "..") > 0 then ChkEmail = false
End Function
'检查组件是否已经安装
Public Function ChkObjInstalled(strClassString)
On Error Resume Next
ChkObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then ChkObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
'判断提交信息是否来自外部
Public Function ChkIsOuter()
Dim server_v1,server_v2
ChkIsOuter=True
server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
If Mid(server_v1,8,len(server_v2))=server_v2 Then ChkIsOuter=False
End Function
'向地址中加入 ? 或 &
Public Function JoinChar(strUrl)
if strUrl="" then JoinChar="":Exit Function
if InStr(strUrl,"?")1 then
if InStr(strUrl,"&") 0 Then
IsSafeStr = False
Exit Function
End If
Next
End Function
'获取任何表任何字段信息函数（字段名,表名,过滤,是否用户表1为是）
Public Function GetTableInfo(ColumnName,TableName,StrWhere,IsUser)
'On Error Resume Next
dim RsStr,SqlStr
SqlStr="select " & ColumnName & " from [" & TableName & "] where "&StrWhere&""
If IsUser=1 then
Set RsStr=Execute_U(SqlStr)
Else
Set RsStr=Execute(SqlStr)
End If
If Err Then
GetTableInfo=""
RsStr.close:set RsStr=Nothing
Exit Function
End if
if RsStr.bof and RsStr.Eof then
GetTableInfo=""
else
GetTableInfo=RsStr(0)
end if
RsStr.close:set RsStr=Nothing
End Function
Public Sub InToDataBase(DataBaseName,TableName,ColumnName,ColumnValue)
On Error Resume Next
dim sConn,sConnstr
Set sConn = Server.CreateObject("ADODB.Connection")
sConnstr="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(DataBaseName)
sConn.Open sConnstr
sConn.Execute("insert into ["&TableName&"] ("&ColumnName&") values ("&Replace(Replace(ColumnValue,"True","1"),"False","0")&")")
sConn.Close:Set sConn = Nothing
If Err Then
Response.Write "在数据库"&DataBaseName&"表"&TableName&"中添加记录失败！原因：" & Err.Description
Err.Clear
End If
End Sub
Public Sub InToColumn(TableName,ColumnName,ColumnValue)
On Error Resume Next
Execute("insert into ["&TableName&"] ("&ColumnName&") values ("&Replace(Replace(ColumnValue,"True","1"),"False","0")&")")
If Err Then
Response.Write "在数据库表"&TableName&"中添加记录失败！原因：" & Err.Description
Err.Clear
'Response.end
End If
End Sub
Public Sub SaveAdminLog()
On Error Resume Next
Dim RequestStr
RequestStr = Request("Action")
If RequestStr<>"" Then
RequestStr=Left("Action="&RequestStr & "&"&request.ServerVariables("QUERY_STRING"),200)
RequestStr=CheckStr(URLDecode(RequestStr))
SQL="Insert Into Cl_AdminLog (UserID,UserName,UserLevel,UserIP,ScriptName,LogContent,LogTime) values ("&Cl.User_Info(4)&",'"&Cl.User_Info(5)&"',"&Cl.User_Info(21)&",'"&Cl.UserTrueIP&"','"&Cl.ScriptName&"','"&RequestStr&"','"&Now&"')"
Cl.Execute_L(SQL)
End If
If request.form<>"" Then
RequestStr=Left(request.form,200)
RequestStr=CheckStr(URLDecode(RequestStr))
SQL="Insert Into Cl_AdminLog (UserID,UserName,UserLevel,UserIP,ScriptName,LogContent,LogTime) values ("&Cl.User_Info(4)&",'"&Cl.User_Info(5)&"',"&Cl.User_Info(21)&",'"&Cl.UserTrueIP&"','"&Cl.ScriptName&"','"&RequestStr&"','"&Now&"')"
Cl.Execute_L(SQL)
End if
If Err Then
'Response.Write "添加管理事件记录失败！原因：" & Err.Description
Err.Clear
End If
End Sub
'Server.URLEncode解码函数
Public Function URLDecode(byval enStr)
dim deStr, c, i, v
deStr=""
for i=1 to len(enStr)
c=Mid(enStr,i,1)
if c="%" then
v=eval("&h"+Mid(enStr,i+1,2))
if v<128 then
deStr=deStr&chr(v)
i=i+2
else
if IsValidHex(mid(enstr,i,3)) then
if IsValidHex(mid(enstr,i+3,3)) then
v=eval("&h"+Mid(enStr,i+1,2)+Mid(enStr,i+4,2))
deStr=deStr&chr(v)
i=i+5
else
v=eval("&h"+Mid(enStr,i+1,2)+cstr(hex(asc(Mid(enStr,i+3,1)))))
deStr=deStr&chr(v)
i=i+3
end if
else
destr=destr&c
end if
end if
else
if c="+" then
deStr=deStr&" "
else
deStr=deStr&c
end if
end if
next
URLDecode=deStr
End Function
Public Function IsValidHex(byval str)
Dim c
IsValidHex=true
str=ucase(str)
if len(str)<>3 then IsValidHex=False : Exit Function
if left(str,1)<>"%" then IsValidHex=False : Exit Function
c=mid(str,2,1)
if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then IsValidHex=False : Exit Function
c=mid(str,3,1)
if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then IsValidHex=False : Exit Function
End Function
'防SQL注入
Public Sub ChkSQLInWord()
Dim InWordStr,NameStr,i
Dim FormWord,QueryStringWord,CookiesWord
CacheData(13,0) = Trim(CacheData(13,0))
if CacheData(13,0)="" then Exit Sub
InWordStr = Split(LCase(CacheData(13,0)),"|")
For Each NameStr In Request.Form 'POST
FormWord = FormWord & "|" & Request.Form(NameStr)
Next
For Each NameStr In Request.QueryString 'GET
QueryStringWord = QueryStringWord & "|" & Request.QueryString(NameStr)
Next
For Each NameStr In Request.Cookies(Web_Cookies) 'Cookies
CookiesWord = CookiesWord & "|" & Request.Cookies(Web_Cookies)(NameStr)
Next
FormWord = LCase(FormWord) & ""
QueryStringWord = LCase(QueryStringWord) & ""
CookiesWord = LCase(CookiesWord) & ""
For i=0 To Ubound(InWordStr)
If Instr(LCase(FormWord & ""),InWordStr(i))<>0 Then
Call SaveSQLLOG(2,FormWord)
end If
If Instr(LCase(QueryStringWord & ""),InWordStr(i))<>0 Then
Call SaveSQLLOG(3,QueryStringWord)
end If
If Instr(LCase(CookiesWord & ""),InWordStr(i))<>0 Then
Call SaveSQLLOG(4,CookiesWord)
end if
Next
End Sub
'显示"上一页 下一页":链接地址,总数,页数,单位,项目名
Public Function ShowPage(sFileName,TotalNumber,MaxperPage,sUnit,sItem)
dim n, i, sTemp, strUrl
n = TotalPages
sTemp = sTemp & "
"
End Function
Public Sub ChecKIPlock()
Dim IPlock
IPlock = False
Dim locklist
If Checkstr(CacheData(9,0))="" Then Exit Sub
Dim i,StrUserIP,StrKillIP
StrUserIP=UserTrueIP
If StrUserIP="" Then Exit Sub
locklist=Split(Checkstr(CacheData(9,0)),"|")
StrUserIP=Split(UserTrueIP,".")
If Ubound(StrUserIP)<>3 Then Exit Sub
For i= 0 to UBound(locklist)
locklist(i)=Checkstr(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(Web_Cookies & "Kill")("kill") = "Yes"
Else
Response.Cookies(Web_Cookies & "Kill")("kill") = "No"
End If
End Sub
Function OutMsg(Message,GoToUrl)
Message = Replace(Message,"'","")
If GoToUrl="-1" Then
Response.Write ""
Else
Response.Write ""
End If
Response.End
End Function
Public Sub OutErr(ErrCodes)
Response.Redirect WebDir & "Showerr.asp?action=Ohter&ErrCodes="&HTMLCode(ErrCodes)&""
Response.End
End Sub
'显示成功提示信息
Public Function ShowSuc(Message)
LoadTemplates("")
ShowSuc = Replace(mainhtml(11),"{%sucmsg%}",Message)
'response.end
End Function
'显示错误提示信息
Public Function ShowErr(Message)
LoadTemplates("")
ShowErr = Replace(mainhtml(12),"{%errmsg%}",Message)
'response.end
End Function
'显示错误提示信息
Public Function NotLoginErr(sLevel,sFunName)
LoadTemplates("")
NotLoginErr = Replace(Cl.lanstr(7),"{%level%}",GetUserGroupName(sLevel))
NotLoginErr = Replace(NotLoginErr,"{%function%}",sFunName)
End Function
Public Function ReplaceLabel(Byval sTrC)
Name="ReplaceLabel"
if ObjIsEmpty() then
Dim RsLabel
Set RsLabel = Execute("Select LabelName,LabelContent from Cl_Label Order By LabelPriority,LabelID")
if RsLabel.bof or RsLabel.eof then
Value=""
else
Value=RsLabel.GetString(,,"||","@@","")
end if
Set RsLabel = Nothing
end if
if Value<>"" then
dim sRow,sCol,i
sRow=Split(Value,"@@")
for i=0 to Ubound(sRow)-1
sCol=Split(sRow(i),"||")
sTrC = Replace(sTrC,"{%"&Trim(sCol(0))&"%}",sCol(1))
next
end if
ReplaceLabel=sTrC
End Function
Public Function ReplaceKeyword(Byval sTrC)
Name="ReplaceKeyword"
if ObjIsEmpty() then
Dim RsKeyword
Set RsKeyword = Execute("Select KeywordName,KeywordColor,KeywordLink from Cl_Keyword Order By KeywordPriority,KeywordID")
if RsKeyword.bof or RsKeyword.eof then
Value=""
else
Value=RsKeyword.GetString(,,"||","@@","")
end if
Set RsKeyword = Nothing
end if
if Value<>"" then
dim sRow,sCol,i
sRow=Split(Value,"@@")
for i=0 to Ubound(sRow)-1
sCol=Split(sRow(i),"||")
sTrC = Replace(sTrC,Trim(sCol(0)),""&Trim(sCol(0))&"")
next
end if
ReplaceKeyword=sTrC
End Function
Public Function ReplaceFlag(Byval sTrC,Byval strFlag,Byval strData)
Dim regEx,Matches,Match,TempStr
sTrC = Replace(sTrC,"","%}")
ReplaceFlag = sTrC
Set regEx = New RegExp
regEx.Pattern = "(\{%"&strFlag&")(.[^\{]*)(\%\})"
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(sTrC)
For Each Match in Matches
TempStr = Replace(Match.Value,"{%","")
TempStr = Replace(TempStr,"%}","")
TempStr = Replace(TempStr,"(",",")
TempStr = Replace(TempStr,")","")
TempStr = Replace(TempStr,"""","")
if strData<>"" then
ReplaceFlag = Replace(ReplaceFlag,Match.Value,strData)
else
ReplaceFlag = Replace(ReplaceFlag,Match.Value,GetLabelContent(TempStr,sTrC))
end if
Next
End Function
Public Function ReplaceAllFlag(Byval sTrC)
Dim regEx,Matches,Match,TempValue,ArrayStr,DataStr
sTrC = Replace(sTrC,"{%showhead%}",Cl.Head)
sTrC = Replace(sTrC,"{%showfooter%}",Cl.Bottom)
sTrC = ReplaceLabel(sTrC)
sTrC = ReplacePublicFlag(sTrC)
Set regEx = New RegExp
regEx.IgnoreCase= True
regEx.Global = True
regEx.Pattern = "(\【)(.[^\【]*)(\】)"
Set Matches = regEx.Execute(sTrC)
For Each Match in Matches
TempValue = Match.Value
TempValue = Replace(TempValue,"【","")
TempValue = Replace(TempValue,"】","")
'TempValue = Replace(TempValue,"(",",")
'TempValue = Replace(TempValue,")","")
TempValue = Replace(TempValue,"""","")
ArrayStr = Split(TempValue,",")
Select Case Lcase(ArrayStr(0))
Case "getarticle"
sTrC = Replace(sTrC,Match.Value,GetArticle(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14)))
Case "getsoft"
sTrC = Replace(sTrC,Match.Value,GetSoft(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14)))
Case "getphoto"
sTrC = Replace(sTrC,Match.Value,GetPhoto(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14)))
Case "getmovie"
sTrC = Replace(sTrC,Match.Value,GetMovie(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14)))
Case "getproduct"
sTrC = Replace(sTrC,Match.Value,GetProduct(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14)))
End Select
Next
regEx.Pattern = "(\{%mainhtml)(.[^\{]*)(\%\})"
Set Matches = regEx.Execute(sTrC)
For Each Match in Matches
TempValue = Replace(Match.Value,"{%","")
TempValue = Replace(TempValue,"%}","")
TempValue = Replace(TempValue,"(",",")
TempValue = Replace(TempValue,")","")
ArrayStr = Split(TempValue,",")
sTrC = Replace(sTrC,Match.Value,Cl.mainhtml(ArrayStr(1)))
Next
regEx.Pattern = "(\{%)(.[^\{]*)(\%\})"'"{%([^{%}])*%}"
Set Matches = regEx.Execute(sTrC)
For Each Match in Matches
TempValue = Match.Value
'TempValue = Replace(TempValue,Chr(13) & Chr(10),"")
TempValue = Replace(TempValue,"{%","")
TempValue = Replace(TempValue,"%}","")
TempValue = Replace(TempValue,"(",",")
TempValue = Replace(TempValue,")","")
TempValue = Replace(TempValue,"""","")
sTrC = Replace(sTrC,Match.Value,GetLabelContent(TempValue,sTrC))
Next
sTrC = Replace(sTrC,"{%temploadjs%}","")
sTrC = Replace(sTrC,"{%width%}",mainsetting(0))
sTrC = Replace(sTrC,"{%webname%}",Web_info(0))
sTrC = Replace(sTrC,"{%weburl%}",Web_info(4))
sTrC = Replace(sTrC,"{%picurl%}",WebDir&Cl.Web_PicUrl)
sTrC = Replace(sTrC,"{%channelid%}",ChannelID)
sTrC = Replace(sTrC,"{%channelname%}",ChannelName)
sTrC = ReplaceDir(sTrC)
'sTrC = ReplaceItem(sTrC)
ReplaceAllFlag = sTrC
Set Matches = Nothing : Set regEx = Nothing
End Function
Public Function ReplaceDir(Byval sTrC)
sTrC = Replace(sTrC,"{%webdir%}",WebDir)
sTrC = Replace(sTrC,"{%admindir%}",Web_Info(14))
sTrC = Replace(sTrC,"{%bbsdir%}",BbsDir)
sTrC = Replace(sTrC,"{%uploaddir%}",UploadDir)
'sTrC = Replace(sTrC,"{%downloaddir%}",DownLoadDir)
sTrC = Replace(sTrC,"{%channeldir%}",ChannelDir)
ReplaceDir = sTrC
End Function
Public Function ReplaceItem(Byval sTrC)
sTrC = Replace(sTrC,"{%channelitemname%}",ChannelItemName)
sTrC = Replace(sTrC,"{%channelitemunit%}",ChannelItemUnit)
sTrC = Replace(sTrC,"{%moneyitemname%}",Web_Setting(26))
sTrC = Replace(sTrC,"{%moneyitemunit%}",Web_Setting(27))
sTrC = Replace(sTrC,"{%pointitemname%}",Web_Setting(28))
sTrC = Replace(sTrC,"{%pointitemunit%}",Web_Setting(29))
ReplaceItem = sTrC
End Function
Public Sub MakeHtml(Byval MakeData,Byval MakeFileName)
Dim Fso,Make
On Error Resume Next
Err=0
MakeFileName=Trim(MakeFileName)
Set Fso = CreateObject(Trim(Cl.Web_Info(13)))
Set Make = Fso.CreateTextFile(Server.MapPath(MakeFileName), True)
Make.Write MakeData & vbNewLine & _
" "
Set Make = Nothing
Set Fso = Nothing
If 0 <> Err Then
Response.Write "生成（"&MakeFileName&"）失败，请检查你的服务器是否有FSO(FileSystemObject)！ "
End if
Err=0
End Sub
'取得带端口的URL
Public Function Get_ScriptNameUrl()
If request.servervariables("SERVER_PORT")="80" Then
Get_ScriptNameUrl="http://" & request.servervariables("server_name")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
Else
Get_ScriptNameUrl="http://" & request.servervariables("server_name")&":"&request.servervariables("SERVER_PORT")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
End If
End Function
' 转为根路径格式
Public Function RelativePath2RootPath(Byval url)
Dim sTempUrl
sTempUrl = url
If Left(sTempUrl, 1) = "/" Then
RelativePath2RootPath = sTempUrl
Exit Function
End If
Dim sNowPath
sNowPath = Request.ServerVariables("SCRIPT_NAME")
sNowPath = Left(sNowPath, InstrRev(sNowPath, "/") - 1)
Do While Left(sTempUrl, 3) = "../"
sTempUrl = Mid(sTempUrl, 4)
sNowPath = Left(sNowPath, InstrRev(sNowPath, "/") - 1)
Loop
RelativePath2RootPath = sNowPath & "/" & sTempUrl
End Function
' 根路径转为带域名全路径格式
Public Function RootPath2DomainPath(Byval url)
Dim sHost, sPort
sHost = Split(Request.ServerVariables("SERVER_PROTOCOL"), "/")(0) & "://" & Request.ServerVariables("HTTP_HOST")
sPort = Request.ServerVariables("SERVER_PORT")
If sPort <> "80" Then sHost = sHost & ":" & sPort
RootPath2DomainPath = sHost & url
End Function
Public Function GetSize(Byval size,Byval unit)
if isEmpty(size) or Not Isnumeric(size) then Exit Function
size=CheckUnit(size,unit)
if size>1024 then
size=(size/1024)
getsize=formatnumber(size,2) & " MB"
else
getsize=size & " KB"
Exit Function
end if
if size>1024 then
size=(size/1024)
getsize=formatnumber(size,2) & " GB"
end if
End Function
Public Function CheckUnit(Byval size,Byval unit)
Select Case Lcase(Unit)
Case "b"
CheckUnit = formatnumber(size/1024,2)
Case "k"
CheckUnit = size
Case "m"
CheckUnit = (size*1024)
Case "g"
CheckUnit = (size*1024*1024)
Case Else
CheckUnit = size
End Select
End Function
Public Sub DelFiles(Byval strFiles)
if strFiles="" then Exit Sub
dim fso,arrFiles,i
On Error Resume Next
Err=0
Set fso = CreateObject(Trim(Web_Info(13)))
if fso.FileExists(server.MapPath(strFiles)) then
fso.DeleteFile(server.MapPath(strFiles))
if 0=Err then
Response.write " 清除文件（"&strFiles&"）成功！"
else
Response.write " 清除文件（"&strFiles&"）失败！"
end if
end if
Set fso = Nothing
Err=0
End Sub
Public Sub DownloadFile(Byval strFile,Byval sReName)
On error resume next
Server.ScriptTimeOut=999999
Dim S,fso,f,intFilelength,strFilename
strFilename = strFile
Response.Clear
Set s = Server.CreateObject("Adodb." & "Str" & "eam")
s.Open
s.Type = 1
Set fso = Server.CreateObject(Trim(Cl.Web_Info(13)))
If Not fso.FileExists(strFilename) Then
Response.Write("
错误:
系统找不到指定文件！点此返回吧！")
Exit Sub
End If
Set f = fso.GetFile(strFilename)
intFilelength = f.size
s.LoadFromFile(strFilename)
If err Then
Response.Write("
错误:
" & err.Description & "
")
Response.End
End If
Set fso=Nothing
Dim Data
Data=s.Read
s.Close
Set s=Nothing
If Response.IsClientConnected Then
Response.AddHeader "Content-Disposition", "attachment; filename="&ReplaceBadChar(sReName)&"."&GetDownLoadFileExt(f.name)
Response.AddHeader "Content-Length", intFilelength
Response.CharSet = "UTF-8"
Response.ContentType = "application/octet-stream"
Response.BinaryWrite Data
Response.Flush
End If
End Sub
Public Function GetDownLoadFileExt(Byval strFile)
GetDownLoadFileExt="rar"
Dim strExt
if Isnull(strFile) then Exit Function
if Instr(strFile,".")<=0 then Exit Function
strExt=Split(strFile,".")
GetDownLoadFileExt=strExt(Ubound(strExt))
End Function
Public Function HTMLEncode(Byval fString)
If Not IsNull(fString) then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = replace(fString, "&", "&")
fString = Replace(fString, CHR(32), " ")
fString = Replace(fString, CHR(9), " ")
fString = Replace(fString, CHR(34), """)
fString = Replace(fString, CHR(39), "'")
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), "
")
fString = Replace(fString, CHR(10), " ")
HTMLEncode = fString
End If
End Function
Public Function HTMLCode(Byval fString)
If Not IsNull(fString) then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, " "," ")
fString = Replace(fString, """, CHR(34))
fString = Replace(fString, "'", CHR(39))
fString = Replace(fString, "
",CHR(10) & CHR(10))
fString = Replace(fString, " ", CHR(10))
HTMLCode = fString
End If
End Function
Public Function NoHtml(Byval str)
if not isnull(str) then
dim re
Set re=new RegExp
re.IgnoreCase =true
re.Global=True
re.Pattern="(\<.[^\<]*\>)"
str=re.replace(str," ")
re.Pattern="(\<\/[^\<]*\>)"
str=re.replace(str," ")
NoHtml=str
Set re=Nothing
End if
End Function
'sContent（要转换的数据字符串）
'sFilters（要过滤掉的格式集，用"|"分隔多个）
Public Function DeCode(Byval sContent, Byval sFilters)
Dim a_Filter, i, s_Result, s_Filters
Decode = sContent
If IsNull(sContent) or IsNull(sFilters) Then Exit Function
If sContent = "" or sFilters = "" Then Exit Function
s_Result = sContent
s_Filters = sFilters
If InStr(s_Filters,"|")>0 then
a_Filter = Split(s_Filters, "|")
For i = 0 To UBound(a_Filter)
s_Result = DecodeFilter(s_Result, a_Filter(i))
Next
Else
s_Result = DecodeFilter(s_Result, s_Filters)
End If
DeCode = s_Result
End Function
Public Function DecodeFilter(Byval sContent, Byval sFilter)
Dim regEx
Set regEx = New RegExp
regEx.IgnoreCase = True
regEx.Global = True
Select Case Ucase(sFilter)
Case "SCRIPT"'去除所有客户端脚本javascipt,vbscript,jscript,js,vbs,event,...
regEx.Pattern = "]*>"
sContent = regEx.replace(sContent,"")
regEx.Pattern = "(javascript|jscript|vbscript|vbs):"
sContent = regEx.replace(sContent,"$1：")
'regEx.Pattern = "on(mouse|exit|error|click|key)"
'sContent = regEx.replace(sContent,"on$1")
Case "OBJECT"'去除对象
regEx.Pattern = "]*>"
sContent = regEx.replace(sContent,"")
regEx.Pattern = "]*>"
sContent = regEx.replace(sContent,"")
regEx.Pattern = "]*>"
sContent = regEx.replace(sContent,"")
Case "TABLE"'去除表格
regEx.Pattern = "]*>"
sContent = regEx.replace(sContent,"")
regEx.Pattern = "]*>"
sContent = regEx.replace(sContent,"")
regEx.Pattern = "]*>"
sContent = regEx.replace(sContent,"")
regEx.Pattern = "]*>"
sContent = regEx.replace(sContent,"")
Case "CLASS"'去除样式类class=""
regEx.Pattern = "(<[^>]+) class=[^ |^>]*([^>]*>)"
sContent = regEx.replace(sContent,"$1 $2")
Case "STYLE"'去除样式style=""
regEx.Pattern = "(<[^>]+) style=\""[^\""]*\""([^>]*>)"
sContent = regEx.replace(sContent,"")
Case "XML"'去除XML
regEx.Pattern = "<\\?xml[^>]*>"
sContent = regEx.replace(sContent,"")
Case "NAMESPACE"'去除命名空间
regEx.Pattern = "<\/?[a-z]+:[^>]*>"
sContent = regEx.replace(sContent,"")
Case Else
regEx.Pattern = "]*>"
sContent = regEx.replace(sContent,"")
End Select
DecodeFilter = sContent
Set regEx=nothing
End Function
Public Function UbbCode(str)
If Not IsNull(str) then
Set ClUbb=New Cls_UbbCode
UbbCode=ClUbb.UbbCode(str)
Set ClUbb=Nothing
End if
End Function
Public Function ChkClng(ByVal str)
If str<>"" and IsNumeric(str) Then
ChkClng = CLng(str)
Else
ChkClng = 0
End If
End Function
Public Function ChkCBool(ByVal str)
If Not IsNull(str) Then
ChkCBool = CBool(str)
Else
ChkCBool = False
End If
End Function
Public Function ChkCDbl(ByVal str)
If str<>"" and IsNumeric(str) Then
ChkCDbl = CDbl(str)
Else
ChkCDbl = 0
End If
End Function
Public Function ChkNull(ByVal str)
If IsNull(str) Then
ChkNull = ""
Else
ChkNull = str
End If
End Function
Public Sub ChkUploadFile(iID,Content,Files)
Dim sTr, sFiles, i, sFile
iID = ChkClng(iID)
sTr = Content
sFiles = Files
If IsNull(sTr) or IsNull(sFiles) or sTr="" or sFiles="" Then Exit Sub
sTr = Lcase(ReplaceDir(sTr))
If Instr(sFiles,"@@@") > 0 then
sFiles = Split(sFiles,"@@@")
For i=0 to Ubound(sFiles)
sFile = Trim(sFiles(i))
sFile = Lcase(ReplaceDir(sFile))
If Instr(sTr,sFile)>0 then
Execute("Update Cl_UpFileLog Set InfoID="&iID&",IsUse=1 Where SaveFileName='"&CheckStr(sFiles(i))&"'")
Else
Execute("Update Cl_UpFileLog Set InfoID="&iID&",IsUse=0 Where SaveFileName='"&CheckStr(sFiles(i))&"'")
End if
Next
Else
sFile = Trim(sFiles)
sFile = Lcase(ReplaceDir(sFile))
If Instr(sTr,sFile)>0 then
Execute("Update Cl_UpFileLog Set InfoID="&iID&",IsUse=1 Where SaveFileName='"&CheckStr(sFiles)&"'")
Else
Execute("Update Cl_UpFileLog Set InfoID="&iID&",IsUse=0 Where SaveFileName='"&CheckStr(sFiles)&"'")
End if
End If
End Sub
End Class
Class Cls_Templates
Public html,Strings,pic
Public Property Let Value(ByVal vNewValue)
Dim tmpstr:tmpstr = vNewValue
tmpstr = Replace(tmpstr,"{%PicUrl%}",Cl.Web_PicUrl)
tmpstr = Split(tmpstr,"@@@")
html = Split(tmpstr(0),"|||"):Strings = Split(tmpstr(1),"|||"):pic = Split(tmpstr(2),"|||")
End Property
End Class
Class Cls_DataBase
Private ConnStr
Public UserTable,MessageTable,FriendTable
Public UserID,UserName,UserSex,UserEmail,UserIM,UserPassword,UserQuestion,UserAnswer
Public UserFace,UserFaceWidth,UserFaceHeight,UserJoinDate,UserLogins,UserLastLogin,UserLastIP,UserLock,UserWealth
Public UserDataNum,UserLevel,UserPoint,UserMoney,ChargeType,BeginDate,ValidNum,UserCheckNum,UserTPassWord
Public UserHomepage,UserQQ,UserIcq
Public UserReName,UserTelePhone,UserAddRess,UserBirthday,IDCard,CityInfo,ZipCode,SchoolAge,UserWorking,UserHomePhone,UserMobile,UserReMark,WaitReceive,Received,UserMsg,TotalExp
Public Property Let ConnValue(ByVal Val)
ConnStr = Val
End Property
Public Property Get ConnValue()
ConnValue = ConnStr
End Property
Public Function OpenConnection(DbType)
Dim TempConn
On Error Resume Next
Set TempConn = Server.CreateObject("ADODB.Connection")
TempConn.Open ConnValue
Set OpenConnection = TempConn
Set TempConn = Nothing
If Err Then
Err.Clear
Response.Write DbType & "链接出错，请检查数据库链接字符串！"
Response.End
End If
End Function
End Class
%>
<%
'===================================================
' CreateLive CMS Version 3.1
' Powered by Aspoo.CoM
'===================================================
' File: Cl_GetLabel.asp
' Date: 2005-10-31
' Mail: aspoo@126.com, Info@aspoo.cn
' Q Q: 3315263, 596197794
' Msn : aspoo@126.com, Clw866@hotmail.com
' Web : http://www.aspoo.com, http://www.aspoo.net
' Bbs : http://bbs.aspoo.com, http://bbs.aspoo.net
' Copyright (C) 2005 Aspoo.CoM All Rights Reserved.
'===================================================
'ReplacePublicFlag(sTrC)
'公共标签处理部分
Public Function ReplacePublicFlag(Byval sTrC)
sTrC = Replace(Replace(sTrC,"","%}")
sTrC = Replace(sTrC,"{%width%}",Cl.mainsetting(0))
sTrC = Replace(sTrC,"{%webname%}",Cl.Web_info(0))
sTrC = Replace(sTrC,"{%generator%}",Cl.Web_Version(2))
sTrC = Replace(sTrC,"{%keyword%}",Replace(Cl.Keywords,"|",","))
sTrC = Replace(sTrC,"{%description%}",Cl.DeScriptIon)
sTrC = Replace(sTrC,"{%weburl%}",Cl.Web_info(4))
sTrC = Replace(sTrC,"{%picurl%}",Cl.WebDir&Cl.Web_PicUrl)
sTrC = Replace(sTrC,"{%webmastemail%}",Cl.Web_info(8))
sTrC = Replace(sTrC,"{%channelid%}",ChannelID)
sTrC = Replace(sTrC,"{%title%}",Cl.Title)
sTrC = Replace(sTrC,"{%channelname%}",Cl.ChannelName)
sTrC = Replace(sTrC,"{%showdate%}","")
sTrC = Replace(sTrC,"{%currentpath%}",Cl.Path)
sTrC = Cl.ReplaceDir(sTrC)
sTrC = Cl.ReplaceItem(sTrC)
ReplacePublicFlag = sTrC
End Function
Public Function GetLabelContent(Byval LabelStr,Byref sTrC)
'On Error Resume next
Dim ArrayStr,Tn
GetLabelContent = "标签("&LabelStr&")错误，请检查标签代码。"
ArrayStr = Split(LabelStr,",")
Select Case LCase(ArrayStr(0))
'=========================公共部分=====================================
Case "showlogo"
GetLabelContent = ShowLogo(ArrayStr(1),ArrayStr(2),ArrayStr(3))
Case "showbanner"
GetLabelContent = ShowBanner(ArrayStr(1),ArrayStr(2),ArrayStr(3))
Case "showannounce"
GetLabelContent = ShowAnnounce(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5))
Case "openannounce"
if Cl.Web_Info(15) = "1" then
GetLabelContent = ""
else
GetLabelContent = ""
end if
Case "showchannelmenu"
if Cl.Web_Info(15) = "1" then
GetLabelContent = ""
else
GetLabelContent = Cl.ShowChannelMenu(ArrayStr(1))
end if
Case "showclassmenu"
if Cl.Web_Info(15) = "1" then
GetLabelContent = ""
else
GetLabelContent = ""
end if
'======================文章部分========================================
Case "showarticle"
GetLabelContent = ShowArticle(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14),ArrayStr(15),ArrayStr(16))
Case "showpicarticle"
GetLabelContent = ShowPicArticle(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12))
Case "showclassarticle"
GetLabelContent = ShowClassArticle(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
Case "showtoparticle"
GetLabelContent = ShowTopArticle(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6))
Case "showcorrelativearticle"
GetLabelContent = ShowCorrelativeArticle(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
Case "showneararticle"
GetLabelContent = ShowNearArticle(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5))
'===========================下载部分===================================
Case "showsoft"
GetLabelContent = ShowSoft(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14),ArrayStr(15),ArrayStr(16))
Case "showpicsoft"
GetLabelContent = ShowPicSoft(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12))
Case "showclasssoft"
GetLabelContent = ShowClassSoft(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
Case "showtopsoft"
GetLabelContent = ShowTopSoft(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6))
Case "showcorrelativesoft"
GetLabelContent = ShowCorrelativeSoft(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
'===========================图片部分===================================
Case "showphoto"
GetLabelContent = ShowPhoto(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14),ArrayStr(15),ArrayStr(16))
Case "showpicphoto"
GetLabelContent = ShowPicPhoto(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12))
Case "showclassphoto"
GetLabelContent = ShowClassPhoto(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
Case "showtopphoto"
GetLabelContent = ShowTopPhoto(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6))
Case "showcorrelativephoto"
GetLabelContent = ShowCorrelativePhoto(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
'============================影视部分==================================
Case "showmovie"
GetLabelContent = ShowMovie(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14),ArrayStr(15),ArrayStr(16))
Case "showpicmovie"
GetLabelContent = ShowPicMovie(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12))
Case "showclassmovie"
GetLabelContent = ShowClassMovie(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
Case "showtopmovie"
GetLabelContent = ShowTopMovie(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6))
Case "showcorrelativemovie"
GetLabelContent = ShowCorrelativeMovie(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
'===========================商城部分===================================
Case "showproduct"
GetLabelContent = ShowProduct(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12),ArrayStr(13),ArrayStr(14),ArrayStr(15),ArrayStr(16))
Case "showpicproduct"
GetLabelContent = ShowPicProduct(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8),ArrayStr(9),ArrayStr(10),ArrayStr(11),ArrayStr(12))
Case "showclassproduct"
GetLabelContent = ShowClassProduct(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
Case "showtopproduct"
GetLabelContent = ShowTopProduct(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6))
Case "showcorrelativeproduct"
GetLabelContent = ShowCorrelativeProduct(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5),ArrayStr(6),ArrayStr(7),ArrayStr(8))
'=========================公共部分=====================================
Case "showspecial"
GetLabelContent = ShowSpecial(ArrayStr(1),ArrayStr(2))
Case "showchildclass"
GetLabelContent = ShowChildClass(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4))
Case "showclassnavigation"
GetLabelContent = ShowClassNavigation(ArrayStr(1),ArrayStr(2),ArrayStr(3))
Case "showcomment"
GetLabelContent = ShowComment(ArrayStr(1),ArrayStr(2),ArrayStr(3))
Case "showsearchform"
if Cint(ArrayStr(2))>=3 and Cl.Web_Info(15) = "1" then
GetLabelContent = ""
else
GetLabelContent = ShowSearchForm(ArrayStr(1),ArrayStr(2))
end if
Case "showvote"
if Ubound(ArrayStr)<2 then ReDim ArrayStr(2)
GetLabelContent = ShowVote(ArrayStr(1),ArrayStr(2))
Case "showad"
if Ubound(ArrayStr)<5 then ReDim ArrayStr(5)
GetLabelContent = ShowAd(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5))
Case "showwebcount"
GetLabelContent = ShowWebCount(ArrayStr(1),ArrayStr(2))
Case "channelcount"
if Cl.Web_Info(15) = "1" then
GetLabelContent = ""
else
GetLabelContent = Replace(Cl.ReplaceFlag(Replace(Cl.CountConfig,"{%channelid%}",ChannelID),"ShowWebCount",""),VbCrLf," ")
end if
Case "showlinksite"
GetLabelContent = ShowLinkSite(ArrayStr(1),ArrayStr(2),ArrayStr(3),ArrayStr(4),ArrayStr(5))
Case "showtopuser"
GetLabelContent = ShowTopUser(ArrayStr(1),ArrayStr(2),ArrayStr(3))
Case "showguest"
GetLabelContent = ShowGuest(ArrayStr(1),ArrayStr(2),ArrayStr(3))
Case "showuserlogin"
if Ubound(ArrayStr) < 1 then
Redim ArrayStr(1)
ArrayStr(1)=0
end if
GetLabelContent = Cl.ShowUserLogin(ArrayStr(1))
Case "showjs"
Randomize
Tn=Int(9999*Rnd)+10000
GetLabelContent = "
" & ArrayStr(1) & "
"
Dim TempsTr
TempsTr="
"&ArrayStr(2)&"
"
TempsTr=TempsTr & Vbcrlf & "" & Vbcrlf & "
")
Case "web_info"
GetLabelContent = Cl.Web_Info(ArrayStr(1))
Case "mainsetting"
GetLabelContent = Cl.mainsetting(ArrayStr(1))
Case "mainpic"
GetLabelContent = Cl.mainpic(ArrayStr(1))
Case "mainhtml"
GetLabelContent = Cl.mainhtml(ArrayStr(1))
Case "powered"
GetLabelContent = Cl.lanstr(2) & "