newasp中main类 <% Const IsDeBug = 1 Class NewaspMain_Cls Public membername, memberpass, membergrade, membergroup, memberid Public memberclass, menbernickname, Cookies_Name, CheckPassword Public SiteName, SiteUrl, MasterMail, keywords, Copyright Public InstallDir, IndexName, IstopSite, StopReadme, IsCloseMail Public SendMailType, MailFrom, MailServer, MailUserName, MailPassword, MailInformPass, ChkSameMail Public CheckUserReg, AdminCheckReg, AddUserPoint, SendRegMessage, FullContQuery, ActionTime Public IsRunTime, UploadClass, UploadFileSize, UploadFileType, ContentKeyword, PreviewSetting Public StopApplyLink, FSO_ScriptName, InitTitleColor, StopBankPay Public ChinaeBank, VersionID, Badwords, Badwordr, serialcode, passedcode Public ChannelName, ChannelDir, StopChannel, ChannelType Public modules, ChannelSkin, HtmlPath, HtmlForm, HtmlPrefix Public IsCreateHtml, HtmlExtName, StopUpload, MaxFileSize, UpFileType Public IsAuditing, AppearGrade, ModuleName, BindDomain, DomainName Public PostGrade, LeastString, MaxString, PaginalNum, LeastHotHist, Channel_Setting Public ChannelSetting,ChannelData,ChannelPath Public ChannelModule,ChannelHtmlPath,ChannelHtmlForm,ChannelUseHtml,ChannelHtmlExt,ChannelPrefix Public ThisEdition, CopyrightStr, Version, Values, startime Public SqlQueryNum, GetUserip, CacheName, Reloadtime Public ScriptName, Admin_Page, skinid, SkinPath, HtmlCss, HtmlTop, HtmlFoot, HtmlContent, sHtmlContent Private Main_Style, Main_Setting, MainStyle, Html_Setting Private LocalCacheName, Cache_Data Private CacheChannel, CacheData Private arrGroupSetting, blnGroupSetting, binUserLong Private Sub Class_Initialize() On Error Resume Next Reloadtime = 28800 SqlQueryNum = 0 '--缓存名称 CacheName = "newasp" Cookies_Name = "newasp_net" binUserLong = False blnGroupSetting = False GetUserip = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If Len(GetUserip) = 0 Then GetUserip = Request.ServerVariables("REMOTE_ADDR") GetUserip = CheckStr(GetUserip) membername = CheckStr(Request.Cookies(Cookies_Name)("username")) memberpass = CheckStr(Request.Cookies(Cookies_Name)("password")) menbernickname = CheckStr(Request.Cookies(Cookies_Name)("nickname")) membergrade = ChkNumeric(Request.Cookies(Cookies_Name)("UserGrade")) membergroup = CheckStr(Request.Cookies(Cookies_Name)("UserGroup")) memberclass = ChkNumeric(Request.Cookies(Cookies_Name)("UserClass")) memberid = ChkNumeric(Request.Cookies(Cookies_Name)("userid")) CheckPassword = CheckStr(Request.Cookies(Cookies_Name)("CheckPassword")) Dim tmpstr, i tmpstr = Request.ServerVariables("PATH_INFO") tmpstr = Split(tmpstr, "/") i = UBound(tmpstr) ScriptName = LCase(tmpstr(i)) Admin_Page = False If InStr(ScriptName, "showerr") > 0 Or InStr(ScriptName, "login") > 0 Or InStr(ScriptName, "admin_") > 0 Then Admin_Page = True End Sub Private Sub Class_Terminate() If IsObject(Conn) Then Conn.Close : Set Conn = Nothing End Sub '===================服务器缓存部分函数开始=================== Public Property Let Name(ByVal vNewValue) LocalCacheName = LCase(vNewValue) Cache_Data = Application(CacheName & "_" & LocalCacheName) End Property Public Property Let Value(ByVal vNewValue) If LocalCacheName <> "" Then ReDim Cache_Data(2) Cache_Data(0) = vNewValue Cache_Data(1) = Now() Application.Lock Application(CacheName & "_" & LocalCacheName) = Cache_Data Application.UnLock Else Err.Raise vbObjectError + 1, "NewaspCacheServer", " please change the CacheName." End If End Property Public Property Get Value() If LocalCacheName <> "" Then If IsArray(Cache_Data) Then Value = Cache_Data(0) Else 'Err.Raise vbObjectError + 1, "NewaspCacheServer", " The Cache_Data("&LocalCacheName&") Is Empty." End If Else Err.Raise vbObjectError + 1, "NewaspCacheServer", " please change the CacheName." End If End Property Public Function ObjIsEmpty() ObjIsEmpty = True If Not IsArray(Cache_Data) Then Exit Function If Not IsDate(Cache_Data(1)) Then Exit Function If DateDiff("s", CDate(Cache_Data(1)), Now()) < (60 * Reloadtime) Then ObjIsEmpty = False End Function Public Sub DelCahe(MyCaheName) Application.Lock Application.Contents.Remove (CacheName & "_" & MyCaheName) Application.UnLock End Sub Public Sub DelCache(MyCaheName) Application.Lock Application.Contents.Remove ("mynewasp_" & MyCaheName) Application.UnLock End Sub '===================服务器缓存部分函数结束=================== Public Function ChkBoolean(ByVal Values) If TypeName(Values) = "Boolean" Or IsNumeric(Values) Or LCase(Values) = "false" Or LCase(Values) = "true" Then ChkBoolean = CBool(Values) Else ChkBoolean = False End If End Function Public Function CheckNumeric(ByVal CHECK_ID) If CHECK_ID <> "" And IsNumeric(CHECK_ID) Then CHECK_ID = CCur(CHECK_ID) Else CHECK_ID = 0 End If CheckNumeric = CHECK_ID End Function Public Function ChkNumeric(ByVal CHECK_ID) If CHECK_ID <> "" And IsNumeric(CHECK_ID) Then CHECK_ID = CLng(CHECK_ID) If CHECK_ID < 0 Then CHECK_ID = 0 Else CHECK_ID = 0 End If ChkNumeric = CHECK_ID End Function Public Function CheckStr(ByVal str) If IsNull(str) Then CheckStr = "" Exit Function End If str = Replace(str, Chr(0), "") CheckStr = Replace(str, "'", "''") End Function '================================================ '过程名：CheckNull '作 用：是否有效值 '================================================ Public Function CheckNull(ByVal sValue) On Error Resume Next If IsNull(sValue) Then CheckNull = False Exit Function End If If Trim(sValue) <> "" And LCase(Trim(sValue)) <> "http://" Then CheckNull = True Else CheckNull = False End If End Function Public Function ChkNull(ByVal str) On Error Resume Next If IsNull(str) Then ChkNull = "" Exit Function End If If Trim(str) <> "" And LCase(Trim(str)) <> "http://" Then ChkNull = Trim(str) Else ChkNull = "" End If End Function '============================================================= '函数名：ChkFormStr '作 用：过滤表单字符 '参 数：str ----原字符串 '返回值：过滤后的字符串 '============================================================= Public Function ChkFormStr(ByVal str) Dim fString fString = str If IsNull(fString) Then ChkFormStr = "" Exit Function End If fString = Replace(fString, "'", "'") fString = Replace(fString, Chr(34), """) fString = Replace(fString, Chr(13), "") fString = Replace(fString, Chr(10), "") fString = Replace(fString, Chr(9), "") fString = Replace(fString, ">", ">") fString = Replace(fString, "<", "<") fString = Replace(fString, "%", "％") ChkFormStr = Trim(JAPEncode(fString)) End Function '============================================================= '函数作用：过滤SQL非法字符 '============================================================= Public Function CheckRequest(ByVal str,ByVal strLen) On Error Resume Next str = Trim(str) str = Replace(str, Chr(0), "") str = Replace(str, "'", "") str = Replace(str, "%", "") str = Replace(str, "^", "") str = Replace(str, ";", "") str = Replace(str, "*", "") str = Replace(str, "<", "") str = Replace(str, ">", "") str = Replace(str, "|", "") str = Replace(str, "and", "") str = Replace(str, "chr", "") If Len(str) > 0 And strLen > 0 Then str = Left(str, strLen) End If CheckRequest = str End Function '-- 移除有害字符 Public Function RemoveBadCharacters(ByVal strTemp) Dim re On Error Resume Next Set re = New RegExp re.Pattern = "[^\s\w]" re.Global = True RemoveBadCharacters = re.Replace(strTemp, "") Set re = Nothing End Function '-- 去掉HTML标记 Public Function RemoveHtml(ByVal Textstr) Dim Str,re Str = Textstr On Error Resume Next Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "<(.[^>]*)>" Str = re.Replace(Str, "") Set re = Nothing RemoveHtml=Str End Function '-- 数据库连接 Public Function Execute(Command) If Not IsObject(Conn) Then ConnectionDatabase If IsDeBug = 0 Then On Error Resume Next Set Execute = Conn.Execute(Command) If Err Then err.Clear Set Conn = Nothing Response.Write "查询数据的时候发现错误，请检查您的查询代码是否正确。
" 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：NewCloud SiteManageSystem Version 2.0.0 SP1" 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 ChannelData = Split(Value, "|||") ChannelPath = InstallDir & ChannelData(1) ChannelModule = ChannelData(2) ChannelHtmlPath = ChannelData(3) ChannelHtmlForm = ChannelData(4) ChannelUseHtml = ChannelData(5) ChannelHtmlExt = ChannelData(6) ChannelPrefix = ChannelData(7) 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, ">", ">") str = Replace(str, "<", "<") str = Replace(str, ">", ">") str = Replace(str, "<", "<") str = Replace(str, "'", "'") str = Replace(str, Chr(34), """) str = Replace(str, "%", "％") str = Replace(str, vbNewLine, "") FormEncode = Trim(str) Else FormEncode = "" End If End Function '================================================ '函数名：ChkKeyWord '作 用：过滤关键字 '参 数：keyword ----关键字 '================================================ Public Function ChkKeyWord(ByVal keyword) Dim FobWords, i On Error Resume Next FobWords = Array(91, 92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12521, 12532, 12533, 65339, 65340) For i = 1 To UBound(FobWords, 1) If InStr(keyword, ChrW(FobWords(i))) > 0 Then keyword = Replace(keyword, ChrW(FobWords(i)), "") End If Next keyword = Left(keyword, 100) FobWords = Array("~", "!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "_", "+", "=", "`", "[", "]", "{", "}", ";", ":", """", "'", ",", "<", ">", ".", "/", "\", "?", "_") For i = 0 To UBound(FobWords, 1) If InStr(keyword, FobWords(i)) > 0 Then keyword = Replace(keyword, FobWords(i), "") End If Next ChkKeyWord = keyword End Function '================================================ '函数名：JAPEncode '作 用：日文片假名编码 '参 数：str ----原字符 '================================================ Public Function JAPEncode(ByVal str) Dim FobWords, i On Error Resume Next If IsNull(str) Or Trim(str) = "" Then JAPEncode = "" Exit Function End If FobWords = Array(92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12521, 12532, 12533, 65340) For i = 1 To UBound(FobWords, 1) If InStr(str, ChrW(FobWords(i))) > 0 Then str = Replace(str, ChrW(FobWords(i)), "&#" & FobWords(i) & ";") End If Next JAPEncode = str End Function '================================================ '函数名：JAPUncode '作 用：日文片假名解码 '参 数：str ----原字符 '================================================ Public Function JAPUncode(ByVal str) Dim FobWords, i On Error Resume Next If IsNull(str) Or Trim(str) = "" Then JAPUncode = "" Exit Function End If FobWords = Array(92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12521, 12532, 12533, 65340) For i = 1 To UBound(FobWords, 1) If InStr(str, "&#" & FobWords(i) & ";") > 0 Then str = Replace(str, "&#" & FobWords(i) & ";", ChrW(FobWords(i))) End If Next str = Replace(str, Chr(0), "") str = Replace(str, "'", "''") JAPUncode = str End Function '============================================================= '函数作用：带脏话过滤 '============================================================= Public Function ChkBadWords(ByVal str) If IsNull(str) Then Exit Function Dim i, Bwords, Bwordr Bwords = Split(Badwords, "|") Bwordr = Split(Badwordr, "|") For i = 0 To UBound(Bwords) If i > UBound(Bwordr) Then str = Replace(str, Bwords(i), "*") Else str = Replace(str, Bwords(i), Bwordr(i)) End If Next ChkBadWords = str End Function '============================================================= '函数作用：过滤HTML代码，带脏话过滤 '============================================================= Public Function HTMLEncode(ByVal fString) If Not IsNull(fString) Then fString = Replace(fString, ">", ">") fString = Replace(fString, "<", "<") fString = Replace(fString, Chr(32), " ") fString = Replace(fString, Chr(9), " ") fString = Replace(fString, Chr(34), """) fString = Replace(fString, Chr(39), "'") fString = Replace(fString, Chr(13), "") fString = Replace(fString, " ", " ") fString = Replace(fString, Chr(10), " ") fString = ChkBadWords(fString) HTMLEncode = fString End If End Function '============================================================= '函数作用：过滤HTML代码，不带脏话过滤 '============================================================= Public Function HTMLEncodes(ByVal fString) If Not IsNull(fString) Then fString = Replace(fString, "'", "'") fString = Replace(fString, ">", ">") fString = Replace(fString, "<", "<") fString = Replace(fString, Chr(32), " ") fString = Replace(fString, Chr(9), " ") fString = Replace(fString, Chr(34), """) fString = Replace(fString, Chr(39), "'") fString = Replace(fString, Chr(13), "") fString = Replace(fString, Chr(10), " ") fString = Replace(fString, " ", " ") HTMLEncodes = fString End If End Function '============================================================= '函数作用：判断发言是否来自外部 '============================================================= Public Function CheckPost() On Error Resume Next Dim server_v1, server_v2 CheckPost = False server_v1 = CStr(Request.ServerVariables("HTTP_REFERER")) server_v2 = CStr(Request.ServerVariables("SERVER_NAME")) If Mid(server_v1, 8, Len(server_v2)) = server_v2 Then CheckPost = True End If End Function '============================================================= '函数作用：判断来源URL是否来自外部 '============================================================= Public Function CheckOuterUrl() On Error Resume Next Dim server_v1, server_v2 server_v1 = Replace(LCase(Trim(Request.ServerVariables("HTTP_REFERER"))), "http://", "") server_v2 = LCase(Trim(Request.ServerVariables("SERVER_NAME"))) If server_v1 <> "" And Left(server_v1, Len(server_v2)) <> server_v2 Then CheckOuterUrl = False Else CheckOuterUrl = True End If End Function '================================================ '函数名：GotTopic '作 用：显示字符串长度 '参 数：str ----原字符串 ' strlen ----显示字符长度 '================================================ Public Function GotTopic(ByVal str, ByVal strLen) Dim l, t, c, i Dim strTemp On Error Resume Next str = Trim(str) str = Replace(str, " ", " ") str = Replace(str, ">", ">") str = Replace(str, "<", "<") str = Replace(str, ">", ">") str = Replace(str, "<", "<") str = Replace(str, "'", "'") str = Replace(str, """, Chr(34)) str = Replace(str, vbNewLine, "") l = Len(str) t = 0 For i = 1 To l c = Abs(Asc(Mid(str, i, 1))) If c > 255 Then t = t + 2 Else t = t + 1 End If If t >= strLen Then strTemp = Left(str, i) & "..." Exit For Else strTemp = str & " " End If Next GotTopic = CheckTopic(strTemp) End Function Public Function CheckTopic(ByVal strContent) Dim re On Error Resume Next Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "()" strContent = re.Replace(strContent, "") re.Pattern = "()" strContent = re.Replace(strContent, "") re.Pattern = "(>)" strContent = re.Replace(strContent, ">") re.Pattern = "(<)" strContent = re.Replace(strContent, "<") Set re = Nothing strContent = Replace(strContent, ">", ">") strContent = Replace(strContent, "<", "<") strContent = Replace(strContent, "'", "'") strContent = Replace(strContent, Chr(34), """) strContent = Replace(strContent, "%", "％") strContent = Replace(strContent, vbNewLine, "") CheckTopic = Trim(strContent) End Function '================================================ '函数名：ReadTopic '作 用：显示字符串长度 '参 数：str ----原字符串 ' strlen ----显示字符长度 '================================================ Public Function ReadTopic(ByVal str, ByVal strLen) Dim l, t, c, i On Error Resume Next str = Replace(str, " ", " ") If Len(str) < strLen Then str = str & String(strLen - Len(str), ".") Else str = str End If l = Len(str) t = 0 For i = 1 To l c = Abs(Asc(Mid(str, i, 1))) If c > 255 Then t = t + 2 Else t = t + 1 End If If t >= strLen Then ReadTopic = Left(str, i) & "..." Exit For Else ReadTopic = str & "..." End If Next End Function '================================================ '函数名：strLength '作 用：计字符串长度 '参 数：str ----字符串 '================================================ Public Function strLength(ByVal str) On Error Resume Next If IsNull(str) Or str = "" Then strLength = 0 Exit Function End If Dim WINNT_CHINESE WINNT_CHINESE = (Len("例子") = 2) If WINNT_CHINESE Then Dim l, t Dim i, c l = Len(str) t = l For i = 1 To l c = Asc(Mid(str, i, 1)) If c < 0 Then c = c + 65536 If c > 255 Then t = t + 1 Next strLength = t Else strLength = Len(str) End If End Function '================================================= '函数名：isInteger '作 用：判断数字是否整型 '参 数：para ----参数 '================================================= Public Function isInteger(ByVal para) On Error Resume Next Dim str Dim l, i If IsNull(para) Then isInteger = False Exit Function End If str = CStr(para) If Trim(str) = "" Then isInteger = False Exit Function End If l = Len(str) For i = 1 To l If Mid(str, i, 1) > "9" Or Mid(str, i, 1) < "0" Then isInteger = False Exit Function End If Next isInteger = True If Err.Number <> 0 Then Err.Clear End Function Public Function CutString(ByVal str, ByVal strLen) On Error Resume Next Dim HtmlStr, l, re, strContent HtmlStr = str HtmlStr = Replace(HtmlStr, " ", " ") HtmlStr = Replace(HtmlStr, """, Chr(34)) HtmlStr = Replace(HtmlStr, "'", Chr(39)) HtmlStr = Replace(HtmlStr, "{", Chr(123)) HtmlStr = Replace(HtmlStr, "}", Chr(125)) HtmlStr = Replace(HtmlStr, "$", Chr(36)) HtmlStr = Replace(HtmlStr, vbCrLf, "") HtmlStr = Replace(HtmlStr, "====", "") HtmlStr = Replace(HtmlStr, "----", "") HtmlStr = Replace(HtmlStr, "////", "") HtmlStr = Replace(HtmlStr, "\\\\", "") HtmlStr = Replace(HtmlStr, "####", "") HtmlStr = Replace(HtmlStr, "@@@@", "") HtmlStr = Replace(HtmlStr, "****", "") HtmlStr = Replace(HtmlStr, "~~~~", "") Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "\[br\]" HtmlStr = re.Replace(HtmlStr, "") re.Pattern = "\[align=right\](.*)\[\/align\]" HtmlStr = re.Replace(HtmlStr, "") re.Pattern = "<(.[^>]*)>" HtmlStr = re.Replace(HtmlStr, "") Set re = Nothing HtmlStr = Replace(HtmlStr, ">", ">") HtmlStr = Replace(HtmlStr, "<", "<") l = Len(HtmlStr) If l >= strLen Then strContent = Left(HtmlStr, strLen) & "..." Else strContent = HtmlStr & " " End If strContent = Replace(strContent, Chr(34), """) strContent = Replace(strContent, Chr(39), "'") strContent = Replace(strContent, Chr(36), "$") strContent = Replace(strContent, Chr(123), "{") strContent = Replace(strContent, Chr(125), "}") strContent = Replace(strContent, ">", ">") strContent = Replace(strContent, "<", "<") CutString = strContent End Function '================================================ '函数名：CheckInfuse '作 用：防止SQL注入 '参 数：str ----原字符串 ' strLen ----提交字符串长度 '================================================ Public Function CheckInfuse(ByVal str, ByVal strLen) Dim strUnsafe, arrUnsafe Dim i If Trim(str) = "" Then CheckInfuse = "" Exit Function End If str = Left(str, strLen) On Error Resume Next strUnsafe = "'|^|;|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare" If Trim(str) <> "" Then If Len(str) > strLen Then Response.Write "" 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 "" CheckInfuse = "" Response.End End If Next End If CheckInfuse = Trim(str) Exit Function If Err.Number <> 0 Then Err.Clear Response.Write "" 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 "" 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 "" Response.End End If Next Next End If End Sub '================================================ '函数名：ChkQueryStr '作 用：过虑查询的非法字符 '参 数：str ----原字符串 '返回值：过滤后的字符 '================================================ Public Function ChkQueryStr(ByVal str) On Error Resume Next If IsNull(str) Then ChkQueryStr = "" Exit Function End If str = Replace(str, "!", "") str = Replace(str, "]", "") str = Replace(str, "[", "") str = Replace(str, ")", "") str = Replace(str, "(", "") str = Replace(str, "|", "") str = Replace(str, "+", "") str = Replace(str, "=", "") str = Replace(str, "'", "''") str = Replace(str, "%", "") str = Replace(str, "&", "") str = Replace(str, "#", "") str = Replace(str, "^", "") str = Replace(str, " ", " ") str = Replace(str, Chr(37), "") str = Replace(str, Chr(0), "") ChkQueryStr = str End Function '================================================ '过程名：CheckQuery '作 用：限制搜索的关键字 '参 数：str ----搜索的字符串 '返回值：True; False '================================================ Public Function CheckQuery(ByVal str) Dim FobWords, i, keyword keyword = str On Error Resume Next FobWords = Array(91, 92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12532, 12533, 65339, 65340) For i = 1 To UBound(FobWords, 1) If InStr(keyword, ChrW(FobWords(i))) > 0 Then CheckQuery = False Exit Function End If Next FobWords = Array("~", "!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "_", "+", "=", "`", "[", "]", "{", "}", ";", ":", """", "'", "<", ">", ".", "/", "\", "|", "?", "about", "after", "all", "also", "an", "and", "another", "any", "are", "as", "at", "be", "because", "been", "before", "being", "between", "both", "but", "by", "came", "can", "come", "could", "did", "do", "each", "for", "from", "get", "got", "had", "has", "have", "he", "her", "here", "him", "himself", "his", "how", "if", "in", "into", "is", "it", "like", "make", "many", "me", "might", "more", "most", "much", "must", "my", "never", "now", "of", "on", "only", "or", "other", "our", "out", "over", "said", "same", "see", "should", "since", "some", "still", "such", "take", "than", "that", "the", "their", "them", "then", "there", "these", "they", "this") keyword = Left(keyword, 100) keyword = Replace(keyword, "!", " ") keyword = Replace(keyword, "]", " ") keyword = Replace(keyword, "[", " ") keyword = Replace(keyword, ")", " ") keyword = Replace(keyword, "(", " ") keyword = Replace(keyword, " ", " ") keyword = Replace(keyword, "-", " ") keyword = Replace(keyword, "/", " ") keyword = Replace(keyword, "+", " ") keyword = Replace(keyword, "=", " ") keyword = Replace(keyword, ",", " ") keyword = Replace(keyword, "'", " ") For i = 0 To UBound(FobWords, 1) If keyword = FobWords(i) Then CheckQuery = False Exit Function End If Next CheckQuery = True End Function '================================================ '函数名：IsValidStr '作 用：判断字符串中是否含有非法字符 '参 数：str ----原字符串 '返回值：False,True -----布尔值 '================================================ Public Function IsValidStr(ByVal str) IsValidStr = False On Error Resume Next If IsNull(str) Then Exit Function If Trim(str) = Empty Then Exit Function Dim ForbidStr, i ForbidStr = "and|chr|:|=|%|&|$|#|@|+|-|*|/|\|<|>|;|,|^|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9) ForbidStr = Split(ForbidStr, "|") For i = 0 To UBound(ForbidStr) If InStr(1,str, ForbidStr(i),1) > 0 Then IsValidStr = False Exit Function End If Next IsValidStr = True End Function '================================================ '函数名：IsValidPassword '作 用：判断密码中是否含有非法字符 '参 数：str ----原字符串 '返回值：False,True -----布尔值 '================================================ Public Function IsValidPassword(ByVal str) IsValidPassword = False On Error Resume Next If IsNull(str) Then Exit Function If Trim(str) = Empty Then Exit Function Dim ForbidStr, i ForbidStr = "=and|chr|*|^|%|&|;|,|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9) ForbidStr = Split(ForbidStr, "|") For i = 0 To UBound(ForbidStr) If InStr(1, str, ForbidStr(i), 1) > 0 Then IsValidPassword = False Exit Function End If Next IsValidPassword = True End Function '================================================ '函数名：IsValidChar '作 用：判断字符串中是否含有非法字符和中文 '参 数：str ----原字符串 '返回值：False,True -----布尔值 '================================================ Public Function IsValidChar(ByVal str) IsValidChar = False On Error Resume Next If IsNull(str) Then Exit Function If Trim(str) = Empty Then Exit Function Dim ValidStr Dim i, l, s, c ValidStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ.-_:~\/0123456789" l = Len(str) s = UCase(str) For i = 1 To l c = Mid(s, i, 1) If InStr(ValidStr, c) = 0 Then IsValidChar = False Exit Function End If Next IsValidChar = True End Function '================================================ '函数名：FormatDate '作 用：格式化日期 '参 数：DateAndTime ----原日期和时间 ' para ----日期格式 '返回值：格式化后的日期 '================================================ Public Function FormatDate(DateAndTime, para) On Error Resume Next Dim y, m, d, h, mi, s, strDateTime FormatDate = DateAndTime If Not IsNumeric(para) Then Exit Function If Not IsDate(DateAndTime) Then Exit Function y = CStr(Year(DateAndTime)) m = CStr(Month(DateAndTime)) If Len(m) = 1 Then m = "0" & m d = CStr(Day(DateAndTime)) If Len(d) = 1 Then d = "0" & d h = CStr(Hour(DateAndTime)) If Len(h) = 1 Then h = "0" & h mi = CStr(Minute(DateAndTime)) If Len(mi) = 1 Then mi = "0" & mi s = CStr(Second(DateAndTime)) If Len(s) = 1 Then s = "0" & s Select Case para Case "1" strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s Case "2" strDateTime = y & "-" & m & "-" & d Case "3" strDateTime = y & "/" & m & "/" & d Case "4" strDateTime = y & "年" & m & "月" & d & "日" Case "5" strDateTime = m & "-" & d Case "6" strDateTime = m & "/" & d Case "7" strDateTime = m & "月" & d & "日" Case "8" strDateTime = y & "年" & m & "月" Case "9" strDateTime = y & "-" & m Case "10" strDateTime = y & "/" & m Case Else strDateTime = DateAndTime End Select FormatDate = strDateTime End Function '================================================ '函数名：ReadFontMode '作 用：读取字体模式 '参 数：str ----原字符串 ' vColor -----颜色的值 ' vFont -----字体的值 '返回值：新字符串 '================================================ Public Function ReadFontMode(str, vColor, vFont) Dim FontStr, tColor Dim ColorStr, arrColor If IsNull(str) Then ReadFontMode = "" Exit Function End If ReadFontMode = str On Error Resume Next If Not IsNumeric(vColor) Then Exit Function If Not IsNumeric(vFont) Then Exit Function Select Case CInt(vFont) Case 1 FontStr = "" & str & "" Case 2 FontStr = "" & str & "" Case 3 FontStr = "" & str & "" Case 4 FontStr = "" & str & "" Case 5 FontStr = "" & str & "" Case 6 FontStr = "" & str & "" Case 7 FontStr = "" & str & "" Case Else FontStr = str End Select ReadFontMode = FontStr If vColor = "" Or vColor = 0 Then Exit Function ColorStr = "," & InitTitleColor arrColor = Split(ColorStr, ",") If vColor > UBound(arrColor) Then Exit Function tColor = Trim(arrColor(vColor)) ReadFontMode = "" & FontStr & "" End Function '============================================================= '函数名：ShowDateTime '作 用：读取日期格式 '参 数：DateAndTime ---- 当前时间 ' para ---- 时间格式 '============================================================= Public Function ShowDateTime(DateAndTime, para) ShowDateTime = "" Dim strDate If Not IsDate(DateAndTime) Then Exit Function If DateAndTime >= Date Then strDate = "" strDate = strDate & FormatDate(DateAndTime, para) strDate = strDate & "" Else strDate = "" strDate = strDate & FormatDate(DateAndTime, para) strDate = strDate & "" End If ShowDateTime = strDate End Function Public Function ShowDatePath(strval, n) ShowDatePath = "" If Trim(strval) = "" Then Exit Function Dim strTempPath, strTime Dim y, m, d strTime = Left(strval, 8) y = Left(strTime, 4) m = Mid(strTime, 5, 2) d = Right(strTime, 2) Select Case CInt(n) Case 1 strTempPath = y & "/" & m & "/" & d & "/" Case 2 strTempPath = y & "/" & m & "/" Case 3 strTempPath = y & m & "/" Case 4 strTempPath = y & "/" Case 5 strTempPath = y & "-" & m & "-" & d & "/" Case 6 strTempPath = y & "-" & m & "/" Case 7 strTempPath = "html/" Case 8 strTempPath = "show/" Case Else strTempPath = "" End Select strTempPath = Replace(strTempPath, " ", "") ShowDatePath = CStr(strTempPath) End Function '============================================================= '函数名：ReadBriefTopicffd '作 用：读取简短标题 '参 数：para '返回值：简短标题 '============================================================= Public Function ReadBriefTopic(ByVal para) Dim sBriefTopic ReadBriefTopic = "" If Not IsNumeric(para) Then Exit Function If para = 0 Then Exit Function Select Case para Case "1" sBriefTopic = "[图文]" Case "2" sBriefTopic = "[组图]" Case "3" sBriefTopic = "[新闻]" Case "4" sBriefTopic = "[推荐]" Case "5" sBriefTopic = "[注意]" Case "6" sBriefTopic = "[转载]" Case Else sBriefTopic = "" End Select ReadBriefTopic = sBriefTopic End Function '============================================================= '函数名：ReadPicTopic '作 用：读取简短标题 '参 数：para '返回值：简短标题 '============================================================= Public Function ReadPicTopic(ByVal para) Dim sBriefTopic ReadPicTopic = "" If Not IsNumeric(para) Then Exit Function If para = 0 Then Exit Function Select Case para Case "1" sBriefTopic = "[图文]" Case "2" sBriefTopic = "[组图]" Case "3" sBriefTopic = "[新闻]" Case "4" sBriefTopic = "[推荐]" Case "5" sBriefTopic = "[注意]" Case "6" sBriefTopic = "[转载]" Case Else sBriefTopic = "" End Select ReadPicTopic = sBriefTopic End Function '============================================================= '函数名：ReadPayMoney '作 用：读取要支付的金钱 '参 数：money ----实际金钱 '返回值：加上手续费后的金钱 '============================================================= Public Function ReadPayMoney(ByVal money, ByVal Reduce) On Error Resume Next If money = 0 Then ReadPayMoney = 0 Exit Function End If Dim arrChinaeBank, valPercent, Percents arrChinaeBank = Split(ChinaeBank, "|||") Percents = CCur(arrChinaeBank(2) / 100) If Percents = 0 Then ReadPayMoney = CCur(money) Else If CBool(Reduce) = True Then valPercent = Round(CCur(money) / (1 + 1 * Percents), 2) ReadPayMoney = CCur(valPercent) Else valPercent = Round(CCur(money) * Percents, 2) ReadPayMoney = CCur(money + valPercent) End If End If End Function '============================================================= '函数名：RebateMoney '作 用：读取打折的后金钱 '参 数：money ----实际金钱 ' Discount ----折扣 '============================================================= Public Function RebateMoney(ByVal money, ByVal Discount) On Error Resume Next Dim Rebate money = CheckNumeric(money) Discount = CheckNumeric(Discount) If Discount > 0 And Discount < 10 Then Rebate = Round(money * (Discount / 10), 2) RebateMoney = CCur(Rebate) Else RebateMoney = CCur(money) End If End Function '================================================ '函数名：Supplemental '作 用：补足参数 '参 数：para ----原参数 ' n ----增补的位数 '================================================ Public Function Supplemental(para, n) Supplemental = "" If Not IsNumeric(para) Then Exit Function If Len(para) < n Then Supplemental = String(n - Len(para), "0") & para Else Supplemental = para End If End Function '----------------------------------------------------------------- Public Function GetChannelDir(ByVal chanid) On Error Resume Next If Not IsNumeric(chanid) Then chanid = 1 Name = "Channel" & chanid If ObjIsEmpty() Then ReloadChannel (chanid) CacheChannel = Value GetChannelDir = InstallDir & CacheChannel(2,0) End Function '================================================ '函数名：GetImageUrl '作 用：获取图片URL '================================================ Public Function GetImageUrl(ByVal url, ByVal ChannelDir) On Error Resume Next Dim strTempUrl, strImageUrl If Not IsNull(url) And Trim(url) <> "" And LCase(url) <> "http://" Then strTempUrl = InstallDir & ChannelDir If CheckUrl(url) = 1 Then strImageUrl = Trim(url) ElseIf CheckUrl(url) = 2 Then strImageUrl = url Else strImageUrl = Replace(url, "../", "") strImageUrl = Trim(strTempUrl & strImageUrl) End If Else strImageUrl = InstallDir & "images/no_pic.gif" End If GetImageUrl = strImageUrl End Function '----------------------------------------------------------------- '================================================ '作 用：读取图片或者FLASH '参 数：url ----文件URL ' height ----高度 ' width ----宽度 '================================================ Function GetFlashAndPic(ByVal url, ByVal height, ByVal width) On Error Resume Next Dim sExtName, ExtName, strTemp Dim strHeight, strWidth If Not IsNumeric(height) Or height < 1 Then strHeight = "" Else strHeight = " height=" & height End If If Not IsNumeric(width) Or width < 1 Then strWidth = "" Else strWidth = " width=" & width End If sExtName = Split(url, ".") ExtName = sExtName(UBound(sExtName)) If LCase(ExtName) = "swf" Then strTemp = "
