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
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, "'", "#39;") fString = Replace(fString, Chr(34), "quot;") fString = Replace(fString, Chr(13), "") fString = Replace(fString, Chr(10), "") fString = Replace(fString, Chr(9), "") fString = Replace(fString, ">", "gt;") fString = Replace(fString, "", "lt;") 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 "查询数据的时候发现错误，请检查您的查询代码是否正确。br />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 CopyrightStr = CopyrightStr "┌─────────────────NEWASP──┐" vbCrLf CopyrightStr = CopyrightStr "│NewCloud SiteManageSystem Version 2.0.0 SP1 │" vbCrLf CopyrightStr = CopyrightStr "│版权所有: 新云网络 (newasp.net) │" vbCrLf CopyrightStr = CopyrightStr "│官方主页: http://www.newasp.net │" vbCrLf CopyrightStr = CopyrightStr "│论坛地址: http://bbs.newasp.net │" vbCrLf CopyrightStr = CopyrightStr "│E-Mail: webenvoy@163.com QQ: 94022511 │" vbCrLf CopyrightStr = CopyrightStr "└────────────────────.NET┘" vbCrLf CopyrightStr = 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(, , "|||", "@@@", "") tmpdata = Left(tmpdata, Len(tmpdata) - 3) Set Rs = Nothing Value = tmpdata End If
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), "|||") 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) 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, "|||") 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, ">", "gt;") str = Replace(str, "", "lt;") str = Replace(str, "#62;", "gt;") str = Replace(str, "#60;", "lt;") str = Replace(str, "'", "#39;") str = Replace(str, Chr(34), "quot;") 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, ">", "gt;") fString = Replace(fString, "", "lt;") fString = Replace(fString, Chr(32), " ") fString = Replace(fString, Chr(9), " ") fString = Replace(fString, Chr(34), "quot;") fString = Replace(fString, Chr(39), "#39;") fString = Replace(fString, Chr(13), "") fString = Replace(fString, " ", "nbsp;") fString = Replace(fString, Chr(10), "br /> ") fString = ChkBadWords(fString) HTMLEncode = fString End If End Function '============================================================= '函数作用：过滤HTML代码，不带脏话过滤 '============================================================= Public Function HTMLEncodes(ByVal fString) If Not IsNull(fString) Then fString = Replace(fString, "'", "#39;") fString = Replace(fString, ">", "gt;") fString = Replace(fString, "", "lt;") fString = Replace(fString, Chr(32), " ") fString = Replace(fString, Chr(9), " ") fString = Replace(fString, Chr(34), "quot;") fString = Replace(fString, Chr(39), "#39;") fString = Replace(fString, Chr(13), "") fString = Replace(fString, Chr(10), "br /> ") fString = Replace(fString, " ", "nbsp;") 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, "nbsp;", " ") str = Replace(str, "gt;", ">") str = Replace(str, "lt;", "") str = Replace(str, "#62;", ">") str = Replace(str, "#60;", "") str = Replace(str, "#39;", "'") str = Replace(str, "quot;", 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 = "(#62;)" strContent = re.Replace(strContent, "gt;") re.Pattern = "(#60;)" strContent = re.Replace(strContent, "lt;") Set re = Nothing strContent = Replace(strContent, ">", "gt;") strContent = Replace(strContent, "", "lt;") strContent = Replace(strContent, "'", "#39;") strContent = Replace(strContent, Chr(34), "quot;") 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, "nbsp;", " ") 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
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, "nbsp;", " ") 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 = "b>" str "/b>" Case 2 FontStr = "em>" str "/em>" Case 3 FontStr = "u>" str "/u>" Case 4 FontStr = "b>em>" str "/em>/b>" Case 5 FontStr = "b>u>" str "/u>/b>" Case 6 FontStr = "em>u>" str "/u>/em>" Case 7 FontStr = "b>em>u>" str "/u>/em>/b>" 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 = "font color=" tColor ">" FontStr "/font>" 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 = "font color='" Main_Setting(1) "'>" strDate = strDate FormatDate(DateAndTime, para) strDate = strDate "/font>" Else strDate = "font color='" Main_Setting(2) "'>" strDate = strDate FormatDate(DateAndTime, para) strDate = strDate "/font>" 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 = "font color='blue'>[图文]/font>" Case "2" sBriefTopic = "font color='red'>[组图]/font>" Case "3" sBriefTopic = "font color='green'>[新闻]/font>" Case "4" sBriefTopic = "font color='blue'>[推荐]/font>" Case "5" sBriefTopic = "font color='red'>[注意]/font>" Case "6" sBriefTopic = "font color='green'>[转载]/font>" 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 = "font color='" Main_Setting(4) "'>[图文]/font>" Case "2" sBriefTopic = "font color='" Main_Setting(5) "'>[组图]/font>" Case "3" sBriefTopic = "font color='" Main_Setting(6) "'>[新闻]/font>" Case "4" sBriefTopic = "font color='" Main_Setting(4) "'>[推荐]/font>" Case "5" sBriefTopic = "font color='" Main_Setting(5) "'>[注意]/font>" Case "6" sBriefTopic = "font color='" Main_Setting(6) "'>[转载]/font>" 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
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 "br>" 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
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
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, "|||") Else strContent = Join(ArrayFilter, "|||") strContent = Replace(strContent, start, "") strContent = Replace(strContent, last, "") End If
CutMatchContent = Replace(strContent, "|||", 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, "$", "\$") 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, "|||") End Sub Public Property Get GroupSetting(i) If Not blnGroupSetting Then LoadGroupSetting GroupSetting = arrGroupSetting(i) End Property Public Function ReadContent(ByVal strContent) On Error Resume Next Dim re, i Dim sContentKeyword, strKeyword
If Trim(ContentKeyword) > "" Then sContentKeyword = Split(ContentKeyword, "@@@") For i = 0 To UBound(sContentKeyword) - 1 strKeyword = Split(sContentKeyword(i), "$$$") re.Pattern = "(" strKeyword(0) ")" strContent = re.Replace(strContent, "a target=""_blank"" href=""" strKeyword(1) """ class=""wordstyle"">$1/a>") Next End If
