newasp中main类_ASP教程-查字典教程网

newasp中main类

摘要：",">")fString=Replace(fString,"0Thenstr=Replace(str,ChrW(FobWords(i)),...

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

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,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

keyword=Left(keyword,100)

FobWords=Array("~","!","@","#","$","%","^","&","*","(",")","_","+","=","`","[","]","{","}",";",":","""","'",",","<",">",".","/","","?","_")

Fori=0ToUBound(FobWords,1)

IfInStr(keyword,FobWords(i))>0Then

keyword=Replace(keyword,FobWords(i),"")

EndIf

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

JAPEncode=str

EndFunction

'================================================

'函数名：JAPUncode

'作用：日文片假名解码

'参数：str----原字符

'================================================

PublicFunctionJAPUncode(ByValstr)

DimFobWords,i

OnErrorResumeNext

IfIsNull(str)OrTrim(str)=""Then

JAPUncode=""

ExitFunction

EndIf

Fori=1ToUBound(FobWords,1)

IfInStr(str,""&FobWords(i)&";")>0Then

str=Replace(str,""&FobWords(i)&";",ChrW(FobWords(i)))

EndIf

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

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,""",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

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

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

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

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

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

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

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

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

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

Fori=1ToUBound(FobWords,1)

IfInStr(keyword,ChrW(FobWords(i)))>0Then

CheckQuery=False

ExitFunction

EndIf

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

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

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

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

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

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

CacheSelClass=CacheSelClass&"{ClassID="&Rs1("ClassID")&"}>"

IfRs1("depth")=1ThenCacheSelClass=CacheSelClass&"├"

IfRs1("depth")>1Then

Fori=2ToRs1("depth")

CacheSelClass=CacheSelClass&""

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&""

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

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

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

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

IfbRepeat=FalseThen

n=n+1

ReDimPreserveArrayFilter(n)

ArrayFilter(n)=Match

EndIf

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

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>")

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