newasp中main类

ttx9n · 发表于 2006-10-3 00:00:00

<%
Const IsDeBug = 1
Class NewaspMain_Cls

 Public membername, memberpass, membergrade, membergroup, memberid
 Public memberclass, menbernickname, Cookies_Name, CheckPassword

 Public SiteName, SiteUrl, MasterMail, keywords, Copyright
 Public InstallDir, IndexName, IstopSite, StopReadme, IsCloseMail
 Public SendMailType, MailFrom, MailServer, MailUserName, MailPassword, MailInformPass, ChkSameMail
 Public CheckUserReg, AdminCheckReg, AddUserPoint, SendRegMessage, FullContQuery, ActionTime
 Public IsRunTime, UploadClass, UploadFileSize, UploadFileType, ContentKeyword, PreviewSetting
 Public StopApplyLink, FSO_ScriptName, InitTitleColor, StopBankPay
 Public ChinaeBank, VersionID, Badwords, Badwordr, serialcode, passedcode

 Public ChannelName, ChannelDir, StopChannel, ChannelType
 Public modules, ChannelSkin, HtmlPath, HtmlForm, HtmlPrefix
 Public IsCreateHtml, HtmlExtName, StopUpload, MaxFileSize, UpFileType
 Public IsAuditing, AppearGrade, ModuleName, BindDomain, DomainName
 Public PostGrade, LeastString, MaxString, PaginalNum, LeastHotHist, Channel_Setting
 Public ChannelSetting,ChannelData,ChannelPath
 Public ChannelModule,ChannelHtmlPath,ChannelHtmlForm,ChannelUseHtml,ChannelHtmlExt,ChannelPrefix

 Public ThisEdition, CopyrightStr, Version, Values, startime
 Public SqlQueryNum, GetUserip, CacheName, Reloadtime

 Public ScriptName, Admin_Page, skinid, SkinPath, HtmlCss, HtmlTop, HtmlFoot, HtmlContent, sHtmlContent
 Private Main_Style, Main_Setting, MainStyle, Html_Setting
 Private LocalCacheName, Cache_Data
 Private CacheChannel, CacheData

 Private arrGroupSetting, blnGroupSetting, binUserLong

 Private Sub Class_Initialize()
 On Error Resume Next
 Reloadtime = 28800
 SqlQueryNum = 0
 '--缓存名称
 CacheName = "newasp"
 Cookies_Name = "newasp_net"
 binUserLong = False
 blnGroupSetting = False
 GetUserip = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
 If Len(GetUserip) = 0 Then GetUserip = 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"))
 Dim tmpstr, i
 tmpstr = Request.ServerVariables("PATH_INFO")
 tmpstr = Split(tmpstr, "/")
 i = UBound(tmpstr)
 ScriptName = LCase(tmpstr(i))
 Admin_Page = False
 If InStr(ScriptName, "showerr") > 0 Or InStr(ScriptName, "login") > 0 Or InStr(ScriptName, "admin_") > 0 Then Admin_Page = True
 End Sub

 Private Sub Class_Terminate()
 If IsObject(Conn) Then Conn.Close : Set Conn = Nothing
 End Sub

 '===================服务器缓存部分函数开始===================
 Public Property Let Name(ByVal vNewValue)
 LocalCacheName = LCase(vNewValue)
 Cache_Data = Application(CacheName & "_" & LocalCacheName)
 End Property
 Public Property Let Value(ByVal vNewValue)
 If LocalCacheName <> "" Then
 ReDim Cache_Data(2)
 Cache_Data(0) = vNewValue
 Cache_Data(1) = Now()
 Application.Lock
 Application(CacheName & "_" & LocalCacheName) = Cache_Data
 Application.UnLock
 Else
 Err.Raise vbObjectError + 1, "NewaspCacheServer", " please change the CacheName."
 End If
 End Property
 Public Property Get Value()
 If LocalCacheName <> "" Then
 If IsArray(Cache_Data) Then
 Value = Cache_Data(0)
 Else
 'Err.Raise vbObjectError + 1, "NewaspCacheServer", " The Cache_Data("&LocalCacheName&") Is Empty."
 End If
 Else
 Err.Raise vbObjectError + 1, "NewaspCacheServer", " please change the CacheName."
 End If
 End Property
 Public Function ObjIsEmpty()
 ObjIsEmpty = True
 If Not IsArray(Cache_Data) Then Exit Function
 If Not IsDate(Cache_Data(1)) Then Exit Function
 If DateDiff("s", CDate(Cache_Data(1)), Now()) < (60 * Reloadtime) Then ObjIsEmpty = False
 End Function
 Public Sub DelCahe(MyCaheName)
 Application.Lock
 Application.Contents.Remove (CacheName & "_" & MyCaheName)
 Application.UnLock
 End Sub
 Public Sub DelCache(MyCaheName)
 Application.Lock
 Application.Contents.Remove ("mynewasp_" & MyCaheName)
 Application.UnLock
 End Sub
 '===================服务器缓存部分函数结束===================

 Public Function ChkBoolean(ByVal Values)
 If TypeName(Values) = "Boolean" Or IsNumeric(Values) Or LCase(Values) = "false" Or LCase(Values) = "true" Then
 ChkBoolean = CBool(Values)
 Else
 ChkBoolean = False
 End If
 End Function

 Public Function CheckNumeric(ByVal CHECK_ID)
 If CHECK_ID <> "" And IsNumeric(CHECK_ID) Then
 CHECK_ID = CCur(CHECK_ID)
 Else
 CHECK_ID = 0
 End If
 CheckNumeric = CHECK_ID
 End Function

 Public Function ChkNumeric(ByVal CHECK_ID)
 If CHECK_ID <> "" And IsNumeric(CHECK_ID) Then
 CHECK_ID = CLng(CHECK_ID)
 If CHECK_ID < 0 Then CHECK_ID = 0
 Else
 CHECK_ID = 0
 End If
 ChkNumeric = CHECK_ID
 End Function

 Public Function CheckStr(ByVal str)
 If IsNull(str) Then
 CheckStr = ""
 Exit Function
 End If
 str = Replace(str, Chr(0), "")
 CheckStr = Replace(str, "'", "''")
 End Function
 '================================================
 '过程名：CheckNull
 '作 用：是否有效值
 '================================================
 Public Function CheckNull(ByVal sValue)
 On Error Resume Next
 If IsNull(sValue) Then
 CheckNull = False
 Exit Function
 End If
 If Trim(sValue) <> "" And LCase(Trim(sValue)) <> "http://" Then
 CheckNull = True
 Else
 CheckNull = False
 End If
 End Function
 Public Function ChkNull(ByVal str)
 On Error Resume Next
 If IsNull(str) Then
 ChkNull = ""
 Exit Function
 End If
 If Trim(str) <> "" And LCase(Trim(str)) <> "http://" Then
 ChkNull = Trim(str)
 Else
 ChkNull = ""
 End If
 End Function
 '=============================================================
 '函数名：ChkFormStr
 '作 用：过滤表单字符
 '参 数：str ----原字符串
 '返回值：过滤后的字符串
 '=============================================================
 Public Function ChkFormStr(ByVal str)
 Dim fString
 fString = str
 If IsNull(fString) Then
 ChkFormStr = ""
 Exit Function
 End If
 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))
 End Function
 '=============================================================
 '函数作用：过滤SQL非法字符
 '=============================================================
 Public Function CheckRequest(ByVal str,ByVal strLen)
 On Error Resume Next
 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", "")

 If Len(str) > 0 And strLen > 0 Then
 str = Left(str, strLen)
 End If
 CheckRequest = str
 End Function
 '-- 移除有害字符
 Public Function RemoveBadCharacters(ByVal strTemp)
 Dim re
 On Error Resume Next
 Set re = New RegExp
 re.Pattern = "[^\s\w]"
 re.Global = True
 RemoveBadCharacters = re.Replace(strTemp, "")
 Set re = Nothing
 End Function
 '-- 去掉HTML标记
 Public Function RemoveHtml(ByVal Textstr)
 Dim Str,re
 Str = Textstr
 On Error Resume Next
 Set re = New RegExp
 re.IgnoreCase = True
 re.Global = True
 re.Pattern = "<(.[^>]*)>"
 Str = re.Replace(Str, "")
 Set re = Nothing
 RemoveHtml=Str
 End Function
 '-- 数据库连接
 Public Function Execute(Command)
 If Not IsObject(Conn) Then ConnectionDatabase
 If IsDeBug = 0 Then
 On Error Resume Next
 Set Execute = Conn.Execute(Command)
 If Err Then
 err.Clear
 Set Conn = Nothing
 Response.Write "查询数据的时候发现错误，请检查您的查询代码是否正确。 <li>"
 Response.Write Command
 Response.End
 End If
 Else
 Set Execute = Conn.Execute(Command)
 End If
 SqlQueryNum = SqlQueryNum+1
 End Function

 Public Sub ReadConfig()
 On Error Resume Next
 Name = "Config"
 If ObjIsEmpty() Then ReloadConfig
 CacheData = Value
 '第一次起用系统或者重启IIS的时候加载缓存
 Name = "Date"
 If ObjIsEmpty() Then
 Value = Date
 Else
 If CStr(Value) <> CStr(Date) Then
 Name = "Config"
 Call ReloadConfig
 CacheData = Value
 End If
 End If
 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 = "免费版 (Free Edition)"
 Version = "Powered by：<a href=""http://www.newasp.net"" target=""_blank"" class=""navmenu"">NewCloud SiteManageSystem Version 2.0.0 SP1</a>"
 CopyrightStr = "" & vbCrLf
 If CInt(IstopSite) = 1 And Not Admin_Page Then Response.Redirect ("" & SiteUrl & InstallDir & "showerr.asp?action=stop")
 End Sub
 Public Sub ReloadConfig()
 Dim SQL, Rs
 On Error Resume Next
 SQL = "SELECT * from [NC_Config] "
 Set Rs = Execute(SQL)
 Value = Rs.GetRows(1)
 Set Rs = Nothing
 End Sub
 '=============================================================
 '过程名：ReloadChannel
 '作 用：再装频道设置
 '参 数：ChannelID ----频道ID
 '=============================================================
 Private Sub ReloadChannel(ChannelID)
 Dim SQL, Rs
 On Error Resume Next
 SQL = "SELECT ChannelID,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_Setting from NC_Channel where ChannelType <= 1 And ChannelID = " & CLng(ChannelID)
 Set Rs = Execute(SQL)
 If Rs.BOF And Rs.EOF Then
 Response.Write "错误的频道参数！"
 Exit Sub
 End If
 Value = Rs.GetRows(1)
 Set Rs = Nothing
 End Sub
 '=============================================================
 '过程名：ReadChannel
 '作 用：读取频道设置
 '参 数：ChannelID ----频道ID
 '=============================================================
 Public Sub ReadChannel(ChannelID)
 On Error Resume Next
 If Not IsNumeric(ChannelID) Then ChannelID = 1
 ChannelID = Clng(ChannelID)
 Name = "Channel" & ChannelID
 If ObjIsEmpty() Then Call ReloadChannel(ChannelID)
 CacheChannel = Value
 If CLng(CacheChannel(0, 0)) <> ChannelID Then
 Call ReloadChannel(ChannelID)
 CacheChannel = Value
 End If
 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)
 If CInt(StopChannel) = 1 And Not Admin_Page Then Response.Redirect (InstallDir & "showerr.asp?action=ChanStop")
 End Sub
 Public Sub LoadChannel(chanid)
 On Error Resume Next
 Dim Rs,SQL,tmpdata
 chanid = CLng(chanid)
 Name = "MyChannel" & chanid
 If ObjIsEmpty() Then
 SQL = "SELECT ChannelName,ChannelDir,ModuleName,HtmlPath,HtmlForm,IsCreateHtml,HtmlExtName,HtmlPrefix,StopUpload,LeastString,MaxString,LeastHotHist FROM NC_Channel WHERE ChannelType<=1 And ChannelID= " & Clng(chanid)
 Set Rs = Execute(SQL)
 tmpdata = Rs.GetString(, , "

回复用户6 · 发表于 2006-10-3 00:00:59

", "@@@", "")
            tmpdata = Left(tmpdata, Len(tmpdata) - 3)
            Set Rs = Nothing
            Value = tmpdata
        End If

        ChannelData = Split(Value, "

回复用户3 · 发表于 2006-10-3 00:01:38

")
        ChannelPath = InstallDir & ChannelData(1)
        ChannelModule = ChannelData(2)
        ChannelHtmlPath = ChannelData(3)
        ChannelHtmlForm = ChannelData(4)
        ChannelUseHtml = ChannelData(5)
        ChannelHtmlExt = ChannelData(6)
        ChannelPrefix = ChannelData(7)

    End Sub
    '=============================================================
    '过程名：LoadTemplates
    '作  用：载入模板
    '参  数：Page_Mark   ----StyleID
    '=============================================================
    Public Sub LoadTemplates(ChannelID, pageid, StyleID)
        Dim rstmp, TempSkinID
        On Error Resume Next
        ChannelID = CLng(ChannelID)
        pageid = CInt(pageid)
        Name = "DefaultSkinID"
        If ObjIsEmpty() Then
            Set rstmp = Execute("SELECT skinid from [NC_Template] where pageid = 0 And isDefault = 1")
            Value = rstmp(0)
            Set rstmp = Nothing
        End If
        TempSkinID = Value
        If StyleID = 0 Or StyleID = "" Then
            skinid = TempSkinID
        Else
            Set rstmp = Execute("SELECT skinid from [NC_Template] where pageid = 0 And skinid = " & StyleID)
            If Not rstmp.EOF Then
                skinid = rstmp(0)
            Else
                skinid = TempSkinID
            End If
            Set rstmp = Nothing
        End If
        skinid = CLng(skinid)
        Name = "MainStyle" & skinid
        If ObjIsEmpty() Then TemplatesMainCache (skinid)
        Main_Style = Value
        SkinPath = Main_Style(0, 0)
        Main_Setting = Split(Main_Style(2, 0), "

回复用户3 · 发表于 2006-10-3 00:02:30

")
        MainStyle = Main_Style(1, 0)
        'MainStyle = Replace(MainStyle, "{$InstallDir}", ReadInstallDir(BindDomain))
        MainStyle = Replace(MainStyle, "{$SkinPath}", SkinPath)
        MainStyle = Split(MainStyle, "

回复用户4 · 发表于 2006-10-3 00:03:14

")
 HtmlCss = MainStyle(0)
 HtmlTop = MainStyle(1)
 HtmlFoot = MainStyle(2)
 If pageid <> 0 Then
 Name = "Templates" & ChannelID & skinid & pageid
 If ObjIsEmpty() Then
 TemplatesToCache ChannelID, pageid
 End If
 ByValue = Value
 End If
 End Sub
 Private Sub TemplatesToCache(ChannelID, pageid)
 On Error Resume Next
 Dim Rs, SQL, rstmp
 SQL = "SELECT skinid,page_content,page_setting FROM [NC_Template] WHERE ChannelID = " & ChannelID & " And skinid = " & skinid & " And pageid = " & pageid
 Set Rs = Execute(SQL)
 If Not Rs.EOF Then
 Value = Rs.GetRows(1)
 Else
 Set rstmp = Execute("SELECT skinid,page_content,page_setting FROM [NC_Template] WHERE ChannelID = " & ChannelID & " And isDefault = 1 And pageid = " & pageid)
 Value = rstmp.GetRows(1)
 Set rstmp = Nothing
 End If
 Set Rs = Nothing
 End Sub
 Private Sub TemplatesMainCache(skinid)
 On Error Resume Next
 Dim Rs, SQL, rstmp
 SQL = "SELECT TemplateDir,page_content,page_setting FROM [NC_Template] WHERE pageid = 0 And skinid = " & skinid & " And ChannelID = 0"
 Set Rs = Execute(SQL)
 If Not Rs.EOF Then
 Value = Rs.GetRows(1)
 Else
 Set rstmp = Execute("SELECT TemplateDir,page_content,page_setting from [NC_Template] WHERE pageid = 0 And isDefault = 1 And ChannelID = 0")
 Value = rstmp.GetRows(1)
 Set rstmp = Nothing
 End If
 Set Rs = Nothing
 End Sub
 Public Property Let ByValue(ByVal vNewValue)
 Dim tmpstr
 tmpstr = vNewValue
 Html_Setting = tmpstr(2, 0)
 Html_Setting = Split(Html_Setting, "

回复用户5 · 发表于 2006-10-3 00:03:55

")
 HtmlContent = tmpstr(1, 0)
 If CInt(Html_Setting(0)) <> 0 Then
 HtmlContent = HtmlTop & HtmlContent & HtmlFoot
 End If
 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
 End Property
 Public Property Get ByValue()
 ByValue = HtmlContent
 End Property
 Public Property Let HTMLValue(ByVal vNewValue)
 Dim TempStr
 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
 End Property
 Public Property Get HTMLValue()
 HTMLValue = sHtmlContent
 End Property
 Public Property Get HtmlSetting(n)
 HtmlSetting = Html_Setting(n)
 End Property
 Public Property Get MainSetting(n)
 MainSetting = Main_Setting(n)
 End Property
 '================================================
 '过程名：GetSiteUrl
 '作 用：取得带端口的URL
 '================================================
 Public Property Get GetSiteUrl()
 If Request.ServerVariables("SERVER_PORT") = "80" Then
 GetSiteUrl = "http://" & Request.ServerVariables("server_name")
 Else
 GetSiteUrl = "http://" & Request.ServerVariables("server_name") & ":" & Request.ServerVariables("SERVER_PORT")
 End If
 End Property
 '================================================
 '函数名：FormEncode
 '作 用：过虑提交的表单数据
 '参 数：str ----原字符串 n ----字符长度
 '================================================
 Public Function FormEncode(ByVal str, ByVal n)
 If Not IsNull(str) And Trim(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 = ""
 End If
 End Function
 '================================================
 '函数名：ChkKeyWord
 '作 用：过滤关键字
 '参 数：keyword ----关键字
 '================================================
 Public Function ChkKeyWord(ByVal keyword)
 Dim FobWords, i
 On Error Resume Next
 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)
 For i = 1 To UBound(FobWords, 1)
 If InStr(keyword, ChrW(FobWords(i))) > 0 Then
 keyword = Replace(keyword, ChrW(FobWords(i)), "")
 End If
 Next
 keyword = Left(keyword, 100)
 FobWords = Array("~", "!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "_", "+", "=", "`", "[", "]", "{", "}", ";", ":", """", "'", ",", "<", ">", ".", "/", "\", "?", "_")
 For i = 0 To UBound(FobWords, 1)
 If InStr(keyword, FobWords(i)) > 0 Then
 keyword = Replace(keyword, FobWords(i), "")
 End If
 Next
 ChkKeyWord = keyword
 End Function
 '================================================
 '函数名：JAPEncode
 '作 用：日文片假名编码
 '参 数：str ----原字符
 '================================================
 Public Function JAPEncode(ByVal str)
 Dim FobWords, i
 On Error Resume Next
 If IsNull(str) Or Trim(str) = "" Then
 JAPEncode = ""
 Exit Function
 End If
 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)
 For i = 1 To UBound(FobWords, 1)
 If InStr(str, ChrW(FobWords(i))) > 0 Then
 str = Replace(str, ChrW(FobWords(i)), "&#" & FobWords(i) & ";")
 End If
 Next
 JAPEncode = str
 End Function
 '================================================
 '函数名：JAPUncode
 '作 用：日文片假名解码
 '参 数：str ----原字符
 '================================================
 Public Function JAPUncode(ByVal str)
 Dim FobWords, i
 On Error Resume Next
 If IsNull(str) Or Trim(str) = "" Then
 JAPUncode = ""
 Exit Function
 End If
 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)
 For i = 1 To UBound(FobWords, 1)
 If InStr(str, "&#" & FobWords(i) & ";") > 0 Then
 str = Replace(str, "&#" & FobWords(i) & ";", ChrW(FobWords(i)))
 End If
 Next
 str = Replace(str, Chr(0), "")
 str = Replace(str, "'", "''")
 JAPUncode = str
 End Function
 '=============================================================
 '函数作用：带脏话过滤
 '=============================================================
 Public Function ChkBadWords(ByVal str)
 If IsNull(str) Then Exit Function
 Dim i, Bwords, Bwordr
 Bwords = Split(Badwords, "|")
 Bwordr = Split(Badwordr, "|")
 For i = 0 To UBound(Bwords)
 If i > UBound(Bwordr) Then
 str = Replace(str, Bwords(i), "*")
 Else
 str = Replace(str, Bwords(i), Bwordr(i))
 End If
 Next
 ChkBadWords = str
 End Function
 '=============================================================
 '函数作用：过滤HTML代码，带脏话过滤
 '=============================================================
 Public Function HTMLEncode(ByVal fString)
 If Not IsNull(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), " ")
 fString = ChkBadWords(fString)
 HTMLEncode = fString
 End If
 End Function
 '=============================================================
 '函数作用：过滤HTML代码，不带脏话过滤
 '=============================================================
 Public Function HTMLEncodes(ByVal fString)
 If Not IsNull(fString) Then
 fString = Replace(fString, "'", "'")
 fString = Replace(fString, ">", ">")
 fString = Replace(fString, "<", "<")
 fString = Replace(fString, Chr(32), " ")
 fString = Replace(fString, Chr(9), " ")
 fString = Replace(fString, Chr(34), """)
 fString = Replace(fString, Chr(39), "'")
 fString = Replace(fString, Chr(13), "")
 fString = Replace(fString, Chr(10), " ")
 fString = Replace(fString, " ", " ")
 HTMLEncodes = fString
 End If
 End Function
 '=============================================================
 '函数作用：判断发言是否来自外部
 '=============================================================
 Public Function CheckPost()
 On Error Resume Next
 Dim server_v1, server_v2
 CheckPost = False
 server_v1 = CStr(Request.ServerVariables("HTTP_REFERER"))
 server_v2 = CStr(Request.ServerVariables("SERVER_NAME"))
 If Mid(server_v1, 8, Len(server_v2)) = server_v2 Then
 CheckPost = True
 End If
 End Function
 '=============================================================
 '函数作用：判断来源URL是否来自外部
 '=============================================================
 Public Function CheckOuterUrl()
 On Error Resume Next
 Dim server_v1, server_v2
 server_v1 = Replace(LCase(Trim(Request.ServerVariables("HTTP_REFERER"))), "http://", "")
 server_v2 = LCase(Trim(Request.ServerVariables("SERVER_NAME")))
 If server_v1 <> "" And Left(server_v1, Len(server_v2)) <> server_v2 Then
 CheckOuterUrl = False
 Else
 CheckOuterUrl = True
 End If
 End Function
 '================================================
 '函数名：GotTopic
 '作 用：显示字符串长度
 '参 数：str ----原字符串
 ' strlen ----显示字符长度
 '================================================
 Public Function GotTopic(ByVal str, ByVal strLen)
 Dim l, t, c, i
 Dim strTemp
 On Error Resume Next
 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
 For i = 1 To l
 c = Abs(Asc(Mid(str, i, 1)))
 If c > 255 Then
 t = t + 2
 Else
 t = t + 1
 End If
 If t >= strLen Then
 strTemp = Left(str, i) & "..."
 Exit For
 Else
 strTemp = str & " "
 End If
 Next
 GotTopic = CheckTopic(strTemp)
 End Function
 Public Function CheckTopic(ByVal strContent)
 Dim re
 On Error Resume Next
 Set re = New RegExp
 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, "<")
 Set re = 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)
 End Function
 '================================================
 '函数名：ReadTopic
 '作 用：显示字符串长度
 '参 数：str ----原字符串
 ' strlen ----显示字符长度
 '================================================
 Public Function ReadTopic(ByVal str, ByVal strLen)
 Dim l, t, c, i
 On Error Resume Next
 str = Replace(str, " ", " ")
 If Len(str) < strLen Then
 str = str & String(strLen - Len(str), ".")
 Else
 str = str
 End If
 l = Len(str)
 t = 0
 For i = 1 To l
 c = Abs(Asc(Mid(str, i, 1)))
 If c > 255 Then
 t = t + 2
 Else
 t = t + 1
 End If
 If t >= strLen Then
 ReadTopic = Left(str, i) & "..."
 Exit For
 Else
 ReadTopic = str & "..."
 End If
 Next
 End Function
 '================================================
 '函数名：strLength
 '作 用：计字符串长度
 '参 数：str ----字符串
 '================================================
 Public Function strLength(ByVal str)
 On Error Resume Next
 If IsNull(str) Or str = "" Then
 strLength = 0
 Exit Function
 End If
 Dim WINNT_CHINESE
 WINNT_CHINESE = (Len("例子") = 2)
 If WINNT_CHINESE Then
 Dim l, t
 Dim i, c
 l = Len(str)
 t = l
 For i = 1 To l
 c = Asc(Mid(str, i, 1))
 If c < 0 Then c = c + 65536
 If c > 255 Then t = t + 1
 Next
 strLength = t
 Else
 strLength = Len(str)
 End If
 End Function
 '=================================================
 '函数名：isInteger
 '作 用：判断数字是否整型
 '参 数：para ----参数
 '=================================================
 Public Function isInteger(ByVal para)
 On Error Resume Next
 Dim str
 Dim l, i
 If IsNull(para) Then
 isInteger = False
 Exit Function
 End If
 str = CStr(para)
 If Trim(str) = "" Then
 isInteger = False
 Exit Function
 End If
 l = Len(str)
 For i = 1 To l
 If Mid(str, i, 1) > "9" Or Mid(str, i, 1) < "0" Then
 isInteger = False
 Exit Function
 End If
 Next
 isInteger = True
 If Err.Number <> 0 Then Err.Clear
 End Function
 Public Function CutString(ByVal str, ByVal strLen)
 On Error Resume Next

 Dim HtmlStr, 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, "~~~~", "")
 Set re = New RegExp
 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, "")
 Set re = Nothing
 HtmlStr = Replace(HtmlStr, ">", ">")
 HtmlStr = Replace(HtmlStr, "<", "<")
 l = Len(HtmlStr)
 If l >= strLen Then
 strContent = Left(HtmlStr, strLen) & "..."
 Else
 strContent = HtmlStr & " "
 End If
 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
 End Function
 '================================================
 '函数名：CheckInfuse
 '作 用：防止SQL注入
 '参 数：str ----原字符串
 ' strLen ----提交字符串长度
 '================================================
 Public Function CheckInfuse(ByVal str, ByVal strLen)
 Dim strUnsafe, arrUnsafe
 Dim i

 If Trim(str) = "" Then
 CheckInfuse = ""
 Exit Function
 End If
 str = Left(str, strLen)

 On Error Resume Next
 strUnsafe = "'|^|;|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
 If Trim(str) <> "" Then
 If Len(str) > strLen Then
 Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n您提交的字符数超过了限制！');history.back(-1)</Script>"
 CheckInfuse = ""
 Response.End
 End If
 arrUnsafe = Split(strUnsafe, "|")
 For i = 0 To UBound(arrUnsafe)
 If InStr(1, str, arrUnsafe(i), 1) > 0 Then
 Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
 CheckInfuse = ""
 Response.End
 End If
 Next
 End If
 CheckInfuse = Trim(str)
 Exit Function
 If Err.Number <> 0 Then
 Err.Clear
 Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
 CheckInfuse = ""
 Response.End
 End If
 End Function
 Public Sub PreventInfuse()
 On Error Resume Next
 Dim SQL_Nonlicet, arrNonlicet
 Dim PostRefer, GetRefer, Sql_DATA

 SQL_Nonlicet = "'|;|^|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
 arrNonlicet = Split(SQL_Nonlicet, "|")
 If Request.Form <> "" Then
 For Each PostRefer In Request.Form
 For Sql_DATA = 0 To UBound(arrNonlicet)
 If InStr(1, Request.Form(PostRefer), arrNonlicet(Sql_DATA), 1) > 0 Then
 Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
 Response.End
 End If
 Next
 Next
 End If

 If Request.QueryString <> "" Then
 For Each GetRefer In Request.QueryString
 For Sql_DATA = 0 To UBound(arrNonlicet)
 If InStr(1, Request.QueryString(GetRefer), arrNonlicet(Sql_DATA), 1) > 0 Then
 Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
 Response.End
 End If
 Next
 Next
 End If
 End Sub
 '================================================
 '函数名：ChkQueryStr
 '作 用：过虑查询的非法字符
 '参 数：str ----原字符串
 '返回值：过滤后的字符
 '================================================
 Public Function ChkQueryStr(ByVal str)
 On Error Resume Next
 If IsNull(str) Then
 ChkQueryStr = ""
 Exit Function
 End If
 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
 End Function
 '================================================
 '过程名：CheckQuery
 '作 用：限制搜索的关键字
 '参 数：str ----搜索的字符串
 '返回值：True; False
 '================================================
 Public Function CheckQuery(ByVal str)
 Dim FobWords, i, keyword
 keyword = str
 On Error Resume Next
 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)
 For i = 1 To UBound(FobWords, 1)
 If InStr(keyword, ChrW(FobWords(i))) > 0 Then
 CheckQuery = False
 Exit Function
 End If
 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, "'", " ")
 For i = 0 To UBound(FobWords, 1)
 If keyword = FobWords(i) Then
 CheckQuery = False
 Exit Function
 End If
 Next
 CheckQuery = True
 End Function
 '================================================
 '函数名：IsValidStr
 '作 用：判断字符串中是否含有非法字符
 '参 数：str ----原字符串
 '返回值：False,True -----布尔值
 '================================================
 Public Function IsValidStr(ByVal str)
 IsValidStr = False
 On Error Resume Next
 If IsNull(str) Then Exit Function
 If Trim(str) = Empty Then Exit Function
 Dim ForbidStr, i
 ForbidStr = "and|chr|:|=|%|&|$|#|@|+|-|*|/|\|<|>|;|,|^|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9)
 ForbidStr = Split(ForbidStr, "|")
 For i = 0 To UBound(ForbidStr)
 If InStr(1,str, ForbidStr(i),1) > 0 Then
 IsValidStr = False
 Exit Function
 End If
 Next
 IsValidStr = True
 End Function
 '================================================
 '函数名：IsValidPassword
 '作 用：判断密码中是否含有非法字符
 '参 数：str ----原字符串
 '返回值：False,True -----布尔值
 '================================================
 Public Function IsValidPassword(ByVal str)
 IsValidPassword = False
 On Error Resume Next
 If IsNull(str) Then Exit Function
 If Trim(str) = Empty Then Exit Function
 Dim ForbidStr, i
 ForbidStr = "=and|chr|*|^|%|&|;|,|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9)
 ForbidStr = Split(ForbidStr, "|")
 For i = 0 To UBound(ForbidStr)
 If InStr(1, str, ForbidStr(i), 1) > 0 Then
 IsValidPassword = False
 Exit Function
 End If
 Next
 IsValidPassword = True
 End Function
 '================================================
 '函数名：IsValidChar
 '作 用：判断字符串中是否含有非法字符和中文
 '参 数：str ----原字符串
 '返回值：False,True -----布尔值
 '================================================
 Public Function IsValidChar(ByVal str)
 IsValidChar = False
 On Error Resume Next

 If IsNull(str) Then Exit Function
 If Trim(str) = Empty Then Exit Function
 Dim ValidStr
 Dim i, l, s, c

 ValidStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ.-_:~\/0123456789"
 l = Len(str)
 s = UCase(str)
 For i = 1 To l
 c = Mid(s, i, 1)
 If InStr(ValidStr, c) = 0 Then
 IsValidChar = False
 Exit Function
 End If
 Next
 IsValidChar = True
 End Function
 '================================================
 '函数名：FormatDate
 '作 用：格式化日期
 '参 数：DateAndTime ----原日期和时间
 ' para ----日期格式
 '返回值：格式化后的日期
 '================================================
 Public Function FormatDate(DateAndTime, para)
 On Error Resume Next
 Dim y, m, d, h, mi, s, strDateTime
 FormatDate = DateAndTime
 If Not IsNumeric(para) Then Exit Function
 If Not IsDate(DateAndTime) Then Exit Function
 y = CStr(Year(DateAndTime))
 m = CStr(Month(DateAndTime))
 If Len(m) = 1 Then m = "0" & m
 d = CStr(Day(DateAndTime))
 If Len(d) = 1 Then d = "0" & d
 h = CStr(Hour(DateAndTime))
 If Len(h) = 1 Then h = "0" & h
 mi = CStr(Minute(DateAndTime))
 If Len(mi) = 1 Then mi = "0" & mi
 s = CStr(Second(DateAndTime))
 If Len(s) = 1 Then s = "0" & s
 Select Case para
 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
 Case Else
 strDateTime = DateAndTime
 End Select
 FormatDate = strDateTime
 End Function
 '================================================
 '函数名：ReadFontMode
 '作 用：读取字体模式
 '参 数：str ----原字符串
 ' vColor -----颜色的值
 ' vFont -----字体的值
 '返回值：新字符串
 '================================================
 Public Function ReadFontMode(str, vColor, vFont)
 Dim FontStr, tColor
 Dim ColorStr, arrColor

 If IsNull(str) Then
 ReadFontMode = ""
 Exit Function
 End If
 ReadFontMode = str
 On Error Resume Next
 If Not IsNumeric(vColor) Then Exit Function
 If Not IsNumeric(vFont) Then Exit Function

 Select Case CInt(vFont)
 Case 1
 FontStr = "" & str & ""
 Case 2
 FontStr = "" & str & ""
 Case 3
 FontStr = "" & str & ""
 Case 4
 FontStr = "" & str & ""
 Case 5
 FontStr = "" & str & ""
 Case 6
 FontStr = "" & str & ""
 Case 7
 FontStr = "" & str & ""
 Case Else
 FontStr = str
 End Select
 ReadFontMode = FontStr

 If vColor = "" Or vColor = 0 Then Exit Function
 ColorStr = "," & InitTitleColor
 arrColor = Split(ColorStr, ",")
 If vColor > UBound(arrColor) Then Exit Function
 tColor = Trim(arrColor(vColor))
 ReadFontMode = "" & FontStr & ""
 End Function
 '=============================================================
 '函数名：ShowDateTime
 '作 用：读取日期格式
 '参 数：DateAndTime ---- 当前时间
 ' para ---- 时间格式
 '=============================================================
 Public Function ShowDateTime(DateAndTime, para)
 ShowDateTime = ""
 Dim strDate
 If Not IsDate(DateAndTime) Then Exit Function
 If DateAndTime >= Date Then
 strDate = ""
 strDate = strDate & FormatDate(DateAndTime, para)
 strDate = strDate & ""
 Else
 strDate = ""
 strDate = strDate & FormatDate(DateAndTime, para)
 strDate = strDate & ""
 End If
 ShowDateTime = strDate
 End Function
 Public Function ShowDatePath(strval, n)
 ShowDatePath = ""
 If Trim(strval) = "" Then Exit Function
 Dim strTempPath, strTime
 Dim y, m, d

 strTime = Left(strval, 8)
 y = Left(strTime, 4)
 m = Mid(strTime, 5, 2)
 d = Right(strTime, 2)
 Select Case CInt(n)
 Case 1
 strTempPath = y & "/" & m & "/" & d & "/"
 Case 2
 strTempPath = y & "/" & m & "/"
 Case 3
 strTempPath = y & m & "/"
 Case 4
 strTempPath = y & "/"
 Case 5
 strTempPath = y & "-" & m & "-" & d & "/"
 Case 6
 strTempPath = y & "-" & m & "/"
 Case 7
 strTempPath = "html/"
 Case 8
 strTempPath = "show/"
 Case Else
 strTempPath = ""
 End Select
 strTempPath = Replace(strTempPath, " ", "")
 ShowDatePath = CStr(strTempPath)
 End Function
 '=============================================================
 '函数名：ReadBriefTopicffd
 '作 用：读取简短标题
 '参 数：para
 '返回值：简短标题
 '=============================================================
 Public Function ReadBriefTopic(ByVal para)
 Dim sBriefTopic

 ReadBriefTopic = ""
 If Not IsNumeric(para) Then Exit Function
 If para = 0 Then Exit Function
 Select Case para
 Case "1"
 sBriefTopic = "[图文]"
 Case "2"
 sBriefTopic = "[组图]"
 Case "3"
 sBriefTopic = "[新闻]"
 Case "4"
 sBriefTopic = "[推荐]"
 Case "5"
 sBriefTopic = "[注意]"
 Case "6"
 sBriefTopic = "[转载]"
 Case Else
 sBriefTopic = ""
 End Select
 ReadBriefTopic = sBriefTopic
 End Function
 '=============================================================
 '函数名：ReadPicTopic
 '作 用：读取简短标题
 '参 数：para
 '返回值：简短标题
 '=============================================================
 Public Function ReadPicTopic(ByVal para)
 Dim sBriefTopic
 ReadPicTopic = ""
 If Not IsNumeric(para) Then Exit Function
 If para = 0 Then Exit Function
 Select Case para
 Case "1"
 sBriefTopic = "[图文]"
 Case "2"
 sBriefTopic = "[组图]"
 Case "3"
 sBriefTopic = "[新闻]"
 Case "4"
 sBriefTopic = "[推荐]"
 Case "5"
 sBriefTopic = "[注意]"
 Case "6"
 sBriefTopic = "[转载]"
 Case Else
 sBriefTopic = ""
 End Select
 ReadPicTopic = sBriefTopic
 End Function
 '=============================================================
 '函数名：ReadPayMoney
 '作 用：读取要支付的金钱
 '参 数：money ----实际金钱
 '返回值：加上手续费后的金钱
 '=============================================================
 Public Function ReadPayMoney(ByVal money, ByVal Reduce)
 On Error Resume Next
 If money = 0 Then
 ReadPayMoney = 0
 Exit Function
 End If
 Dim arrChinaeBank, valPercent, Percents

 arrChinaeBank = Split(ChinaeBank, "

回复用户3 · 发表于 2006-10-3 00:04:26

")
 Percents = CCur(arrChinaeBank(2) / 100)

 If Percents = 0 Then
 ReadPayMoney = CCur(money)
 Else
 If CBool(Reduce) = True Then
 valPercent = Round(CCur(money) / (1 + 1 * Percents), 2)
 ReadPayMoney = CCur(valPercent)
 Else
 valPercent = Round(CCur(money) * Percents, 2)
 ReadPayMoney = CCur(money + valPercent)
 End If
 End If
 End Function
 '=============================================================
 '函数名：RebateMoney
 '作 用：读取打折的后金钱
 '参 数：money ----实际金钱
 ' Discount ----折扣
 '=============================================================
 Public Function RebateMoney(ByVal money, ByVal Discount)
 On Error Resume Next
 Dim Rebate

 money = CheckNumeric(money)
 Discount = CheckNumeric(Discount)
 If Discount > 0 And Discount < 10 Then
 Rebate = Round(money * (Discount / 10), 2)
 RebateMoney = CCur(Rebate)
 Else
 RebateMoney = CCur(money)
 End If
 End Function
 '================================================
 '函数名：Supplemental
 '作 用：补足参数
 '参 数：para ----原参数
 ' n ----增补的位数
 '================================================
 Public Function Supplemental(para, n)
 Supplemental = ""
 If Not IsNumeric(para) Then Exit Function
 If Len(para) < n Then
 Supplemental = String(n - Len(para), "0") & para
 Else
 Supplemental = para
 End If
 End Function
 '-----------------------------------------------------------------
 Public Function GetChannelDir(ByVal chanid)
 On Error Resume Next
 If Not IsNumeric(chanid) Then chanid = 1
 Name = "Channel" & chanid
 If ObjIsEmpty() Then ReloadChannel (chanid)
 CacheChannel = Value
 GetChannelDir = InstallDir & CacheChannel(2,0)
 End Function

 '================================================
 '函数名：GetImageUrl
 '作 用：获取图片URL
 '================================================
 Public Function GetImageUrl(ByVal url, ByVal ChannelDir)
 On Error Resume Next
 Dim strTempUrl, strImageUrl

 If Not IsNull(url) And Trim(url) <> "" And LCase(url) <> "http://" Then
 strTempUrl = InstallDir & ChannelDir
 If CheckUrl(url) = 1 Then
 strImageUrl = Trim(url)
 ElseIf CheckUrl(url) = 2 Then
 strImageUrl = url
 Else
 strImageUrl = Replace(url, "../", "")
 strImageUrl = Trim(strTempUrl & strImageUrl)
 End If
 Else
 strImageUrl = InstallDir & "images/no_pic.gif"
 End If
 GetImageUrl = strImageUrl
 End Function
 '-----------------------------------------------------------------
 '================================================
 '作 用：读取图片或者FLASH
 '参 数：url ----文件URL
 ' height ----高度
 ' width ----宽度
 '================================================
 Function GetFlashAndPic(ByVal url, ByVal height, ByVal width)
 On Error Resume Next
 Dim sExtName, ExtName, strTemp
 Dim strHeight, strWidth

 If Not IsNumeric(height) Or height < 1 Then
 strHeight = ""
 Else
 strHeight = " height=" & height
 End If
 If Not IsNumeric(width) Or width < 1 Then
 strWidth = ""
 Else
 strWidth = " width=" & width
 End If
 sExtName = Split(url, ".")
 ExtName = sExtName(UBound(sExtName))
 If LCase(ExtName) = "swf" Then
 strTemp = "<embed src=""" & url & """" & strWidth & strHeight & ">"
 Else
 strTemp = "<img src=""" & url & """" & strWidth & strHeight & " border=0>"
 End If
 GetFlashAndPic = strTemp
 End Function
 '================================================
 '函数名：ReadFileUrl
 '作 用：读取文件URL
 '================================================
 Public Function ReadFileUrl(url)
 On Error Resume Next
 ReadFileUrl = ""
 If url = "" Then Exit Function
 Dim strTemp
 If CheckUrl(url) = 1 Then
 strTemp = Trim(url)
 ElseIf CheckUrl(url) = 2 Then
 strTemp = Trim(url)
 Else
 strTemp = Replace(url, "../", "")
 strTemp = Trim(InstallDir & strTemp)
 End If
 ReadFileUrl = strTemp
 End Function
 Public Function CheckUrl(ByVal url)
 Dim strUrl
 If Left(url, 1) = "/" Then
 CheckUrl = 1
 Exit Function
 End If
 strUrl = LCase(Left(url, 6))
 Select Case Trim(strUrl)
 Case "http:/", "https:", "ftp://", "rtsp:/", "mms://"
 CheckUrl = 2
 Exit Function
 Case Else
 CheckUrl = 0
 End Select
 End Function
 '================================================
 '函数名：ReadFileName
 '作 用：读取HTML文件名
 '参 数：strname ----文件名称
 ' id ----数据ID
 ' ExtName ----HTML扩展名
 ' PrefixStr ----HTML名称前缀
 ' HtmlForm ----HTML文件格式
 ' n ----HTML分页
 '================================================
 Public Function ReadFileName(ByVal strname, ByVal id, ByVal ExtName, ByVal PrefixStr, ByVal HtmlForm, ByVal n)

 Dim strFileName, strExtName, CurrentPage
 If Trim(strname) = "" Then Exit Function
 If Trim(ExtName) = "" Then ExtName = ".html"
 If Not IsNumeric(n) Then n = 0
 On Error Resume Next
 If CInt(n) <= 1 Then
 CurrentPage = ""
 Else
 CurrentPage = "_" & n
 End If
 If Left(ExtName, 1) <> "." Then
 strExtName = "." & Trim(ExtName)
 Else
 strExtName = Trim(ExtName)
 End If
 Select Case Trim(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))
 Case Else
 strFileName = strname
 End Select
 strFileName = Replace(strFileName & CurrentPage & strExtName, " ", "")
 ReadFileName = CStr(strFileName)
 End Function
 '================================================
 '过程名：HtmlRndFileName
 '作 用：取HTML的随机文件名
 '================================================
 Function HtmlRndFileName()
 Dim sRnd
 Randomize
 sRnd = Int(90 * Rnd) + 10
 HtmlRndFileName = Replace(Replace(Replace(FormatDate(Now(), 1), "-", ""), ":", ""), " ", "") & sRnd
 End Function
 '================================================
 '函数名：ClassFileName
 '作 用：读取HTML文件列表名
 '参 数：ClassID ----分类ID
 '================================================
 Public Function ClassFileName(ByVal ClassID, ByVal ExtName, ByVal PrefixStr, ByVal n)
 Dim strFileName, strExtName, strClassID

 If Trim(ExtName) = "" Then ExtName = ".html"
 If Not IsNumeric(n) Then n = 0
 If Left(ExtName, 1) <> "." Then
 strExtName = "." & Trim(ExtName)
 Else
 strExtName = Trim(ExtName)
 End If
 If CInt(n) <= 1 Then
 strFileName = "index" & strExtName
 Else
 strClassID = Supplemental(ClassID, 3)
 strFileName = PrefixStr & strClassID & "_" & n & strExtName
 End If
 strFileName = Replace(strFileName, " ", "")
 ClassFileName = CStr(strFileName)
 End Function
 '================================================
 '函数名：SpecialFileName
 '作 用：读取专题HTML文件名
 '参 数：specid ----专题ID
 '================================================
 Public Function SpecialFileName(ByVal specid, ByVal ExtName, ByVal n)
 Dim strFileName, strExtName, strSpecialID

 If Trim(ExtName) = "" Then ExtName = ".html"
 If Not IsNumeric(n) Then n = 0
 If Left(ExtName, 1) <> "." Then
 strExtName = "." & Trim(ExtName)
 Else
 strExtName = Trim(ExtName)
 End If
 If CInt(n) <= 1 Then
 strFileName = "index" & strExtName
 Else
 strSpecialID = Supplemental(specid, 3)
 strFileName = "Special" & strSpecialID & "_" & n & strExtName
 End If
 strFileName = Replace(strFileName, " ", "")
 SpecialFileName = CStr(strFileName)
 End Function
 '================================================
 '函数名：ChannelMenu
 '作 用：显示频道菜单
 '================================================
 Public Function ChannelMenu()
 Dim SQL, Rs, i, TotalNumber,strTop
 Dim strContent, LinkTarget, ChannelName
 Dim ChannelUrl, HtmlContent, sCaption


 Name = "ChannelMenu"
 If ObjIsEmpty() Then
 If ChkNumeric(Main_Setting(7)) = 0 Then
 strTop = vbNullString
 Else
 strTop = "TOP " & CInt(Main_Setting(7))
 End If
 SQL = "SELECT " & strTop & " ChannelID,orders,ColorModes,FontModes,ChannelName,Caption,ChannelDir,StopChannel,IsHidden,BindDomain,DomainName,LinkTarget,ChannelType,ChannelUrl,IsHidden FROM [NC_Channel] WHERE IsHidden = 0 Order By orders"
 Set Rs = Execute(SQL)
 If Rs.BOF And Rs.EOF Then
 strContent = ""
 Else
 i = 0
 TotalNumber = Rs.RecordCount
 Do While Not Rs.EOF
 i = i + 1
 If Rs("LinkTarget") <> 0 Then
 LinkTarget = " target=""_blank"""
 Else
 LinkTarget = ""
 End If
 HtmlContent = HtmlContent & Main_Setting(9)
 ChannelName = ReadFontMode(Rs("ChannelName"), Rs("ColorModes"), Rs("FontModes"))
 If Rs("ChannelType") < 2 Then
 ChannelUrl = InstallDir & Rs("ChannelDir")
 Else
 ChannelUrl = Rs("ChannelUrl")
 End If
 If Rs("StopChannel") <> 0 Then
 sCaption = "此频道暂时关闭,不能访问！"
 Else
 sCaption = Rs("Caption")
 End If
 strContent = "<a href=""" & ChannelUrl & """" & LinkTarget & " title=""" & sCaption & """ class=navmenu>" & ChannelName & "</a>"
 If i Mod CInt(Main_Setting(8)) = 0 Then strContent = strContent & " "
 HtmlContent = Replace(HtmlContent, "{$ChannelMenu}", strContent)
 Rs.MoveNext
 Loop
 End If
 Rs.Close: Set Rs = Nothing
 'Value = strContent
 End If
 'strContent = Value

 ChannelMenu = HtmlContent
 End Function
 '=============================================================
 '函数名：LoadSelectClass
 '作 用：载入缓存下拉分类列表
 '参 数：ChannelID ----频道ID
 '返回值：下拉分类列表
 '=============================================================
 Public Function LoadSelectClass(ChannelID)
 Dim CacheSelClass, SQL, Rs1, i

 Name = "SelectClass" & ChannelID
 If ObjIsEmpty() Then
 SQL = "select ClassID,ClassName,depth,TurnLink,child from NC_Classify where ChannelID = " & ChannelID & " order by rootid,orders"
 Set Rs1 = Execute(SQL)
 If Rs1.BOF And Rs1.EOF Then
 CacheSelClass = CacheSelClass & "<option>没有添加分类</option>"
 End If
 Do While Not Rs1.EOF
 If Rs1("TurnLink") <> 0 Then
 CacheSelClass = CacheSelClass & "<option value=""0"""
 Else
 If Rs1("depth") = 0 And Rs1("child") <> 0 Then
 CacheSelClass = CacheSelClass & "<option"
 Else
 CacheSelClass = CacheSelClass & "<option value=""" & Rs1("ClassID") & """"
 End If
 End If
 CacheSelClass = CacheSelClass & " {ClassID=" & Rs1("ClassID") & "}>"
 If Rs1("depth") = 1 Then CacheSelClass = CacheSelClass & "　├ "
 If Rs1("depth") > 1 Then
 For i = 2 To Rs1("depth")
 CacheSelClass = CacheSelClass & "　"
 Next
 CacheSelClass = CacheSelClass & "　├ "
 End If
 CacheSelClass = CacheSelClass & Rs1("ClassName") & "</option>" & vbCrLf
 Rs1.MoveNext
 Loop
 Rs1.Close
 Set Rs1 = Nothing
 Value = CacheSelClass
 End If
 LoadSelectClass = Value
 End Function
 Public Function ClassJumpMenu(ChannelID)
 Dim CacheJumpMenu
 Dim Rs1
 Dim i
 Name = "ClassJumpMenu" & ChannelID
 If ObjIsEmpty() Then
 Set Rs1 = Execute("select ClassID,ChannelID,ClassName,depth,TurnLink,TurnLinkUrl from [NC_Classify] where ChannelID = " & ChannelID & " order by rootid,orders")
 Do While Not Rs1.EOF
 If Rs1("TurnLink") <> 0 Then
 CacheJumpMenu = CacheJumpMenu & "<option value=""" & Rs1("TurnLinkUrl") & """ {ClassID=" & Rs1("classid") & "}"
 Else
 CacheJumpMenu = CacheJumpMenu & "<option value=""?ChannelID=" & Rs1("ChannelID") & "&sortid=" & Rs1("classid") & """ {ClassID=" & Rs1("classid") & "}"
 End If
 If Trim(Request("sortid")) <> "" Then
 If CLng(Request("sortid")) = Rs1("classid") Then CacheJumpMenu = CacheJumpMenu & " selected"
 End If
 CacheJumpMenu = CacheJumpMenu & ">"
 If Rs1("depth") = 1 Then CacheJumpMenu = CacheJumpMenu & "　├ "
 If Rs1("depth") > 1 Then
 For i = 2 To Rs1("depth")
 CacheJumpMenu = CacheJumpMenu & "　"
 Next
 CacheJumpMenu = CacheJumpMenu & "　├ "
 End If
 CacheJumpMenu = CacheJumpMenu & Rs1("ClassName") & "</option>" & vbCrLf
 Rs1.MoveNext
 Loop
 Rs1.Close
 Set Rs1 = Nothing
 Value = CacheJumpMenu
 End If
 ClassJumpMenu = Value
 End Function
 '================================================
 '函数名：GetRandomCode
 '作 用：系统分配随机代码
 '================================================
 Public Function GetRandomCode()
 Dim Ran, i, LengthNum

 LengthNum = 16
 GetRandomCode = ""
 For i = 1 To LengthNum
 Randomize
 Ran = CInt(Rnd * 2)
 Randomize
 If Ran = 0 Then
 Ran = CInt(Rnd * 25) + 97
 GetRandomCode = GetRandomCode & UCase(Chr(Ran))
 ElseIf Ran = 1 Then
 Ran = CInt(Rnd * 9)
 GetRandomCode = GetRandomCode & Ran
 ElseIf Ran = 2 Then
 Ran = CInt(Rnd * 25) + 97
 GetRandomCode = GetRandomCode & Chr(Ran)
 End If
 Next
 End Function
 '================================================
 ' 函数名：CodeIsTrue
 ' 作 用：检查验证码是否正确
 '================================================
 Public Function CodeIsTrue()
 Dim CodeStr
 CodeStr = Trim(Request("CodeStr"))
 On Error Resume Next
 If CStr(Session("GetCode")) = CStr(CodeStr) And CodeStr <> "" Then
 CodeIsTrue = True
 Session("GetCode") = Empty
 Else
 CodeIsTrue = False
 Session("GetCode") = Empty
 End If
 End Function
 Public Function CheckAdmin(ByVal Flag)
 Dim Rs, SQL
 Dim i, TempAdmin, AdminFlag, AdminGrade

 CheckAdmin = False
 On Error Resume Next
 SQL = "SELECT AdminGrade,Adminflag FROM NC_Admin WHERE username='" & Replace(Session("AdminName"), "'", "''") & "' And password='" & Replace(Session("AdminPass"), "'", "''") & "' And isLock=0 And id=" & CLng(Session("AdminID"))
 Set Rs = Execute(SQL)
 If Rs.BOF And Rs.EOF Then
 CheckAdmin = False
 Set Rs = Nothing
 Exit Function
 Else
 AdminFlag = Rs("Adminflag")
 AdminGrade = Rs("AdminGrade")
 End If
 Rs.Close: Set Rs = Nothing
 If CInt(AdminGrade) = 999 Then
 CheckAdmin = True
 Exit Function
 Else
 If Trim(Flag) = "" Then Exit Function
 If AdminFlag = "" Then
 CheckAdmin = False
 Exit Function
 Else
 TempAdmin = Split(AdminFlag, ",")
 For i = 0 To UBound(TempAdmin)
 If Trim(LCase(TempAdmin(i))) = Trim(LCase(Flag)) Then
 CheckAdmin = True
 Exit For
 End If
 Next
 End If
 End If
 End Function
 '================================================
 '函数名：ReadAlpha
 '作 用：读取字符串的第一个字母
 '参 数：str ----字符
 '返回值：返回第一个字母
 '================================================
 Public Function ReadAlpha(ByVal str)
 Dim strTemp
 If IsNull(str) Or Trim(str) = "" Then
 ReadAlpha = "A-9"
 Exit Function
 End If
 str = Trim(str)
 strTemp = 65536 + Asc(str)
 If (strTemp >= 45217 And strTemp <= 45252) Or (strTemp = 65601) Or (strTemp = 65633) Or (strTemp = 37083) Then
 ReadAlpha = "A-Z"
 ElseIf (strTemp >= 45253 And strTemp <= 45760) Or (strTemp = 65602) Or (strTemp = 65634) Or (strTemp = 39658) Then
 ReadAlpha = "B-Z"
 ElseIf (strTemp >= 45761 And strTemp <= 46317) Or (strTemp = 65603) Or (strTemp = 65635) Or (strTemp = 33405) Then
 ReadAlpha = "C-Z"
 ElseIf (strTemp >= 46318 And strTemp <= 46930) Or (strTemp >= 61884 And strTemp <= 61884) Or (strTemp = 65604) Or (strTemp >= 36820 And strTemp <= 38524) Or (strTemp = 65636) Then
 ReadAlpha = "D-Z"
 ElseIf (strTemp >= 46931 And strTemp <= 47009) Or (strTemp = 65605) Or (strTemp = 65637) Or (strTemp = 61513) Then
 ReadAlpha = "E-Z"
 ElseIf (strTemp >= 47010 And strTemp <= 47296) Or (strTemp = 65606) Or (strTemp = 65638) Or (strTemp = 61320) Or (strTemp = 63568) Or (strTemp = 36281) Then
 ReadAlpha = "F-Z"
 ElseIf (strTemp >= 47297 And strTemp <= 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 >= 47614 And strTemp <= 48118) Or (strTemp >= 59112 And strTemp <= 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 >= 48119 And strTemp <= 49061 And strTemp <> 48739) Or (strTemp >= 62430 And strTemp <= 62430) Or (strTemp = 65610) Or (strTemp = 65642) Or (strTemp = 39048) Then
 ReadAlpha = "J-Z"
 ElseIf (strTemp >= 49062 And strTemp <= 49323) Or (strTemp = 65611) Or (strTemp = 65643) Then
 ReadAlpha = "K-Z"
 ElseIf (strTemp >= 49324 And strTemp <= 49895) Or (strTemp >= 58838 And strTemp <= 58838) Or (strTemp = 65612) Or (strTemp = 65644) Or (strTemp = 62418) Or (strTemp = 48739) Then
 ReadAlpha = "L-Z"
 ElseIf (strTemp >= 49896 And strTemp <= 50370) Or (strTemp = 65613) Or (strTemp = 65645) Then
 ReadAlpha = "M-Z"
 ElseIf (strTemp >= 50371 And strTemp <= 50613) Or (strTemp = 65614) Or (strTemp = 65646) Then
 ReadAlpha = "N-Z"
 ElseIf (strTemp >= 50614 And strTemp <= 50621) Or (strTemp = 65615) Or (strTemp = 65647) Then
 ReadAlpha = "O-Z"
 ElseIf (strTemp >= 50622 And strTemp <= 50905) Or (strTemp = 65616) Or (strTemp = 65648) Then
 ReadAlpha = "P-Z"
 ElseIf (strTemp >= 50906 And strTemp <= 51386) Or (strTemp >= 62659 And strTemp <= 63172) Or (strTemp = 65617) Or (strTemp = 65649) Then
 ReadAlpha = "Q-Z"
 ElseIf (strTemp >= 51387 And strTemp <= 51445) Or (strTemp = 65618) Or (strTemp = 65650) Then
 ReadAlpha = "R-Z"
 ElseIf (strTemp >= 51446 And strTemp <= 52217) Or (strTemp = 65619) Or (strTemp = 65651) Or (strTemp = 34009) Then
 ReadAlpha = "S-Z"
 ElseIf (strTemp >= 52218 And strTemp <= 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 >= 52698 And strTemp <= 52979) Or (strTemp = 65623) Or (strTemp = 65655) Then
 ReadAlpha = "W-Z"
 ElseIf (strTemp >= 52980 And strTemp <= 53688) Or (strTemp = 65624) Or (strTemp = 65656) Then
 ReadAlpha = "X-Z"
 ElseIf (strTemp >= 53689 And strTemp <= 54480) Or (strTemp = 65625) Or (strTemp = 65657) Then
 ReadAlpha = "Y-Z"
 ElseIf (strTemp >= 54481 And strTemp <= 62383 And strTemp <> 59112 And strTemp <> 58838) Or (strTemp = 65626) Or (strTemp = 65658) Or (strTemp = 38395) Or (strTemp = 39783) Then
 ReadAlpha = "Z-Z"
 Else
 ReadAlpha = "A-9"
 End If
 If (strTemp >= 65633 And strTemp <= 65658) Or (strTemp >= 65601 And strTemp <= 65626) Then ReadAlpha = UCase(Left(str, 1))
 If (strTemp >= 65584 And strTemp <= 65593) Then ReadAlpha = "0-9"
 End Function
 '-- 修正文件路径
 Public Function CheckPath(ByVal sPath)
 sPath = Trim(sPath)
 If Right(sPath, 1) <> "\" And sPath <> "" Then
 sPath = sPath & "\"
 End If
 CheckPath = sPath
 End Function
 '-- 生成目录
 Public Function CreatPathEx(ByVal sPath)
 sPath = Replace(sPath, "/", "\")
 sPath = Replace(sPath, "\\", "\")
 On Error Resume Next

 Dim strHostPath,strPath
 Dim sPathItem,sTempPath
 Dim i,fso

 Set fso = Server.CreateObject(FSO_ScriptName)
 strHostPath = Server.MapPath("/")
 If InStr(sPath, ":") = 0 Then sPath = Server.MapPath(sPath)
 If fso.FolderExists(sPath) Or Len(sPath) < 3 Then
 CreatPathEx = True
 Exit Function
 End If

 strPath = Replace(sPath, strHostPath, vbNullString,1,-1,1)
 sPathItem = Split(strPath, "\")

 If InStr(LCase(sPath), LCase(strHostPath)) = 0 Then
 sTempPath = sPathItem(0)
 Else
 sTempPath = strHostPath
 End If

 For i = 1 To UBound(sPathItem)
 If sPathItem(i) <> "" Then
 sTempPath = sTempPath & "\" & sPathItem(i)
 If fso.FolderExists(sTempPath) = False Then
 fso.CreateFolder sTempPath
 End If
 End If
 Next
 Set fso = Nothing
 If Err.Number <> 0 Then Err.Clear
 CreatPathEx = True
 End Function
 '================================================
 '函数名：FilesDelete
 '作 用：FSO删除文件
 '参 数：filepath ----文件路径
 '返回值：False ---- True
 '================================================
 Public Function FileDelete(ByVal FilePath)
 On Error Resume Next
 FileDelete = False
 Dim fso
 Set fso = Server.CreateObject(FSO_ScriptName)
 If FilePath = "" Then Exit Function
 If InStr(FilePath, ":") = 0 Then FilePath = Server.MapPath(FilePath)
 If fso.FileExists(FilePath) Then
 fso.DeleteFile FilePath, True
 FileDelete = True
 End If
 Set fso = Nothing
 If Err.Number <> 0 Then Err.Clear
 End Function
 '================================================
 '函数名：FolderDelete
 '作 用：FSO删除目录
 '参 数：folderpath ----目录路径
 '返回值：False ---- True
 '================================================
 Public Function FolderDelete(ByVal FolderPath)
 FolderDelete = False
 On Error Resume Next
 Dim fso
 Set fso = Server.CreateObject(FSO_ScriptName)
 If FolderPath = "" Then Exit Function
 If InStr(FolderPath, ":") = 0 Then FolderPath = Server.MapPath(FolderPath)
 If fso.FolderExists(FolderPath) Then
 fso.DeleteFolder FolderPath, True
 FolderDelete = True
 End If
 Set fso = Nothing
 If Err.Number <> 0 Then Err.Clear
 End Function
 '================================================
 '函数名：CopyToFile
 '作 用：复制文件
 '参 数：SoureFile ----原文件路径
 ' NewFile ----目标文件路径
 '================================================
 Public Function CopyToFile(ByVal SoureFile, ByVal NewFile)
 On Error Resume Next
 If SoureFile = "" Then Exit Function
 If NewFile = "" Then Exit Function
 If InStr(SoureFile, ":") = 0 Then SoureFile = Server.MapPath(SoureFile)
 If InStr(NewFile, ":") = 0 Then NewFile = Server.MapPath(NewFile)
 Dim fso
 Set fso = Server.CreateObject(FSO_ScriptName)
 If fso.FileExists(SoureFile) Then
 fso.CopyFile SoureFile, NewFile
 End If
 Set fso = Nothing
 If Err.Number <> 0 Then Err.Clear
 End Function
 '================================================
 '函数名：CopyToFolder
 '作 用：复制文件夹
 '参 数：SoureFolder ----原路径
 ' NewFolder ----目标路径
 '================================================
 Public Function CopyToFolder(ByVal SoureFolder, ByVal NewFolder)
 On Error Resume Next
 If SoureFolder = "" Then Exit Function
 If NewFolder = "" Then Exit Function
 If InStr(SoureFolder, ":") = 0 Then SoureFolder = Server.MapPath(SoureFolder)
 If InStr(NewFolder, ":") = 0 Then NewFolder = Server.MapPath(NewFolder)
 Dim fso
 Set fso = Server.CreateObject(FSO_ScriptName)
 If fso.FolderExists(SoureFolder) Then
 fso.CopyFolder SoureFolder, NewFolder
 End If
 Set fso = Nothing
 If Err.Number <> 0 Then Err.Clear
 End Function
 '=============================================================
 '过程名：CreatedTextFile
 '作 用：创建文本文件
 '参 数：filename ----文件名
 ' body ----主要内容
 '=============================================================
 Public Function CreatedTextFile(ByVal FileName, ByVal body)
 On Error Resume Next
 If InStr(FileName, ":") = 0 Then FileName = Server.MapPath(FileName)
 Dim fso,f
 Set fso = Server.CreateObject(FSO_ScriptName)
 Set f = fso.CreateTextFile(FileName)
 f.WriteLine body
 f.Close
 Set f = Nothing
 Set fso = Nothing
 If Err.Number <> 0 Then Err.Clear
 End Function
 '================================================
 '函数名：Readfile
 '作 用：读取文件内容
 '参 数：fromPath ----来源文件路径
 '================================================
 Public Function Readfile(ByVal fromPath)
 On Error Resume Next
 Dim strTemp,fso,f
 If InStr(fromPath, ":") = 0 Then fromPath = Server.MapPath(fromPath)
 Set fso = Server.CreateObject(FSO_ScriptName)
 If fso.FileExists(fromPath) Then
 Set f = fso.OpenTextFile(fromPath, 1, True)
 strTemp = f.ReadAll
 f.Close
 Set f = Nothing
 End If
 Set fso = Nothing
 Readfile = strTemp
 If Err.Number <> 0 Then Err.Clear
 End Function

 '================================================
 '函数名：CutMatchContent
 '作 用：截取相匹配的内容
 '参 数：Str ----原字符串
 ' PatStr ----符合条件字符
 '================================================
 Public Function CutMatchContent(ByVal str, ByVal start, ByVal last, ByVal Condition)

 Dim Match,s,re
 Dim FilterStr,MatchStr
 Dim strContent,ArrayFilter
 Dim i, n,bRepeat

 If Len(start) = 0 Or Len(last) = 0 Then Exit Function

 On Error Resume Next

 MatchStr = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")"

 Set re = New RegExp
 re.IgnoreCase = True
 re.Global = True
 re.Pattern = MatchStr
 Set s = re.Execute(str)
 n = 0
 For Each Match In s
 If n = 0 Then
 n = n + 1
 ReDim ArrayFilter(n)
 ArrayFilter(n) = Match
 Else
 bRepeat = False
 For i = 0 To UBound(ArrayFilter)
 If UCase(Match) = UCase(ArrayFilter(i)) Then
 bRepeat = True
 Exit For
 End If
 Next
 If bRepeat = False Then
 n = n + 1
 ReDim Preserve ArrayFilter(n)
 ArrayFilter(n) = Match
 End If
 End If
 Next

 Set s = Nothing
 Set re = Nothing

 If CBool(Condition) Then
 strContent = Join(ArrayFilter, "

回复用户1 · 发表于 2006-10-3 00:05:09

")
Else
strContent = Join(ArrayFilter, "

回复用户5 · 发表于 2006-10-3 00:05:44

")
            strContent = Replace(strContent, start, "")
            strContent = Replace(strContent, last, "")
        End If

        CutMatchContent = Replace(strContent, "

回复用户3 · 发表于 2006-10-3 00:06:38

", vbNullString, 1, 1)
 End Function

 Function CutFixContent(ByVal str, ByVal start, ByVal last, ByVal n)
 Dim strTemp
 On Error Resume Next
 If InStr(str, start) > 0 Then
 Select Case n
 Case 0 '左右都截取（都取前面）（去处关键字）
 strTemp = Right(str, Len(str) - InStr(str, start) - Len(start) + 1)
 strTemp = Left(strTemp, InStr(strTemp, last) - 1)
 Case Else '左右都截取（都取前面）（保留关键字）
 strTemp = Right(str, Len(str) - InStr(str, start) + 1)
 strTemp = Left(strTemp, InStr(strTemp, last) + Len(last) - 1)
 End Select
 Else
 strTemp = ""
 End If
 CutFixContent = strTemp
 End Function
 Private Function CorrectPattern(ByVal 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, "|", "\|")
 str = Replace(str, "$", "\$")
 CorrectPattern = str
 End Function
 '=============================================================
 '函数名：UserGroupSetting
 '作 用：取用户级权限设置
 '参 数：gradeid ----等级ID
 '=============================================================
 Public Function UserGroupSetting(ByVal gradeid)
 If Not IsNumeric(gradeid) Then
 gradeid = 0
 End If
 On Error Resume Next
 Dim Rs, SQL

 Name = "GroupSetting" & gradeid
 If ObjIsEmpty() Then
 SQL = "Select Groupname,GroupSet from [NC_UserGroup] where Grades =" & gradeid
 Set Rs = Execute(SQL)
 If Rs.BOF And Rs.EOF Then
 UserGroupSetting = ""
 Set Rs = Nothing
 Exit Function
 End If
 Value = Rs("GroupSet") & Rs("Groupname")
 Set Rs = Nothing
 End If
 UserGroupSetting = Value
 End Function
 Private Sub LoadGroupSetting()
 Dim strGroupSetting
 Dim Rs, SQL
 Dim Grades
 Grades = CInt(membergrade)
 On Error Resume Next
 If Grades > 0 And memberid > 0 Then
 If binUserLong = False Then
 Set Rs = Execute("SELECT userid FROM [NC_User] WHERE password='" & CheckRequest(memberpass, 45) & "' And UserGrade=" & Grades & " And UserLock=0 And userid =" & memberid)
 If Rs.BOF And Rs.EOF Then
 Grades = 0
 Response.Cookies(Cookies_Name) = ""
 binUserLong = False
 Else
 binUserLong = True
 End If
 Set Rs = Nothing
 End If
 End If

 Name = "GroupSetting" & Grades
 If ObjIsEmpty() Then
 SQL = "Select Groupname,GroupSet from [NC_UserGroup] where Grades =" & Grades
 Set Rs = Execute(SQL)
 If Rs.BOF And Rs.EOF Then
 Response.Cookies(Cookies_Name) = ""
 Set Rs = Nothing
 Exit Sub
 End If
 Value = Rs("GroupSet") & Rs("Groupname")
 Set Rs = Nothing
 End If
 blnGroupSetting = True
 strGroupSetting = Value
 arrGroupSetting = Split(strGroupSetting, "

账号		自动登录	找回密码
密码			立即注册

[ASP编程] newasp中main类

相关帖子