<%
ConstIsDeBug=1
ClassNewaspMain_Cls
Publicmembername,memberpass,membergrade,membergroup,memberid
Publicmemberclass,menbernickname,Cookies_Name,CheckPassword
PublicSiteName,SiteUrl,MasterMail,keywords,Copyright
PublicInstallDir,IndexName,IstopSite,StopReadme,IsCloseMail
PublicSendMailType,MailFrom,MailServer,MailUserName,MailPassword,MailInformPass,ChkSameMail
PublicCheckUserReg,AdminCheckReg,AddUserPoint,SendRegMessage,FullContQuery,ActionTime
PublicIsRunTime,UploadClass,UploadFileSize,UploadFileType,ContentKeyword,PreviewSetting
PublicStopApplyLink,FSO_ScriptName,InitTitleColor,StopBankPay
PublicChinaeBank,VersionID,Badwords,Badwordr,serialcode,passedcode
PublicChannelName,ChannelDir,StopChannel,ChannelType
Publicmodules,ChannelSkin,HtmlPath,HtmlForm,HtmlPrefix
PublicIsCreateHtml,HtmlExtName,StopUpload,MaxFileSize,UpFileType
PublicIsAuditing,AppearGrade,ModuleName,BindDomain,DomainName
PublicPostGrade,LeastString,MaxString,PaginalNum,LeastHotHist,Channel_Setting
PublicChannelSetting,ChannelData,ChannelPath
PublicChannelModule,ChannelHtmlPath,ChannelHtmlForm,ChannelUseHtml,ChannelHtmlExt,ChannelPrefix
PublicThisEdition,CopyrightStr,Version,Values,startime
PublicSqlQueryNum,GetUserip,CacheName,Reloadtime
PublicScriptName,Admin_Page,skinid,SkinPath,HtmlCss,HtmlTop,HtmlFoot,HtmlContent,sHtmlContent
PrivateMain_Style,Main_Setting,MainStyle,Html_Setting
PrivateLocalCacheName,Cache_Data
PrivateCacheChannel,CacheData
PrivatearrGroupSetting,blnGroupSetting,binUserLong
PrivateSubClass_Initialize()
OnErrorResumeNext
Reloadtime=28800
SqlQueryNum=0
'--缓存名称
CacheName="newasp"
Cookies_Name="newasp_net"
binUserLong=False
blnGroupSetting=False
GetUserip=Request.ServerVariables("HTTP_X_FORWARDED_FOR")
IfLen(GetUserip)=0ThenGetUserip=Request.ServerVariables("REMOTE_ADDR")
GetUserip=CheckStr(GetUserip)
membername=CheckStr(Request.Cookies(Cookies_Name)("username"))
memberpass=CheckStr(Request.Cookies(Cookies_Name)("password"))
menbernickname=CheckStr(Request.Cookies(Cookies_Name)("nickname"))
membergrade=ChkNumeric(Request.Cookies(Cookies_Name)("UserGrade"))
membergroup=CheckStr(Request.Cookies(Cookies_Name)("UserGroup"))
memberclass=ChkNumeric(Request.Cookies(Cookies_Name)("UserClass"))
memberid=ChkNumeric(Request.Cookies(Cookies_Name)("userid"))
CheckPassword=CheckStr(Request.Cookies(Cookies_Name)("CheckPassword"))
Dimtmpstr,i
tmpstr=Request.ServerVariables("PATH_INFO")
tmpstr=Split(tmpstr,"/")
i=UBound(tmpstr)
ScriptName=LCase(tmpstr(i))
Admin_Page=False
IfInStr(ScriptName,"showerr")>0OrInStr(ScriptName,"login")>0OrInStr(ScriptName,"admin_")>0ThenAdmin_Page=True
EndSub
PrivateSubClass_Terminate()
IfIsObject(Conn)ThenConn.Close:SetConn=Nothing
EndSub
'===================服务器缓存部分函数开始===================
PublicPropertyLetName(ByValvNewValue)
LocalCacheName=LCase(vNewValue)
Cache_Data=Application(CacheName&"_"&LocalCacheName)
EndProperty
PublicPropertyLetValue(ByValvNewValue)
IfLocalCacheName<>""Then
ReDimCache_Data(2)
Cache_Data(0)=vNewValue
Cache_Data(1)=Now()
Application.Lock
Application(CacheName&"_"&LocalCacheName)=Cache_Data
Application.UnLock
Else
Err.RaisevbObjectError+1,"NewaspCacheServer","pleasechangetheCacheName."
EndIf
EndProperty
PublicPropertyGetValue()
IfLocalCacheName<>""Then
IfIsArray(Cache_Data)Then
Value=Cache_Data(0)
Else
'Err.RaisevbObjectError+1,"NewaspCacheServer","TheCache_Data("&LocalCacheName&")IsEmpty."
EndIf
Else
Err.RaisevbObjectError+1,"NewaspCacheServer","pleasechangetheCacheName."
EndIf
EndProperty
PublicFunctionObjIsEmpty()
ObjIsEmpty=True
IfNotIsArray(Cache_Data)ThenExitFunction
IfNotIsDate(Cache_Data(1))ThenExitFunction
IfDateDiff("s",CDate(Cache_Data(1)),Now())<(60*Reloadtime)ThenObjIsEmpty=False
EndFunction
PublicSubDelCahe(MyCaheName)
Application.Lock
Application.Contents.Remove(CacheName&"_"&MyCaheName)
Application.UnLock
EndSub
PublicSubDelCache(MyCaheName)
Application.Lock
Application.Contents.Remove("mynewasp_"&MyCaheName)
Application.UnLock
EndSub
'===================服务器缓存部分函数结束===================
PublicFunctionChkBoolean(ByValValues)
IfTypeName(Values)="Boolean"OrIsNumeric(Values)OrLCase(Values)="false"OrLCase(Values)="true"Then
ChkBoolean=CBool(Values)
Else
ChkBoolean=False
EndIf
EndFunction
PublicFunctionCheckNumeric(ByValCHECK_ID)
IfCHECK_ID<>""AndIsNumeric(CHECK_ID)Then
CHECK_ID=CCur(CHECK_ID)
Else
CHECK_ID=0
EndIf
CheckNumeric=CHECK_ID
EndFunction
PublicFunctionChkNumeric(ByValCHECK_ID)
IfCHECK_ID<>""AndIsNumeric(CHECK_ID)Then
CHECK_ID=CLng(CHECK_ID)
IfCHECK_ID<0ThenCHECK_ID=0
Else
CHECK_ID=0
EndIf
ChkNumeric=CHECK_ID
EndFunction
PublicFunctionCheckStr(ByValstr)
IfIsNull(str)Then
CheckStr=""
ExitFunction
EndIf
str=Replace(str,Chr(0),"")
CheckStr=Replace(str,"'","''")
EndFunction
'================================================
'过程名：CheckNull
'作用：是否有效值
'================================================
PublicFunctionCheckNull(ByValsValue)
OnErrorResumeNext
IfIsNull(sValue)Then
CheckNull=False
ExitFunction
EndIf
IfTrim(sValue)<>""AndLCase(Trim(sValue))<>"http://"Then
CheckNull=True
Else
CheckNull=False
EndIf
EndFunction
PublicFunctionChkNull(ByValstr)
OnErrorResumeNext
IfIsNull(str)Then
ChkNull=""
ExitFunction
EndIf
IfTrim(str)<>""AndLCase(Trim(str))<>"http://"Then
ChkNull=Trim(str)
Else
ChkNull=""
EndIf
EndFunction
'=============================================================
'函数名：ChkFormStr
'作用：过滤表单字符
'参数：str----原字符串
'返回值：过滤后的字符串
'=============================================================
PublicFunctionChkFormStr(ByValstr)
DimfString
fString=str
IfIsNull(fString)Then
ChkFormStr=""
ExitFunction
EndIf
fString=Replace(fString,"'","")
fString=Replace(fString,Chr(34),""")
fString=Replace(fString,Chr(13),"")
fString=Replace(fString,Chr(10),"")
fString=Replace(fString,Chr(9),"")
fString=Replace(fString,">",">")
fString=Replace(fString,"<","<")
fString=Replace(fString,"%","％")
ChkFormStr=Trim(JAPEncode(fString))
EndFunction
'=============================================================
'函数作用：过滤SQL非法字符
'=============================================================
PublicFunctionCheckRequest(ByValstr,ByValstrLen)
OnErrorResumeNext
str=Trim(str)
str=Replace(str,Chr(0),"")
str=Replace(str,"'","")
str=Replace(str,"%","")
str=Replace(str,"^","")
str=Replace(str,";","")
str=Replace(str,"*","")
str=Replace(str,"<","")
str=Replace(str,">","")
str=Replace(str,"|","")
str=Replace(str,"and","")
str=Replace(str,"chr","")
IfLen(str)>0AndstrLen>0Then
str=Left(str,strLen)
EndIf
CheckRequest=str
EndFunction
'--移除有害字符
PublicFunctionRemoveBadCharacters(ByValstrTemp)
Dimre
OnErrorResumeNext
Setre=NewRegExp
re.Pattern="[^sw]"
re.Global=True
RemoveBadCharacters=re.Replace(strTemp,"")
Setre=Nothing
EndFunction
'--去掉HTML标记
PublicFunctionRemoveHtml(ByValTextstr)
DimStr,re
Str=Textstr
OnErrorResumeNext
Setre=NewRegExp
re.IgnoreCase=True
re.Global=True
re.Pattern="<(.[^>]*)>"
Str=re.Replace(Str,"")
Setre=Nothing
RemoveHtml=Str
EndFunction
'--数据库连接
PublicFunctionExecute(Command)
IfNotIsObject(Conn)ThenConnectionDatabase
IfIsDeBug=0Then
OnErrorResumeNext
SetExecute=Conn.Execute(Command)
IfErrThen
err.Clear
SetConn=Nothing
Response.Write"查询数据的时候发现错误，请检查您的查询代码是否正确。<br/><li>"
Response.WriteCommand
Response.End
EndIf
Else
SetExecute=Conn.Execute(Command)
EndIf
SqlQueryNum=SqlQueryNum+1
EndFunction
PublicSubReadConfig()
OnErrorResumeNext
Name="Config"
IfObjIsEmpty()ThenReloadConfig
CacheData=Value
'第一次起用系统或者重启IIS的时候加载缓存
Name="Date"
IfObjIsEmpty()Then
Value=Date
Else
IfCStr(Value)<>CStr(Date)Then
Name="Config"
CallReloadConfig
CacheData=Value
EndIf
EndIf
SiteName=CacheData(1,0):SiteUrl=CacheData(2,0):MasterMail=CacheData(3,0):keywords=CacheData(4,0):Copyright=CacheData(5,0):InstallDir=CacheData(6,0)
IndexName=CacheData(7,0):IstopSite=CacheData(8,0):StopReadme=CacheData(9,0):IsCloseMail=CacheData(10,0):SendMailType=CacheData(11,0):MailFrom=CacheData(12,0)
MailServer=CacheData(13,0):MailUserName=CacheData(14,0):MailPassword=CacheData(15,0):CheckUserReg=CacheData(16,0):AdminCheckReg=CacheData(17,0):MailInformPass=CacheData(18,0)
ChkSameMail=CacheData(19,0):AddUserPoint=CacheData(20,0):SendRegMessage=CacheData(21,0):FullContQuery=CacheData(22,0):ActionTime=CacheData(23,0):IsRunTime=CacheData(24,0)
UploadClass=CacheData(25,0):UploadFileSize=CacheData(26,0):UploadFileType=CacheData(27,0):ContentKeyword=CacheData(28,0):StopApplyLink=CacheData(29,0):FSO_ScriptName=CacheData(30,0)
InitTitleColor=CacheData(31,0):StopBankPay=CacheData(32,0):ChinaeBank=CacheData(33,0):VersionID=CacheData(34,0):Badwords=CacheData(35,0):Badwordr=CacheData(36,0)
serialcode=CacheData(37,0):passedcode=CacheData(38,0):PreviewSetting=CacheData(39,0)
ThisEdition="免费版(FreeEdition)"
Version="Poweredby：<ahref=""http://www.newasp.net""target=""_blank""class=""navmenu"">NewCloudSiteManageSystemVersion2.0.0SP1</a>"
CopyrightStr="<>"&vbCrLf
IfCInt(IstopSite)=1AndNotAdmin_PageThenResponse.Redirect(""&SiteUrl&InstallDir&"showerr.asp?action=stop")
EndSub
PublicSubReloadConfig()
DimSQL,Rs
OnErrorResumeNext
SQL="SELECT*from[NC_Config]"
SetRs=Execute(SQL)
Value=Rs.GetRows(1)
SetRs=Nothing
EndSub
'=============================================================
'过程名：ReloadChannel
'作用：再装频道设置
'参数：ChannelID----频道ID
'=============================================================
PrivateSubReloadChannel(ChannelID)
DimSQL,Rs
OnErrorResumeNext
SQL="SELECTChannelID,ChannelName,ChannelDir,StopChannel,ChannelType,modules,ModuleName,BindDomain,DomainName,ChannelSkin,HtmlPath,HtmlForm,IsCreateHtml,HtmlExtName,HtmlPrefix,StopUpload,MaxFileSize,UpFileType,IsAuditing,AppearGrade,PostGrade,LeastString,MaxString,PaginalNum,LeastHotHist,Channel_SettingfromNC_ChannelwhereChannelType<=1AndChannelID="&CLng(ChannelID)
SetRs=Execute(SQL)
IfRs.BOFAndRs.EOFThen
Response.Write"错误的频道参数！"
ExitSub
EndIf
Value=Rs.GetRows(1)
SetRs=Nothing
EndSub
'=============================================================
'过程名：ReadChannel
'作用：读取频道设置
'参数：ChannelID----频道ID
'=============================================================
PublicSubReadChannel(ChannelID)
OnErrorResumeNext
IfNotIsNumeric(ChannelID)ThenChannelID=1
ChannelID=Clng(ChannelID)
Name="Channel"&ChannelID
IfObjIsEmpty()ThenCallReloadChannel(ChannelID)
CacheChannel=Value
IfCLng(CacheChannel(0,0))<>ChannelIDThen
CallReloadChannel(ChannelID)
CacheChannel=Value
EndIf
ChannelName=CacheChannel(1,0):ChannelDir=CacheChannel(2,0):StopChannel=CacheChannel(3,0):ChannelType=CacheChannel(4,0):modules=CacheChannel(5,0):ModuleName=CacheChannel(6,0):BindDomain=CacheChannel(7,0):DomainName=CacheChannel(8,0):ChannelSkin=CacheChannel(9,0):HtmlPath=CacheChannel(10,0)
HtmlForm=CacheChannel(11,0):IsCreateHtml=CacheChannel(12,0):HtmlExtName=CacheChannel(13,0):HtmlPrefix=CacheChannel(14,0):StopUpload=CacheChannel(15,0):MaxFileSize=CacheChannel(16,0):UpFileType=CacheChannel(17,0):IsAuditing=CacheChannel(18,0):AppearGrade=CacheChannel(19,0)
PostGrade=CacheChannel(20,0):LeastString=CacheChannel(21,0):MaxString=CacheChannel(22,0):PaginalNum=CacheChannel(23,0):LeastHotHist=CacheChannel(24,0):Channel_Setting=CacheChannel(25,0)
IfCInt(StopChannel)=1AndNotAdmin_PageThenResponse.Redirect(InstallDir&"showerr.asp?action=ChanStop")
EndSub
PublicSubLoadChannel(chanid)
OnErrorResumeNext
DimRs,SQL,tmpdata
chanid=CLng(chanid)
Name="MyChannel"&chanid
IfObjIsEmpty()Then
SQL="SELECTChannelName,ChannelDir,ModuleName,HtmlPath,HtmlForm,IsCreateHtml,HtmlExtName,HtmlPrefix,StopUpload,LeastString,MaxString,LeastHotHistFROMNC_ChannelWHEREChannelType<=1AndChannelID="&Clng(chanid)
SetRs=Execute(SQL)
tmpdata=Rs.GetString(,,"|||","@@@","")
tmpdata=Left(tmpdata,Len(tmpdata)-3)
SetRs=Nothing
Value=tmpdata
EndIf
ChannelData=Split(Value,"|||")
ChannelPath=InstallDir&ChannelData(1)
ChannelModule=ChannelData(2)
ChannelHtmlPath=ChannelData(3)
ChannelHtmlForm=ChannelData(4)
ChannelUseHtml=ChannelData(5)
ChannelHtmlExt=ChannelData(6)
ChannelPrefix=ChannelData(7)
EndSub
'=============================================================
'过程名：LoadTemplates
'作用：载入模板
'参数：Page_Mark----StyleID
'=============================================================
PublicSubLoadTemplates(ChannelID,pageid,StyleID)
Dimrstmp,TempSkinID
OnErrorResumeNext
ChannelID=CLng(ChannelID)
pageid=CInt(pageid)
Name="DefaultSkinID"
IfObjIsEmpty()Then
Setrstmp=Execute("SELECTskinidfrom[NC_Template]wherepageid=0AndisDefault=1")
Value=rstmp(0)
Setrstmp=Nothing
EndIf
TempSkinID=Value
IfStyleID=0OrStyleID=""Then
skinid=TempSkinID
Else
Setrstmp=Execute("SELECTskinidfrom[NC_Template]wherepageid=0Andskinid="&StyleID)
IfNotrstmp.EOFThen
skinid=rstmp(0)
Else
skinid=TempSkinID
EndIf
Setrstmp=Nothing
EndIf
skinid=CLng(skinid)
Name="MainStyle"&skinid
IfObjIsEmpty()ThenTemplatesMainCache(skinid)
Main_Style=Value
SkinPath=Main_Style(0,0)
Main_Setting=Split(Main_Style(2,0),"|||")
MainStyle=Main_Style(1,0)
'MainStyle=Replace(MainStyle,"{$InstallDir}",ReadInstallDir(BindDomain))
MainStyle=Replace(MainStyle,"{$SkinPath}",SkinPath)
MainStyle=Split(MainStyle,"|||")
HtmlCss=MainStyle(0)
HtmlTop=MainStyle(1)
HtmlFoot=MainStyle(2)
Ifpageid<>0Then
Name="Templates"&ChannelID&skinid&pageid
IfObjIsEmpty()Then
TemplatesToCacheChannelID,pageid
EndIf
ByValue=Value
EndIf
EndSub
PrivateSubTemplatesToCache(ChannelID,pageid)
OnErrorResumeNext
DimRs,SQL,rstmp
SQL="SELECTskinid,page_content,page_settingFROM[NC_Template]WHEREChannelID="&ChannelID&"Andskinid="&skinid&"Andpageid="&pageid
SetRs=Execute(SQL)
IfNotRs.EOFThen
Value=Rs.GetRows(1)
Else
Setrstmp=Execute("SELECTskinid,page_content,page_settingFROM[NC_Template]WHEREChannelID="&ChannelID&"AndisDefault=1Andpageid="&pageid)
Value=rstmp.GetRows(1)
Setrstmp=Nothing
EndIf
SetRs=Nothing
EndSub
PrivateSubTemplatesMainCache(skinid)
OnErrorResumeNext
DimRs,SQL,rstmp
SQL="SELECTTemplateDir,page_content,page_settingFROM[NC_Template]WHEREpageid=0Andskinid="&skinid&"AndChannelID=0"
SetRs=Execute(SQL)
IfNotRs.EOFThen
Value=Rs.GetRows(1)
Else
Setrstmp=Execute("SELECTTemplateDir,page_content,page_settingfrom[NC_Template]WHEREpageid=0AndisDefault=1AndChannelID=0")
Value=rstmp.GetRows(1)
Setrstmp=Nothing
EndIf
SetRs=Nothing
EndSub
PublicPropertyLetByValue(ByValvNewValue)
Dimtmpstr
tmpstr=vNewValue
Html_Setting=tmpstr(2,0)
Html_Setting=Split(Html_Setting,"|||")
HtmlContent=tmpstr(1,0)
IfCInt(Html_Setting(0))<>0Then
HtmlContent=HtmlTop&HtmlContent&HtmlFoot
EndIf
HtmlContent=Replace(HtmlContent,"{$Style_CSS}",HtmlCss)
HtmlContent=Replace(HtmlContent,"{$SkinPath}",SkinPath)
HtmlContent=Replace(HtmlContent,"{$Width}",Main_Setting(0))
HtmlContent=Replace(HtmlContent,"{$ChannelMenu}",ChannelMenu)
HtmlContent=Replace(HtmlContent,"{$WebSiteName}",SiteName)
HtmlContent=Replace(HtmlContent,"{$WebSiteUrl}",SiteUrl)
HtmlContent=Replace(HtmlContent,"{$MasterMail}",MasterMail)
HtmlContent=Replace(HtmlContent,"{$Keyword}",keywords)
HtmlContent=Replace(HtmlContent,"{$Copyright}",Copyright)
HtmlContent=Replace(HtmlContent,"{$IndexName}",IndexName)
HtmlContent=Replace(HtmlContent,"{$Version}","")
HtmlContent=HtmlContent
EndProperty
PublicPropertyGetByValue()
ByValue=HtmlContent
EndProperty
PublicPropertyLetHTMLValue(ByValvNewValue)
DimTempStr
TempStr=vNewValue
TempStr=Replace(TempStr,"{$Style_CSS}",HtmlCss)
TempStr=Replace(TempStr,"{$SkinPath}",SkinPath)
TempStr=Replace(TempStr,"{$Width}",Main_Setting(0))
TempStr=Replace(TempStr,"{$ChannelMenu}",ChannelMenu)
TempStr=Replace(TempStr,"{$WebSiteName}",SiteName)
TempStr=Replace(TempStr,"{$WebSiteUrl}",SiteUrl)
TempStr=Replace(TempStr,"{$MasterMail}",MasterMail)
TempStr=Replace(TempStr,"{$Keyword}",keywords)
TempStr=Replace(TempStr,"{$Copyright}",Copyright)
TempStr=Replace(TempStr,"{$IndexName}",IndexName)
TempStr=Replace(TempStr,"{$Version}","")
sHtmlContent=TempStr
EndProperty
PublicPropertyGetHTMLValue()
HTMLValue=sHtmlContent
EndProperty
PublicPropertyGetHtmlSetting(n)
HtmlSetting=Html_Setting(n)
EndProperty
PublicPropertyGetMainSetting(n)
MainSetting=Main_Setting(n)
EndProperty
'================================================
'过程名：GetSiteUrl
'作用：取得带端口的URL
'================================================
PublicPropertyGetGetSiteUrl()
IfRequest.ServerVariables("SERVER_PORT")="80"Then
GetSiteUrl="http://"&Request.ServerVariables("server_name")
Else
GetSiteUrl="http://"&Request.ServerVariables("server_name")&":"&Request.ServerVariables("SERVER_PORT")
EndIf
EndProperty
'================================================
'函数名：FormEncode
'作用：过虑提交的表单数据
'参数：str----原字符串n----字符长度
'================================================
PublicFunctionFormEncode(ByValstr,ByValn)
IfNotIsNull(str)AndTrim(str)<>""Then
str=Left(str,n)
str=Replace(str,">",">")
str=Replace(str,"<","<")
str=Replace(str,"")
str=Replace(str,"")
str=Replace(str,"'","")
str=Replace(str,Chr(34),""")
str=Replace(str,"%","％")
str=Replace(str,vbNewLine,"")
FormEncode=Trim(str)
Else
FormEncode=""
EndIf
EndFunction
'================================================
'函数名：ChkKeyWord
'作用：过滤关键字
'参数：keyword----关键字
'================================================
PublicFunctionChkKeyWord(ByValkeyword)
DimFobWords,i
OnErrorResumeNext
FobWords=Array(91,92,304,305,430,431,437,438,12460,12461,12462,12463,12464,12465,12466,12467,12468,12469,12470,12471,12472,12473,12474,12475,12476,12477,12478,12479,12480,12481,12482,12483,12485,12486,12487,12488,12489,12490,12496,12497,12498,12499,12500,12501,12502,12503,12504,12505,12506,12507,12508,12509,12510,12521,12532,12533,65339,65340)
Fori=1ToUBound(FobWords,1)
IfInStr(keyword,ChrW(FobWords(i)))>0Then
keyword=Replace(keyword,ChrW(FobWords(i)),"")
EndIf
Next
keyword=Left(keyword,100)
FobWords=Array("~","!","@","#","$","%","^","&","*","(",")","_","+","=","`","[","]","{","}",";",":","""","'",",","<",">",".","/","","?","_")
Fori=0ToUBound(FobWords,1)
IfInStr(keyword,FobWords(i))>0Then
keyword=Replace(keyword,FobWords(i),"")
EndIf
Next
ChkKeyWord=keyword
EndFunction
'================================================
'函数名：JAPEncode
'作用：日文片假名编码
'参数：str----原字符
'================================================
PublicFunctionJAPEncode(ByValstr)
DimFobWords,i
OnErrorResumeNext
IfIsNull(str)OrTrim(str)=""Then
JAPEncode=""
ExitFunction
EndIf
FobWords=Array(92,304,305,430,431,437,438,12460,12461,12462,12463,12464,12465,12466,12467,12468,12469,12470,12471,12472,12473,12474,12475,12476,12477,12478,12479,12480,12481,12482,12483,12485,12486,12487,12488,12489,12490,12496,12497,12498,12499,12500,12501,12502,12503,12504,12505,12506,12507,12508,12509,12510,12521,12532,12533,65340)
Fori=1ToUBound(FobWords,1)
IfInStr(str,ChrW(FobWords(i)))>0Then
str=Replace(str,ChrW(FobWords(i)),""&FobWords(i)&";")
EndIf
Next
JAPEncode=str
EndFunction
'================================================
'函数名：JAPUncode
'作用：日文片假名解码
'参数：str----原字符
'================================================
PublicFunctionJAPUncode(ByValstr)
DimFobWords,i
OnErrorResumeNext
IfIsNull(str)OrTrim(str)=""Then
JAPUncode=""
ExitFunction
EndIf
FobWords=Array(92,304,305,430,431,437,438,12460,12461,12462,12463,12464,12465,12466,12467,12468,12469,12470,12471,12472,12473,12474,12475,12476,12477,12478,12479,12480,12481,12482,12483,12485,12486,12487,12488,12489,12490,12496,12497,12498,12499,12500,12501,12502,12503,12504,12505,12506,12507,12508,12509,12510,12521,12532,12533,65340)
Fori=1ToUBound(FobWords,1)
IfInStr(str,""&FobWords(i)&";")>0Then
str=Replace(str,""&FobWords(i)&";",ChrW(FobWords(i)))
EndIf
Next
str=Replace(str,Chr(0),"")
str=Replace(str,"'","''")
JAPUncode=str
EndFunction
'=============================================================
'函数作用：带脏话过滤
'=============================================================
PublicFunctionChkBadWords(ByValstr)
IfIsNull(str)ThenExitFunction
Dimi,Bwords,Bwordr
Bwords=Split(Badwords,"|")
Bwordr=Split(Badwordr,"|")
Fori=0ToUBound(Bwords)
Ifi>UBound(Bwordr)Then
str=Replace(str,Bwords(i),"*")
Else
str=Replace(str,Bwords(i),Bwordr(i))
EndIf
Next
ChkBadWords=str
EndFunction
'=============================================================
'函数作用：过滤HTML代码，带脏话过滤
'=============================================================
PublicFunctionHTMLEncode(ByValfString)
IfNotIsNull(fString)Then
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,"","")
fString=Replace(fString,Chr(10),"<br/>")
fString=ChkBadWords(fString)
HTMLEncode=fString
EndIf
EndFunction
'=============================================================
'函数作用：过滤HTML代码，不带脏话过滤
'=============================================================
PublicFunctionHTMLEncodes(ByValfString)
IfNotIsNull(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),"<br/>")
fString=Replace(fString,"","")
HTMLEncodes=fString
EndIf
EndFunction
'=============================================================
'函数作用：判断发言是否来自外部
'=============================================================
PublicFunctionCheckPost()
OnErrorResumeNext
Dimserver_v1,server_v2
CheckPost=False
server_v1=CStr(Request.ServerVariables("HTTP_REFERER"))
server_v2=CStr(Request.ServerVariables("SERVER_NAME"))
IfMid(server_v1,8,Len(server_v2))=server_v2Then
CheckPost=True
EndIf
EndFunction
'=============================================================
'函数作用：判断来源URL是否来自外部
'=============================================================
PublicFunctionCheckOuterUrl()
OnErrorResumeNext
Dimserver_v1,server_v2
server_v1=Replace(LCase(Trim(Request.ServerVariables("HTTP_REFERER"))),"http://","")
server_v2=LCase(Trim(Request.ServerVariables("SERVER_NAME")))
Ifserver_v1<>""AndLeft(server_v1,Len(server_v2))<>server_v2Then
CheckOuterUrl=False
Else
CheckOuterUrl=True
EndIf
EndFunction
'================================================
'函数名：GotTopic
'作用：显示字符串长度
'参数：str----原字符串
'strlen----显示字符长度
'================================================
PublicFunctionGotTopic(ByValstr,ByValstrLen)
Diml,t,c,i
DimstrTemp
OnErrorResumeNext
str=Trim(str)
str=Replace(str,"","")
str=Replace(str,">",">")
str=Replace(str,"<","<")
str=Replace(str,"")
str=Replace(str,"")
str=Replace(str,"")
str=Replace(str,""",Chr(34))
str=Replace(str,vbNewLine,"")
l=Len(str)
t=0
Fori=1Tol
c=Abs(Asc(Mid(str,i,1)))
Ifc>255Then
t=t+2
Else
t=t+1
EndIf
Ift>=strLenThen
strTemp=Left(str,i)&"..."
ExitFor
Else
strTemp=str&""
EndIf
Next
GotTopic=CheckTopic(strTemp)
EndFunction
PublicFunctionCheckTopic(ByValstrContent)
Dimre
OnErrorResumeNext
Setre=NewRegExp
re.IgnoreCase=True
re.Global=True
re.Pattern="(<s+cript(.+?)</s+cript>)"
strContent=re.Replace(strContent,"")
re.Pattern="(<iframe(.+?)</iframe>)"
strContent=re.Replace(strContent,"")
re.Pattern="("
strContent=re.Replace(strContent,">")
re.Pattern="("
strContent=re.Replace(strContent,"<")
Setre=Nothing
strContent=Replace(strContent,">",">")
strContent=Replace(strContent,"<","<")
strContent=Replace(strContent,"'","")
strContent=Replace(strContent,Chr(34),""")
strContent=Replace(strContent,"%","％")
strContent=Replace(strContent,vbNewLine,"")
CheckTopic=Trim(strContent)
EndFunction
'================================================
'函数名：ReadTopic
'作用：显示字符串长度
'参数：str----原字符串
'strlen----显示字符长度
'================================================
PublicFunctionReadTopic(ByValstr,ByValstrLen)
Diml,t,c,i
OnErrorResumeNext
str=Replace(str,"","")
IfLen(str)<strLenThen
str=str&String(strLen-Len(str),".")
Else
str=str
EndIf
l=Len(str)
t=0
Fori=1Tol
c=Abs(Asc(Mid(str,i,1)))
Ifc>255Then
t=t+2
Else
t=t+1
EndIf
Ift>=strLenThen
ReadTopic=Left(str,i)&"..."
ExitFor
Else
ReadTopic=str&"..."
EndIf
Next
EndFunction
'================================================
'函数名：strLength
'作用：计字符串长度
'参数：str----字符串
'================================================
PublicFunctionstrLength(ByValstr)
OnErrorResumeNext
IfIsNull(str)Orstr=""Then
strLength=0
ExitFunction
EndIf
DimWINNT_CHINESE
WINNT_CHINESE=(Len("例子")=2)
IfWINNT_CHINESEThen
Diml,t
Dimi,c
l=Len(str)
t=l
Fori=1Tol
c=Asc(Mid(str,i,1))
Ifc<0Thenc=c+65536
Ifc>255Thent=t+1
Next
strLength=t
Else
strLength=Len(str)
EndIf
EndFunction
'=================================================
'函数名：isInteger
'作用：判断数字是否整型
'参数：para----参数
'=================================================
PublicFunctionisInteger(ByValpara)
OnErrorResumeNext
Dimstr
Diml,i
IfIsNull(para)Then
isInteger=False
ExitFunction
EndIf
str=CStr(para)
IfTrim(str)=""Then
isInteger=False
ExitFunction
EndIf
l=Len(str)
Fori=1Tol
IfMid(str,i,1)>"9"OrMid(str,i,1)<"0"Then
isInteger=False
ExitFunction
EndIf
Next
isInteger=True
IfErr.Number<>0ThenErr.Clear
EndFunction
PublicFunctionCutString(ByValstr,ByValstrLen)
OnErrorResumeNext
DimHtmlStr,l,re,strContent
HtmlStr=str
HtmlStr=Replace(HtmlStr,"","")
HtmlStr=Replace(HtmlStr,""",Chr(34))
HtmlStr=Replace(HtmlStr,"",Chr(39))
HtmlStr=Replace(HtmlStr,"",Chr(123))
HtmlStr=Replace(HtmlStr,"",Chr(125))
HtmlStr=Replace(HtmlStr,"",Chr(36))
HtmlStr=Replace(HtmlStr,vbCrLf,"")
HtmlStr=Replace(HtmlStr,"====","")
HtmlStr=Replace(HtmlStr,"----","")
HtmlStr=Replace(HtmlStr,"////","")
HtmlStr=Replace(HtmlStr,"","")
HtmlStr=Replace(HtmlStr,"####","")
HtmlStr=Replace(HtmlStr,"@@@@","")
HtmlStr=Replace(HtmlStr,"****","")
HtmlStr=Replace(HtmlStr,"~~~~","")
Setre=NewRegExp
re.IgnoreCase=True
re.Global=True
re.Pattern="[br]"
HtmlStr=re.Replace(HtmlStr,"")
re.Pattern="[align=right](.*)[/align]"
HtmlStr=re.Replace(HtmlStr,"")
re.Pattern="<(.[^>]*)>"
HtmlStr=re.Replace(HtmlStr,"")
Setre=Nothing
HtmlStr=Replace(HtmlStr,">",">")
HtmlStr=Replace(HtmlStr,"<","<")
l=Len(HtmlStr)
Ifl>=strLenThen
strContent=Left(HtmlStr,strLen)&"..."
Else
strContent=HtmlStr&""
EndIf
strContent=Replace(strContent,Chr(34),""")
strContent=Replace(strContent,Chr(39),"")
strContent=Replace(strContent,Chr(36),"")
strContent=Replace(strContent,Chr(123),"")
strContent=Replace(strContent,Chr(125),"")
strContent=Replace(strContent,">",">")
strContent=Replace(strContent,"<","<")
CutString=strContent
EndFunction
'================================================
'函数名：CheckInfuse
'作用：防止SQL注入
'参数：str----原字符串
'strLen----提交字符串长度
'================================================
PublicFunctionCheckInfuse(ByValstr,ByValstrLen)
DimstrUnsafe,arrUnsafe
Dimi
IfTrim(str)=""Then
CheckInfuse=""
ExitFunction
EndIf
str=Left(str,strLen)
OnErrorResumeNext
strUnsafe="'|^|;|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
IfTrim(str)<>""Then
IfLen(str)>strLenThen
Response.Write"<ScriptLanguage=JavaScript>alert('安全系统提示↓nn您提交的字符数超过了限制！');history.back(-1)</Script>"
CheckInfuse=""
Response.End
EndIf
arrUnsafe=Split(strUnsafe,"|")
Fori=0ToUBound(arrUnsafe)
IfInStr(1,str,arrUnsafe(i),1)>0Then
Response.Write"<ScriptLanguage=JavaScript>alert('安全系统提示↓nn请不要在参数中包含非法字符！');history.back(-1)</Script>"
CheckInfuse=""
Response.End
EndIf
Next
EndIf
CheckInfuse=Trim(str)
ExitFunction
IfErr.Number<>0Then
Err.Clear
Response.Write"<ScriptLanguage=JavaScript>alert('安全系统提示↓nn请不要在参数中包含非法字符！');history.back(-1)</Script>"
CheckInfuse=""
Response.End
EndIf
EndFunction
PublicSubPreventInfuse()
OnErrorResumeNext
DimSQL_Nonlicet,arrNonlicet
DimPostRefer,GetRefer,Sql_DATA
SQL_Nonlicet="'|;|^|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
arrNonlicet=Split(SQL_Nonlicet,"|")
IfRequest.Form<>""Then
ForEachPostReferInRequest.Form
ForSql_DATA=0ToUBound(arrNonlicet)
IfInStr(1,Request.Form(PostRefer),arrNonlicet(Sql_DATA),1)>0Then
Response.Write"<ScriptLanguage=JavaScript>alert('安全系统提示↓nn请不要在参数中包含非法字符！');history.back(-1)</Script>"
Response.End
EndIf
Next
Next
EndIf
IfRequest.QueryString<>""Then
ForEachGetReferInRequest.QueryString
ForSql_DATA=0ToUBound(arrNonlicet)
IfInStr(1,Request.QueryString(GetRefer),arrNonlicet(Sql_DATA),1)>0Then
Response.Write"<ScriptLanguage=JavaScript>alert('安全系统提示↓nn请不要在参数中包含非法字符！');history.back(-1)</Script>"
Response.End
EndIf
Next
Next
EndIf
EndSub
'================================================
'函数名：ChkQueryStr
'作用：过虑查询的非法字符
'参数：str----原字符串
'返回值：过滤后的字符
'================================================
PublicFunctionChkQueryStr(ByValstr)
OnErrorResumeNext
IfIsNull(str)Then
ChkQueryStr=""
ExitFunction
EndIf
str=Replace(str,"!","")
str=Replace(str,"]","")
str=Replace(str,"[","")
str=Replace(str,")","")
str=Replace(str,"(","")
str=Replace(str,"|","")
str=Replace(str,"+","")
str=Replace(str,"=","")
str=Replace(str,"'","''")
str=Replace(str,"%","")
str=Replace(str,"&","")
str=Replace(str,"#","")
str=Replace(str,"^","")
str=Replace(str,"","")
str=Replace(str,Chr(37),"")
str=Replace(str,Chr(0),"")
ChkQueryStr=str
EndFunction
'================================================
'过程名：CheckQuery
'作用：限制搜索的关键字
'参数：str----搜索的字符串
'返回值：True;False
'================================================
PublicFunctionCheckQuery(ByValstr)
DimFobWords,i,keyword
keyword=str
OnErrorResumeNext
FobWords=Array(91,92,304,305,430,431,437,438,12460,12461,12462,12463,12464,12465,12466,12467,12468,12469,12470,12471,12472,12473,12474,12475,12476,12477,12478,12479,12480,12481,12482,12483,12485,12486,12487,12488,12489,12490,12496,12497,12498,12499,12500,12501,12502,12503,12504,12505,12506,12507,12508,12509,12510,12532,12533,65339,65340)
Fori=1ToUBound(FobWords,1)
IfInStr(keyword,ChrW(FobWords(i)))>0Then
CheckQuery=False
ExitFunction
EndIf
Next
FobWords=Array("~","!","@","#","$","%","^","&","*","(",")","_","+","=","`","[","]","{","}",";",":","""","'","<",">",".","/","","|","?","about","after","all","also","an","and","another","any","are","as","at","be","because","been","before","being","between","both","but","by","came","can","come","could","did","do","each","for","from","get","got","had","has","have","he","her","here","him","himself","his","how","if","in","into","is","it","like","make","many","me","might","more","most","much","must","my","never","now","of","on","only","or","other","our","out","over","said","same","see","should","since","some","still","such","take","than","that","the","their","them","then","there","these","they","this")
keyword=Left(keyword,100)
keyword=Replace(keyword,"!","")
keyword=Replace(keyword,"]","")
keyword=Replace(keyword,"[","")
keyword=Replace(keyword,")","")
keyword=Replace(keyword,"(","")
keyword=Replace(keyword,"","")
keyword=Replace(keyword,"-","")
keyword=Replace(keyword,"/","")
keyword=Replace(keyword,"+","")
keyword=Replace(keyword,"=","")
keyword=Replace(keyword,",","")
keyword=Replace(keyword,"'","")
Fori=0ToUBound(FobWords,1)
Ifkeyword=FobWords(i)Then
CheckQuery=False
ExitFunction
EndIf
Next
CheckQuery=True
EndFunction
'================================================
'函数名：IsValidStr
'作用：判断字符串中是否含有非法字符
'参数：str----原字符串
'返回值：False,True-----布尔值
'================================================
PublicFunctionIsValidStr(ByValstr)
IsValidStr=False
OnErrorResumeNext
IfIsNull(str)ThenExitFunction
IfTrim(str)=EmptyThenExitFunction
DimForbidStr,i
ForbidStr="and|chr|:|=|%|&|$|#|@|+|-|*|/||<|>|;|,|^|"&Chr(32)&"|"&Chr(34)&"|"&Chr(39)&"|"&Chr(9)
ForbidStr=Split(ForbidStr,"|")
Fori=0ToUBound(ForbidStr)
IfInStr(1,str,ForbidStr(i),1)>0Then
IsValidStr=False
ExitFunction
EndIf
Next
IsValidStr=True
EndFunction
'================================================
'函数名：IsValidPassword
'作用：判断密码中是否含有非法字符
'参数：str----原字符串
'返回值：False,True-----布尔值
'================================================
PublicFunctionIsValidPassword(ByValstr)
IsValidPassword=False
OnErrorResumeNext
IfIsNull(str)ThenExitFunction
IfTrim(str)=EmptyThenExitFunction
DimForbidStr,i
ForbidStr="=and|chr|*|^|%|&|;|,|"&Chr(32)&"|"&Chr(34)&"|"&Chr(39)&"|"&Chr(9)
ForbidStr=Split(ForbidStr,"|")
Fori=0ToUBound(ForbidStr)
IfInStr(1,str,ForbidStr(i),1)>0Then
IsValidPassword=False
ExitFunction
EndIf
Next
IsValidPassword=True
EndFunction
'================================================
'函数名：IsValidChar
'作用：判断字符串中是否含有非法字符和中文
'参数：str----原字符串
'返回值：False,True-----布尔值
'================================================
PublicFunctionIsValidChar(ByValstr)
IsValidChar=False
OnErrorResumeNext
IfIsNull(str)ThenExitFunction
IfTrim(str)=EmptyThenExitFunction
DimValidStr
Dimi,l,s,c
ValidStr="ABCDEFGHIJKLMNOPQRSTUVWXYZ.-_:~/0123456789"
l=Len(str)
s=UCase(str)
Fori=1Tol
c=Mid(s,i,1)
IfInStr(ValidStr,c)=0Then
IsValidChar=False
ExitFunction
EndIf
Next
IsValidChar=True
EndFunction
'================================================
'函数名：FormatDate
'作用：格式化日期
'参数：DateAndTime----原日期和时间
'para----日期格式
'返回值：格式化后的日期
'================================================
PublicFunctionFormatDate(DateAndTime,para)
OnErrorResumeNext
Dimy,m,d,h,mi,s,strDateTime
FormatDate=DateAndTime
IfNotIsNumeric(para)ThenExitFunction
IfNotIsDate(DateAndTime)ThenExitFunction
y=CStr(Year(DateAndTime))
m=CStr(Month(DateAndTime))
IfLen(m)=1Thenm="0"&m
d=CStr(Day(DateAndTime))
IfLen(d)=1Thend="0"&d
h=CStr(Hour(DateAndTime))
IfLen(h)=1Thenh="0"&h
mi=CStr(Minute(DateAndTime))
IfLen(mi)=1Thenmi="0"&mi
s=CStr(Second(DateAndTime))
IfLen(s)=1Thens="0"&s
SelectCasepara
Case"1"
strDateTime=y&"-"&m&"-"&d&""&h&":"&mi&":"&s
Case"2"
strDateTime=y&"-"&m&"-"&d
Case"3"
strDateTime=y&"/"&m&"/"&d
Case"4"
strDateTime=y&"年"&m&"月"&d&"日"
Case"5"
strDateTime=m&"-"&d
Case"6"
strDateTime=m&"/"&d
Case"7"
strDateTime=m&"月"&d&"日"
Case"8"
strDateTime=y&"年"&m&"月"
Case"9"
strDateTime=y&"-"&m
Case"10"
strDateTime=y&"/"&m
CaseElse
strDateTime=DateAndTime
EndSelect
FormatDate=strDateTime
EndFunction
'================================================
'函数名：ReadFontMode
'作用：读取字体模式
'参数：str----原字符串
'vColor-----颜色的值
'vFont-----字体的值
'返回值：新字符串
'================================================
PublicFunctionReadFontMode(str,vColor,vFont)
DimFontStr,tColor
DimColorStr,arrColor
IfIsNull(str)Then
ReadFontMode=""
ExitFunction
EndIf
ReadFontMode=str
OnErrorResumeNext
IfNotIsNumeric(vColor)ThenExitFunction
IfNotIsNumeric(vFont)ThenExitFunction
SelectCaseCInt(vFont)
Case1
FontStr="<b>"&str&"</b>"
Case2
FontStr="<em>"&str&"</em>"
Case3
FontStr="<u>"&str&"</u>"
Case4
FontStr="<b><em>"&str&"</em></b>"
Case5
FontStr="<b><u>"&str&"</u></b>"
Case6
FontStr="<em><u>"&str&"</u></em>"
Case7
FontStr="<b><em><u>"&str&"</u></em></b>"
CaseElse
FontStr=str
EndSelect
ReadFontMode=FontStr
IfvColor=""OrvColor=0ThenExitFunction
ColorStr=","&InitTitleColor
arrColor=Split(ColorStr,",")
IfvColor>UBound(arrColor)ThenExitFunction
tColor=Trim(arrColor(vColor))
ReadFontMode="<fontcolor="&tColor&">"&FontStr&"</font>"
EndFunction
'=============================================================
'函数名：ShowDateTime
'作用：读取日期格式
'参数：DateAndTime----当前时间
'para----时间格式
'=============================================================
PublicFunctionShowDateTime(DateAndTime,para)
ShowDateTime=""
DimstrDate
IfNotIsDate(DateAndTime)ThenExitFunction
IfDateAndTime>=DateThen
strDate="<fontcolor='"&Main_Setting(1)&"'>"
strDate=strDate&FormatDate(DateAndTime,para)
strDate=strDate&"</font>"
Else
strDate="<fontcolor='"&Main_Setting(2)&"'>"
strDate=strDate&FormatDate(DateAndTime,para)
strDate=strDate&"</font>"
EndIf
ShowDateTime=strDate
EndFunction
PublicFunctionShowDatePath(strval,n)
ShowDatePath=""
IfTrim(strval)=""ThenExitFunction
DimstrTempPath,strTime
Dimy,m,d
strTime=Left(strval,8)
y=Left(strTime,4)
m=Mid(strTime,5,2)
d=Right(strTime,2)
SelectCaseCInt(n)
Case1
strTempPath=y&"/"&m&"/"&d&"/"
Case2
strTempPath=y&"/"&m&"/"
Case3
strTempPath=y&m&"/"
Case4
strTempPath=y&"/"
Case5
strTempPath=y&"-"&m&"-"&d&"/"
Case6
strTempPath=y&"-"&m&"/"
Case7
strTempPath="html/"
Case8
strTempPath="show/"
CaseElse
strTempPath=""
EndSelect
strTempPath=Replace(strTempPath,"","")
ShowDatePath=CStr(strTempPath)
EndFunction
'=============================================================
'函数名：ReadBriefTopicffd
'作用：读取简短标题
'参数：para
'返回值：简短标题
'=============================================================
PublicFunctionReadBriefTopic(ByValpara)
DimsBriefTopic
ReadBriefTopic=""
IfNotIsNumeric(para)ThenExitFunction
Ifpara=0ThenExitFunction
SelectCasepara
Case"1"
sBriefTopic="<fontcolor='blue'>[图文]</font>"
Case"2"
sBriefTopic="<fontcolor='red'>[组图]</font>"
Case"3"
sBriefTopic="<fontcolor='green'>[新闻]</font>"
Case"4"
sBriefTopic="<fontcolor='blue'>[推荐]</font>"
Case"5"
sBriefTopic="<fontcolor='red'>[注意]</font>"
Case"6"
sBriefTopic="<fontcolor='green'>[转载]</font>"
CaseElse
sBriefTopic=""
EndSelect
ReadBriefTopic=sBriefTopic
EndFunction
'=============================================================
'函数名：ReadPicTopic
'作用：读取简短标题
'参数：para
'返回值：简短标题
'=============================================================
PublicFunctionReadPicTopic(ByValpara)
DimsBriefTopic
ReadPicTopic=""
IfNotIsNumeric(para)ThenExitFunction
Ifpara=0ThenExitFunction
SelectCasepara
Case"1"
sBriefTopic="<fontcolor='"&Main_Setting(4)&"'>[图文]</font>"
Case"2"
sBriefTopic="<fontcolor='"&Main_Setting(5)&"'>[组图]</font>"
Case"3"
sBriefTopic="<fontcolor='"&Main_Setting(6)&"'>[新闻]</font>"
Case"4"
sBriefTopic="<fontcolor='"&Main_Setting(4)&"'>[推荐]</font>"
Case"5"
sBriefTopic="<fontcolor='"&Main_Setting(5)&"'>[注意]</font>"
Case"6"
sBriefTopic="<fontcolor='"&Main_Setting(6)&"'>[转载]</font>"
CaseElse
sBriefTopic=""
EndSelect
ReadPicTopic=sBriefTopic
EndFunction
'=============================================================
'函数名：ReadPayMoney
'作用：读取要支付的金钱
'参数：money----实际金钱
'返回值：加上手续费后的金钱
'=============================================================
PublicFunctionReadPayMoney(ByValmoney,ByValReduce)
OnErrorResumeNext
Ifmoney=0Then
ReadPayMoney=0
ExitFunction
EndIf
DimarrChinaeBank,valPercent,Percents
arrChinaeBank=Split(ChinaeBank,"|||")
Percents=CCur(arrChinaeBank(2)/100)
IfPercents=0Then
ReadPayMoney=CCur(money)
Else
IfCBool(Reduce)=TrueThen
valPercent=Round(CCur(money)/(1+1*Percents),2)
ReadPayMoney=CCur(valPercent)
Else
valPercent=Round(CCur(money)*Percents,2)
ReadPayMoney=CCur(money+valPercent)
EndIf
EndIf
EndFunction
'=============================================================
'函数名：RebateMoney
'作用：读取打折的后金钱
'参数：money----实际金钱
'Discount----折扣
'=============================================================
PublicFunctionRebateMoney(ByValmoney,ByValDiscount)
OnErrorResumeNext
DimRebate
money=CheckNumeric(money)
Discount=CheckNumeric(Discount)
IfDiscount>0AndDiscount<10Then
Rebate=Round(money*(Discount/10),2)
RebateMoney=CCur(Rebate)
Else
RebateMoney=CCur(money)
EndIf
EndFunction
'================================================
'函数名：Supplemental
'作用：补足参数
'参数：para----原参数
'n----增补的位数
'================================================
PublicFunctionSupplemental(para,n)
Supplemental=""
IfNotIsNumeric(para)ThenExitFunction
IfLen(para)<nThen
Supplemental=String(n-Len(para),"0")¶
Else
Supplemental=para
EndIf
EndFunction
'-----------------------------------------------------------------
PublicFunctionGetChannelDir(ByValchanid)
OnErrorResumeNext
IfNotIsNumeric(chanid)Thenchanid=1
Name="Channel"&chanid
IfObjIsEmpty()ThenReloadChannel(chanid)
CacheChannel=Value
GetChannelDir=InstallDir&CacheChannel(2,0)
EndFunction
'================================================
'函数名：GetImageUrl
'作用：获取图片URL
'================================================
PublicFunctionGetImageUrl(ByValurl,ByValChannelDir)
OnErrorResumeNext
DimstrTempUrl,strImageUrl
IfNotIsNull(url)AndTrim(url)<>""AndLCase(url)<>"http://"Then
strTempUrl=InstallDir&ChannelDir
IfCheckUrl(url)=1Then
strImageUrl=Trim(url)
ElseIfCheckUrl(url)=2Then
strImageUrl=url
Else
strImageUrl=Replace(url,"../","")
strImageUrl=Trim(strTempUrl&strImageUrl)
EndIf
Else
strImageUrl=InstallDir&"images/no_pic.gif"
EndIf
GetImageUrl=strImageUrl
EndFunction
'-----------------------------------------------------------------
'================================================
'作用：读取图片或者FLASH
'参数：url----文件URL
'height----高度
'width----宽度
'================================================
FunctionGetFlashAndPic(ByValurl,ByValheight,ByValwidth)
OnErrorResumeNext
DimsExtName,ExtName,strTemp
DimstrHeight,strWidth
IfNotIsNumeric(height)Orheight<1Then
strHeight=""
Else
strHeight="height="&height
EndIf
IfNotIsNumeric(width)Orwidth<1Then
strWidth=""
Else
strWidth="width="&width
EndIf
sExtName=Split(url,".")
ExtName=sExtName(UBound(sExtName))
IfLCase(ExtName)="swf"Then
strTemp="<embedsrc="""&url&""""&strWidth&strHeight&">"
Else
strTemp="<imgsrc="""&url&""""&strWidth&strHeight&"border=0>"
EndIf
GetFlashAndPic=strTemp
EndFunction
'================================================
'函数名：ReadFileUrl
'作用：读取文件URL
'================================================
PublicFunctionReadFileUrl(url)
OnErrorResumeNext
ReadFileUrl=""
Ifurl=""ThenExitFunction
DimstrTemp
IfCheckUrl(url)=1Then
strTemp=Trim(url)
ElseIfCheckUrl(url)=2Then
strTemp=Trim(url)
Else
strTemp=Replace(url,"../","")
strTemp=Trim(InstallDir&strTemp)
EndIf
ReadFileUrl=strTemp
EndFunction
PublicFunctionCheckUrl(ByValurl)
DimstrUrl
IfLeft(url,1)="/"Then
CheckUrl=1
ExitFunction
EndIf
strUrl=LCase(Left(url,6))
SelectCaseTrim(strUrl)
Case"http:/","https:","ftp://","rtsp:/","mms://"
CheckUrl=2
ExitFunction
CaseElse
CheckUrl=0
EndSelect
EndFunction
'================================================
'函数名：ReadFileName
'作用：读取HTML文件名
'参数：strname----文件名称
'id----数据ID
'ExtName----HTML扩展名
'PrefixStr----HTML名称前缀
'HtmlForm----HTML文件格式
'n----HTML分页
'================================================
PublicFunctionReadFileName(ByValstrname,ByValid,ByValExtName,ByValPrefixStr,ByValHtmlForm,ByValn)
DimstrFileName,strExtName,CurrentPage
IfTrim(strname)=""ThenExitFunction
IfTrim(ExtName)=""ThenExtName=".html"
IfNotIsNumeric(n)Thenn=0
OnErrorResumeNext
IfCInt(n)<=1Then
CurrentPage=""
Else
CurrentPage="_"&n
EndIf
IfLeft(ExtName,1)<>"."Then
strExtName="."&Trim(ExtName)
Else
strExtName=Trim(ExtName)
EndIf
SelectCaseTrim(HtmlForm)
Case"1"
strFileName=Trim(id)
Case"2"
strFileName=Trim(PrefixStr)&Trim(Supplemental(id,3))
Case"3"
strFileName=Left(strname,8)
strFileName=strFileName&Trim(Supplemental(id,3))
Case"4"
strFileName=Right(strname,7)
strFileName=strFileName&Trim(Supplemental(id,3))
CaseElse
strFileName=strname
EndSelect
strFileName=Replace(strFileName&CurrentPage&strExtName,"","")
ReadFileName=CStr(strFileName)
EndFunction
'================================================
'过程名：HtmlRndFileName
'作用：取HTML的随机文件名
'================================================
FunctionHtmlRndFileName()
DimsRnd
Randomize
sRnd=Int(90*Rnd)+10
HtmlRndFileName=Replace(Replace(Replace(FormatDate(Now(),1),"-",""),":",""),"","")&sRnd
EndFunction
'================================================
'函数名：ClassFileName
'作用：读取HTML文件列表名
'参数：ClassID----分类ID
'================================================
PublicFunctionClassFileName(ByValClassID,ByValExtName,ByValPrefixStr,ByValn)
DimstrFileName,strExtName,strClassID
IfTrim(ExtName)=""ThenExtName=".html"
IfNotIsNumeric(n)Thenn=0
IfLeft(ExtName,1)<>"."Then
strExtName="."&Trim(ExtName)
Else
strExtName=Trim(ExtName)
EndIf
IfCInt(n)<=1Then
strFileName="index"&strExtName
Else
strClassID=Supplemental(ClassID,3)
strFileName=PrefixStr&strClassID&"_"&n&strExtName
EndIf
strFileName=Replace(strFileName,"","")
ClassFileName=CStr(strFileName)
EndFunction
'================================================
'函数名：SpecialFileName
'作用：读取专题HTML文件名
'参数：specid----专题ID
'================================================
PublicFunctionSpecialFileName(ByValspecid,ByValExtName,ByValn)
DimstrFileName,strExtName,strSpecialID
IfTrim(ExtName)=""ThenExtName=".html"
IfNotIsNumeric(n)Thenn=0
IfLeft(ExtName,1)<>"."Then
strExtName="."&Trim(ExtName)
Else
strExtName=Trim(ExtName)
EndIf
IfCInt(n)<=1Then
strFileName="index"&strExtName
Else
strSpecialID=Supplemental(specid,3)
strFileName="Special"&strSpecialID&"_"&n&strExtName
EndIf
strFileName=Replace(strFileName,"","")
SpecialFileName=CStr(strFileName)
EndFunction
'================================================
'函数名：ChannelMenu
'作用：显示频道菜单
'================================================
PublicFunctionChannelMenu()
DimSQL,Rs,i,TotalNumber,strTop
DimstrContent,LinkTarget,ChannelName
DimChannelUrl,HtmlContent,sCaption
Name="ChannelMenu"
IfObjIsEmpty()Then
IfChkNumeric(Main_Setting(7))=0Then
strTop=vbNullString
Else
strTop="TOP"&CInt(Main_Setting(7))
EndIf
SQL="SELECT"&strTop&"ChannelID,orders,ColorModes,FontModes,ChannelName,Caption,ChannelDir,StopChannel,IsHidden,BindDomain,DomainName,LinkTarget,ChannelType,ChannelUrl,IsHiddenFROM[NC_Channel]WHEREIsHidden=0OrderByorders"
SetRs=Execute(SQL)
IfRs.BOFAndRs.EOFThen
strContent=""
Else
i=0
TotalNumber=Rs.RecordCount
DoWhileNotRs.EOF
i=i+1
IfRs("LinkTarget")<>0Then
LinkTarget="target=""_blank"""
Else
LinkTarget=""
EndIf
HtmlContent=HtmlContent&Main_Setting(9)
ChannelName=ReadFontMode(Rs("ChannelName"),Rs("ColorModes"),Rs("FontModes"))
IfRs("ChannelType")<2Then
ChannelUrl=InstallDir&Rs("ChannelDir")
Else
ChannelUrl=Rs("ChannelUrl")
EndIf
IfRs("StopChannel")<>0Then
sCaption="此频道暂时关闭,不能访问！"
Else
sCaption=Rs("Caption")
EndIf
strContent="<ahref="""&ChannelUrl&""""&LinkTarget&"title="""&sCaption&"""class=navmenu>"&ChannelName&"</a>"
IfiModCInt(Main_Setting(8))=0ThenstrContent=strContent&"<br>"
HtmlContent=Replace(HtmlContent,"{$ChannelMenu}",strContent)
Rs.MoveNext
Loop
EndIf
Rs.Close:SetRs=Nothing
'Value=strContent
EndIf
'strContent=Value
ChannelMenu=HtmlContent
EndFunction
'=============================================================
'函数名：LoadSelectClass
'作用：载入缓存下拉分类列表
'参数：ChannelID----频道ID
'返回值：下拉分类列表
'=============================================================
PublicFunctionLoadSelectClass(ChannelID)
DimCacheSelClass,SQL,Rs1,i
Name="SelectClass"&ChannelID
IfObjIsEmpty()Then
SQL="selectClassID,ClassName,depth,TurnLink,childfromNC_ClassifywhereChannelID="&ChannelID&"orderbyrootid,orders"
SetRs1=Execute(SQL)
IfRs1.BOFAndRs1.EOFThen
CacheSelClass=CacheSelClass&"<option>没有添加分类</option>"
EndIf
DoWhileNotRs1.EOF
IfRs1("TurnLink")<>0Then
CacheSelClass=CacheSelClass&"<optionvalue=""0"""
Else
IfRs1("depth")=0AndRs1("child")<>0Then
CacheSelClass=CacheSelClass&"<option"
Else
CacheSelClass=CacheSelClass&"<optionvalue="""&Rs1("ClassID")&""""
EndIf
EndIf
CacheSelClass=CacheSelClass&"{ClassID="&Rs1("ClassID")&"}>"
IfRs1("depth")=1ThenCacheSelClass=CacheSelClass&"├"
IfRs1("depth")>1Then
Fori=2ToRs1("depth")
CacheSelClass=CacheSelClass&""
Next
CacheSelClass=CacheSelClass&"├"
EndIf
CacheSelClass=CacheSelClass&Rs1("ClassName")&"</option>"&vbCrLf
Rs1.MoveNext
Loop
Rs1.Close
SetRs1=Nothing
Value=CacheSelClass
EndIf
LoadSelectClass=Value
EndFunction
PublicFunctionClassJumpMenu(ChannelID)
DimCacheJumpMenu
DimRs1
Dimi
Name="ClassJumpMenu"&ChannelID
IfObjIsEmpty()Then
SetRs1=Execute("selectClassID,ChannelID,ClassName,depth,TurnLink,TurnLinkUrlfrom[NC_Classify]whereChannelID="&ChannelID&"orderbyrootid,orders")
DoWhileNotRs1.EOF
IfRs1("TurnLink")<>0Then
CacheJumpMenu=CacheJumpMenu&"<optionvalue="""&Rs1("TurnLinkUrl")&"""{ClassID="&Rs1("classid")&"}"
Else
CacheJumpMenu=CacheJumpMenu&"<optionvalue=""?ChannelID="&Rs1("ChannelID")&"&sortid="&Rs1("classid")&"""{ClassID="&Rs1("classid")&"}"
EndIf
IfTrim(Request("sortid"))<>""Then
IfCLng(Request("sortid"))=Rs1("classid")ThenCacheJumpMenu=CacheJumpMenu&"selected"
EndIf
CacheJumpMenu=CacheJumpMenu&">"
IfRs1("depth")=1ThenCacheJumpMenu=CacheJumpMenu&"├"
IfRs1("depth")>1Then
Fori=2ToRs1("depth")
CacheJumpMenu=CacheJumpMenu&""
Next
CacheJumpMenu=CacheJumpMenu&"├"
EndIf
CacheJumpMenu=CacheJumpMenu&Rs1("ClassName")&"</option>"&vbCrLf
Rs1.MoveNext
Loop
Rs1.Close
SetRs1=Nothing
Value=CacheJumpMenu
EndIf
ClassJumpMenu=Value
EndFunction
'================================================
'函数名：GetRandomCode
'作用：系统分配随机代码
'================================================
PublicFunctionGetRandomCode()
DimRan,i,LengthNum
LengthNum=16
GetRandomCode=""
Fori=1ToLengthNum
Randomize
Ran=CInt(Rnd*2)
Randomize
IfRan=0Then
Ran=CInt(Rnd*25)+97
GetRandomCode=GetRandomCode&UCase(Chr(Ran))
ElseIfRan=1Then
Ran=CInt(Rnd*9)
GetRandomCode=GetRandomCode&Ran
ElseIfRan=2Then
Ran=CInt(Rnd*25)+97
GetRandomCode=GetRandomCode&Chr(Ran)
EndIf
Next
EndFunction
'================================================
'函数名：CodeIsTrue
'作用：检查验证码是否正确
'================================================
PublicFunctionCodeIsTrue()
DimCodeStr
CodeStr=Trim(Request("CodeStr"))
OnErrorResumeNext
IfCStr(Session("GetCode"))=CStr(CodeStr)AndCodeStr<>""Then
CodeIsTrue=True
Session("GetCode")=Empty
Else
CodeIsTrue=False
Session("GetCode")=Empty
EndIf
EndFunction
PublicFunctionCheckAdmin(ByValFlag)
DimRs,SQL
Dimi,TempAdmin,AdminFlag,AdminGrade
CheckAdmin=False
OnErrorResumeNext
SQL="SELECTAdminGrade,AdminflagFROMNC_AdminWHEREusername='"&Replace(Session("AdminName"),"'","''")&"'Andpassword='"&Replace(Session("AdminPass"),"'","''")&"'AndisLock=0Andid="&CLng(Session("AdminID"))
SetRs=Execute(SQL)
IfRs.BOFAndRs.EOFThen
CheckAdmin=False
SetRs=Nothing
ExitFunction
Else
AdminFlag=Rs("Adminflag")
AdminGrade=Rs("AdminGrade")
EndIf
Rs.Close:SetRs=Nothing
IfCInt(AdminGrade)=999Then
CheckAdmin=True
ExitFunction
Else
IfTrim(Flag)=""ThenExitFunction
IfAdminFlag=""Then
CheckAdmin=False
ExitFunction
Else
TempAdmin=Split(AdminFlag,",")
Fori=0ToUBound(TempAdmin)
IfTrim(LCase(TempAdmin(i)))=Trim(LCase(Flag))Then
CheckAdmin=True
ExitFor
EndIf
Next
EndIf
EndIf
EndFunction
'================================================
'函数名：ReadAlpha
'作用：读取字符串的第一个字母
'参数：str----字符
'返回值：返回第一个字母
'================================================
PublicFunctionReadAlpha(ByValstr)
DimstrTemp
IfIsNull(str)OrTrim(str)=""Then
ReadAlpha="A-9"
ExitFunction
EndIf
str=Trim(str)
strTemp=65536+Asc(str)
If(strTemp>=45217AndstrTemp<=45252)Or(strTemp=65601)Or(strTemp=65633)Or(strTemp=37083)Then
ReadAlpha="A-Z"
ElseIf(strTemp>=45253AndstrTemp<=45760)Or(strTemp=65602)Or(strTemp=65634)Or(strTemp=39658)Then
ReadAlpha="B-Z"
ElseIf(strTemp>=45761AndstrTemp<=46317)Or(strTemp=65603)Or(strTemp=65635)Or(strTemp=33405)Then
ReadAlpha="C-Z"
ElseIf(strTemp>=46318AndstrTemp<=46930)Or(strTemp>=61884AndstrTemp<=61884)Or(strTemp=65604)Or(strTemp>=36820AndstrTemp<=38524)Or(strTemp=65636)Then
ReadAlpha="D-Z"
ElseIf(strTemp>=46931AndstrTemp<=47009)Or(strTemp=65605)Or(strTemp=65637)Or(strTemp=61513)Then
ReadAlpha="E-Z"
ElseIf(strTemp>=47010AndstrTemp<=47296)Or(strTemp=65606)Or(strTemp=65638)Or(strTemp=61320)Or(strTemp=63568)Or(strTemp=36281)Then
ReadAlpha="F-Z"
ElseIf(strTemp>=47297AndstrTemp<=47613)Or(strTemp=65607)Or(strTemp=65639)Or(strTemp=35949)Or(strTemp=36089)Or(strTemp=36694)Or(strTemp=34808)Then
ReadAlpha="G-Z"
ElseIf(strTemp>=47614AndstrTemp<=48118)Or(strTemp>=59112AndstrTemp<=59112)Or(strTemp=65608)Or(strTemp=65640)Then
ReadAlpha="H-Z"
ElseIf(strTemp=65641)Or(strTemp=65609)Or(strTemp=65641)Then
ReadAlpha="I-Z"
ElseIf(strTemp>=48119AndstrTemp<=49061AndstrTemp<>48739)Or(strTemp>=62430AndstrTemp<=62430)Or(strTemp=65610)Or(strTemp=65642)Or(strTemp=39048)Then
ReadAlpha="J-Z"
ElseIf(strTemp>=49062AndstrTemp<=49323)Or(strTemp=65611)Or(strTemp=65643)Then
ReadAlpha="K-Z"
ElseIf(strTemp>=49324AndstrTemp<=49895)Or(strTemp>=58838AndstrTemp<=58838)Or(strTemp=65612)Or(strTemp=65644)Or(strTemp=62418)Or(strTemp=48739)Then
ReadAlpha="L-Z"
ElseIf(strTemp>=49896AndstrTemp<=50370)Or(strTemp=65613)Or(strTemp=65645)Then
ReadAlpha="M-Z"
ElseIf(strTemp>=50371AndstrTemp<=50613)Or(strTemp=65614)Or(strTemp=65646)Then
ReadAlpha="N-Z"
ElseIf(strTemp>=50614AndstrTemp<=50621)Or(strTemp=65615)Or(strTemp=65647)Then
ReadAlpha="O-Z"
ElseIf(strTemp>=50622AndstrTemp<=50905)Or(strTemp=65616)Or(strTemp=65648)Then
ReadAlpha="P-Z"
ElseIf(strTemp>=50906AndstrTemp<=51386)Or(strTemp>=62659AndstrTemp<=63172)Or(strTemp=65617)Or(strTemp=65649)Then
ReadAlpha="Q-Z"
ElseIf(strTemp>=51387AndstrTemp<=51445)Or(strTemp=65618)Or(strTemp=65650)Then
ReadAlpha="R-Z"
ElseIf(strTemp>=51446AndstrTemp<=52217)Or(strTemp=65619)Or(strTemp=65651)Or(strTemp=34009)Then
ReadAlpha="S-Z"
ElseIf(strTemp>=52218AndstrTemp<=52697)Or(strTemp=65620)Or(strTemp=65652)Then
ReadAlpha="T-Z"
ElseIf(strTemp=65621)Or(strTemp=65653)Then
ReadAlpha="U-Z"
ElseIf(strTemp=65622)Or(strTemp=65654)Then
ReadAlpha="V-Z"
ElseIf(strTemp>=52698AndstrTemp<=52979)Or(strTemp=65623)Or(strTemp=65655)Then
ReadAlpha="W-Z"
ElseIf(strTemp>=52980AndstrTemp<=53688)Or(strTemp=65624)Or(strTemp=65656)Then
ReadAlpha="X-Z"
ElseIf(strTemp>=53689AndstrTemp<=54480)Or(strTemp=65625)Or(strTemp=65657)Then
ReadAlpha="Y-Z"
ElseIf(strTemp>=54481AndstrTemp<=62383AndstrTemp<>59112AndstrTemp<>58838)Or(strTemp=65626)Or(strTemp=65658)Or(strTemp=38395)Or(strTemp=39783)Then
ReadAlpha="Z-Z"
Else
ReadAlpha="A-9"
EndIf
If(strTemp>=65633AndstrTemp<=65658)Or(strTemp>=65601AndstrTemp<=65626)ThenReadAlpha=UCase(Left(str,1))
If(strTemp>=65584AndstrTemp<=65593)ThenReadAlpha="0-9"
EndFunction
'--修正文件路径
PublicFunctionCheckPath(ByValsPath)
sPath=Trim(sPath)
IfRight(sPath,1)<>""AndsPath<>""Then
sPath=sPath&""
EndIf
CheckPath=sPath
EndFunction
'--生成目录
PublicFunctionCreatPathEx(ByValsPath)
sPath=Replace(sPath,"/","")
sPath=Replace(sPath,"","")
OnErrorResumeNext
DimstrHostPath,strPath
DimsPathItem,sTempPath
Dimi,fso
Setfso=Server.CreateObject(FSO_ScriptName)
strHostPath=Server.MapPath("/")
IfInStr(sPath,":")=0ThensPath=Server.MapPath(sPath)
Iffso.FolderExists(sPath)OrLen(sPath)<3Then
CreatPathEx=True
ExitFunction
EndIf
strPath=Replace(sPath,strHostPath,vbNullString,1,-1,1)
sPathItem=Split(strPath,"")
IfInStr(LCase(sPath),LCase(strHostPath))=0Then
sTempPath=sPathItem(0)
Else
sTempPath=strHostPath
EndIf
Fori=1ToUBound(sPathItem)
IfsPathItem(i)<>""Then
sTempPath=sTempPath&""&sPathItem(i)
Iffso.FolderExists(sTempPath)=FalseThen
fso.CreateFoldersTempPath
EndIf
EndIf
Next
Setfso=Nothing
IfErr.Number<>0ThenErr.Clear
CreatPathEx=True
EndFunction
'================================================
'函数名：FilesDelete
'作用：FSO删除文件
'参数：filepath----文件路径
'返回值：False----True
'================================================
PublicFunctionFileDelete(ByValFilePath)
OnErrorResumeNext
FileDelete=False
Dimfso
Setfso=Server.CreateObject(FSO_ScriptName)
IfFilePath=""ThenExitFunction
IfInStr(FilePath,":")=0ThenFilePath=Server.MapPath(FilePath)
Iffso.FileExists(FilePath)Then
fso.DeleteFileFilePath,True
FileDelete=True
EndIf
Setfso=Nothing
IfErr.Number<>0ThenErr.Clear
EndFunction
'================================================
'函数名：FolderDelete
'作用：FSO删除目录
'参数：folderpath----目录路径
'返回值：False----True
'================================================
PublicFunctionFolderDelete(ByValFolderPath)
FolderDelete=False
OnErrorResumeNext
Dimfso
Setfso=Server.CreateObject(FSO_ScriptName)
IfFolderPath=""ThenExitFunction
IfInStr(FolderPath,":")=0ThenFolderPath=Server.MapPath(FolderPath)
Iffso.FolderExists(FolderPath)Then
fso.DeleteFolderFolderPath,True
FolderDelete=True
EndIf
Setfso=Nothing
IfErr.Number<>0ThenErr.Clear
EndFunction
'================================================
'函数名：CopyToFile
'作用：复制文件
'参数：SoureFile----原文件路径
'NewFile----目标文件路径
'================================================
PublicFunctionCopyToFile(ByValSoureFile,ByValNewFile)
OnErrorResumeNext
IfSoureFile=""ThenExitFunction
IfNewFile=""ThenExitFunction
IfInStr(SoureFile,":")=0ThenSoureFile=Server.MapPath(SoureFile)
IfInStr(NewFile,":")=0ThenNewFile=Server.MapPath(NewFile)
Dimfso
Setfso=Server.CreateObject(FSO_ScriptName)
Iffso.FileExists(SoureFile)Then
fso.CopyFileSoureFile,NewFile
EndIf
Setfso=Nothing
IfErr.Number<>0ThenErr.Clear
EndFunction
'================================================
'函数名：CopyToFolder
'作用：复制文件夹
'参数：SoureFolder----原路径
'NewFolder----目标路径
'================================================
PublicFunctionCopyToFolder(ByValSoureFolder,ByValNewFolder)
OnErrorResumeNext
IfSoureFolder=""ThenExitFunction
IfNewFolder=""ThenExitFunction
IfInStr(SoureFolder,":")=0ThenSoureFolder=Server.MapPath(SoureFolder)
IfInStr(NewFolder,":")=0ThenNewFolder=Server.MapPath(NewFolder)
Dimfso
Setfso=Server.CreateObject(FSO_ScriptName)
Iffso.FolderExists(SoureFolder)Then
fso.CopyFolderSoureFolder,NewFolder
EndIf
Setfso=Nothing
IfErr.Number<>0ThenErr.Clear
EndFunction
'=============================================================
'过程名：CreatedTextFile
'作用：创建文本文件
'参数：filename----文件名
'body----主要内容
'=============================================================
PublicFunctionCreatedTextFile(ByValFileName,ByValbody)
OnErrorResumeNext
IfInStr(FileName,":")=0ThenFileName=Server.MapPath(FileName)
Dimfso,f
Setfso=Server.CreateObject(FSO_ScriptName)
Setf=fso.CreateTextFile(FileName)
f.WriteLinebody
f.Close
Setf=Nothing
Setfso=Nothing
IfErr.Number<>0ThenErr.Clear
EndFunction
'================================================
'函数名：Readfile
'作用：读取文件内容
'参数：fromPath----来源文件路径
'================================================
PublicFunctionReadfile(ByValfromPath)
OnErrorResumeNext
DimstrTemp,fso,f
IfInStr(fromPath,":")=0ThenfromPath=Server.MapPath(fromPath)
Setfso=Server.CreateObject(FSO_ScriptName)
Iffso.FileExists(fromPath)Then
Setf=fso.OpenTextFile(fromPath,1,True)
strTemp=f.ReadAll
f.Close
Setf=Nothing
EndIf
Setfso=Nothing
Readfile=strTemp
IfErr.Number<>0ThenErr.Clear
EndFunction
'================================================
'函数名：CutMatchContent
'作用：截取相匹配的内容
'参数：Str----原字符串
'PatStr----符合条件字符
'================================================
PublicFunctionCutMatchContent(ByValstr,ByValstart,ByVallast,ByValCondition)
DimMatch,s,re
DimFilterStr,MatchStr
DimstrContent,ArrayFilter
Dimi,n,bRepeat
IfLen(start)=0OrLen(last)=0ThenExitFunction
OnErrorResumeNext
MatchStr="("&CorrectPattern(start)&")(.+?)("&CorrectPattern(last)&")"
Setre=NewRegExp
re.IgnoreCase=True
re.Global=True
re.Pattern=MatchStr
Sets=re.Execute(str)
n=0
ForEachMatchIns
Ifn=0Then
n=n+1
ReDimArrayFilter(n)
ArrayFilter(n)=Match
Else
bRepeat=False
Fori=0ToUBound(ArrayFilter)
IfUCase(Match)=UCase(ArrayFilter(i))Then
bRepeat=True
ExitFor
EndIf
Next
IfbRepeat=FalseThen
n=n+1
ReDimPreserveArrayFilter(n)
ArrayFilter(n)=Match
EndIf
EndIf
Next
Sets=Nothing
Setre=Nothing
IfCBool(Condition)Then
strContent=Join(ArrayFilter,"|||")
Else
strContent=Join(ArrayFilter,"|||")
strContent=Replace(strContent,start,"")
strContent=Replace(strContent,last,"")
EndIf
CutMatchContent=Replace(strContent,"|||",vbNullString,1,1)
EndFunction
FunctionCutFixContent(ByValstr,ByValstart,ByVallast,ByValn)
DimstrTemp
OnErrorResumeNext
IfInStr(str,start)>0Then
SelectCasen
Case0'左右都截取（都取前面）（去处关键字）
strTemp=Right(str,Len(str)-InStr(str,start)-Len(start)+1)
strTemp=Left(strTemp,InStr(strTemp,last)-1)
CaseElse'左右都截取（都取前面）（保留关键字）
strTemp=Right(str,Len(str)-InStr(str,start)+1)
strTemp=Left(strTemp,InStr(strTemp,last)+Len(last)-1)
EndSelect
Else
strTemp=""
EndIf
CutFixContent=strTemp
EndFunction
PrivateFunctionCorrectPattern(ByValstr)
str=Replace(str,"","")
str=Replace(str,"~","~")
str=Replace(str,"!","!")
str=Replace(str,"@","@")
str=Replace(str,"#","#")
str=Replace(str,"%","%")
str=Replace(str,"^","^")
str=Replace(str,"&","&")
str=Replace(str,"*","*")
str=Replace(str,"(","(")
str=Replace(str,")",")")
str=Replace(str,"-","-")
str=Replace(str,"+","+")
str=Replace(str,"[","[")
str=Replace(str,"]","]")
str=Replace(str,"<","<")
str=Replace(str,">",">")
str=Replace(str,".",".")
str=Replace(str,"/","/")
str=Replace(str,"?","?")
str=Replace(str,"=","=")
str=Replace(str,"|","|")
str=Replace(str,"$","$")
CorrectPattern=str
EndFunction
'=============================================================
'函数名：UserGroupSetting
'作用：取用户级权限设置
'参数：gradeid----等级ID
'=============================================================
PublicFunctionUserGroupSetting(ByValgradeid)
IfNotIsNumeric(gradeid)Then
gradeid=0
EndIf
OnErrorResumeNext
DimRs,SQL
Name="GroupSetting"&gradeid
IfObjIsEmpty()Then
SQL="SelectGroupname,GroupSetfrom[NC_UserGroup]whereGrades="&gradeid
SetRs=Execute(SQL)
IfRs.BOFAndRs.EOFThen
UserGroupSetting=""
SetRs=Nothing
ExitFunction
EndIf
Value=Rs("GroupSet")&Rs("Groupname")
SetRs=Nothing
EndIf
UserGroupSetting=Value
EndFunction
PrivateSubLoadGroupSetting()
DimstrGroupSetting
DimRs,SQL
DimGrades
Grades=CInt(membergrade)
OnErrorResumeNext
IfGrades>0Andmemberid>0Then
IfbinUserLong=FalseThen
SetRs=Execute("SELECTuseridFROM[NC_User]WHEREpassword='"&CheckRequest(memberpass,45)&"'AndUserGrade="&Grades&"AndUserLock=0Anduserid="&memberid)
IfRs.BOFAndRs.EOFThen
Grades=0
Response.Cookies(Cookies_Name)=""
binUserLong=False
Else
binUserLong=True
EndIf
SetRs=Nothing
EndIf
EndIf
Name="GroupSetting"&Grades
IfObjIsEmpty()Then
SQL="SelectGroupname,GroupSetfrom[NC_UserGroup]whereGrades="&Grades
SetRs=Execute(SQL)
IfRs.BOFAndRs.EOFThen
Response.Cookies(Cookies_Name)=""
SetRs=Nothing
ExitSub
EndIf
Value=Rs("GroupSet")&Rs("Groupname")
SetRs=Nothing
EndIf
blnGroupSetting=True
strGroupSetting=Value
arrGroupSetting=Split(strGroupSetting,"|||")
EndSub
PublicPropertyGetGroupSetting(i)
IfNotblnGroupSettingThenLoadGroupSetting
GroupSetting=arrGroupSetting(i)
EndProperty
PublicFunctionReadContent(ByValstrContent)
OnErrorResumeNext
Dimre,i
DimsContentKeyword,strKeyword
Setre=NewRegExp
re.IgnoreCase=True
re.Global=True
'过滤危险脚本
re.Pattern="(<s+cript(.[^>]*)>)"
strContent=re.Replace(strContent,"<")
re.Pattern="(</s+cript>)"
strContent=re.Replace(strContent,"</")
re.Pattern="(<body(.[^>]*)>)"
strContent=re.Replace(strContent,"<body>")
re.Pattern="(<!(.[^>]*)>)"
strContent=re.Replace(strContent,"<$2>")
re.Pattern="(<!)"
strContent=re.Replace(strContent,"<!")
re.Pattern="(-->)"
strContent=re.Replace(strContent,"-->")
re.Pattern="(javascript:)"
strContent=re.Replace(strContent,"<i>javascript</i>:")
IfTrim(ContentKeyword)<>""Then
sContentKeyword=Split(ContentKeyword,"@@@")
Fori=0ToUBound(sContentKeyword)-1
strKeyword=Split(sContentKeyword(i),"$$$")
re.Pattern="("&strKeyword(0)&")"
strContent=re.Replace(strContent,"<atarget=""_blank""href="""&strKeyword(1)&"""class=""wordstyle"">$1</a>")
Next
EndIf
re.Pattern="([i])(.[^[]*)([/i])"
strContent=re.Replace(strContent,"<i>$2</i>")
re.Pattern="([u])(.[^[]*)([/u])"
strContent=re.Replace(strContent,"<u>$2</u>")
re.Pattern="([b])(.[^[]*)([/b])"
strContent=re.Replace(strContent,"<b>$2</b>")
re.Pattern="([fly])(.*)([/fly])"
strContent=re.Replace(strContent,"<marquee>$2</marquee>")
re.Pattern="[size=([1-9])](.[^[]*)[/size]"
strContent=re.Replace(strContent,"<fontsize=$1>$2</font>")
re.Pattern="([center])(.[^[]*)([/center])"
strContent=re.Replace(strContent,"<center>$2</center>")
're.Pattern="<IMG.[^>]*SRC(=|)(.[^>]*)>"
'strContent=re.Replace(strContent,"<IMGSRC=$2border=""0"">")
re.Pattern="<img(.[^>]*)>"
strContent=re.Replace(strContent,"<img$1onload=""returnimgzoom(this,550)"">")
re.Pattern="[DIR=*([0-9]*),*([0-9]*)](.[^[]*)[/DIR]"
strContent=re.Replace(strContent,"<embedsrc=$3pluginspage=http://www.macromedia.com/shockwave/download/width=$1height=$2></embed>")
re.Pattern="[QT=*([0-9]*),*([0-9]*)](.[^[]*)[/QT]"
strContent=re.Replace(strContent,"<embedsrc=$3width=$1height=$2autoplay=trueloop=falsecontroller=trueplayeveryframe=falsecache=falsescale=TOFITbgcolor=#000000kioskmode=falsetargetcache=falsepluginspage=http://www.apple.com/quicktime/>")
re.Pattern="[MP=*([0-9]*),*([0-9]*)](.[^[]*)[/MP]"
strContent=re.Replace(strContent,"<embedtype=application/x-oleobjectcodebase=http://activex.microsoft.com/activex/controls/mplayer/en/nsmp2inf.cab#Version=5,1,52,701flename=mpsrc=$3width=$1height=$2></embed>")
re.Pattern="[RM=*([0-9]*),*([0-9]*)](.[^[]*)[/RM]"
strContent=re.Replace(strContent,"<OBJECTclassid=clsid:CFCDAA03-8BE4-11cf-B84B-0020AFBBCCFAclass=OBJECTid=RAOCXwidth=$1height=$2><PARAMNAME=SRCVALUE=$3><PARAMNAME=CONSOLEVALUE=Clip1><PARAMNAME=CONTROLSVALUE=imagewindow><PARAMNAME=AUTOSTARTVALUE=true></OBJECT><br><OBJECTclassid=CLSID:CFCDAA03-8BE4-11CF-B84B-0020AFBBCCFAheight=32id=video2width=$1><PARAMNAME=SRCVALUE=$3><PARAMNAME=AUTOSTARTVALUE=-1><PARAMNAME=CONTROLSVALUE=controlpanel><PARAMNAME=CONSOLEVALUE=Clip1></OBJECT>")
re.Pattern="([FLASH])(.[^[]*)([/FLASH])"
strContent=re.Replace(strContent,"<embedsrc=""$2""quality=highpluginspage='http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash'type='application/x-shockwave-flash'width=500height=400>$2</embed>")
re.Pattern="([FLASH=*([0-9]*),*([0-9]*)])(.[^[]*)([/FLASH])"
strContent=re.Replace(strContent,"<embedsrc=""$4""quality=highpluginspage='http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash'type='application/x-shockwave-flash'width=$2height=$3>$4</embed>")
re.Pattern="[UPLOAD=(gif|jpg|jpeg|bmp|png)](.[^[]*)(gif|jpg|jpeg|bmp|png)[/UPLOAD]"
strContent=re.Replace(strContent,"<br><AHREF=""$2$1""TARGET=_blank><IMGSRC=""$2$1""border=0alt=按此在新窗口浏览图片onload=""javascript:if(this.width>screen.width-333)this.width=screen.width-333""></A>")
re.Pattern="([UPLOAD=(.[^[]*)])(.[^[]*)([/UPLOAD])"
strContent=re.Replace(strContent,"<br><ahref=""$3"">点击浏览该文件</a>")
re.Pattern="([URL])(.[^[]*)([/URL])"
strContent=re.Replace(strContent,"<AHREF=""$2""TARGET=_blank>$2</A>")
re.Pattern="([URL=(.[^[]*)])(.[^[]*)([/URL])"
strContent=re.Replace(strContent,"<AHREF=""$2""TARGET=_blank>$3</A>")
re.Pattern="([EMAIL])(.[^[]*)([/EMAIL])"
strContent=re.Replace(strContent,"<AHREF=""mailto:$2"">$2</A>")
re.Pattern="([EMAIL=(.[^[]*)])(.[^[]*)([/EMAIL])"
strContent=re.Replace(strContent,"<AHREF=""mailto:$2""TARGET=_blank>$3</A>")
re.Pattern="([HTML])(.[^[]*)([/HTML])"
strContent=re.Replace(strContent,"<tablewidth='100%'border='0'cellspacing='0'cellpadding='6'bgcolor='#F6F6F6'><td><b>以下内容为程序代码:</b><br>$2</td></table>")
re.Pattern="([code])(.[^[]*)([/code])"
strContent=re.Replace(strContent,"<tablewidth='100%'border='0'cellspacing='0'cellpadding='6'bgcolor='#F6F6F6'><td><b>以下内容为程序代码:</b><br>$2</td></table>")
re.Pattern="([color=(.[^[]*)])(.[^[]*)([/color])"
strContent=re.Replace(strContent,"<fontcolor=$2>$3</font>")
re.Pattern="([face=(.[^[]*)])(.[^[]*)([/face])"
strContent=re.Replace(strContent,"<fontface=$2>$3</font>")
re.Pattern="[align=(center|left|right)](.*)[/align]"
strContent=re.Replace(strContent,"<divalign=$1>$2</div>")
re.Pattern="([QUOTE])(.*)([/QUOTE])"
strContent=re.Replace(strContent,"<tablecellpadding=0cellspacing=0border=1WIDTH=94%bordercolor=#000000bgcolor=#F2F8FFalign=center><tr><td><tablewidth=100%cellpadding=5cellspacing=1border=0><TR><TDBGCOLOR='#F6F6F6'>$2</table></table><br>")
re.Pattern="([move])(.*)([/move])"
strContent=re.Replace(strContent,"<MARQUEEscrollamount=3>$2</marquee>")
re.Pattern="[GLOW=*([0-9]*),*(#*[a-z0-9]*),*([0-9]*)](.[^[]*)[/GLOW]"
strContent=re.Replace(strContent,"<tablewidth=$1style=""filter:glow(color=$2,strength=$3)"">$4</table>")
re.Pattern="[SHADOW=*([0-9]*),*(#*[a-z0-9]*),*([0-9]*)](.[^[]*)[/SHADOW]"
strContent=re.Replace(strContent,"<tablewidth=$1style=""filter:shadow(color=$2,strength=$3)"">$4</table>")
Setre=Nothing
strContent=Replace(strContent,"[InstallDir_ChannelDir]",InstallDir&"/"&ChannelDir)
strContent=Replace(strContent,"{","")
strContent=Replace(strContent,"}","")
strContent=Replace(strContent,"$","")
ReadContent=strContent
EndFunction
EndClass
%>