www.gusucode.com > 艺术签名文章资讯网源代码 > 艺术签名文章资讯网源代码/624/inc/cls_main.asp
<!--#include file="cls_custom.asp"--> <% 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,ThunderPid,HostPath Public ChinaeBank, VersionID, Badwords, Badwordr, serialcode, passedcode,siteAdsCode,ArraySiteAdsCode Public ChannelName, ChannelDir, StopChannel, ChannelType,BokeccUnion,UnionSetting Public modules, ChannelSkin,MainSetting,HtmlSetting 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,ChannelUseHtml,ChannelHtmlExt Public SortDestination,InfoDestination,MoreDestination,m_intChannelID Public m_SortDestination,m_InfoDestination,m_MoreDestination,m_ChannelDir,ChannelDomain Public HtmlFilesPath,HtmlFilesName,setEditor,setEditorArray,setAdminEditor,setUserEditor,NamedPath,IsBindDomain Public Wss_IsUsed,Wss_SiteID,Wss_PassWord,Wss_Domain,Wss_Key Public ThisEdition, CopyrightStr, Version, Values, startime Public SqlQueryNum, GetUserip, CacheName, Reloadtime,Actforip Public ScriptName, Admin_Page, skinid, SkinPath, HtmlContent, sHtmlContent Private Main_Style, MainStyle, Html_Setting Private LocalCacheName, Cache_Data Private CacheChannel, CacheData,ThisChannelID 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 IsBindDomain = 0 GetUserip = CheckStr(getIP) 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 If CHECK_ID > 922337203685477 Then CHECK_ID = 0 If CHECK_ID < -922337203685477 Then CHECK_ID = 0 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 If CHECK_ID < 0 Then CHECK_ID = 0 If CHECK_ID > 2147483647 Then CHECK_ID = 0 CHECK_ID = CLng(CHECK_ID) 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 Private Function getIP() Dim strIPAddr If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" Or InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then strIPAddr = Request.ServerVariables("REMOTE_ADDR") ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1) Actforip = Request.ServerVariables("REMOTE_ADDR") ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1) Actforip = Request.ServerVariables("REMOTE_ADDR") Else strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR") Actforip = Request.ServerVariables("REMOTE_ADDR") End If getIP = Replace(Trim(Mid(strIPAddr, 1, 30)), "'", "") 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", "") str = Replace(str, "@", "") str = Replace(str, "$", "") If Len(str) > 0 And strLen > 0 Then str = Left(str, strLen) End If CheckRequest = str End Function Public Function CheckBadstr(str) If IsNull(str) Then CheckBadstr = vbNullString Exit Function End If str = Replace(str, Chr(0), vbNullString) str = Replace(str, Chr(34), vbNullString) str = Replace(str, "%", vbNullString) str = Replace(str, "@", vbNullString) str = Replace(str, "!", vbNullString) str = Replace(str, "^", vbNullString) str = Replace(str, "=", vbNullString) str = Replace(str, "--", vbNullString) str = Replace(str, "$", vbNullString) str = Replace(str, "'", vbNullString) str = Replace(str, ";", vbNullString) str = Replace(str, "<", vbNullString) str = Replace(str, ">", vbNullString) CheckBadstr = Trim(str) End Function '-- 移除有害字符 Public Function RemoveBadCharacters(ByVal strTemp) Dim re On Error Resume Next Set re = New RegExp re.Pattern = "[^\s\w]" re.Global = True RemoveBadCharacters = re.Replace(strTemp, "") Set re = Nothing End Function '-- 去掉HTML标记 Public Function RemoveHtml(ByVal Textstr) Dim Str,re Str = Textstr On Error Resume Next Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "<(.[^>]*)>" Str = re.Replace(Str, "") Set re = Nothing RemoveHtml=Str End Function '-- 数据库连接 Public Function Execute(Command) If Not IsObject(Conn) Then ConnectionDatabase If IsDeBug = 0 Then On Error Resume Next Set Execute = Conn.Execute(Command) If Err Then err.Clear Set Conn = Nothing Response.Write "查询数据的时候发现错误,请检查您的查询代码是否正确。<br /><li>" 'Response.Write Command Response.End End If Else Set Execute = Conn.Execute(Command) End If SqlQueryNum = SqlQueryNum+1 End Function Public Sub ReadConfig() 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 If Len(CacheData(1, 0)) = 0 Then Name = "Config" Call ReloadConfig CacheData = Value 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): siteAdsCode = CacheData(40, 0): ThunderPid = Trim(CacheData(41, 0) & ""): HostPath = Trim(CacheData(42, 0) & ""): UnionSetting = Trim(CacheData(43, 0) & "$$$") If Len(ThunderPid) = 0 Then ThunderPid = "0|0|0" UnionSetting = Split(UnionSetting & "$$$", "$$$") If UnionSetting(0) ="" Then UnionSetting(0) = "0|0|plugin.swf|72|24|0|" BokeccUnion = Split(UnionSetting(0) & "0|0|0|0|0", "|") ArraySiteAdsCode = Split(siteAdsCode & "||||||||||||||||||", "|||") ThisEdition = "免费版 (Free Edition)" Version = "<a href=""http://www.newasp.net"" target=""_blank"" class=""navmenu"">新云网站内容管理系统 3.1.0</a>" CopyrightStr = "<!--" & vbCrLf CopyrightStr = CopyrightStr & "┌─────────────────NEWASP──┐" & vbCrLf CopyrightStr = CopyrightStr & "│新云网站内容管理系统 Version 3.1 │" & vbCrLf CopyrightStr = CopyrightStr & "│版权所有: 新云网络 (newasp.net) │" & vbCrLf CopyrightStr = CopyrightStr & "│官方主页: http://www.newasp.net │" & vbCrLf CopyrightStr = CopyrightStr & "│论坛地址: http://bbs.newasp.net │" & vbCrLf CopyrightStr = CopyrightStr & "│E-Mail: newasp@163.com QQ: 94022511 │" & vbCrLf CopyrightStr = CopyrightStr & "└────────────────────.NET┘" & vbCrLf CopyrightStr = CopyrightStr & "-->" If CInt(IstopSite) = 1 And Not Admin_Page Then Response.Redirect (SiteUrl & InstallDir & "showerr.asp?action=stop") LoadWssConfig() End Sub Public Sub ReloadConfig() Dim SQL, Rs 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 SQL = "SELECT ChannelID,ChannelName,ChannelDir,StopChannel,ChannelType,modules,ModuleName,BindDomain,DomainName,ChannelSkin,IsCreateHtml,HtmlExtName,StopUpload,MaxFileSize,UpFileType,IsAuditing,AppearGrade,PostGrade,LeastString,MaxString,PaginalNum,LeastHotHist,Channel_Setting,SortDestination,InfoDestination,MoreDestination,setEditor,NamedPath from NC_Channel where ChannelType <= 1 And ChannelID = " & CLng(ChannelID) Set Rs = Execute(SQL) If Rs.BOF And Rs.EOF Then Response.Write "错误的频道参数!" Response.End End If Value = Rs.GetRows(1) Set Rs = Nothing End Sub '============================================================= '过程名:ReadChannel '作 用:读取频道设置 '参 数:ChannelID ----频道ID '============================================================= Public Sub ReadChannel(ChannelID) 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 m_intChannelID = CacheChannel(0, 0): 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) IsCreateHtml = CacheChannel(10, 0): HtmlExtName = CacheChannel(11, 0): StopUpload = CacheChannel(12, 0): MaxFileSize = CacheChannel(13, 0): UpFileType = CacheChannel(14, 0): IsAuditing = CacheChannel(15, 0): AppearGrade = CacheChannel(16, 0) PostGrade = CacheChannel(17, 0): LeastString = CacheChannel(18, 0): MaxString = CacheChannel(19, 0): PaginalNum = CacheChannel(20, 0): LeastHotHist = CacheChannel(21, 0): Channel_Setting = CacheChannel(22, 0) & "|||||||||||||||" SortDestination = CacheChannel(23, 0):InfoDestination = CacheChannel(24, 0):MoreDestination = CacheChannel(25, 0): setEditor = CacheChannel(26, 0) & "":NamedPath = CacheChannel(27, 0) & "" If CInt(StopChannel) = 1 And Not Admin_Page Then Response.Redirect (SiteUrl & InstallDir & "showerr.asp?action=ChanStop") If setEditor = "" Then setEditor = "0|AdminMode|590|350|editor/|||0|Simple|560|350|0|0|0|0|0|1|0|0|0|0|0|550|5000|1|1|1|1|1|0|0|0|0|0|0|0|0|0" setEditorArray = Split(setEditor, "|||") setAdminEditor = Split(setEditorArray(0), "|") setUserEditor = Split(setEditorArray(1), "|") If BindDomain <> "0" Then IsBindDomain = 1 End Sub Public Sub LoadChannel(ByVal chanid) Dim Rs,SQL,tmpdata chanid = CLng(chanid) Name = "MyChannel" & chanid If ObjIsEmpty() Then SQL = "SELECT ChannelID,ChannelDir,ModuleName,IsCreateHtml,HtmlExtName,StopUpload,SortDestination,InfoDestination,MoreDestination,BindDomain,DomainName FROM NC_Channel WHERE ChannelType<=1 And ChannelID= " & Clng(chanid) Set Rs = Execute(SQL) If Rs.BOF And Rs.EOF Then Set Rs = Nothing Exit Sub End If tmpdata = Rs.GetString(, , "$$$", "@@@", "") tmpdata = Left(tmpdata, Len(tmpdata) - 3) Set Rs = Nothing Value = tmpdata End If ChannelData = Split(Value, "$$$") m_ChannelDir = ChannelData(1) ChannelModule = ChannelData(2) ChannelUseHtml = ChannelData(3) ChannelHtmlExt = ChannelData(4) m_SortDestination = ChannelData(6) m_InfoDestination = ChannelData(7) m_MoreDestination = ChannelData(8) If IsBindDomain = 0 Then If ChannelData(9) = "0" Then ChannelPath = InstallDir & ChannelData(1) ChannelDomain = "" Else If ChannelUseHtml <> "1" Then ChannelPath = Trim(ChannelData(10)) &"/" Else ChannelPath = Trim(ChannelData(10)) & "" End If ChannelDomain = Trim(ChannelData(10)) & "" End If Else If ChannelData(9) = "0" Then ChannelPath = Trim(SiteUrl) & "/" & ChannelData(1) ChannelDomain = Trim(SiteUrl) Else If CInt(ChannelData(0)) = CInt(m_intChannelID) Then ChannelPath = "/" ChannelDomain = "" Else If ChannelUseHtml <> "1" Then ChannelPath = Trim(ChannelData(10)) &"/" Else ChannelPath = Trim(ChannelData(10)) & "" End If ChannelDomain = Trim(ChannelData(10)) & "" End If End If End If End Sub '============================================================= '过程名:LoadTemplates '作 用:载入模板 '参 数:Page_Mark ----StyleID '============================================================= Public Sub LoadTemplates(ChannelID, pageid, StyleID) Dim rstmp, TempSkinID ChannelID = CLng(ChannelID) ThisChannelID = 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) MainSetting = Split(Main_Style(2, 0), "|||") MainStyle = Main_Style(1, 0) 'MainStyle = Replace(MainStyle, "{$InstallDir}", ReadInstallDir(BindDomain)) MainStyle = Replace(MainStyle, "{$SkinPath}", SkinPath) MainStyle = Replace(MainStyle, "|||","") 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) 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) If Not rstmp.EOF Then Value = rstmp.GetRows(1) Else Value = "找不到模板,请检查你的模板是否存在" End If Set rstmp = Nothing End If Set Rs = Nothing End Sub Private Sub TemplatesMainCache(skinid) 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") If Not rstmp.EOF Then Value = rstmp.GetRows(1) Else Value = "找不到模板,请检查你的模板是否存在" End If 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) HtmlSetting = Split(Html_Setting, "|||") HtmlContent = tmpstr(1, 0) HtmlContent = TemplateCustom(HtmlContent) HtmlContent = Replace(HtmlContent, "{$Style_CSS}", MainStyle) HtmlContent = Replace(HtmlContent, "{$SkinPath}", SkinPath) HtmlContent = Replace(HtmlContent, "{$Width}", MainSetting(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}", Version) HtmlContent = Replace(HtmlContent, "{$PublishedDate}", Now()) HtmlContent = Replace(HtmlContent, "{$siteAdsCode1}", ArraySiteAdsCode(0)) HtmlContent = Replace(HtmlContent, "{$siteAdsCode2}", ArraySiteAdsCode(1)) HtmlContent = Replace(HtmlContent, "{$siteAdsCode3}", ArraySiteAdsCode(2)) HtmlContent = Replace(HtmlContent, "{$siteAdsCode4}", ArraySiteAdsCode(3)) HtmlContent = Replace(HtmlContent, "{$siteAdsCode5}", ArraySiteAdsCode(4)) HtmlContent = Replace(HtmlContent, "{$siteAdsCode6}", ArraySiteAdsCode(5)) HtmlContent = HtmlContent End Property Public Property Get ByValue() ByValue = HtmlContent End Property Public Property Let HTMLValue(ByVal vNewValue) Dim TempStr TempStr = TemplateCustom(vNewValue) TempStr = Replace(TempStr, "{$Style_CSS}", MainStyle) TempStr = Replace(TempStr, "{$SkinPath}", SkinPath) TempStr = Replace(TempStr, "{$Width}", MainSetting(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}", Version) TempStr = Replace(TempStr, "{$PublishedDate}", Now()) TempStr = Replace(TempStr, "{$siteAdsCode1}", ArraySiteAdsCode(0)) TempStr = Replace(TempStr, "{$siteAdsCode2}", ArraySiteAdsCode(1)) TempStr = Replace(TempStr, "{$siteAdsCode3}", ArraySiteAdsCode(2)) TempStr = Replace(TempStr, "{$siteAdsCode4}", ArraySiteAdsCode(3)) TempStr = Replace(TempStr, "{$siteAdsCode5}", ArraySiteAdsCode(4)) TempStr = Replace(TempStr, "{$siteAdsCode6}", ArraySiteAdsCode(5)) sHtmlContent = TempStr End Property Public Property Get HTMLValue() HTMLValue = sHtmlContent End Property Public Function TemplateCustom(ByVal strHTML) Dim Custom,strContent strContent = strHTML Set Custom = New LabelCustom_Cls Custom.Template = strContent Custom.Channel = ThisChannelID Custom.Execute strContent = Custom.Template Set Custom = Nothing TemplateCustom = strContent End Function Public Function RecordsetToxml(Recordset,row,xmlroot) Dim i,node,rs,j,DataArray If xmlroot="" Then xmlroot="xml" If row="" Then row="row" Set RecordsetToxml=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) RecordsetToxml.appendChild(RecordsetToxml.createElement(xmlroot)) If Not Recordset.EOF Then DataArray=Recordset.GetRows(-1) For i=0 To UBound(DataArray,2) Set Node=RecordsetToxml.createNode(1,row,"") j=0 For Each rs in Recordset.Fields node.attributes.setNamedItem(RecordsetToxml.createNode(2,LCase(rs.name),"")).text= DataArray(j,i)& "" j=j+1 Next RecordsetToxml.documentElement.appendChild(Node) Next End If DataArray=Null End Function Public Function ArrayToxml(DataArray,Recordset,row,xmlroot) Dim i,node,rs,j If xmlroot="" Then xmlroot="xml" Set ArrayToxml=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) ArrayToxml.appendChild(ArrayToxml.createElement(xmlroot)) If row="" Then row="row" For i=0 To UBound(DataArray,2) Set Node=ArrayToxml.createNode(1,row,"") j=0 For Each rs in Recordset.Fields node.attributes.setNamedItem(ArrayToxml.createNode(2,LCase(rs.name),"")).text= DataArray(j,i)& "" j=j+1 Next ArrayToxml.documentElement.appendChild(Node) Next End Function Public Function SaveXMLDocument(ByVal strXMLFile,ByVal strXMLDom) On Error Resume Next Dim oXMLDom SaveXMLDocument = False If strXMLFile = "" Then Exit Function If InStr(strXMLFile, ":") = 0 Then strXMLFile = Server.MapPath(strXMLFile) Set oXMLDom = Server.CreateObject("Msxml2.FreeThreadedDOMDocument"& MsxmlVersion) If oXMLDom.LoadXml(strXMLDom) Then oXMLDom.save strXMLFile SaveXMLDocument = True End If Set oXMLDom = Nothing If Err.Number <> 0 Then Err.Clear SaveXMLDocument = False End If End Function Public Function ReadXMLDocument(ByVal strXMLFile,ByVal strNode) On Error Resume Next Dim oXMLDom,xmlNodes If strXMLFile = "" Then Exit Function If InStr(strXMLFile, ":") = 0 Then strXMLFile = Server.MapPath(strXMLFile) Set oXMLDom = Server.CreateObject("Msxml2.FreeThreadedDOMDocument"& MsxmlVersion) 'oXMLDom.appendChild(XMLDom.createElement("xml")) If oXMLDom.Load(strXMLFile) Then If strNode = "" Or strNode = "0" Then ReadXMLDocument = oXMLDom.xml Else ReadXMLDocument = oXMLDom.documentElement.selectSingleNode(strNode).text End If Else ReadXMLDocument = "" End If Set oXMLDom = Nothing If Err.Number <> 0 Then Err.Clear End Function Public Function XMLEncode(ByVal str) Dim i str = Replace(str,"&","&") For i = 0 to 31 str = Replace(str,Chr(i),"&#"&i&";") Next For i = 95 to 96 str = Replace(str,Chr(i),"&#"&i&";") Next XMLEncode = str End Function Public Function XMLDecode(ByVal str) Dim i str = Replace(str,"&","&") For i = 0 to 31 str = Replace(str,"&#"&i&";",Chr(i)) Next For i = 95 to 96 str = Replace(str,"&#"&i&";",Chr(i)) Next XMLDecode = str End Function Public Function CreateFileName(ByVal strExt, ByVal Prefix, ByVal str) Randomize str = CStr(str) Dim m_strRandArray,m_intRandlen,m_strRandomize,i,strName m_strRandArray = Array(0,1,2,3,4,5,6,7,8,9,"A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W","X","Y","Z") m_intRandlen = 10 '定义随机码的长度 for i = 1 to m_intRandlen m_strRandomize = m_strRandomize & m_strRandArray(Int((21*Rnd))) next If str <> "" And str <> "0" Then If Len(str) < 6 Then strName = String(6-Len(str), "0") & str Else strName = str End If Else strName = "" End If CreateFileName = Trim(Prefix & m_strRandomize & strName & strExt) End Function '================================================ '过程名: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 On Error Resume Next 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 Public Function CheckBadword(ByVal str) CheckBadword = True If IsNull(str) Then Exit Function On Error Resume Next Dim i,ArrayBadword If Len(Badwords) > 1 Then ArrayBadword = Split(Badwords, "|") For i = 0 To UBound(ArrayBadword) If Trim(ArrayBadword(i)) <> "" Then If InStr(str, ArrayBadword(i)) > 0 Then CheckBadword = False Exit Function End If End If Next End If End Function '============================================================= '函数作用:发表信息需要审核 '============================================================= Public Function NeedIsAudit(ByVal strContent,ByVal strTitle) NeedIsAudit = 0 On Error Resume Next Dim ArraySetting,ArrayBadWord Dim i,ChecKData strContent = LCase(strContent) strTitle = LCase(strTitle) ArraySetting = Split(Channel_Setting & "@@@||||||@@@||||||", "@@@") ArrayBadWord = Split(LCase(ArraySetting(1)), "|||") If Len(ArrayBadWord(0)) > 1 Then ChecKData = Split(ArrayBadWord(0),"|") For i = 0 To UBound(ChecKData) If Trim(ChecKData(i)) <> "" Then If InStr(strContent, ChecKData(i)) > 0 Or InStr(strTitle, ChecKData(i)) > 0 Then NeedIsAudit = 1 Exit Function End If End If Next End If If Len(ArrayBadWord(1)) > 1 Then ChecKData = Split(ArrayBadWord(1),"|") For i = 0 To UBound(ChecKData) If Trim(ChecKData(i)) <> "" Then If InStr(strContent, ChecKData(i)) > 0 Or InStr(strTitle, ChecKData(i)) > 0 Then NeedIsAudit = 2 Exit Function End If End If Next End If End Function '============================================================= '函数作用:过滤HTML代码,带脏话过滤 '============================================================= Public Function HTMLEncode(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, " ", " ") fString = Replace(fString, Chr(10), "<br />") fString = ChkBadWords(fString) HTMLEncode = fString End If End Function '============================================================= '函数作用:过滤HTML代码,不带脏话过滤 '============================================================= Public Function HTMLEncodes(ByVal fString) If Not IsNull(fString) Then fString = Replace(fString, "&", "&") 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, " ", " ") fString = Replace(fString, Chr(10), "<br />") 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 Public Sub ChkPostAgent() On Error Resume Next Dim server_v1, server_v2 Dim m_blnAgent,m_strAgent m_blnAgent = 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 m_blnAgent = True End If If m_blnAgent Then m_strAgent = Request.ServerVariables("HTTP_USER_AGENT") If Left(m_strAgent, 7) = "Mozilla" Or Left(m_strAgent, 5) = "Opera" Then m_blnAgent = True End If End If If m_blnAgent = False Then 'Response.Status = "302 Object Moved" Set Newasp = Nothing Response.End End If End Sub Public Sub Checkspider() On Error Resume Next Dim botlist, i, m_strAgent botlist = "Google,Isaac,Webdup,SurveyBot,Baiduspider,ia_archiver,P.Arthur,FAST-WebCrawler,Java,Microsoft-ATL-Native,TurnitinBot,WebGather,Sleipnir" botlist = Split(botlist, ",") m_strAgent = Request.ServerVariables("HTTP_USER_AGENT") If Left(m_strAgent, 7) = "Mozilla" Or Left(m_strAgent, 5) = "Opera" Then Exit Sub End If For i = 0 To UBound(botlist) If InStr(m_strAgent, botlist(i)) > 0 Then 'Response.Status = "302 Object Moved" Set Newasp = Nothing Response.End End If Next End Sub '============================================================= '函数作用:判断来源URL是否来自外部 '============================================================= Public Function CheckOuterUrl() On Error Resume Next Dim server_v1, server_v2 server_v1 = Replace(LCase(Trim(Request.ServerVariables("HTTP_REFERER"))), "http://", "") server_v2 = LCase(Trim(Request.ServerVariables("SERVER_NAME"))) If server_v1 <> "" And Left(server_v1, Len(server_v2)) <> server_v2 Then CheckOuterUrl = False Else CheckOuterUrl = True End If End Function '================================================ '函数名:GotTopic '作 用:显示字符串长度 '参 数:str ----原字符串 ' strlen ----显示字符长度 '================================================ Public Function GotTopic(ByVal str, ByVal strLen) Dim l, t, c, i Dim strTemp On Error Resume Next str = Trim(str) str = Replace(str, " ", " ") str = Replace(str, ">", ">") str = Replace(str, "<", "<") str = Replace(str, ">", ">") str = Replace(str, "<", "<") str = Replace(str, "'", "'") str = Replace(str, """, Chr(34)) str = Replace(str, vbNewLine, "") l = Len(str) t = 0 For i = 1 To l c = Abs(Asc(Mid(str, i, 1))) If c > 255 Then t = t + 2 Else t = t + 1 End If If t >= strLen Then strTemp = Left(str, i) & "..." Exit For Else strTemp = str & "" End If Next GotTopic = CheckTopic(strTemp) End Function Public Function CheckTopic(ByVal strContent) Dim re On Error Resume Next Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "(<s+cript(.+?)<\/s+cript>)" strContent = re.Replace(strContent, "") re.Pattern = "(<iframe(.+?)<\/iframe>)" strContent = re.Replace(strContent, "") re.Pattern = "(>)" strContent = re.Replace(strContent, ">") re.Pattern = "(<)" strContent = re.Replace(strContent, "<") Set re = Nothing strContent = Replace(strContent, ">", ">") strContent = Replace(strContent, "<", "<") strContent = Replace(strContent, "'", "'") strContent = Replace(strContent, Chr(34), """) strContent = Replace(strContent, "%", "%") strContent = Replace(strContent, vbNewLine, "") CheckTopic = Trim(strContent) End Function '================================================ '函数名:ReadTopic '作 用:显示字符串长度 '参 数:str ----原字符串 ' strlen ----显示字符长度 '================================================ Public Function ReadTopic(ByVal str, ByVal strLen) Dim l, t, c, i On Error Resume Next str = Replace(str, " ", " ") If Len(str) < strLen Then str = str & String(strLen - Len(str), ".") Else str = str End If l = Len(str) t = 0 For i = 1 To l c = Abs(Asc(Mid(str, i, 1))) If c > 255 Then t = t + 2 Else t = t + 1 End If If t >= strLen Then ReadTopic = Left(str, i) & "..." Exit For Else ReadTopic = str & "..." End If Next End Function '================================================ '函数名:strLength '作 用:计字符串长度 '参 数:str ----字符串 '================================================ Public Function strLength(ByVal str) On Error Resume Next If IsNull(str) Or str = "" Then strLength = 0 Exit Function End If Dim WINNT_CHINESE WINNT_CHINESE = (Len("例子") = 2) If WINNT_CHINESE Then Dim l, t Dim i, c l = Len(str) t = l For i = 1 To l c = Asc(Mid(str, i, 1)) If c < 0 Then c = c + 65536 If c > 255 Then t = t + 1 Next strLength = t Else strLength = Len(str) End If End Function '================================================= '函数名:isInteger '作 用:判断数字是否整型 '参 数:para ----参数 '================================================= Public Function isInteger(ByVal para) On Error Resume Next Dim str Dim l, i If IsNull(para) Then isInteger = False Exit Function End If str = CStr(para) If Trim(str) = "" Then isInteger = False Exit Function End If l = Len(str) For i = 1 To l If Mid(str, i, 1) > "9" Or Mid(str, i, 1) < "0" Then isInteger = False Exit Function End If Next isInteger = True If Err.Number <> 0 Then Err.Clear End Function Public Function CutString(ByVal str, ByVal strLen) On Error Resume Next Dim HtmlStr, l, re, strContent HtmlStr = str 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 = "([\f\n\r\t\v])":HtmlStr = re.Replace(HtmlStr, "") re.Pattern="(\[InstallDir_ChannelDir\])":HtmlStr=re.Replace(HtmlStr, "") re.Pattern="(\[img\])(.|\n)*?(\[\/img\])":HtmlStr=re.Replace(HtmlStr,"") re.Pattern="(\[url\]|\[\/url\])":HtmlStr=re.Replace(HtmlStr, "") re.Pattern="(\[b\]|\[\/b\])":HtmlStr=re.Replace(HtmlStr, "") re.Pattern="(\[i\]|\[\/i\])":HtmlStr=re.Replace(HtmlStr, "") re.Pattern="(\[u\]|\[\/u\])":HtmlStr=re.Replace(HtmlStr, "") re.Pattern = "<(.[^>]*)>":HtmlStr = re.Replace(HtmlStr, "") Set re = Nothing 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, "~~~~", "") HtmlStr = Replace(HtmlStr, "≡≡≡", "") HtmlStr = Replace(HtmlStr, "++++", "") HtmlStr = Replace(HtmlStr, "::::", "") HtmlStr = Replace(HtmlStr, " ", "") HtmlStr = Replace(HtmlStr, ">", ">") HtmlStr = Replace(HtmlStr, "<", "<") l = Len(HtmlStr) If l >= strLen Then strContent = Left(HtmlStr, strLen) & "..." Else strContent = HtmlStr & " " End If strContent = Replace(strContent, Chr(34), """) strContent = Replace(strContent, Chr(39), "'") strContent = Replace(strContent, Chr(36), "$") strContent = Replace(strContent, Chr(123), "{") strContent = Replace(strContent, Chr(125), "}") strContent = Replace(strContent, ">", ">") strContent = Replace(strContent, "<", "<") CutString = strContent End Function '================================================ '函数名:CheckInfuse '作 用:防止SQL注入 '参 数:str ----原字符串 ' strLen ----提交字符串长度 '================================================ Public Function CheckInfuse(ByVal str, ByVal strLen) Dim strUnsafe, arrUnsafe Dim i If Trim(str) = "" Then CheckInfuse = "" Exit Function End If str = Left(str, strLen) On Error Resume Next strUnsafe = "'|^|;|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare" If Trim(str) <> "" Then If Len(str) > strLen Then Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n您提交的字符数超过了限制!');history.back(-1)</Script>" CheckInfuse = "" Response.End End If arrUnsafe = Split(strUnsafe, "|") For i = 0 To UBound(arrUnsafe) If InStr(1, str, arrUnsafe(i), 1) > 0 Then Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符!');history.back(-1)</Script>" CheckInfuse = "" Response.End End If Next End If CheckInfuse = Trim(str) Exit Function If Err.Number <> 0 Then Err.Clear Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符!');history.back(-1)</Script>" CheckInfuse = "" Response.End End If End Function Public Sub PreventInfuse() On Error Resume Next Dim SQL_Nonlicet, arrNonlicet Dim PostRefer, GetRefer, Sql_DATA SQL_Nonlicet = "'|;|^|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare" arrNonlicet = Split(SQL_Nonlicet, "|") If Request.Form <> "" Then For Each PostRefer In Request.Form For Sql_DATA = 0 To UBound(arrNonlicet) If InStr(1, Request.Form(PostRefer), arrNonlicet(Sql_DATA), 1) > 0 Then Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符!');history.back(-1)</Script>" Response.End End If Next Next End If If Request.QueryString <> "" Then For Each GetRefer In Request.QueryString For Sql_DATA = 0 To UBound(arrNonlicet) If InStr(1, Request.QueryString(GetRefer), arrNonlicet(Sql_DATA), 1) > 0 Then Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符!');history.back(-1)</Script>" Response.End End If Next Next End If End Sub '================================================ '函数名:ChkQueryStr '作 用:过虑查询的非法字符 '参 数:str ----原字符串 '返回值:过滤后的字符 '================================================ Public Function ChkQueryStr(ByVal str) On Error Resume Next If IsNull(str) Then ChkQueryStr = "" Exit Function End If str = Replace(str, "!", "") str = Replace(str, "]", "") str = Replace(str, "[", "") str = Replace(str, ")", "") str = Replace(str, "(", "") str = Replace(str, "|", "") str = Replace(str, "+", "") str = Replace(str, "=", "") str = Replace(str, "'", "''") str = Replace(str, "%", "") str = Replace(str, "&", "") str = Replace(str, "@", "") str = Replace(str, "#", "") str = Replace(str, "^", "") str = Replace(str, "《", "") 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 = 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) Dim y, m, d, h, mi, s, strDateTime FormatDate = DateAndTime If Not IsNumeric(para) Then Exit Function If Not IsDate(DateAndTime) Then Exit Function y = CStr(Year(DateAndTime)) m = CStr(Month(DateAndTime)) If Len(m) = 1 Then m = "0" & m d = CStr(Day(DateAndTime)) If Len(d) = 1 Then d = "0" & d h = CStr(Hour(DateAndTime)) If Len(h) = 1 Then h = "0" & h mi = CStr(Minute(DateAndTime)) If Len(mi) = 1 Then mi = "0" & mi s = CStr(Second(DateAndTime)) If Len(s) = 1 Then s = "0" & s Select Case para Case "1":strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s Case "2":strDateTime = y & "-" & m & "-" & d Case "3":strDateTime = y & "/" & m & "/" & d Case "4":strDateTime = y & "年" & m & "月" & d & "日" Case "5":strDateTime = m & "-" & d Case "6":strDateTime = m & "/" & d Case "7":strDateTime = m & "月" & d & "日" Case "8":strDateTime = y & "年" & m & "月" Case "9":strDateTime = y & "-" & m Case "10":strDateTime = y & "/" & m Case Else strDateTime = DateAndTime End Select FormatDate = strDateTime End Function '================================================ '函数名:ReadFontMode '作 用:读取字体模式 '参 数:str ----原字符串 ' vColor -----颜色的值 ' vFont -----字体的值 '返回值:新字符串 '================================================ Public Function ReadFontMode(str, vColor, vFont) Dim FontStr, tColor Dim ColorStr, arrColor If IsNull(str) Then ReadFontMode = "" Exit Function End If ReadFontMode = str On Error Resume Next If Not IsNumeric(vColor) Then Exit Function If Not IsNumeric(vFont) Then Exit Function Select Case CInt(vFont) Case 1 FontStr = "<b>" & str & "</b>" Case 2 FontStr = "<em>" & str & "</em>" Case 3 FontStr = "<u>" & str & "</u>" Case 4 FontStr = "<b><em>" & str & "</em></b>" Case 5 FontStr = "<b><u>" & str & "</u></b>" Case 6 FontStr = "<em><u>" & str & "</u></em>" Case 7 FontStr = "<b><em><u>" & str & "</u></em></b>" Case Else FontStr = str End Select ReadFontMode = FontStr If vColor = "" Or vColor = 0 Then Exit Function ColorStr = "," & InitTitleColor arrColor = Split(ColorStr, ",") If vColor > UBound(arrColor) Then Exit Function tColor = Trim(arrColor(vColor)) ReadFontMode = "<font color=" & tColor & ">" & FontStr & "</font>" End Function '============================================================= '函数名:showDateTime '作 用:读取日期格式 '参 数:DateAndTime ---- 当前时间 ' para ---- 时间格式 '============================================================= Public Function showDateTime(DateAndTime, para) showDateTime = "" Dim strDate If Not IsDate(DateAndTime) Then Exit Function If Datediff("d",Now(),CDate(DateAndTime)) = 0 Then strDate = "<span class=""newDate globalDate"">" strDate = strDate & FormatDate(DateAndTime, para) strDate = strDate & "</span>" Else strDate = "<span class=""oldDate globalDate"">" strDate = strDate & FormatDate(DateAndTime, para) strDate = strDate & "</span>" End If showDateTime = strDate End Function Public Function ShowDatePath(strval, n) ShowDatePath = "" If Trim(strval) = "" Then Exit Function Dim strTempPath, strTime Dim y, m, d strTime = Left(strval, 8) y = Left(strTime, 4) m = Mid(strTime, 5, 2) d = Right(strTime, 2) Select Case CInt(n) Case 1 strTempPath = y & "/" & m & "/" & d & "/" Case 2 strTempPath = y & "/" & m & "/" Case 3 strTempPath = y & m & "/" Case 4 strTempPath = y & "/" Case 5 strTempPath = y & "-" & m & "-" & d & "/" Case 6 strTempPath = y & "-" & m & "/" Case 7 strTempPath = "html/" Case 8 strTempPath = "show/" Case Else strTempPath = "" End Select strTempPath = Replace(strTempPath, " ", "") ShowDatePath = CStr(strTempPath) End Function '============================================================= '函数名:ReadBriefTopicffd '作 用:读取简短标题 '参 数:para '返回值:简短标题 '============================================================= Public Function ReadBriefTopic(ByVal para) Dim sBriefTopic ReadBriefTopic = "" If Not IsNumeric(para) Then Exit Function If para = 0 Then Exit Function Select Case para Case "1" sBriefTopic = "<font color=""blue"">[图文]</font>" Case "2" sBriefTopic = "<font color=""red"">[组图]</font>" Case "3" sBriefTopic = "<font color=""green"">[新闻]</font>" Case "4" sBriefTopic = "<font color=""blue"">[推荐]</font>" Case "5" sBriefTopic = "<font color=""red"">[注意]</font>" Case "6" sBriefTopic = "<font color=""green"">[转载]</font>" Case Else sBriefTopic = "" End Select ReadBriefTopic = sBriefTopic End Function '============================================================= '函数名:ReadPicTopic '作 用:读取简短标题 '参 数:para '返回值:简短标题 '============================================================= Public Function ReadPicTopic(ByVal para) Dim sBriefTopic ReadPicTopic = "" If Not IsNumeric(para) Then Exit Function If para = 0 Then Exit Function Select Case para Case "1" sBriefTopic = "<font color=""" & MainSetting(4) & """>[图文]</font>" Case "2" sBriefTopic = "<font color=""" & MainSetting(5) & """>[组图]</font>" Case "3" sBriefTopic = "<font color=""" & MainSetting(6) & """>[新闻]</font>" Case "4" sBriefTopic = "<font color=""" & MainSetting(4) & """>[推荐]</font>" Case "5" sBriefTopic = "<font color=""" & MainSetting(5) & """>[注意]</font>" Case "6" sBriefTopic = "<font color=""" & MainSetting(6) & """>[转载]</font>" Case Else sBriefTopic = "" End Select ReadPicTopic = sBriefTopic End Function '============================================================= '函数名:ReadPayMoney '作 用:读取要支付的金钱 '参 数:money ----实际金钱 '返回值:加上手续费后的金钱 '============================================================= Public Function ReadPayMoney(ByVal money, ByVal Reduce) 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) 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 '----------------------------------------------------------------- '================================================ '函数名:GetImageUrl '作 用:获取图片URL '================================================ Public Function GetImageUrl(ByVal url, ByVal ChannelDir) Dim strTempUrl, strImageUrl If Len(ChannelDir) = 0 Then ChannelDir = "/" If Not IsNull(url) And Trim(url) <> "" And LCase(url) <> "http://" Then strTempUrl = ChannelDir If Right(strTempUrl,1) <> "/" Then strTempUrl = strTempUrl & "/" 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 If IsBindDomain = 0 Then strImageUrl = InstallDir & "images/no_pic.gif" Else strImageUrl = SiteUrl & "/images/no_pic.gif" End If End If GetImageUrl = strImageUrl End Function '----------------------------------------------------------------- '================================================ '作 用:读取图片或者FLASH '参 数:url ----文件URL ' height ----高度 ' width ----宽度 '================================================ Function GetFlashAndPic(ByVal url, ByVal height, ByVal width) Dim sExtName, ExtName, strTemp Dim strHeight, strWidth If Not IsNumeric(height) Or height < 1 Then strHeight = "" Else strHeight = " height=""" & height & """" End If If Not IsNumeric(width) Or width < 1 Then strWidth = "" Else strWidth = " width=""" & width & """" End If sExtName = Split(url, ".") ExtName = sExtName(UBound(sExtName)) If LCase(ExtName) = "swf" Then strTemp = "<embed src=""" & url & """" & strWidth & strHeight & "/>" Else strTemp = "<img src=""" & url & """" & strWidth & strHeight & " border=""0""/>" End If GetFlashAndPic = strTemp End Function '================================================ '函数名:ReadFileUrl '作 用:读取文件URL '================================================ Public Function ReadFileUrl(url) ReadFileUrl = "" If url = "" Then Exit Function Dim strTemp If CheckUrl(url) = 1 Then strTemp = Trim(url) If IsBindDomain = 1 Then strTemp = SiteUrl & strTemp ElseIf CheckUrl(url) = 2 Then strTemp = Trim(url) Else strTemp = Replace(url, "../", "") strTemp = Trim(InstallDir & strTemp) If IsBindDomain = 1 Then strTemp = SiteUrl & 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 Public Function ReadDestination(ByVal strDestination,ByVal strChannel,ByVal strFileDate,ByVal strFileDir,ByVal classid,ByVal id,ByVal page,ByVal strName) Dim strParent, strTime, strChild Dim y, m, d If Len(strDestination) < 6 Then Exit Function classid = ChkNumeric(classid) id = ChkNumeric(id) page = ChkNumeric(page) strDestination = Replace(strDestination, "[classid]", classid, 1, -1, 1) If Len(strName) < 2 Then strDestination = Replace(strDestination, "[page]", page, 1, -1, 1) End If strDestination = Replace(strDestination, "[root]", InstallDir, 1, -1, 1) strDestination = Replace(strDestination, "[InstallDir]", InstallDir, 1, -1, 1) strDestination = Replace(strDestination, "[channel]", strChannel, 1, -1, 1) strDestination = Replace(strDestination, "[class]", strFileDir, 1, -1, 1) strDestination = Replace(strDestination, "[name]", strName, 1, -1, 1) strDestination = Replace(strDestination, "[cid]", Supplemental(classid,5), 1, -1, 1) strDestination = Replace(strDestination, "[sortid]", Supplemental(classid,3), 1, -1, 1) If page > 1 Then strDestination = Replace(strDestination, "[id]", id & "_" & page, 1, -1, 1) strDestination = Replace(strDestination, "[sid]", Supplemental(id,6) & "_" & page, 1, -1, 1) strDestination = Replace(strDestination, "[eid]", Supplemental(id,8) & "_" & page, 1, -1, 1) strDestination = Replace(strDestination, "[rid]", Supplemental(id,3) & "_" & page, 1, -1, 1) Else strDestination = Replace(strDestination, "[id]", id, 1, -1, 1) strDestination = Replace(strDestination, "[sid]", Supplemental(id,6), 1, -1, 1) strDestination = Replace(strDestination, "[eid]", Supplemental(id,8), 1, -1, 1) strDestination = Replace(strDestination, "[rid]", Supplemental(id,3), 1, -1, 1) End If If Len(strFileDir) > 1 Then If InStr(strFileDir,"/") > 0 Then strParent = Mid(strFileDir, 1, InStr(1, strFileDir, "/")-1) strChild = Left(strFileDir,Len(strFileDir)-1) If InStr(strChild,"/") > 0 Then strChild = Mid(strChild, InStrRev(strChild, "/") + 1) Else strChild = strChild End If Else strParent = strFileDir strChild = strFileDir End If Else strParent = "" strChild = "" End If strDestination = Replace(strDestination, "[parent]", strParent, 1, -1, 1) strDestination = Replace(strDestination, "[child]", strChild, 1, -1, 1) If Len(strFileDate) > 5 Then strTime = Left(strFileDate, 8) y = Left(strTime, 4) m = Mid(strTime, 5, 2) d = Right(strTime, 2) strDestination = Replace(strDestination, "[year]", y, 1, -1, 1) strDestination = Replace(strDestination, "[month]", m, 1, -1, 1) strDestination = Replace(strDestination, "[day]", d, 1, -1, 1) strDestination = Replace(strDestination, "[date]", strTime, 1, -1, 1) strDestination = Replace(strDestination, "[random]", Right(strFileDate, 7), 1, -1, 1) If page > 1 Then strDestination = Replace(strDestination, "[datetime]", strFileDate & "_" & page, 1, -1, 1) Else strDestination = Replace(strDestination, "[datetime]", strFileDate, 1, -1, 1) End If End If strDestination = Replace(strDestination, "\", "/") strDestination = Replace(strDestination, "//", "/") If Left(strDestination,1) = "/" Then strDestination = strDestination Else strDestination = InstallDir & strDestination End If HtmlFilesPath = Left(strDestination, InStrRev(strDestination, "/")) HtmlFilesName = Mid(strDestination, InStrRev(strDestination, "/") + 1) strDestination = Replace(strDestination, "[page]", page, 1, -1, 1) ReadDestination = strDestination End Function '================================================ '过程名:HtmlRndFileName '作 用:取HTML的随机文件名 '================================================ Function HtmlRndFileName() Dim sRnd Randomize sRnd = Int(90 * Rnd) + 10 HtmlRndFileName = Replace(Replace(Replace(FormatDate(Now(), 1), "-", ""), ":", ""), " ", "") & sRnd End Function '================================================ '函数名:ChannelMenu '作 用:显示频道菜单 '================================================ Public Function ChannelMenu() Dim SQL, Rs, i, TotalNumber,strTop Dim strContent, LinkTarget, ChannelName Dim ChannelUrl, sCaption,m_strValue If Not IsObject(Conn) Then ConnectionDatabase If ChkNumeric(MainSetting(7)) = 0 Then strTop = vbNullString Else strTop = "TOP " & ChkNumeric(MainSetting(7)) End If SQL = "SELECT " & strTop & " ChannelID,orders,ColorModes,FontModes,ChannelName,Caption,ChannelDir,StopChannel,IsHidden,BindDomain,DomainName,LinkTarget,ChannelType,ChannelUrl FROM [NC_Channel] WHERE IsHidden=0 ORDER BY orders" Set Rs = Server.CreateObject("ADODB.Recordset") Rs.Open SQL,Conn,1,1 If Rs.BOF And Rs.EOF Then m_strValue = "" 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 m_strValue = m_strValue & MainSetting(9) ChannelName = ReadFontMode(Rs("ChannelName"), Rs("ColorModes"), Rs("FontModes")) If Rs("ChannelType") < 2 Then If IsBindDomain = 0 Then If Rs("BindDomain") = 0 Then ChannelUrl = Trim(InstallDir & Rs("ChannelDir")) Else If Rs("ChannelID") = CLng(m_intChannelID) Then ChannelUrl = "/" Else ChannelUrl = Trim(Rs("DomainName")) End If End If Else If Rs("BindDomain") = 0 Then ChannelUrl = Trim(SiteUrl &"/"& Rs("ChannelDir")) Else If Rs("ChannelID") = CLng(m_intChannelID) Then ChannelUrl = "/" Else ChannelUrl = Trim(Rs("DomainName")) End If End If End If Else ChannelUrl = Rs("ChannelUrl") End If If Rs("StopChannel") <> 0 Then sCaption = "此频道暂时关闭,不能访问!" Else sCaption = Rs("Caption") End If strContent = "<a href=""" & ChannelUrl & """" & LinkTarget & LoadRemark(sCaption) & ">" & ChannelName & "</a>" If i < TotalNumber Then If i Mod CInt(MainSetting(8)) = 0 Then strContent = strContent & "<br />" & vbNewLine End If m_strValue = Replace(m_strValue, "{$ChannelMenu}", strContent) Rs.MoveNext Loop End If Rs.Close: Set Rs = Nothing ChannelMenu = m_strValue End Function '============================================================= '函数名:LoadSelectClass '作 用:载入缓存下拉分类列表 '参 数:ChannelID ----频道ID '返回值:下拉分类列表 '============================================================= Public Function LoadSelectClass(ChannelID) Dim CacheSelClass, SQL, Rs1, i Name = "SelectClass" & ChannelID If ObjIsEmpty() Then SQL = "SELECT ClassID,ClassName,depth,TurnLink,child FROM NC_Classify WHERE ChannelID=" & ChannelID & " ORDER BY rootid,orders" Set Rs1 = Execute(SQL) If Rs1.BOF And Rs1.EOF Then CacheSelClass = CacheSelClass & "<option>没有添加分类</option>" End If Do While Not Rs1.EOF If Rs1("TurnLink") <> 0 Then CacheSelClass = CacheSelClass & "<option value=""0""" Else If Rs1("depth") = 0 And Rs1("child") <> 0 Then CacheSelClass = CacheSelClass & "<option" Else CacheSelClass = CacheSelClass & "<option value=""" & Rs1("ClassID") & """" End If End If CacheSelClass = CacheSelClass & " {ClassID=" & Rs1("ClassID") & "}>" If Rs1("depth") = 1 Then CacheSelClass = CacheSelClass & " ├ " If Rs1("depth") > 1 Then For i = 2 To Rs1("depth") CacheSelClass = CacheSelClass & " " Next CacheSelClass = CacheSelClass & " ├ " End If CacheSelClass = CacheSelClass & Rs1("ClassName") & "</option>" & vbCrLf Rs1.MoveNext Loop Rs1.Close Set Rs1 = Nothing Value = CacheSelClass End If LoadSelectClass = Value End Function Public Function ClassJumpMenu(ChannelID) Dim CacheJumpMenu Dim Rs1 Dim i Name = "ClassJumpMenu" & ChannelID If ObjIsEmpty() Then Set Rs1 = Execute("select ClassID,ChannelID,ClassName,depth,TurnLink,TurnLinkUrl from [NC_Classify] where ChannelID = " & ChannelID & " order by rootid,orders") Do While Not Rs1.EOF If Rs1("TurnLink") <> 0 Then CacheJumpMenu = CacheJumpMenu & "<option value=""" & Rs1("TurnLinkUrl") & """ {ClassID=" & Rs1("classid") & "}" Else CacheJumpMenu = CacheJumpMenu & "<option value=""?ChannelID=" & Rs1("ChannelID") & "&sortid=" & Rs1("classid") & """ {ClassID=" & Rs1("classid") & "}" End If If Trim(Request("sortid")) <> "" Then If CLng(Request("sortid")) = Rs1("classid") Then CacheJumpMenu = CacheJumpMenu & " selected" End If CacheJumpMenu = CacheJumpMenu & ">" If Rs1("depth") = 1 Then CacheJumpMenu = CacheJumpMenu & " ├ " If Rs1("depth") > 1 Then For i = 2 To Rs1("depth") CacheJumpMenu = CacheJumpMenu & " " Next CacheJumpMenu = CacheJumpMenu & " ├ " End If CacheJumpMenu = CacheJumpMenu & Rs1("ClassName") & "</option>" & vbCrLf Rs1.MoveNext Loop Rs1.Close Set Rs1 = Nothing Value = CacheJumpMenu End If ClassJumpMenu = Value End Function '================================================ '函数名:GetRandomCode '作 用:系统分配随机代码 '================================================ Public Function GetRandomCode() Dim Ran, i, LengthNum LengthNum = 16 GetRandomCode = "" For i = 1 To LengthNum Randomize Ran = CInt(Rnd * 2) Randomize If Ran = 0 Then Ran = CInt(Rnd * 25) + 97 GetRandomCode = GetRandomCode & UCase(Chr(Ran)) ElseIf Ran = 1 Then Ran = CInt(Rnd * 9) GetRandomCode = GetRandomCode & Ran ElseIf Ran = 2 Then Ran = CInt(Rnd * 25) + 97 GetRandomCode = GetRandomCode & Chr(Ran) End If Next End Function '================================================ ' 函数名:CodeIsTrue ' 作 用:检查验证码是否正确 '================================================ Public Function CodeIsTrue() Dim CodeStr CodeStr = Trim(Request("CodeStr")) On Error Resume Next If CStr(Session("GetCode")) = CStr(CodeStr) And CodeStr <> "" Then CodeIsTrue = True Session("GetCode") = Empty Else CodeIsTrue = False Session("GetCode") = Empty End If End Function Public Function CheckAdmin(ByVal Flag) Dim Rs, SQL Dim i, TempAdmin, AdminFlag, AdminGrade CheckAdmin = False On Error Resume Next SQL = "SELECT AdminGrade,Adminflag FROM NC_Admin WHERE username='" & Replace(Session("AdminName"), "'", "''") & "' And password='" & Replace(Session("AdminPass"), "'", "''") & "' And isLock=0 And id=" & CLng(Session("AdminID")) Set Rs = Execute(SQL) If Rs.BOF And Rs.EOF Then CheckAdmin = False Set Rs = Nothing Exit Function Else AdminFlag = Rs("Adminflag") AdminGrade = Rs("AdminGrade") End If Rs.Close: Set Rs = Nothing If CInt(AdminGrade) = 999 Then CheckAdmin = True Exit Function Else If Trim(Flag) = "" Then Exit Function If AdminFlag = "" Then CheckAdmin = False Exit Function Else TempAdmin = Split(AdminFlag, ",") For i = 0 To UBound(TempAdmin) If Trim(LCase(TempAdmin(i))) = Trim(LCase(Flag)) Then CheckAdmin = True Exit For End If Next End If End If End Function '================================================ '函数名:ReadAlpha '作 用:读取字符串的第一个字母 '参 数:str ----字符 '返回值:返回第一个字母 '================================================ Public Function ReadAlpha(ByVal str) Dim strTemp If IsNull(str) Or Trim(str) = "" Then ReadAlpha = "A-9" Exit Function End If str = Trim(str) strTemp = 65536 + Asc(str) If (strTemp >= 45217 And strTemp <= 45252) Or (strTemp = 65601) Or (strTemp = 65633) Or (strTemp = 37083) Then ReadAlpha = "A-Z" ElseIf (strTemp >= 45253 And strTemp <= 45760) Or (strTemp = 65602) Or (strTemp = 65634) Or (strTemp = 39658) Then ReadAlpha = "B-Z" ElseIf (strTemp >= 45761 And strTemp <= 46317) Or (strTemp = 65603) Or (strTemp = 65635) Or (strTemp = 33405) Then ReadAlpha = "C-Z" ElseIf (strTemp >= 46318 And strTemp <= 46836) Or (strTemp >= 46847 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 >= 46837 And strTemp <= 46846) Or (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 CreationPath = True Exit Function End If strPath = Replace(sPath, strHostPath, vbNullString,1,-1,1) sPathItem = Split(strPath, "\") If InStr(LCase(sPath), LCase(strHostPath)) = 0 Then sTempPath = sPathItem(0) Else sTempPath = strHostPath End If For i = 1 To UBound(sPathItem) If sPathItem(i) <> "" Then sTempPath = sTempPath & "\" & sPathItem(i) If fso.FolderExists(sTempPath) = False Then fso.CreateFolder sTempPath End If End If Next Set fso = Nothing If Err.Number <> 0 Then Err.Clear CreatPathEx = True End Function '================================================ '函数名:FilesDelete '作 用:FSO删除文件 '参 数:filepath ----文件路径 '返回值:False ---- True '================================================ Public Function FileDelete(ByVal FilePath) On Error Resume Next FileDelete = False Dim fso Set fso = Server.CreateObject(FSO_ScriptName) If FilePath = "" Then Exit Function If InStr(FilePath, ":") = 0 Then FilePath = Server.MapPath(FilePath) If fso.FileExists(FilePath) Then fso.DeleteFile FilePath, True FileDelete = True End If Set fso = Nothing If Err.Number <> 0 Then Err.Clear End Function Public Function FilePathExists(ByVal FilePath,ByVal stype) On Error Resume Next Dim fso Set fso = Server.CreateObject(FSO_ScriptName) If FilePath = "" Then Exit Function If InStr(FilePath, ":") = 0 Then FilePath = Server.MapPath(FilePath) If stype = 1 Then FilePathExists = fso.FileExists(FilePath) Else FilePathExists = fso.FolderExists(FilePath) End If Set fso = Nothing If Err.Number <> 0 Then Err.Clear FilePathExists = False End If End Function '================================================ '函数名:FolderDelete '作 用:FSO删除目录 '参 数:folderpath ----目录路径 '返回值:False ---- True '================================================ Public Function FolderDelete(ByVal FolderPath) FolderDelete = False On Error Resume Next Dim fso Set fso = Server.CreateObject(FSO_ScriptName) If FolderPath = "" Then Exit Function If InStr(FolderPath, ":") = 0 Then FolderPath = Server.MapPath(FolderPath) If fso.FolderExists(FolderPath) Then fso.DeleteFolder FolderPath, True FolderDelete = True End If Set fso = Nothing If Err.Number <> 0 Then Err.Clear End Function '================================================ '函数名:CopyToFile '作 用:复制文件 '参 数:SoureFile ----原文件路径 ' NewFile ----目标文件路径 '================================================ Public Function CopyToFile(ByVal SoureFile, ByVal NewFile) On Error Resume Next If SoureFile = "" Then Exit Function If NewFile = "" Then Exit Function If InStr(SoureFile, ":") = 0 Then SoureFile = Server.MapPath(SoureFile) If InStr(NewFile, ":") = 0 Then NewFile = Server.MapPath(NewFile) Dim fso Set fso = Server.CreateObject(FSO_ScriptName) If fso.FileExists(SoureFile) Then fso.CopyFile SoureFile, NewFile End If Set fso = Nothing If Err.Number <> 0 Then Err.Clear End Function '================================================ '函数名:CopyToFolder '作 用:复制文件夹 '参 数:SoureFolder ----原路径 ' NewFolder ----目标路径 '================================================ Public Function CopyToFolder(ByVal SoureFolder, ByVal NewFolder) On Error Resume Next If SoureFolder = "" Then Exit Function If NewFolder = "" Then Exit Function If InStr(SoureFolder, ":") = 0 Then SoureFolder = Server.MapPath(SoureFolder) If InStr(NewFolder, ":") = 0 Then NewFolder = Server.MapPath(NewFolder) Dim fso Set fso = Server.CreateObject(FSO_ScriptName) If fso.FolderExists(SoureFolder) Then fso.CopyFolder SoureFolder, NewFolder End If Set fso = Nothing If Err.Number <> 0 Then Err.Clear End Function '============================================================= '过程名:CreatedTextFile '作 用:创建文本文件 '参 数:filename ----文件名 ' body ----主要内容 '============================================================= Public Function CreatedTextFile(ByVal FileName, ByVal body) On Error Resume Next Dim fso,f FileName = Replace(Replace(FileName, "/", "\"), "\\", "\") If InStr(FileName, ":") = 0 Then FileName = Server.MapPath(FileName) Set fso = Server.CreateObject(FSO_ScriptName) Set f = fso.CreateTextFile(FileName,True) f.WriteLine body f.Close Set f = Nothing Set fso = Nothing If Err.Number <> 0 Then Err.Clear End Function Public Function CreatedTextFiles(ByVal FileName, ByVal body) On Error Resume Next FileName = Replace(Replace(FileName, "/", "\"), "\\", "\") If InStr(FileName, ":") = 0 Then FileName = Server.MapPath(FileName) Dim oStream Set oStream = Server.CreateObject("ADODB.Stream") oStream.Type = 2 '设置为可读可写 oStream.Mode = 3 '设置内容为文本 oStream.Charset = "GB2312" oStream.Open oStream.Position = oStream.Size oStream.WriteText body oStream.SaveToFile FileName, 2 oStream.Close Set oStream = Nothing If Err.Number <> 0 Then Err.Clear End Function '================================================ '函数名:Readfile '作 用:读取文件内容 '参 数:fromPath ----来源文件路径 '================================================ Public Function Readfile(ByVal fromPath) On Error Resume Next Dim strTemp,fso,f fromPath = Replace(Replace(fromPath, "/", "\"), "\\", "\") If InStr(fromPath, ":") = 0 Then fromPath = Server.MapPath(fromPath) Set fso = Server.CreateObject(FSO_ScriptName) If fso.FileExists(fromPath) Then Set f = fso.OpenTextFile(fromPath, 1, True) strTemp = f.ReadAll f.Close Set f = Nothing End If Set fso = Nothing Readfile = strTemp If Err.Number <> 0 Then Err.Clear End Function '================================================ '函数名:CutMatchContent '作 用:截取相匹配的内容 '参 数:Str ----原字符串 ' PatStr ----符合条件字符 '================================================ Public Function CutMatchContent(ByVal str, ByVal start, ByVal last, ByVal Condition) Dim Match,s,re Dim FilterStr,MatchStr Dim strContent,ArrayFilter Dim i, n,bRepeat If Len(start) = 0 Or Len(last) = 0 Then Exit Function On Error Resume Next MatchStr = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")" Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = MatchStr Set s = re.Execute(str) n = 0 For Each Match In s If n = 0 Then n = n + 1 ReDim ArrayFilter(n) ArrayFilter(n) = Match Else bRepeat = False For i = 0 To UBound(ArrayFilter) If UCase(Match) = UCase(ArrayFilter(i)) Then bRepeat = True Exit For End If Next If bRepeat = False Then n = n + 1 ReDim Preserve ArrayFilter(n) ArrayFilter(n) = Match End If End If Next Set s = Nothing Set re = Nothing If CBool(Condition) Then strContent = Join(ArrayFilter, "|||") Else strContent = Join(ArrayFilter, "|||") strContent = Replace(strContent, start, "") strContent = Replace(strContent, last, "") End If CutMatchContent = Replace(strContent, "|||", vbNullString, 1, 1) End Function Function CutFixContent(ByVal str, ByVal start, ByVal last, ByVal n) Dim strTemp On Error Resume Next If InStr(str, start) > 0 Then Select Case n Case 0 '左右都截取(都取前面)(去处关键字) strTemp = Right(str, Len(str) - InStr(str, start) - Len(start) + 1) strTemp = Left(strTemp, InStr(strTemp, last) - 1) Case Else '左右都截取(都取前面)(保留关键字) strTemp = Right(str, Len(str) - InStr(str, start) + 1) strTemp = Left(strTemp, InStr(strTemp, last) + Len(last) - 1) End Select Else strTemp = "" End If CutFixContent = strTemp End Function Private Function CorrectPattern(ByVal str) str = Replace(str, "\", "\\") str = Replace(str, "~", "\~") str = Replace(str, "!", "\!") str = Replace(str, "@", "\@") str = Replace(str, "#", "\#") str = Replace(str, "%", "\%") str = Replace(str, "^", "\^") str = Replace(str, "&", "\&") str = Replace(str, "*", "\*") str = Replace(str, "(", "\(") str = Replace(str, ")", "\)") str = Replace(str, "-", "\-") str = Replace(str, "+", "\+") str = Replace(str, "[", "\[") str = Replace(str, "]", "\]") str = Replace(str, "<", "\<") str = Replace(str, ">", "\>") str = Replace(str, ".", "\.") str = Replace(str, "/", "\/") str = Replace(str, "?", "\?") str = Replace(str, "=", "\=") str = Replace(str, "|", "\|") str = Replace(str, "$", "\$") CorrectPattern = str End Function '============================================================= '函数名:UserGroupSetting '作 用:取用户级权限设置 '参 数:gradeid ----等级ID '============================================================= Public Function UserGroupSetting(ByVal gradeid) gradeid = ChkNumeric(gradeid) 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 Dim GroupValue GroupValue = Replace(Rs("GroupSet"), "|||", "|") GroupValue = Replace(GroupValue, "|", "|||") & "0|||0|||0|||0|||0|||0|||0|||0|||0|||0|||" Value = GroupValue & 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 Dim GroupValue GroupValue = Replace(Rs("GroupSet"), "|||", "|") GroupValue = Replace(GroupValue, "|", "|||") & "0|||0|||0|||0|||0|||0|||0|||0|||0|||0|||" Value = GroupValue & 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 Sub LoadWssConfig() Dim XmlDoc,XmlNode,Xml_Files Xml_Files = "inc/newasp.config" Xml_Files = Server.MapPath(MyAppPath & Xml_Files) Set XmlDoc = Server.CreateObject("Msxml2.FreeThreadedDOMDocument" & MsxmlVersion) If Not XmlDoc.Load(Xml_Files) Then Wss_IsUsed = 0 Wss_SiteID = "0" Wss_PassWord = "0" Wss_Domain = "0" Wss_Key = "0" Else Set XmlNode = XmlDoc.documentElement.selectSingleNode("rs:data/z:row[@id=0]") Wss_IsUsed = Newasp.ChkNumeric(XmlNode.getAttribute("wss_isused")) Wss_SiteID = Newasp.CheckStr(XmlNode.getAttribute("wss_siteid")) Wss_PassWord = Newasp.CheckStr(XmlNode.getAttribute("wss_password")) Wss_Domain = Newasp.CheckStr(XmlNode.getAttribute("wss_domain")) Wss_Key = Newasp.CheckStr(XmlNode.getAttribute("wss_key")) Set XmlNode = Nothing End If Set XmlDoc = Nothing End Sub End Class %>