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
'===================服務(wù)器緩存部分函數(shù)開始=================== 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 '===================服務(wù)器緩存部分函數(shù)結(jié)束===================
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 '============================================================= '函數(shù)名：ChkFormStr '作 用：過濾表單字符 '參 數(shù)：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 '============================================================= '函數(shù)作用：過濾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 '-- 數(shù)據(jù)庫連接 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 "查詢數(shù)據(jù)的時候發(fā)現(xiàn)錯誤，請檢查您的查詢代碼是否正確。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 '第一次起用系統(tǒng)或者重啟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 "│版權(quán)所有: 新云網(wǎng)絡(luò) (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 '作 用：再裝頻道設(shè)置 '參 數(shù)：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 "錯誤的頻道參數(shù)！" Exit Sub End If Value = Rs.GetRows(1) Set Rs = Nothing End Sub '============================================================= '過程名：ReadChannel '作 用：讀取頻道設(shè)置 '參 數(shù)：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 '作 用：載入模板 '參 數(shù)：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 '================================================ '函數(shù)名：FormEncode '作 用：過慮提交的表單數(shù)據(jù) '參 數(shù)：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 '================================================ '函數(shù)名：ChkKeyWord '作 用：過濾關(guān)鍵字 '參 數(shù)：keyword ----關(guān)鍵字 '================================================ 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 '================================================ '函數(shù)名：JAPEncode '作 用：日文片假名編碼 '參 數(shù)：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 '================================================ '函數(shù)名：JAPUncode '作 用：日文片假名解碼 '參 數(shù)：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 '============================================================= '函數(shù)作用：帶臟話過濾 '============================================================= 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 '============================================================= '函數(shù)作用：過濾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 '============================================================= '函數(shù)作用：過濾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 '============================================================= '函數(shù)作用：判斷發(fā)言是否來自外部 '============================================================= 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 '============================================================= '函數(shù)作用：判斷來源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 '================================================ '函數(shù)名：GotTopic '作 用：顯示字符串長度 '參 數(shù)：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 '================================================ '函數(shù)名：ReadTopic '作 用：顯示字符串長度 '參 數(shù)：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 '================================================ '函數(shù)名：strLength '作 用：計字符串長度 '參 數(shù)：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 '================================================= '函數(shù)名：isInteger '作 用：判斷數(shù)字是否整型 '參 數(shù)：para ----參數(shù) '================================================= 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('安全系統(tǒng)提示↓\n\n您提交的字符數(shù)超過了限制！');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('安全系統(tǒng)提示↓\n\n請不要在參數(shù)中包含非法字符！');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('安全系統(tǒng)提示↓\n\n請不要在參數(shù)中包含非法字符！');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('安全系統(tǒng)提示↓\n\n請不要在參數(shù)中包含非法字符！');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('安全系統(tǒng)提示↓\n\n請不要在參數(shù)中包含非法字符！');history.back(-1)/Script>" Response.End End If Next Next End If End Sub '================================================ '函數(shù)名：ChkQueryStr '作 用：過慮查詢的非法字符 '參 數(shù)：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 '作 用：限制搜索的關(guān)鍵字 '參 數(shù)：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 '================================================ '函數(shù)名：IsValidStr '作 用：判斷字符串中是否含有非法字符 '參 數(shù)：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 '================================================ '函數(shù)名：IsValidPassword '作 用：判斷密碼中是否含有非法字符 '參 數(shù)：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 '================================================ '函數(shù)名：IsValidChar '作 用：判斷字符串中是否含有非法字符和中文 '參 數(shù)：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 '================================================ '函數(shù)名：FormatDate '作 用：格式化日期 '參 數(shù)：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 '================================================ '函數(shù)名：ReadFontMode '作 用：讀取字體模式 '參 數(shù)：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 '============================================================= '函數(shù)名：ShowDateTime '作 用：讀取日期格式 '參 數(shù)：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 '============================================================= '函數(shù)名：ReadBriefTopicffd '作 用：讀取簡短標題 '參 數(shù)：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'>[轉(zhuǎn)載]/font>" Case Else sBriefTopic = "" End Select ReadBriefTopic = sBriefTopic End Function '============================================================= '函數(shù)名：ReadPicTopic '作 用：讀取簡短標題 '參 數(shù)：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) "'>[轉(zhuǎn)載]/font>" Case Else sBriefTopic = "" End Select ReadPicTopic = sBriefTopic End Function '============================================================= '函數(shù)名：ReadPayMoney '作 用：讀取要支付的金錢 '參 數(shù)：money ----實際金錢 '返回值：加上手續(xù)費后的金錢 '============================================================= 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 '============================================================= '函數(shù)名：RebateMoney '作 用：讀取打折的后金錢 '參 數(shù)：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 '================================================ '函數(shù)名：Supplemental '作 用：補足參數(shù) '參 數(shù)：para ----原參數(shù) ' n ----增補的位數(shù) '================================================ 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
'================================================ '函數(shù)名：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 '參 數(shù)：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 '================================================ '函數(shù)名：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 '================================================ '函數(shù)名：ReadFileName '作 用：讀取HTML文件名 '參 數(shù)：strname ----文件名稱 ' id ----數(shù)據(jù)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 '================================================ '函數(shù)名：ClassFileName '作 用：讀取HTML文件列表名 '參 數(shù)：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 '================================================ '函數(shù)名：SpecialFileName '作 用：讀取專題HTML文件名 '參 數(shù)：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 '================================================ '函數(shù)名：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 = "此頻道暫時關(guān)閉,不能訪問！" 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 '============================================================= '函數(shù)名：LoadSelectClass '作 用：載入緩存下拉分類列表 '參 數(shù)：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 '================================================ '函數(shù)名：GetRandomCode '作 用：系統(tǒng)分配隨機代碼 '================================================ 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 '================================================ ' 函數(shù)名：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 '================================================ '函數(shù)名：ReadAlpha '作 用：讀取字符串的第一個字母 '參 數(shù)：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 '================================================ '函數(shù)名：FilesDelete '作 用：FSO刪除文件 '參 數(shù)：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 '================================================ '函數(shù)名：FolderDelete '作 用：FSO刪除目錄 '參 數(shù)：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 '================================================ '函數(shù)名：CopyToFile '作 用：復制文件 '參 數(shù)：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 '================================================ '函數(shù)名：CopyToFolder '作 用：復制文件夾 '參 數(shù)：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 '作 用：創(chuàng)建文本文件 '參 數(shù)：filename ----文件名 ' body ----主要內(nèi)容 '============================================================= 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 '================================================ '函數(shù)名：Readfile '作 用：讀取文件內(nèi)容 '參 數(shù)：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
'================================================ '函數(shù)名：CutMatchContent '作 用：截取相匹配的內(nèi)容 '參 數(shù)：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 '左右都截?。ǘ既∏懊妫ㄈヌ庩P(guān)鍵字） strTemp = Right(str, Len(str) - InStr(str, start) - Len(start) + 1) strTemp = Left(strTemp, InStr(strTemp, last) - 1) Case Else '左右都截取（都取前面）（保留關(guān)鍵字） 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 '============================================================= '函數(shù)名：UserGroupSetting '作 用：取用戶級權(quán)限設(shè)置 '參 數(shù)：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
