<%
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 "查询数据的时候发现错误，请检查您的查询代码是否正确。<br /><li>"
Response.Write Command
Response.End
End If
Else
Set Execute = Conn.Execute(Command)
End If
SqlQueryNum = SqlQueryNum+1
End Function
Public Sub ReadConfig()
On Error Resume Next
Name = "Config"
If ObjIsEmpty() Then ReloadConfig
CacheData = Value
'第一次起用系统或者重启IIS的时候加载缓存
Name = "Date"
If ObjIsEmpty() Then
Value = Date
Else
If CStr(Value) <> CStr(Date) Then
Name = "Config"
Call ReloadConfig
CacheData = Value
End If
End If
SiteName = CacheData(1, 0): SiteUrl = CacheData(2, 0): MasterMail = CacheData(3, 0): keywords = CacheData(4, 0): Copyright = CacheData(5, 0): InstallDir = CacheData(6, 0)
IndexName = CacheData(7, 0): IstopSite = CacheData(8, 0): StopReadme = CacheData(9, 0): IsCloseMail = CacheData(10, 0): SendMailType = CacheData(11, 0): MailFrom = CacheData(12, 0)
MailServer = CacheData(13, 0): MailUserName = CacheData(14, 0): MailPassword = CacheData(15, 0): CheckUserReg = CacheData(16, 0): AdminCheckReg = CacheData(17, 0): MailInformPass = CacheData(18, 0)
ChkSameMail = CacheData(19, 0): AddUserPoint = CacheData(20, 0): SendRegMessage = CacheData(21, 0): FullContQuery = CacheData(22, 0): ActionTime = CacheData(23, 0): IsRunTime = CacheData(24, 0)
UploadClass = CacheData(25, 0): UploadFileSize = CacheData(26, 0): UploadFileType = CacheData(27, 0): ContentKeyword = CacheData(28, 0): StopApplyLink = CacheData(29, 0): FSO_ScriptName = CacheData(30, 0)
InitTitleColor = CacheData(31, 0): StopBankPay = CacheData(32, 0): ChinaeBank = CacheData(33, 0): VersionID = CacheData(34, 0): Badwords = CacheData(35, 0): Badwordr = CacheData(36, 0)
serialcode = CacheData(37, 0): passedcode = CacheData(38, 0) : PreviewSetting = CacheData(39, 0)
ThisEdition = "免费版 (Free Edition)"
Version = "Powered by：<a href=""http://www.newasp.net"" target=""_blank"" class=""navmenu"">NewCloud SiteManageSystem Version 2.0.0 SP1</a>"
CopyrightStr = "<!--" & vbCrLf
CopyrightStr = CopyrightStr & "┌─────────────────NEWASP──┐" & vbCrLf
CopyrightStr = CopyrightStr & "│NewCloud SiteManageSystem Version 2.0.0 SP1 │" & vbCrLf
CopyrightStr = CopyrightStr & "│版权所有: 新云网络 (newasp.net) │" & vbCrLf
CopyrightStr = CopyrightStr & "│官方主页: http://www.newasp.net │" & vbCrLf
CopyrightStr = CopyrightStr & "│论坛地址: http://bbs.newasp.net │" & vbCrLf
CopyrightStr = CopyrightStr & "│E-Mail: webenvoy@163.com QQ: 94022511 │" & vbCrLf
CopyrightStr = CopyrightStr & "└────────────────────.NET┘" & vbCrLf
CopyrightStr = CopyrightStr & "-->" & vbCrLf
If CInt(IstopSite) = 1 And Not Admin_Page Then Response.Redirect ("" & SiteUrl & InstallDir & "showerr.asp?action=stop")
End Sub
Public Sub ReloadConfig()
Dim SQL, Rs
On Error Resume Next
SQL = "SELECT * from [NC_Config] "
Set Rs = Execute(SQL)
Value = Rs.GetRows(1)
Set Rs = Nothing
End Sub
'=============================================================
'过程名：ReloadChannel
'作 用：再装频道设置
'参 数：ChannelID ----频道ID
'=============================================================
Private Sub ReloadChannel(ChannelID)
Dim SQL, Rs
On Error Resume Next
SQL = "SELECT ChannelID,ChannelName,ChannelDir,StopChannel,ChannelType,modules,ModuleName,BindDomain,DomainName,ChannelSkin,HtmlPath,HtmlForm,IsCreateHtml,HtmlExtName,HtmlPrefix,StopUpload,MaxFileSize,UpFileType,IsAuditing,AppearGrade,PostGrade,LeastString,MaxString,PaginalNum,LeastHotHist,Channel_Setting from NC_Channel where ChannelType <= 1 And ChannelID = " & CLng(ChannelID)
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
Response.Write "错误的频道参数！"
Exit Sub
End If
Value = Rs.GetRows(1)
Set Rs = Nothing
End Sub
'=============================================================
'过程名：ReadChannel
'作 用：读取频道设置
'参 数：ChannelID ----频道ID
'=============================================================
Public Sub ReadChannel(ChannelID)
On Error Resume Next
If Not IsNumeric(ChannelID) Then ChannelID = 1
ChannelID = Clng(ChannelID)
Name = "Channel" & ChannelID
If ObjIsEmpty() Then Call ReloadChannel(ChannelID)
CacheChannel = Value
If CLng(CacheChannel(0, 0)) <> ChannelID Then
Call ReloadChannel(ChannelID)
CacheChannel = Value
End If
ChannelName = CacheChannel(1, 0): ChannelDir = CacheChannel(2, 0): StopChannel = CacheChannel(3, 0): ChannelType = CacheChannel(4, 0): modules = CacheChannel(5, 0): ModuleName = CacheChannel(6, 0): BindDomain = CacheChannel(7, 0): DomainName = CacheChannel(8, 0): ChannelSkin = CacheChannel(9, 0): HtmlPath = CacheChannel(10, 0)
HtmlForm = CacheChannel(11, 0): IsCreateHtml = CacheChannel(12, 0): HtmlExtName = CacheChannel(13, 0): HtmlPrefix = CacheChannel(14, 0): StopUpload = CacheChannel(15, 0): MaxFileSize = CacheChannel(16, 0): UpFileType = CacheChannel(17, 0): IsAuditing = CacheChannel(18, 0): AppearGrade = CacheChannel(19, 0)
PostGrade = CacheChannel(20, 0): LeastString = CacheChannel(21, 0): MaxString = CacheChannel(22, 0): PaginalNum = CacheChannel(23, 0): LeastHotHist = CacheChannel(24, 0): Channel_Setting = CacheChannel(25, 0)
If CInt(StopChannel) = 1 And Not Admin_Page Then Response.Redirect (InstallDir & "showerr.asp?action=ChanStop")
End Sub
Public Sub LoadChannel(chanid)
On Error Resume Next
Dim Rs,SQL,tmpdata
chanid = CLng(chanid)
Name = "MyChannel" & chanid
If ObjIsEmpty() Then
SQL = "SELECT ChannelName,ChannelDir,ModuleName,HtmlPath,HtmlForm,IsCreateHtml,HtmlExtName,HtmlPrefix,StopUpload,LeastString,MaxString,LeastHotHist FROM NC_Channel WHERE ChannelType<=1 And ChannelID= " & Clng(chanid)
Set Rs = Execute(SQL)
tmpdata = Rs.GetString(, , "|||", "@@@", "")
tmpdata = Left(tmpdata, Len(tmpdata) - 3)
Set Rs = Nothing
Value = tmpdata
End If
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), "<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, 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), "<br /> ")
fString = Replace(fString, " ", " ")
HTMLEncodes = fString
End If
End Function
'=============================================================
'函数作用：判断发言是否来自外部
'=============================================================
Public Function CheckPost()
On Error Resume Next
Dim server_v1, server_v2
CheckPost = False
server_v1 = CStr(Request.ServerVariables("HTTP_REFERER"))
server_v2 = CStr(Request.ServerVariables("SERVER_NAME"))
If Mid(server_v1, 8, Len(server_v2)) = server_v2 Then
CheckPost = True
End If
End Function
'=============================================================
'函数作用：判断来源URL是否来自外部
'=============================================================
Public Function CheckOuterUrl()
On Error Resume Next
Dim server_v1, server_v2
server_v1 = Replace(LCase(Trim(Request.ServerVariables("HTTP_REFERER"))), "http://", "")
server_v2 = LCase(Trim(Request.ServerVariables("SERVER_NAME")))
If server_v1 <> "" And Left(server_v1, Len(server_v2)) <> server_v2 Then
CheckOuterUrl = False
Else
CheckOuterUrl = True
End If
End Function
'================================================
'函数名：GotTopic
'作 用：显示字符串长度
'参 数：str ----原字符串
' strlen ----显示字符长度
'================================================
Public Function GotTopic(ByVal str, ByVal strLen)
Dim l, t, c, i
Dim strTemp
On Error Resume Next
str = Trim(str)
str = Replace(str, " ", " ")
str = Replace(str, ">", ">")
str = Replace(str, "<", "<")
str = Replace(str, ">", ">")
str = Replace(str, "<", "<")
str = Replace(str, "'", "'")
str = Replace(str, """, Chr(34))
str = Replace(str, vbNewLine, "")
l = Len(str)
t = 0
For i = 1 To l
c = Abs(Asc(Mid(str, i, 1)))
If c > 255 Then
t = t + 2
Else
t = t + 1
End If
If t >= strLen Then
strTemp = Left(str, i) & "..."
Exit For
Else
strTemp = str & " "
End If
Next
GotTopic = CheckTopic(strTemp)
End Function
Public Function CheckTopic(ByVal strContent)
Dim re
On Error Resume Next
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(<s+cript(.+?)<\/s+cript>)"
strContent = re.Replace(strContent, "")
re.Pattern = "(<iframe(.+?)<\/iframe>)"
strContent = re.Replace(strContent, "")
re.Pattern = "(>)"
strContent = re.Replace(strContent, ">")
re.Pattern = "(<)"
strContent = re.Replace(strContent, "<")
Set re = Nothing
strContent = Replace(strContent, ">", ">")
strContent = Replace(strContent, "<", "<")
strContent = Replace(strContent, "'", "'")
strContent = Replace(strContent, Chr(34), """)
strContent = Replace(strContent, "%", "％")
strContent = Replace(strContent, vbNewLine, "")
CheckTopic = Trim(strContent)
End Function
'================================================
'函数名：ReadTopic
'作 用：显示字符串长度
'参 数：str ----原字符串
' strlen ----显示字符长度
'================================================
Public Function ReadTopic(ByVal str, ByVal strLen)
Dim l, t, c, i
On Error Resume Next
str = Replace(str, " ", " ")
If Len(str) < strLen Then
str = str & String(strLen - Len(str), ".")
Else
str = str
End If
l = Len(str)
t = 0
For i = 1 To l
c = Abs(Asc(Mid(str, i, 1)))
If c > 255 Then
t = t + 2
Else
t = t + 1
End If
If t >= strLen Then
ReadTopic = Left(str, i) & "..."
Exit For
Else
ReadTopic = str & "..."
End If
Next
End Function
'================================================
'函数名：strLength
'作 用：计字符串长度
'参 数：str ----字符串
'================================================
Public Function strLength(ByVal str)
On Error Resume Next
If IsNull(str) Or str = "" Then
strLength = 0
Exit Function
End If
Dim WINNT_CHINESE
WINNT_CHINESE = (Len("例子") = 2)
If WINNT_CHINESE Then
Dim l, t
Dim i, c
l = Len(str)
t = l
For i = 1 To l
c = Asc(Mid(str, i, 1))
If c < 0 Then c = c + 65536
If c > 255 Then t = t + 1
Next
strLength = t
Else
strLength = Len(str)
End If
End Function
'=================================================
'函数名：isInteger
'作 用：判断数字是否整型
'参 数：para ----参数
'=================================================
Public Function isInteger(ByVal para)
On Error Resume Next
Dim str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
str = CStr(para)
If Trim(str) = "" Then
isInteger = False
Exit Function
End If
l = Len(str)
For i = 1 To l
If Mid(str, i, 1) > "9" Or Mid(str, i, 1) < "0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number <> 0 Then Err.Clear
End Function
Public Function CutString(ByVal str, ByVal strLen)
On Error Resume Next
Dim HtmlStr, l, re, strContent
HtmlStr = str
HtmlStr = Replace(HtmlStr, " ", " ")
HtmlStr = Replace(HtmlStr, """, Chr(34))
HtmlStr = Replace(HtmlStr, "'", Chr(39))
HtmlStr = Replace(HtmlStr, "{", Chr(123))
HtmlStr = Replace(HtmlStr, "}", Chr(125))
HtmlStr = Replace(HtmlStr, "$", Chr(36))
HtmlStr = Replace(HtmlStr, vbCrLf, "")
HtmlStr = Replace(HtmlStr, "====", "")
HtmlStr = Replace(HtmlStr, "----", "")
HtmlStr = Replace(HtmlStr, "////", "")
HtmlStr = Replace(HtmlStr, "\\\\", "")
HtmlStr = Replace(HtmlStr, "####", "")
HtmlStr = Replace(HtmlStr, "@@@@", "")
HtmlStr = Replace(HtmlStr, "****", "")
HtmlStr = Replace(HtmlStr, "~~~~", "")
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "\[br\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "\[align=right\](.*)\[\/align\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "<(.[^>]*)>"
HtmlStr = re.Replace(HtmlStr, "")
Set re = Nothing
HtmlStr = Replace(HtmlStr, ">", ">")
HtmlStr = Replace(HtmlStr, "<", "<")
l = Len(HtmlStr)
If l >= strLen Then
strContent = Left(HtmlStr, strLen) & "..."
Else
strContent = HtmlStr & " "
End If
strContent = Replace(strContent, Chr(34), """)
strContent = Replace(strContent, Chr(39), "'")
strContent = Replace(strContent, Chr(36), "$")
strContent = Replace(strContent, Chr(123), "{")
strContent = Replace(strContent, Chr(125), "}")
strContent = Replace(strContent, ">", ">")
strContent = Replace(strContent, "<", "<")
CutString = strContent
End Function
'================================================
'函数名：CheckInfuse
'作 用：防止SQL注入
'参 数：str ----原字符串
' strLen ----提交字符串长度
'================================================
Public Function CheckInfuse(ByVal str, ByVal strLen)
Dim strUnsafe, arrUnsafe
Dim i
If Trim(str) = "" Then
CheckInfuse = ""
Exit Function
End If
str = Left(str, strLen)
On Error Resume Next
strUnsafe = "'|^|;|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
If Trim(str) <> "" Then
If Len(str) > strLen Then
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n您提交的字符数超过了限制！');history.back(-1)</Script>"
CheckInfuse = ""
Response.End
End If
arrUnsafe = Split(strUnsafe, "|")
For i = 0 To UBound(arrUnsafe)
If InStr(1, str, arrUnsafe(i), 1) > 0 Then
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
CheckInfuse = ""
Response.End
End If
Next
End If
CheckInfuse = Trim(str)
Exit Function
If Err.Number <> 0 Then
Err.Clear
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
CheckInfuse = ""
Response.End
End If
End Function
Public Sub PreventInfuse()
On Error Resume Next
Dim SQL_Nonlicet, arrNonlicet
Dim PostRefer, GetRefer, Sql_DATA
SQL_Nonlicet = "'|;|^|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
arrNonlicet = Split(SQL_Nonlicet, "|")
If Request.Form <> "" Then
For Each PostRefer In Request.Form
For Sql_DATA = 0 To UBound(arrNonlicet)
If InStr(1, Request.Form(PostRefer), arrNonlicet(Sql_DATA), 1) > 0 Then
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
Response.End
End If
Next
Next
End If
If Request.QueryString <> "" Then
For Each GetRefer In Request.QueryString
For Sql_DATA = 0 To UBound(arrNonlicet)
If InStr(1, Request.QueryString(GetRefer), arrNonlicet(Sql_DATA), 1) > 0 Then
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
Response.End
End If
Next
Next
End If
End Sub
'================================================
'函数名：ChkQueryStr
'作 用：过虑查询的非法字符
'参 数：str ----原字符串
'返回值：过滤后的字符
'================================================
Public Function ChkQueryStr(ByVal str)
On Error Resume Next
If IsNull(str) Then
ChkQueryStr = ""
Exit Function
End If
str = Replace(str, "!", "")
str = Replace(str, "]", "")
str = Replace(str, "[", "")
str = Replace(str, ")", "")
str = Replace(str, "(", "")
str = Replace(str, "|", "")
str = Replace(str, "+", "")
str = Replace(str, "=", "")
str = Replace(str, "'", "''")
str = Replace(str, "%", "")
str = Replace(str, "&", "")
str = Replace(str, "#", "")
str = Replace(str, "^", "")
str = Replace(str, " ", " ")
str = Replace(str, Chr(37), "")
str = Replace(str, Chr(0), "")
ChkQueryStr = str
End Function
'================================================
'过程名：CheckQuery
'作 用：限制搜索的关键字
'参 数：str ----搜索的字符串
'返回值：True; False
'================================================
Public Function CheckQuery(ByVal str)
Dim FobWords, i, keyword
keyword = str
On Error Resume Next
FobWords = Array(91, 92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12532, 12533, 65339, 65340)
For i = 1 To UBound(FobWords, 1)
If InStr(keyword, ChrW(FobWords(i))) > 0 Then
CheckQuery = False
Exit Function
End If
Next
FobWords = Array("~", "!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "_", "+", "=", "`", "[", "]", "{", "}", ";", ":", """", "'", "<", ">", ".", "/", "\", "|", "?", "about", "after", "all", "also", "an", "and", "another", "any", "are", "as", "at", "be", "because", "been", "before", "being", "between", "both", "but", "by", "came", "can", "come", "could", "did", "do", "each", "for", "from", "get", "got", "had", "has", "have", "he", "her", "here", "him", "himself", "his", "how", "if", "in", "into", "is", "it", "like", "make", "many", "me", "might", "more", "most", "much", "must", "my", "never", "now", "of", "on", "only", "or", "other", "our", "out", "over", "said", "same", "see", "should", "since", "some", "still", "such", "take", "than", "that", "the", "their", "them", "then", "there", "these", "they", "this")
keyword = Left(keyword, 100)
keyword = Replace(keyword, "!", " ")
keyword = Replace(keyword, "]", " ")
keyword = Replace(keyword, "[", " ")
keyword = Replace(keyword, ")", " ")
keyword = Replace(keyword, "(", " ")
keyword = Replace(keyword, " ", " ")
keyword = Replace(keyword, "-", " ")
keyword = Replace(keyword, "/", " ")
keyword = Replace(keyword, "+", " ")
keyword = Replace(keyword, "=", " ")
keyword = Replace(keyword, ",", " ")
keyword = Replace(keyword, "'", " ")
For i = 0 To UBound(FobWords, 1)
If keyword = FobWords(i) Then
CheckQuery = False
Exit Function
End If
Next
CheckQuery = True
End Function
'================================================
'函数名：IsValidStr
'作 用：判断字符串中是否含有非法字符
'参 数：str ----原字符串
'返回值：False,True -----布尔值
'================================================
Public Function IsValidStr(ByVal str)
IsValidStr = False
On Error Resume Next
If IsNull(str) Then Exit Function
If Trim(str) = Empty Then Exit Function
Dim ForbidStr, i
ForbidStr = "and|chr|:|=|%|&|$|#|@|+|-|*|/|\|<|>|;|,|^|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9)
ForbidStr = Split(ForbidStr, "|")
For i = 0 To UBound(ForbidStr)
If InStr(1,str, ForbidStr(i),1) > 0 Then
IsValidStr = False
Exit Function
End If
Next
IsValidStr = True
End Function
'================================================
'函数名：IsValidPassword
'作 用：判断密码中是否含有非法字符
'参 数：str ----原字符串
'返回值：False,True -----布尔值
'================================================
Public Function IsValidPassword(ByVal str)
IsValidPassword = False
On Error Resume Next
If IsNull(str) Then Exit Function
If Trim(str) = Empty Then Exit Function
Dim ForbidStr, i
ForbidStr = "=and|chr|*|^|%|&|;|,|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9)
ForbidStr = Split(ForbidStr, "|")
For i = 0 To UBound(ForbidStr)
If InStr(1, str, ForbidStr(i), 1) > 0 Then
IsValidPassword = False
Exit Function
End If
Next
IsValidPassword = True
End Function
'================================================
'函数名：IsValidChar
'作 用：判断字符串中是否含有非法字符和中文
'参 数：str ----原字符串
'返回值：False,True -----布尔值
'================================================
Public Function IsValidChar(ByVal str)
IsValidChar = False
On Error Resume Next
If IsNull(str) Then Exit Function
If Trim(str) = Empty Then Exit Function
Dim ValidStr
Dim i, l, s, c
ValidStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ.-_:~\/0123456789"
l = Len(str)
s = UCase(str)
For i = 1 To l
c = Mid(s, i, 1)
If InStr(ValidStr, c) = 0 Then
IsValidChar = False
Exit Function
End If
Next
IsValidChar = True
End Function
'================================================
'函数名：FormatDate
'作 用：格式化日期
'参 数：DateAndTime ----原日期和时间
' para ----日期格式
'返回值：格式化后的日期
'================================================
Public Function FormatDate(DateAndTime, para)
On Error Resume Next
Dim y, m, d, h, mi, s, strDateTime
FormatDate = DateAndTime
If Not IsNumeric(para) Then Exit Function
If Not IsDate(DateAndTime) Then Exit Function
y = CStr(Year(DateAndTime))
m = CStr(Month(DateAndTime))
If Len(m) = 1 Then m = "0" & m
d = CStr(Day(DateAndTime))
If Len(d) = 1 Then d = "0" & d
h = CStr(Hour(DateAndTime))
If Len(h) = 1 Then h = "0" & h
mi = CStr(Minute(DateAndTime))
If Len(mi) = 1 Then mi = "0" & mi
s = CStr(Second(DateAndTime))
If Len(s) = 1 Then s = "0" & s
Select Case para
Case "1"
strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
Case "2"
strDateTime = y & "-" & m & "-" & d
Case "3"
strDateTime = y & "/" & m & "/" & d
Case "4"
strDateTime = y & "年" & m & "月" & d & "日"
Case "5"
strDateTime = m & "-" & d
Case "6"
strDateTime = m & "/" & d
Case "7"
strDateTime = m & "月" & d & "日"
Case "8"
strDateTime = y & "年" & m & "月"
Case "9"
strDateTime = y & "-" & m
Case "10"
strDateTime = y & "/" & m
Case Else
strDateTime = DateAndTime
End Select
FormatDate = strDateTime
End Function
'================================================
'函数名：ReadFontMode
'作 用：读取字体模式
'参 数：str ----原字符串
' vColor -----颜色的值
' vFont -----字体的值
'返回值：新字符串
'================================================
Public Function ReadFontMode(str, vColor, vFont)
Dim FontStr, tColor
Dim ColorStr, arrColor
If IsNull(str) Then
ReadFontMode = ""
Exit Function
End If
ReadFontMode = str
On Error Resume Next
If Not IsNumeric(vColor) Then Exit Function
If Not IsNumeric(vFont) Then Exit Function
Select Case CInt(vFont)
Case 1
FontStr = "<b>" & str & "</b>"
Case 2
FontStr = "<em>" & str & "</em>"
Case 3
FontStr = "<u>" & str & "</u>"
Case 4
FontStr = "<b><em>" & str & "</em></b>"
Case 5
FontStr = "<b><u>" & str & "</u></b>"
Case 6
FontStr = "<em><u>" & str & "</u></em>"
Case 7
FontStr = "<b><em><u>" & str & "</u></em></b>"
Case Else
FontStr = str
End Select
ReadFontMode = FontStr
If vColor = "" Or vColor = 0 Then Exit Function
ColorStr = "," & InitTitleColor
arrColor = Split(ColorStr, ",")
If vColor > UBound(arrColor) Then Exit Function
tColor = Trim(arrColor(vColor))
ReadFontMode = "<font color=" & tColor & ">" & FontStr & "</font>"
End Function
'=============================================================
'函数名：ShowDateTime
'作 用：读取日期格式
'参 数：DateAndTime ---- 当前时间
' para ---- 时间格式
'=============================================================
Public Function ShowDateTime(DateAndTime, para)
ShowDateTime = ""
Dim strDate
If Not IsDate(DateAndTime) Then Exit Function
If DateAndTime >= Date Then
strDate = "<font color='" & Main_Setting(1) & "'>"
strDate = strDate & FormatDate(DateAndTime, para)
strDate = strDate & "</font>"
Else
strDate = "<font color='" & Main_Setting(2) & "'>"
strDate = strDate & FormatDate(DateAndTime, para)
strDate = strDate & "</font>"
End If
ShowDateTime = strDate
End Function
Public Function ShowDatePath(strval, n)
ShowDatePath = ""
If Trim(strval) = "" Then Exit Function
Dim strTempPath, strTime
Dim y, m, d
strTime = Left(strval, 8)
y = Left(strTime, 4)
m = Mid(strTime, 5, 2)
d = Right(strTime, 2)
Select Case CInt(n)
Case 1
strTempPath = y & "/" & m & "/" & d & "/"
Case 2
strTempPath = y & "/" & m & "/"
Case 3
strTempPath = y & m & "/"
Case 4
strTempPath = y & "/"
Case 5
strTempPath = y & "-" & m & "-" & d & "/"
Case 6
strTempPath = y & "-" & m & "/"
Case 7
strTempPath = "html/"
Case 8
strTempPath = "show/"
Case Else
strTempPath = ""
End Select
strTempPath = Replace(strTempPath, " ", "")
ShowDatePath = CStr(strTempPath)
End Function
'=============================================================
'函数名：ReadBriefTopicffd
'作 用：读取简短标题
'参 数：para
'返回值：简短标题
'=============================================================
Public Function ReadBriefTopic(ByVal para)
Dim sBriefTopic
ReadBriefTopic = ""
If Not IsNumeric(para) Then Exit Function
If para = 0 Then Exit Function
Select Case para
Case "1"
sBriefTopic = "<font color='blue'>[图文]</font>"
Case "2"
sBriefTopic = "<font color='red'>[组图]</font>"
Case "3"
sBriefTopic = "<font color='green'>[新闻]</font>"
Case "4"
sBriefTopic = "<font color='blue'>[推荐]</font>"
Case "5"
sBriefTopic = "<font color='red'>[注意]</font>"
Case "6"
sBriefTopic = "<font color='green'>[转载]</font>"
Case Else
sBriefTopic = ""
End Select
ReadBriefTopic = sBriefTopic
End Function
'=============================================================
'函数名：ReadPicTopic
'作 用：读取简短标题
'参 数：para
'返回值：简短标题
'=============================================================
Public Function ReadPicTopic(ByVal para)
Dim sBriefTopic
ReadPicTopic = ""
If Not IsNumeric(para) Then Exit Function
If para = 0 Then Exit Function
Select Case para
Case "1"
sBriefTopic = "<font color='" & Main_Setting(4) & "'>[图文]</font>"
Case "2"
sBriefTopic = "<font color='" & Main_Setting(5) & "'>[组图]</font>"
Case "3"
sBriefTopic = "<font color='" & Main_Setting(6) & "'>[新闻]</font>"
Case "4"
sBriefTopic = "<font color='" & Main_Setting(4) & "'>[推荐]</font>"
Case "5"
sBriefTopic = "<font color='" & Main_Setting(5) & "'>[注意]</font>"
Case "6"
sBriefTopic = "<font color='" & Main_Setting(6) & "'>[转载]</font>"
Case Else
sBriefTopic = ""
End Select
ReadPicTopic = sBriefTopic
End Function
'=============================================================
'函数名：ReadPayMoney
'作 用：读取要支付的金钱
'参 数：money ----实际金钱
'返回值：加上手续费后的金钱
'=============================================================
Public Function ReadPayMoney(ByVal money, ByVal Reduce)
On Error Resume Next
If money = 0 Then
ReadPayMoney = 0
Exit Function
End If
Dim arrChinaeBank, valPercent, Percents
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 = "<embed src="/UploadFiles/2021-04-02/"> Else
strTemp = "<img src=""> End If
GetFlashAndPic = strTemp
End Function
'================================================
'函数名：ReadFileUrl
'作 用：读取文件URL
'================================================
Public Function ReadFileUrl(url)
On Error Resume Next
ReadFileUrl = ""
If url = "" Then Exit Function
Dim strTemp
If CheckUrl(url) = 1 Then
strTemp = Trim(url)
ElseIf CheckUrl(url) = 2 Then
strTemp = Trim(url)
Else
strTemp = Replace(url, "../", "")
strTemp = Trim(InstallDir & strTemp)
End If
ReadFileUrl = strTemp
End Function
Public Function CheckUrl(ByVal url)
Dim strUrl
If Left(url, 1) = "/" Then
CheckUrl = 1
Exit Function
End If
strUrl = LCase(Left(url, 6))
Select Case Trim(strUrl)
Case "http:/", "https:", "ftp://", "rtsp:/", "mms://"
CheckUrl = 2
Exit Function
Case Else
CheckUrl = 0
End Select
End Function
'================================================
'函数名：ReadFileName
'作 用：读取HTML文件名
'参 数：strname ----文件名称
' id ----数据ID
' ExtName ----HTML扩展名
' PrefixStr ----HTML名称前缀
' HtmlForm ----HTML文件格式
' n ----HTML分页
'================================================
Public Function ReadFileName(ByVal strname, ByVal id, ByVal ExtName, ByVal PrefixStr, ByVal HtmlForm, ByVal n)
Dim strFileName, strExtName, CurrentPage
If Trim(strname) = "" Then Exit Function
If Trim(ExtName) = "" Then ExtName = ".html"
If Not IsNumeric(n) Then n = 0
On Error Resume Next
If CInt(n) <= 1 Then
CurrentPage = ""
Else
CurrentPage = "_" & n
End If
If Left(ExtName, 1) <> "." Then
strExtName = "." & Trim(ExtName)
Else
strExtName = Trim(ExtName)
End If
Select Case Trim(HtmlForm)
Case "1"
strFileName = Trim(id)
Case "2"
strFileName = Trim(PrefixStr) & Trim(Supplemental(id, 3))
Case "3"
strFileName = Left(strname, 8)
strFileName = strFileName & Trim(Supplemental(id, 3))
Case "4"
strFileName = Right(strname, 7)
strFileName = strFileName & Trim(Supplemental(id, 3))
Case Else
strFileName = strname
End Select
strFileName = Replace(strFileName & CurrentPage & strExtName, " ", "")
ReadFileName = CStr(strFileName)
End Function
'================================================
'过程名：HtmlRndFileName
'作 用：取HTML的随机文件名
'================================================
Function HtmlRndFileName()
Dim sRnd
Randomize
sRnd = Int(90 * Rnd) + 10
HtmlRndFileName = Replace(Replace(Replace(FormatDate(Now(), 1), "-", ""), ":", ""), " ", "") & sRnd
End Function
'================================================
'函数名：ClassFileName
'作 用：读取HTML文件列表名
'参 数：ClassID ----分类ID
'================================================
Public Function ClassFileName(ByVal ClassID, ByVal ExtName, ByVal PrefixStr, ByVal n)
Dim strFileName, strExtName, strClassID
If Trim(ExtName) = "" Then ExtName = ".html"
If Not IsNumeric(n) Then n = 0
If Left(ExtName, 1) <> "." Then
strExtName = "." & Trim(ExtName)
Else
strExtName = Trim(ExtName)
End If
If CInt(n) <= 1 Then
strFileName = "index" & strExtName
Else
strClassID = Supplemental(ClassID, 3)
strFileName = PrefixStr & strClassID & "_" & n & strExtName
End If
strFileName = Replace(strFileName, " ", "")
ClassFileName = CStr(strFileName)
End Function
'================================================
'函数名：SpecialFileName
'作 用：读取专题HTML文件名
'参 数：specid ----专题ID
'================================================
Public Function SpecialFileName(ByVal specid, ByVal ExtName, ByVal n)
Dim strFileName, strExtName, strSpecialID
If Trim(ExtName) = "" Then ExtName = ".html"
If Not IsNumeric(n) Then n = 0
If Left(ExtName, 1) <> "." Then
strExtName = "." & Trim(ExtName)
Else
strExtName = Trim(ExtName)
End If
If CInt(n) <= 1 Then
strFileName = "index" & strExtName
Else
strSpecialID = Supplemental(specid, 3)
strFileName = "Special" & strSpecialID & "_" & n & strExtName
End If
strFileName = Replace(strFileName, " ", "")
SpecialFileName = CStr(strFileName)
End Function
'================================================
'函数名：ChannelMenu
'作 用：显示频道菜单
'================================================
Public Function ChannelMenu()
Dim SQL, Rs, i, TotalNumber,strTop
Dim strContent, LinkTarget, ChannelName
Dim ChannelUrl, HtmlContent, sCaption
Name = "ChannelMenu"
If ObjIsEmpty() Then
If ChkNumeric(Main_Setting(7)) = 0 Then
strTop = vbNullString
Else
strTop = "TOP " & CInt(Main_Setting(7))
End If
SQL = "SELECT " & strTop & " ChannelID,orders,ColorModes,FontModes,ChannelName,Caption,ChannelDir,StopChannel,IsHidden,BindDomain,DomainName,LinkTarget,ChannelType,ChannelUrl,IsHidden FROM [NC_Channel] WHERE IsHidden = 0 Order By orders"
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
strContent = ""
Else
i = 0
TotalNumber = Rs.RecordCount
Do While Not Rs.EOF
i = i + 1
If Rs("LinkTarget") <> 0 Then
LinkTarget = " target=""_blank"""
Else
LinkTarget = ""
End If
HtmlContent = HtmlContent & Main_Setting(9)
ChannelName = ReadFontMode(Rs("ChannelName"), Rs("ColorModes"), Rs("FontModes"))
If Rs("ChannelType") < 2 Then
ChannelUrl = InstallDir & Rs("ChannelDir")
Else
ChannelUrl = Rs("ChannelUrl")
End If
If Rs("StopChannel") <> 0 Then
sCaption = "此频道暂时关闭,不能访问！"
Else
sCaption = Rs("Caption")
End If
strContent = "<a href=""" & ChannelUrl & """" & LinkTarget & " title=""" & sCaption & """ class=navmenu>" & ChannelName & "</a>"
If i Mod CInt(Main_Setting(8)) = 0 Then strContent = strContent & "<br>"
HtmlContent = Replace(HtmlContent, "{$ChannelMenu}", strContent)
Rs.MoveNext
Loop
End If
Rs.Close: Set Rs = Nothing
'Value = strContent
End If
'strContent = Value
ChannelMenu = HtmlContent
End Function
'=============================================================
'函数名：LoadSelectClass
'作 用：载入缓存下拉分类列表
'参 数：ChannelID ----频道ID
'返回值：下拉分类列表
'=============================================================
Public Function LoadSelectClass(ChannelID)
Dim CacheSelClass, SQL, Rs1, i
Name = "SelectClass" & ChannelID
If ObjIsEmpty() Then
SQL = "select ClassID,ClassName,depth,TurnLink,child from NC_Classify where ChannelID = " & ChannelID & " order by rootid,orders"
Set Rs1 = Execute(SQL)
If Rs1.BOF And Rs1.EOF Then
CacheSelClass = CacheSelClass & "<option>没有添加分类</option>"
End If
Do While Not Rs1.EOF
If Rs1("TurnLink") <> 0 Then
CacheSelClass = CacheSelClass & "<option value=""0"""
Else
If Rs1("depth") = 0 And Rs1("child") <> 0 Then
CacheSelClass = CacheSelClass & "<option"
Else
CacheSelClass = CacheSelClass & "<option value=""" & Rs1("ClassID") & """"
End If
End If
CacheSelClass = CacheSelClass & " {ClassID=" & Rs1("ClassID") & "}>"
If Rs1("depth") = 1 Then CacheSelClass = CacheSelClass & " ├ "
If Rs1("depth") > 1 Then
For i = 2 To Rs1("depth")
CacheSelClass = CacheSelClass & " "
Next
CacheSelClass = CacheSelClass & " ├ "
End If
CacheSelClass = CacheSelClass & Rs1("ClassName") & "</option>" & vbCrLf
Rs1.MoveNext
Loop
Rs1.Close
Set Rs1 = Nothing
Value = CacheSelClass
End If
LoadSelectClass = Value
End Function
Public Function ClassJumpMenu(ChannelID)
Dim CacheJumpMenu
Dim Rs1
Dim i
Name = "ClassJumpMenu" & ChannelID
If ObjIsEmpty() Then
Set Rs1 = Execute("select ClassID,ChannelID,ClassName,depth,TurnLink,TurnLinkUrl from [NC_Classify] where ChannelID = " & ChannelID & " order by rootid,orders")
Do While Not Rs1.EOF
If Rs1("TurnLink") <> 0 Then
CacheJumpMenu = CacheJumpMenu & "<option value=""" & Rs1("TurnLinkUrl") & """ {ClassID=" & Rs1("classid") & "}"
Else
CacheJumpMenu = CacheJumpMenu & "<option value=""?ChannelID=" & Rs1("ChannelID") & "&sortid=" & Rs1("classid") & """ {ClassID=" & Rs1("classid") & "}"
End If
If Trim(Request("sortid")) <> "" Then
If CLng(Request("sortid")) = Rs1("classid") Then CacheJumpMenu = CacheJumpMenu & " selected"
End If
CacheJumpMenu = CacheJumpMenu & ">"
If Rs1("depth") = 1 Then CacheJumpMenu = CacheJumpMenu & " ├ "
If Rs1("depth") > 1 Then
For i = 2 To Rs1("depth")
CacheJumpMenu = CacheJumpMenu & " "
Next
CacheJumpMenu = CacheJumpMenu & " ├ "
End If
CacheJumpMenu = CacheJumpMenu & Rs1("ClassName") & "</option>" & vbCrLf
Rs1.MoveNext
Loop
Rs1.Close
Set Rs1 = Nothing
Value = CacheJumpMenu
End If
ClassJumpMenu = Value
End Function
'================================================
'函数名：GetRandomCode
'作 用：系统分配随机代码
'================================================
Public Function GetRandomCode()
Dim Ran, i, LengthNum
LengthNum = 16
GetRandomCode = ""
For i = 1 To LengthNum
Randomize
Ran = CInt(Rnd * 2)
Randomize
If Ran = 0 Then
Ran = CInt(Rnd * 25) + 97
GetRandomCode = GetRandomCode & UCase(Chr(Ran))
ElseIf Ran = 1 Then
Ran = CInt(Rnd * 9)
GetRandomCode = GetRandomCode & Ran
ElseIf Ran = 2 Then
Ran = CInt(Rnd * 25) + 97
GetRandomCode = GetRandomCode & Chr(Ran)
End If
Next
End Function
'================================================
' 函数名：CodeIsTrue
' 作 用：检查验证码是否正确
'================================================
Public Function CodeIsTrue()
Dim CodeStr
CodeStr = Trim(Request("CodeStr"))
On Error Resume Next
If CStr(Session("GetCode")) = CStr(CodeStr) And CodeStr <> "" Then
CodeIsTrue = True
Session("GetCode") = Empty
Else
CodeIsTrue = False
Session("GetCode") = Empty
End If
End Function
Public Function CheckAdmin(ByVal Flag)
Dim Rs, SQL
Dim i, TempAdmin, AdminFlag, AdminGrade
CheckAdmin = False
On Error Resume Next
SQL = "SELECT AdminGrade,Adminflag FROM NC_Admin WHERE username='" & Replace(Session("AdminName"), "'", "''") & "' And password='" & Replace(Session("AdminPass"), "'", "''") & "' And isLock=0 And id=" & CLng(Session("AdminID"))
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
CheckAdmin = False
Set Rs = Nothing
Exit Function
Else
AdminFlag = Rs("Adminflag")
AdminGrade = Rs("AdminGrade")
End If
Rs.Close: Set Rs = Nothing
If CInt(AdminGrade) = 999 Then
CheckAdmin = True
Exit Function
Else
If Trim(Flag) = "" Then Exit Function
If AdminFlag = "" Then
CheckAdmin = False
Exit Function
Else
TempAdmin = Split(AdminFlag, ",")
For i = 0 To UBound(TempAdmin)
If Trim(LCase(TempAdmin(i))) = Trim(LCase(Flag)) Then
CheckAdmin = True
Exit For
End If
Next
End If
End If
End Function
'================================================
'函数名：ReadAlpha
'作 用：读取字符串的第一个字母
'参 数：str ----字符
'返回值：返回第一个字母
'================================================
Public Function ReadAlpha(ByVal str)
Dim strTemp
If IsNull(str) Or Trim(str) = "" Then
ReadAlpha = "A-9"
Exit Function
End If
str = Trim(str)
strTemp = 65536 + Asc(str)
If (strTemp >= 45217 And strTemp <= 45252) Or (strTemp = 65601) Or (strTemp = 65633) Or (strTemp = 37083) Then
ReadAlpha = "A-Z"
ElseIf (strTemp >= 45253 And strTemp <= 45760) Or (strTemp = 65602) Or (strTemp = 65634) Or (strTemp = 39658) Then
ReadAlpha = "B-Z"
ElseIf (strTemp >= 45761 And strTemp <= 46317) Or (strTemp = 65603) Or (strTemp = 65635) Or (strTemp = 33405) Then
ReadAlpha = "C-Z"
ElseIf (strTemp >= 46318 And strTemp <= 46930) Or (strTemp >= 61884 And strTemp <= 61884) Or (strTemp = 65604) Or (strTemp >= 36820 And strTemp <= 38524) Or (strTemp = 65636) Then
ReadAlpha = "D-Z"
ElseIf (strTemp >= 46931 And strTemp <= 47009) Or (strTemp = 65605) Or (strTemp = 65637) Or (strTemp = 61513) Then
ReadAlpha = "E-Z"
ElseIf (strTemp >= 47010 And strTemp <= 47296) Or (strTemp = 65606) Or (strTemp = 65638) Or (strTemp = 61320) Or (strTemp = 63568) Or (strTemp = 36281) Then
ReadAlpha = "F-Z"
ElseIf (strTemp >= 47297 And strTemp <= 47613) Or (strTemp = 65607) Or (strTemp = 65639) Or (strTemp = 35949) Or (strTemp = 36089) Or (strTemp = 36694) Or (strTemp = 34808) Then
ReadAlpha = "G-Z"
ElseIf (strTemp >= 47614 And strTemp <= 48118) Or (strTemp >= 59112 And strTemp <= 59112) Or (strTemp = 65608) Or (strTemp = 65640) Then
ReadAlpha = "H-Z"
ElseIf (strTemp = 65641) Or (strTemp = 65609) Or (strTemp = 65641) Then
ReadAlpha = "I-Z"
ElseIf (strTemp >= 48119 And strTemp <= 49061 And strTemp <> 48739) Or (strTemp >= 62430 And strTemp <= 62430) Or (strTemp = 65610) Or (strTemp = 65642) Or (strTemp = 39048) Then
ReadAlpha = "J-Z"
ElseIf (strTemp >= 49062 And strTemp <= 49323) Or (strTemp = 65611) Or (strTemp = 65643) Then
ReadAlpha = "K-Z"
ElseIf (strTemp >= 49324 And strTemp <= 49895) Or (strTemp >= 58838 And strTemp <= 58838) Or (strTemp = 65612) Or (strTemp = 65644) Or (strTemp = 62418) Or (strTemp = 48739) Then
ReadAlpha = "L-Z"
ElseIf (strTemp >= 49896 And strTemp <= 50370) Or (strTemp = 65613) Or (strTemp = 65645) Then
ReadAlpha = "M-Z"
ElseIf (strTemp >= 50371 And strTemp <= 50613) Or (strTemp = 65614) Or (strTemp = 65646) Then
ReadAlpha = "N-Z"
ElseIf (strTemp >= 50614 And strTemp <= 50621) Or (strTemp = 65615) Or (strTemp = 65647) Then
ReadAlpha = "O-Z"
ElseIf (strTemp >= 50622 And strTemp <= 50905) Or (strTemp = 65616) Or (strTemp = 65648) Then
ReadAlpha = "P-Z"
ElseIf (strTemp >= 50906 And strTemp <= 51386) Or (strTemp >= 62659 And strTemp <= 63172) Or (strTemp = 65617) Or (strTemp = 65649) Then
ReadAlpha = "Q-Z"
ElseIf (strTemp >= 51387 And strTemp <= 51445) Or (strTemp = 65618) Or (strTemp = 65650) Then
ReadAlpha = "R-Z"
ElseIf (strTemp >= 51446 And strTemp <= 52217) Or (strTemp = 65619) Or (strTemp = 65651) Or (strTemp = 34009) Then
ReadAlpha = "S-Z"
ElseIf (strTemp >= 52218 And strTemp <= 52697) Or (strTemp = 65620) Or (strTemp = 65652) Then
ReadAlpha = "T-Z"
ElseIf (strTemp = 65621) Or (strTemp = 65653) Then
ReadAlpha = "U-Z"
ElseIf (strTemp = 65622) Or (strTemp = 65654) Then
ReadAlpha = "V-Z"
ElseIf (strTemp >= 52698 And strTemp <= 52979) Or (strTemp = 65623) Or (strTemp = 65655) Then
ReadAlpha = "W-Z"
ElseIf (strTemp >= 52980 And strTemp <= 53688) Or (strTemp = 65624) Or (strTemp = 65656) Then
ReadAlpha = "X-Z"
ElseIf (strTemp >= 53689 And strTemp <= 54480) Or (strTemp = 65625) Or (strTemp = 65657) Then
ReadAlpha = "Y-Z"
ElseIf (strTemp >= 54481 And strTemp <= 62383 And strTemp <> 59112 And strTemp <> 58838) Or (strTemp = 65626) Or (strTemp = 65658) Or (strTemp = 38395) Or (strTemp = 39783) Then
ReadAlpha = "Z-Z"
Else
ReadAlpha = "A-9"
End If
If (strTemp >= 65633 And strTemp <= 65658) Or (strTemp >= 65601 And strTemp <= 65626) Then ReadAlpha = UCase(Left(str, 1))
If (strTemp >= 65584 And strTemp <= 65593) Then ReadAlpha = "0-9"
End Function
'-- 修正文件路径
Public Function CheckPath(ByVal sPath)
sPath = Trim(sPath)
If Right(sPath, 1) <> "\" And sPath <> "" Then
sPath = sPath & "\"
End If
CheckPath = sPath
End Function
'-- 生成目录
Public Function CreatPathEx(ByVal sPath)
sPath = Replace(sPath, "/", "\")
sPath = Replace(sPath, "\\", "\")
On Error Resume Next
Dim strHostPath,strPath
Dim sPathItem,sTempPath
Dim i,fso
Set fso = Server.CreateObject(FSO_ScriptName)
strHostPath = Server.MapPath("/")
If InStr(sPath, ":") = 0 Then sPath = Server.MapPath(sPath)
If fso.FolderExists(sPath) Or Len(sPath) < 3 Then
CreatPathEx = True
Exit Function
End If
strPath = Replace(sPath, strHostPath, vbNullString,1,-1,1)
sPathItem = Split(strPath, "\")
If InStr(LCase(sPath), LCase(strHostPath)) = 0 Then
sTempPath = sPathItem(0)
Else
sTempPath = strHostPath
End If
For i = 1 To UBound(sPathItem)
If sPathItem(i) <> "" Then
sTempPath = sTempPath & "\" & sPathItem(i)
If fso.FolderExists(sTempPath) = False Then
fso.CreateFolder sTempPath
End If
End If
Next
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
CreatPathEx = True
End Function
'================================================
'函数名：FilesDelete
'作 用：FSO删除文件
'参 数：filepath ----文件路径
'返回值：False ---- True
'================================================
Public Function FileDelete(ByVal FilePath)
On Error Resume Next
FileDelete = False
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If FilePath = "" Then Exit Function
If InStr(FilePath, ":") = 0 Then FilePath = Server.MapPath(FilePath)
If fso.FileExists(FilePath) Then
fso.DeleteFile FilePath, True
FileDelete = True
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：FolderDelete
'作 用：FSO删除目录
'参 数：folderpath ----目录路径
'返回值：False ---- True
'================================================
Public Function FolderDelete(ByVal FolderPath)
FolderDelete = False
On Error Resume Next
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If FolderPath = "" Then Exit Function
If InStr(FolderPath, ":") = 0 Then FolderPath = Server.MapPath(FolderPath)
If fso.FolderExists(FolderPath) Then
fso.DeleteFolder FolderPath, True
FolderDelete = True
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：CopyToFile
'作 用：复制文件
'参 数：SoureFile ----原文件路径
' NewFile ----目标文件路径
'================================================
Public Function CopyToFile(ByVal SoureFile, ByVal NewFile)
On Error Resume Next
If SoureFile = "" Then Exit Function
If NewFile = "" Then Exit Function
If InStr(SoureFile, ":") = 0 Then SoureFile = Server.MapPath(SoureFile)
If InStr(NewFile, ":") = 0 Then NewFile = Server.MapPath(NewFile)
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If fso.FileExists(SoureFile) Then
fso.CopyFile SoureFile, NewFile
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：CopyToFolder
'作 用：复制文件夹
'参 数：SoureFolder ----原路径
' NewFolder ----目标路径
'================================================
Public Function CopyToFolder(ByVal SoureFolder, ByVal NewFolder)
On Error Resume Next
If SoureFolder = "" Then Exit Function
If NewFolder = "" Then Exit Function
If InStr(SoureFolder, ":") = 0 Then SoureFolder = Server.MapPath(SoureFolder)
If InStr(NewFolder, ":") = 0 Then NewFolder = Server.MapPath(NewFolder)
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If fso.FolderExists(SoureFolder) Then
fso.CopyFolder SoureFolder, NewFolder
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'=============================================================
'过程名：CreatedTextFile
'作 用：创建文本文件
'参 数：filename ----文件名
' body ----主要内容
'=============================================================
Public Function CreatedTextFile(ByVal FileName, ByVal body)
On Error Resume Next
If InStr(FileName, ":") = 0 Then FileName = Server.MapPath(FileName)
Dim fso,f
Set fso = Server.CreateObject(FSO_ScriptName)
Set f = fso.CreateTextFile(FileName)
f.WriteLine body
f.Close
Set f = Nothing
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：Readfile
'作 用：读取文件内容
'参 数：fromPath ----来源文件路径
'================================================
Public Function Readfile(ByVal fromPath)
On Error Resume Next
Dim strTemp,fso,f
If InStr(fromPath, ":") = 0 Then fromPath = Server.MapPath(fromPath)
Set fso = Server.CreateObject(FSO_ScriptName)
If fso.FileExists(fromPath) Then
Set f = fso.OpenTextFile(fromPath, 1, True)
strTemp = f.ReadAll
f.Close
Set f = Nothing
End If
Set fso = Nothing
Readfile = strTemp
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：CutMatchContent
'作 用：截取相匹配的内容
'参 数：Str ----原字符串
' PatStr ----符合条件字符
'================================================
Public Function CutMatchContent(ByVal str, ByVal start, ByVal last, ByVal Condition)
Dim Match,s,re
Dim FilterStr,MatchStr
Dim strContent,ArrayFilter
Dim i, n,bRepeat
If Len(start) = 0 Or Len(last) = 0 Then Exit Function
On Error Resume Next
MatchStr = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")"
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = MatchStr
Set s = re.Execute(str)
n = 0
For Each Match In s
If n = 0 Then
n = n + 1
ReDim ArrayFilter(n)
ArrayFilter(n) = Match
Else
bRepeat = False
For i = 0 To UBound(ArrayFilter)
If UCase(Match) = UCase(ArrayFilter(i)) Then
bRepeat = True
Exit For
End If
Next
If bRepeat = False Then
n = n + 1
ReDim Preserve ArrayFilter(n)
ArrayFilter(n) = Match
End If
End If
Next
Set s = Nothing
Set re = Nothing
If CBool(Condition) Then
strContent = Join(ArrayFilter, "|||")
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)
If Not IsNumeric(gradeid) Then
gradeid = 0
End If
On Error Resume Next
Dim Rs, SQL
Name = "GroupSetting" & gradeid
If ObjIsEmpty() Then
SQL = "Select Groupname,GroupSet from [NC_UserGroup] where Grades =" & gradeid
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
UserGroupSetting = ""
Set Rs = Nothing
Exit Function
End If
Value = Rs("GroupSet") & Rs("Groupname")
Set Rs = Nothing
End If
UserGroupSetting = Value
End Function
Private Sub LoadGroupSetting()
Dim strGroupSetting
Dim Rs, SQL
Dim Grades
Grades = CInt(membergrade)
On Error Resume Next
If Grades > 0 And memberid > 0 Then
If binUserLong = False Then
Set Rs = Execute("SELECT userid FROM [NC_User] WHERE password='" & CheckRequest(memberpass, 45) & "' And UserGrade=" & Grades & " And UserLock=0 And userid =" & memberid)
If Rs.BOF And Rs.EOF Then
Grades = 0
Response.Cookies(Cookies_Name) = ""
binUserLong = False
Else
binUserLong = True
End If
Set Rs = Nothing
End If
End If
Name = "GroupSetting" & Grades
If ObjIsEmpty() Then
SQL = "Select Groupname,GroupSet from [NC_UserGroup] where Grades =" & Grades
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
Response.Cookies(Cookies_Name) = ""
Set Rs = Nothing
Exit Sub
End If
Value = Rs("GroupSet") & Rs("Groupname")
Set Rs = Nothing
End If
blnGroupSetting = True
strGroupSetting = Value
arrGroupSetting = Split(strGroupSetting, "|||")
End Sub
Public Property Get GroupSetting(i)
If Not blnGroupSetting Then LoadGroupSetting
GroupSetting = arrGroupSetting(i)
End Property
Public Function ReadContent(ByVal strContent)
On Error Resume Next
Dim re, i
Dim sContentKeyword, strKeyword
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
'过滤危险脚本
re.Pattern = "(<s+cript(.[^>]*)>)"
strContent = re.Replace(strContent, "<Script$2>")
re.Pattern = "(<\/s+cript>)"
strContent = re.Replace(strContent, "</Script>")
re.Pattern = "(<body(.[^>]*)>)"
strContent = re.Replace(strContent, "<body>")
re.Pattern = "(<\!(.[^>]*)>)"
strContent = re.Replace(strContent, "<$2>")
re.Pattern = "(<\!)"
strContent = re.Replace(strContent, "<!")
re.Pattern = "(-->)"
strContent = re.Replace(strContent, "-->")
re.Pattern = "(javascript:)"
strContent = re.Replace(strContent, "<i>javascript</i>:")
If Trim(ContentKeyword) <> "" Then
sContentKeyword = Split(ContentKeyword, "@@@")
For i = 0 To UBound(sContentKeyword) - 1
strKeyword = Split(sContentKeyword(i), "$$$")
re.Pattern = "(" & strKeyword(0) & ")"
strContent = re.Replace(strContent, "<a target=""_blank"" href=""" & strKeyword(1) & """ class=""wordstyle"">$1</a>")
Next
End If
re.Pattern = "(\[i\])(.[^\[]*)(\[\/i\])"
strContent = re.Replace(strContent, "<i>$2</i>")
re.Pattern = "(\[u\])(.[^\[]*)(\[\/u\])"
strContent = re.Replace(strContent, "<u>$2</u>")
re.Pattern = "(\[b\])(.[^\[]*)(\[\/b\])"
strContent = re.Replace(strContent, "<b>$2</b>")
re.Pattern = "(\[fly\])(.*)(\[\/fly\])"
strContent = re.Replace(strContent, "<marquee>$2</marquee>")
re.Pattern = "\[size=([1-9])\](.[^\[]*)\[\/size\]"
strContent = re.Replace(strContent, "<font size=$1>$2</font>")
re.Pattern = "(\[center\])(.[^\[]*)(\[\/center\])"
strContent = re.Replace(strContent, "<center>$2</center>")
're.Pattern = "<IMG.[^>]*SRC(=| )(.[^>]*)>"
'strContent = re.Replace(strContent, "<IMG SRC=$2 border=""0"">")
re.Pattern = "<img(.[^>]*)>"
strContent = re.Replace(strContent, "<img$1 onload=""return imgzoom(this,550)"">")
re.Pattern = "\[DIR=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/DIR]"
strContent = re.Replace(strContent, "<embed src=$3 pluginspage=http://www.macromedia.com/shockwave/download/ width=$1 height=$2></embed>")
re.Pattern = "\[QT=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/QT]"
strContent = re.Replace(strContent, "<embed src=$3 width=$1 height=$2 autoplay=true loop=false controller=true playeveryframe=false cache=false scale=TOFIT bgcolor=#000000 kioskmode=false targetcache=false pluginspage=http://www.apple.com/quicktime/>")
re.Pattern = "\[MP=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/MP]"
strContent = re.Replace(strContent, "<embed type=application/x-oleobject codebase=http://activex.microsoft.com/activex/controls/mplayer/en/nsmp2inf.cab#Version=5,1,52,701 flename=mp src=$3 width=$1 height=$2></embed>")
re.Pattern = "\[RM=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/RM]"
strContent = re.Replace(strContent, "<OBJECT classid=clsid:CFCDAA03-8BE4-11cf-B84B-0020AFBBCCFA class=OBJECT id=RAOCX width=$1 height=$2><PARAM NAME=SRC VALUE=$3><PARAM NAME=CONSOLE VALUE=Clip1><PARAM NAME=CONTROLS VALUE=imagewindow><PARAM NAME=AUTOSTART VALUE=true></OBJECT><br><OBJECT classid=CLSID:CFCDAA03-8BE4-11CF-B84B-0020AFBBCCFA height=32 id=video2 width=$1><PARAM NAME=SRC VALUE=$3><PARAM NAME=AUTOSTART VALUE=-1><PARAM NAME=CONTROLS VALUE=controlpanel><PARAM NAME=CONSOLE VALUE=Clip1></OBJECT>")
re.Pattern = "(\[FLASH\])(.[^\[]*)(\[\/FLASH\])"
strContent = re.Replace(strContent, "<embed src="/UploadFiles/2021-04-02/"> re.Pattern = "(\[FLASH=*([0-9]*),*([0-9]*)\])(.[^\[]*)(\[\/FLASH\])"
strContent = re.Replace(strContent, "<embed src="/UploadFiles/2021-04-02/"> re.Pattern = "\[UPLOAD=(gif|jpg|jpeg|bmp|png)\](.[^\[]*)(gif|jpg|jpeg|bmp|png)\[\/UPLOAD\]"
strContent = re.Replace(strContent, "<br><A HREF=""$2$1"" TARGET=_blank><IMG SRC=""$2$1"" border=0 alt=按此在新窗口浏览图片 onload=""javascript:if(this.width>screen.width-333)this.width=screen.width-333""></A>")
re.Pattern = "(\[UPLOAD=(.[^\[]*)\])(.[^\[]*)(\[\/UPLOAD\])"
strContent = re.Replace(strContent, "<br><a href=""$3"">点击浏览该文件</a>")
re.Pattern = "(\[URL\])(.[^\[]*)(\[\/URL\])"
strContent = re.Replace(strContent, "<A HREF=""$2"" TARGET=_blank>$2</A>")
re.Pattern = "(\[URL=(.[^\[]*)\])(.[^\[]*)(\[\/URL\])"
strContent = re.Replace(strContent, "<A HREF=""$2"" TARGET=_blank>$3</A>")
re.Pattern = "(\[EMAIL\])(.[^\[]*)(\[\/EMAIL\])"
strContent = re.Replace(strContent, "<A HREF=""mailto:$2"">$2</A>")
re.Pattern = "(\[EMAIL=(.[^\[]*)\])(.[^\[]*)(\[\/EMAIL\])"
strContent = re.Replace(strContent, "<A HREF=""mailto:$2"" TARGET=_blank>$3</A>")
re.Pattern = "(\[HTML\])(.[^\[]*)(\[\/HTML\])"
strContent = re.Replace(strContent, "<table width='100%' border='0' cellspacing='0' cellpadding='6' bgcolor='#F6F6F6'><td><b>以下内容为程序代码:</b><br>$2</td></table>")
re.Pattern = "(\[code\])(.[^\[]*)(\[\/code\])"
strContent = re.Replace(strContent, "<table width='100%' border='0' cellspacing='0' cellpadding='6' bgcolor='#F6F6F6'><td><b>以下内容为程序代码:</b><br>$2</td></table>")
re.Pattern = "(\[color=(.[^\[]*)\])(.[^\[]*)(\[\/color\])"
strContent = re.Replace(strContent, "<font color=$2>$3</font>")
re.Pattern = "(\[face=(.[^\[]*)\])(.[^\[]*)(\[\/face\])"
strContent = re.Replace(strContent, "<font face=$2>$3</font>")
re.Pattern = "\[align=(center|left|right)\](.*)\[\/align\]"
strContent = re.Replace(strContent, "<div align=$1>$2</div>")
re.Pattern = "(\[QUOTE\])(.*)(\[\/QUOTE\])"
strContent = re.Replace(strContent, "<table cellpadding=0 cellspacing=0 border=1 WIDTH=94% bordercolor=#000000 bgcolor=#F2F8FF align=center ><tr><td ><table width=100% cellpadding=5 cellspacing=1 border=0><TR><TD BGCOLOR='#F6F6F6'>$2</table></table><br>")
re.Pattern = "(\[move\])(.*)(\[\/move\])"
strContent = re.Replace(strContent, "<MARQUEE scrollamount=3>$2</marquee>")
re.Pattern = "\[GLOW=*([0-9]*),*(#*[a-z0-9]*),*([0-9]*)\](.[^\[]*)\[\/GLOW]"
strContent = re.Replace(strContent, "<table width=$1 style=""filter:glow(color=$2, strength=$3)"">$4</table>")
re.Pattern = "\[SHADOW=*([0-9]*),*(#*[a-z0-9]*),*([0-9]*)\](.[^\[]*)\[\/SHADOW]"
strContent = re.Replace(strContent, "<table width=$1 style=""filter:shadow(color=$2, strength=$3)"">$4</table>")
Set re = Nothing
strContent = Replace(strContent, "[InstallDir_ChannelDir]", InstallDir & "/" & ChannelDir)
strContent = Replace(strContent, "{", "{")
strContent = Replace(strContent, "}", "}")
strContent = Replace(strContent, "$", "$")
ReadContent = strContent
End Function
End Class
%>
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 "查询数据的时候发现错误，请检查您的查询代码是否正确。<br /><li>"
Response.Write Command
Response.End
End If
Else
Set Execute = Conn.Execute(Command)
End If
SqlQueryNum = SqlQueryNum+1
End Function
Public Sub ReadConfig()
On Error Resume Next
Name = "Config"
If ObjIsEmpty() Then ReloadConfig
CacheData = Value
'第一次起用系统或者重启IIS的时候加载缓存
Name = "Date"
If ObjIsEmpty() Then
Value = Date
Else
If CStr(Value) <> CStr(Date) Then
Name = "Config"
Call ReloadConfig
CacheData = Value
End If
End If
SiteName = CacheData(1, 0): SiteUrl = CacheData(2, 0): MasterMail = CacheData(3, 0): keywords = CacheData(4, 0): Copyright = CacheData(5, 0): InstallDir = CacheData(6, 0)
IndexName = CacheData(7, 0): IstopSite = CacheData(8, 0): StopReadme = CacheData(9, 0): IsCloseMail = CacheData(10, 0): SendMailType = CacheData(11, 0): MailFrom = CacheData(12, 0)
MailServer = CacheData(13, 0): MailUserName = CacheData(14, 0): MailPassword = CacheData(15, 0): CheckUserReg = CacheData(16, 0): AdminCheckReg = CacheData(17, 0): MailInformPass = CacheData(18, 0)
ChkSameMail = CacheData(19, 0): AddUserPoint = CacheData(20, 0): SendRegMessage = CacheData(21, 0): FullContQuery = CacheData(22, 0): ActionTime = CacheData(23, 0): IsRunTime = CacheData(24, 0)
UploadClass = CacheData(25, 0): UploadFileSize = CacheData(26, 0): UploadFileType = CacheData(27, 0): ContentKeyword = CacheData(28, 0): StopApplyLink = CacheData(29, 0): FSO_ScriptName = CacheData(30, 0)
InitTitleColor = CacheData(31, 0): StopBankPay = CacheData(32, 0): ChinaeBank = CacheData(33, 0): VersionID = CacheData(34, 0): Badwords = CacheData(35, 0): Badwordr = CacheData(36, 0)
serialcode = CacheData(37, 0): passedcode = CacheData(38, 0) : PreviewSetting = CacheData(39, 0)
ThisEdition = "免费版 (Free Edition)"
Version = "Powered by：<a href=""http://www.newasp.net"" target=""_blank"" class=""navmenu"">NewCloud SiteManageSystem Version 2.0.0 SP1</a>"
CopyrightStr = "<!--" & vbCrLf
CopyrightStr = CopyrightStr & "┌─────────────────NEWASP──┐" & vbCrLf
CopyrightStr = CopyrightStr & "│NewCloud SiteManageSystem Version 2.0.0 SP1 │" & vbCrLf
CopyrightStr = CopyrightStr & "│版权所有: 新云网络 (newasp.net) │" & vbCrLf
CopyrightStr = CopyrightStr & "│官方主页: http://www.newasp.net │" & vbCrLf
CopyrightStr = CopyrightStr & "│论坛地址: http://bbs.newasp.net │" & vbCrLf
CopyrightStr = CopyrightStr & "│E-Mail: webenvoy@163.com QQ: 94022511 │" & vbCrLf
CopyrightStr = CopyrightStr & "└────────────────────.NET┘" & vbCrLf
CopyrightStr = CopyrightStr & "-->" & vbCrLf
If CInt(IstopSite) = 1 And Not Admin_Page Then Response.Redirect ("" & SiteUrl & InstallDir & "showerr.asp?action=stop")
End Sub
Public Sub ReloadConfig()
Dim SQL, Rs
On Error Resume Next
SQL = "SELECT * from [NC_Config] "
Set Rs = Execute(SQL)
Value = Rs.GetRows(1)
Set Rs = Nothing
End Sub
'=============================================================
'过程名：ReloadChannel
'作 用：再装频道设置
'参 数：ChannelID ----频道ID
'=============================================================
Private Sub ReloadChannel(ChannelID)
Dim SQL, Rs
On Error Resume Next
SQL = "SELECT ChannelID,ChannelName,ChannelDir,StopChannel,ChannelType,modules,ModuleName,BindDomain,DomainName,ChannelSkin,HtmlPath,HtmlForm,IsCreateHtml,HtmlExtName,HtmlPrefix,StopUpload,MaxFileSize,UpFileType,IsAuditing,AppearGrade,PostGrade,LeastString,MaxString,PaginalNum,LeastHotHist,Channel_Setting from NC_Channel where ChannelType <= 1 And ChannelID = " & CLng(ChannelID)
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
Response.Write "错误的频道参数！"
Exit Sub
End If
Value = Rs.GetRows(1)
Set Rs = Nothing
End Sub
'=============================================================
'过程名：ReadChannel
'作 用：读取频道设置
'参 数：ChannelID ----频道ID
'=============================================================
Public Sub ReadChannel(ChannelID)
On Error Resume Next
If Not IsNumeric(ChannelID) Then ChannelID = 1
ChannelID = Clng(ChannelID)
Name = "Channel" & ChannelID
If ObjIsEmpty() Then Call ReloadChannel(ChannelID)
CacheChannel = Value
If CLng(CacheChannel(0, 0)) <> ChannelID Then
Call ReloadChannel(ChannelID)
CacheChannel = Value
End If
ChannelName = CacheChannel(1, 0): ChannelDir = CacheChannel(2, 0): StopChannel = CacheChannel(3, 0): ChannelType = CacheChannel(4, 0): modules = CacheChannel(5, 0): ModuleName = CacheChannel(6, 0): BindDomain = CacheChannel(7, 0): DomainName = CacheChannel(8, 0): ChannelSkin = CacheChannel(9, 0): HtmlPath = CacheChannel(10, 0)
HtmlForm = CacheChannel(11, 0): IsCreateHtml = CacheChannel(12, 0): HtmlExtName = CacheChannel(13, 0): HtmlPrefix = CacheChannel(14, 0): StopUpload = CacheChannel(15, 0): MaxFileSize = CacheChannel(16, 0): UpFileType = CacheChannel(17, 0): IsAuditing = CacheChannel(18, 0): AppearGrade = CacheChannel(19, 0)
PostGrade = CacheChannel(20, 0): LeastString = CacheChannel(21, 0): MaxString = CacheChannel(22, 0): PaginalNum = CacheChannel(23, 0): LeastHotHist = CacheChannel(24, 0): Channel_Setting = CacheChannel(25, 0)
If CInt(StopChannel) = 1 And Not Admin_Page Then Response.Redirect (InstallDir & "showerr.asp?action=ChanStop")
End Sub
Public Sub LoadChannel(chanid)
On Error Resume Next
Dim Rs,SQL,tmpdata
chanid = CLng(chanid)
Name = "MyChannel" & chanid
If ObjIsEmpty() Then
SQL = "SELECT ChannelName,ChannelDir,ModuleName,HtmlPath,HtmlForm,IsCreateHtml,HtmlExtName,HtmlPrefix,StopUpload,LeastString,MaxString,LeastHotHist FROM NC_Channel WHERE ChannelType<=1 And ChannelID= " & Clng(chanid)
Set Rs = Execute(SQL)
tmpdata = Rs.GetString(, , "|||", "@@@", "")
tmpdata = Left(tmpdata, Len(tmpdata) - 3)
Set Rs = Nothing
Value = tmpdata
End If
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), "<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, 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), "<br /> ")
fString = Replace(fString, " ", " ")
HTMLEncodes = fString
End If
End Function
'=============================================================
'函数作用：判断发言是否来自外部
'=============================================================
Public Function CheckPost()
On Error Resume Next
Dim server_v1, server_v2
CheckPost = False
server_v1 = CStr(Request.ServerVariables("HTTP_REFERER"))
server_v2 = CStr(Request.ServerVariables("SERVER_NAME"))
If Mid(server_v1, 8, Len(server_v2)) = server_v2 Then
CheckPost = True
End If
End Function
'=============================================================
'函数作用：判断来源URL是否来自外部
'=============================================================
Public Function CheckOuterUrl()
On Error Resume Next
Dim server_v1, server_v2
server_v1 = Replace(LCase(Trim(Request.ServerVariables("HTTP_REFERER"))), "http://", "")
server_v2 = LCase(Trim(Request.ServerVariables("SERVER_NAME")))
If server_v1 <> "" And Left(server_v1, Len(server_v2)) <> server_v2 Then
CheckOuterUrl = False
Else
CheckOuterUrl = True
End If
End Function
'================================================
'函数名：GotTopic
'作 用：显示字符串长度
'参 数：str ----原字符串
' strlen ----显示字符长度
'================================================
Public Function GotTopic(ByVal str, ByVal strLen)
Dim l, t, c, i
Dim strTemp
On Error Resume Next
str = Trim(str)
str = Replace(str, " ", " ")
str = Replace(str, ">", ">")
str = Replace(str, "<", "<")
str = Replace(str, ">", ">")
str = Replace(str, "<", "<")
str = Replace(str, "'", "'")
str = Replace(str, """, Chr(34))
str = Replace(str, vbNewLine, "")
l = Len(str)
t = 0
For i = 1 To l
c = Abs(Asc(Mid(str, i, 1)))
If c > 255 Then
t = t + 2
Else
t = t + 1
End If
If t >= strLen Then
strTemp = Left(str, i) & "..."
Exit For
Else
strTemp = str & " "
End If
Next
GotTopic = CheckTopic(strTemp)
End Function
Public Function CheckTopic(ByVal strContent)
Dim re
On Error Resume Next
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(<s+cript(.+?)<\/s+cript>)"
strContent = re.Replace(strContent, "")
re.Pattern = "(<iframe(.+?)<\/iframe>)"
strContent = re.Replace(strContent, "")
re.Pattern = "(>)"
strContent = re.Replace(strContent, ">")
re.Pattern = "(<)"
strContent = re.Replace(strContent, "<")
Set re = Nothing
strContent = Replace(strContent, ">", ">")
strContent = Replace(strContent, "<", "<")
strContent = Replace(strContent, "'", "'")
strContent = Replace(strContent, Chr(34), """)
strContent = Replace(strContent, "%", "％")
strContent = Replace(strContent, vbNewLine, "")
CheckTopic = Trim(strContent)
End Function
'================================================
'函数名：ReadTopic
'作 用：显示字符串长度
'参 数：str ----原字符串
' strlen ----显示字符长度
'================================================
Public Function ReadTopic(ByVal str, ByVal strLen)
Dim l, t, c, i
On Error Resume Next
str = Replace(str, " ", " ")
If Len(str) < strLen Then
str = str & String(strLen - Len(str), ".")
Else
str = str
End If
l = Len(str)
t = 0
For i = 1 To l
c = Abs(Asc(Mid(str, i, 1)))
If c > 255 Then
t = t + 2
Else
t = t + 1
End If
If t >= strLen Then
ReadTopic = Left(str, i) & "..."
Exit For
Else
ReadTopic = str & "..."
End If
Next
End Function
'================================================
'函数名：strLength
'作 用：计字符串长度
'参 数：str ----字符串
'================================================
Public Function strLength(ByVal str)
On Error Resume Next
If IsNull(str) Or str = "" Then
strLength = 0
Exit Function
End If
Dim WINNT_CHINESE
WINNT_CHINESE = (Len("例子") = 2)
If WINNT_CHINESE Then
Dim l, t
Dim i, c
l = Len(str)
t = l
For i = 1 To l
c = Asc(Mid(str, i, 1))
If c < 0 Then c = c + 65536
If c > 255 Then t = t + 1
Next
strLength = t
Else
strLength = Len(str)
End If
End Function
'=================================================
'函数名：isInteger
'作 用：判断数字是否整型
'参 数：para ----参数
'=================================================
Public Function isInteger(ByVal para)
On Error Resume Next
Dim str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
str = CStr(para)
If Trim(str) = "" Then
isInteger = False
Exit Function
End If
l = Len(str)
For i = 1 To l
If Mid(str, i, 1) > "9" Or Mid(str, i, 1) < "0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number <> 0 Then Err.Clear
End Function
Public Function CutString(ByVal str, ByVal strLen)
On Error Resume Next
Dim HtmlStr, l, re, strContent
HtmlStr = str
HtmlStr = Replace(HtmlStr, " ", " ")
HtmlStr = Replace(HtmlStr, """, Chr(34))
HtmlStr = Replace(HtmlStr, "'", Chr(39))
HtmlStr = Replace(HtmlStr, "{", Chr(123))
HtmlStr = Replace(HtmlStr, "}", Chr(125))
HtmlStr = Replace(HtmlStr, "$", Chr(36))
HtmlStr = Replace(HtmlStr, vbCrLf, "")
HtmlStr = Replace(HtmlStr, "====", "")
HtmlStr = Replace(HtmlStr, "----", "")
HtmlStr = Replace(HtmlStr, "////", "")
HtmlStr = Replace(HtmlStr, "\\\\", "")
HtmlStr = Replace(HtmlStr, "####", "")
HtmlStr = Replace(HtmlStr, "@@@@", "")
HtmlStr = Replace(HtmlStr, "****", "")
HtmlStr = Replace(HtmlStr, "~~~~", "")
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "\[br\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "\[align=right\](.*)\[\/align\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "<(.[^>]*)>"
HtmlStr = re.Replace(HtmlStr, "")
Set re = Nothing
HtmlStr = Replace(HtmlStr, ">", ">")
HtmlStr = Replace(HtmlStr, "<", "<")
l = Len(HtmlStr)
If l >= strLen Then
strContent = Left(HtmlStr, strLen) & "..."
Else
strContent = HtmlStr & " "
End If
strContent = Replace(strContent, Chr(34), """)
strContent = Replace(strContent, Chr(39), "'")
strContent = Replace(strContent, Chr(36), "$")
strContent = Replace(strContent, Chr(123), "{")
strContent = Replace(strContent, Chr(125), "}")
strContent = Replace(strContent, ">", ">")
strContent = Replace(strContent, "<", "<")
CutString = strContent
End Function
'================================================
'函数名：CheckInfuse
'作 用：防止SQL注入
'参 数：str ----原字符串
' strLen ----提交字符串长度
'================================================
Public Function CheckInfuse(ByVal str, ByVal strLen)
Dim strUnsafe, arrUnsafe
Dim i
If Trim(str) = "" Then
CheckInfuse = ""
Exit Function
End If
str = Left(str, strLen)
On Error Resume Next
strUnsafe = "'|^|;|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
If Trim(str) <> "" Then
If Len(str) > strLen Then
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n您提交的字符数超过了限制！');history.back(-1)</Script>"
CheckInfuse = ""
Response.End
End If
arrUnsafe = Split(strUnsafe, "|")
For i = 0 To UBound(arrUnsafe)
If InStr(1, str, arrUnsafe(i), 1) > 0 Then
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
CheckInfuse = ""
Response.End
End If
Next
End If
CheckInfuse = Trim(str)
Exit Function
If Err.Number <> 0 Then
Err.Clear
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
CheckInfuse = ""
Response.End
End If
End Function
Public Sub PreventInfuse()
On Error Resume Next
Dim SQL_Nonlicet, arrNonlicet
Dim PostRefer, GetRefer, Sql_DATA
SQL_Nonlicet = "'|;|^|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
arrNonlicet = Split(SQL_Nonlicet, "|")
If Request.Form <> "" Then
For Each PostRefer In Request.Form
For Sql_DATA = 0 To UBound(arrNonlicet)
If InStr(1, Request.Form(PostRefer), arrNonlicet(Sql_DATA), 1) > 0 Then
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
Response.End
End If
Next
Next
End If
If Request.QueryString <> "" Then
For Each GetRefer In Request.QueryString
For Sql_DATA = 0 To UBound(arrNonlicet)
If InStr(1, Request.QueryString(GetRefer), arrNonlicet(Sql_DATA), 1) > 0 Then
Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
Response.End
End If
Next
Next
End If
End Sub
'================================================
'函数名：ChkQueryStr
'作 用：过虑查询的非法字符
'参 数：str ----原字符串
'返回值：过滤后的字符
'================================================
Public Function ChkQueryStr(ByVal str)
On Error Resume Next
If IsNull(str) Then
ChkQueryStr = ""
Exit Function
End If
str = Replace(str, "!", "")
str = Replace(str, "]", "")
str = Replace(str, "[", "")
str = Replace(str, ")", "")
str = Replace(str, "(", "")
str = Replace(str, "|", "")
str = Replace(str, "+", "")
str = Replace(str, "=", "")
str = Replace(str, "'", "''")
str = Replace(str, "%", "")
str = Replace(str, "&", "")
str = Replace(str, "#", "")
str = Replace(str, "^", "")
str = Replace(str, " ", " ")
str = Replace(str, Chr(37), "")
str = Replace(str, Chr(0), "")
ChkQueryStr = str
End Function
'================================================
'过程名：CheckQuery
'作 用：限制搜索的关键字
'参 数：str ----搜索的字符串
'返回值：True; False
'================================================
Public Function CheckQuery(ByVal str)
Dim FobWords, i, keyword
keyword = str
On Error Resume Next
FobWords = Array(91, 92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12532, 12533, 65339, 65340)
For i = 1 To UBound(FobWords, 1)
If InStr(keyword, ChrW(FobWords(i))) > 0 Then
CheckQuery = False
Exit Function
End If
Next
FobWords = Array("~", "!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "_", "+", "=", "`", "[", "]", "{", "}", ";", ":", """", "'", "<", ">", ".", "/", "\", "|", "?", "about", "after", "all", "also", "an", "and", "another", "any", "are", "as", "at", "be", "because", "been", "before", "being", "between", "both", "but", "by", "came", "can", "come", "could", "did", "do", "each", "for", "from", "get", "got", "had", "has", "have", "he", "her", "here", "him", "himself", "his", "how", "if", "in", "into", "is", "it", "like", "make", "many", "me", "might", "more", "most", "much", "must", "my", "never", "now", "of", "on", "only", "or", "other", "our", "out", "over", "said", "same", "see", "should", "since", "some", "still", "such", "take", "than", "that", "the", "their", "them", "then", "there", "these", "they", "this")
keyword = Left(keyword, 100)
keyword = Replace(keyword, "!", " ")
keyword = Replace(keyword, "]", " ")
keyword = Replace(keyword, "[", " ")
keyword = Replace(keyword, ")", " ")
keyword = Replace(keyword, "(", " ")
keyword = Replace(keyword, " ", " ")
keyword = Replace(keyword, "-", " ")
keyword = Replace(keyword, "/", " ")
keyword = Replace(keyword, "+", " ")
keyword = Replace(keyword, "=", " ")
keyword = Replace(keyword, ",", " ")
keyword = Replace(keyword, "'", " ")
For i = 0 To UBound(FobWords, 1)
If keyword = FobWords(i) Then
CheckQuery = False
Exit Function
End If
Next
CheckQuery = True
End Function
'================================================
'函数名：IsValidStr
'作 用：判断字符串中是否含有非法字符
'参 数：str ----原字符串
'返回值：False,True -----布尔值
'================================================
Public Function IsValidStr(ByVal str)
IsValidStr = False
On Error Resume Next
If IsNull(str) Then Exit Function
If Trim(str) = Empty Then Exit Function
Dim ForbidStr, i
ForbidStr = "and|chr|:|=|%|&|$|#|@|+|-|*|/|\|<|>|;|,|^|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9)
ForbidStr = Split(ForbidStr, "|")
For i = 0 To UBound(ForbidStr)
If InStr(1,str, ForbidStr(i),1) > 0 Then
IsValidStr = False
Exit Function
End If
Next
IsValidStr = True
End Function
'================================================
'函数名：IsValidPassword
'作 用：判断密码中是否含有非法字符
'参 数：str ----原字符串
'返回值：False,True -----布尔值
'================================================
Public Function IsValidPassword(ByVal str)
IsValidPassword = False
On Error Resume Next
If IsNull(str) Then Exit Function
If Trim(str) = Empty Then Exit Function
Dim ForbidStr, i
ForbidStr = "=and|chr|*|^|%|&|;|,|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9)
ForbidStr = Split(ForbidStr, "|")
For i = 0 To UBound(ForbidStr)
If InStr(1, str, ForbidStr(i), 1) > 0 Then
IsValidPassword = False
Exit Function
End If
Next
IsValidPassword = True
End Function
'================================================
'函数名：IsValidChar
'作 用：判断字符串中是否含有非法字符和中文
'参 数：str ----原字符串
'返回值：False,True -----布尔值
'================================================
Public Function IsValidChar(ByVal str)
IsValidChar = False
On Error Resume Next
If IsNull(str) Then Exit Function
If Trim(str) = Empty Then Exit Function
Dim ValidStr
Dim i, l, s, c
ValidStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ.-_:~\/0123456789"
l = Len(str)
s = UCase(str)
For i = 1 To l
c = Mid(s, i, 1)
If InStr(ValidStr, c) = 0 Then
IsValidChar = False
Exit Function
End If
Next
IsValidChar = True
End Function
'================================================
'函数名：FormatDate
'作 用：格式化日期
'参 数：DateAndTime ----原日期和时间
' para ----日期格式
'返回值：格式化后的日期
'================================================
Public Function FormatDate(DateAndTime, para)
On Error Resume Next
Dim y, m, d, h, mi, s, strDateTime
FormatDate = DateAndTime
If Not IsNumeric(para) Then Exit Function
If Not IsDate(DateAndTime) Then Exit Function
y = CStr(Year(DateAndTime))
m = CStr(Month(DateAndTime))
If Len(m) = 1 Then m = "0" & m
d = CStr(Day(DateAndTime))
If Len(d) = 1 Then d = "0" & d
h = CStr(Hour(DateAndTime))
If Len(h) = 1 Then h = "0" & h
mi = CStr(Minute(DateAndTime))
If Len(mi) = 1 Then mi = "0" & mi
s = CStr(Second(DateAndTime))
If Len(s) = 1 Then s = "0" & s
Select Case para
Case "1"
strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
Case "2"
strDateTime = y & "-" & m & "-" & d
Case "3"
strDateTime = y & "/" & m & "/" & d
Case "4"
strDateTime = y & "年" & m & "月" & d & "日"
Case "5"
strDateTime = m & "-" & d
Case "6"
strDateTime = m & "/" & d
Case "7"
strDateTime = m & "月" & d & "日"
Case "8"
strDateTime = y & "年" & m & "月"
Case "9"
strDateTime = y & "-" & m
Case "10"
strDateTime = y & "/" & m
Case Else
strDateTime = DateAndTime
End Select
FormatDate = strDateTime
End Function
'================================================
'函数名：ReadFontMode
'作 用：读取字体模式
'参 数：str ----原字符串
' vColor -----颜色的值
' vFont -----字体的值
'返回值：新字符串
'================================================
Public Function ReadFontMode(str, vColor, vFont)
Dim FontStr, tColor
Dim ColorStr, arrColor
If IsNull(str) Then
ReadFontMode = ""
Exit Function
End If
ReadFontMode = str
On Error Resume Next
If Not IsNumeric(vColor) Then Exit Function
If Not IsNumeric(vFont) Then Exit Function
Select Case CInt(vFont)
Case 1
FontStr = "<b>" & str & "</b>"
Case 2
FontStr = "<em>" & str & "</em>"
Case 3
FontStr = "<u>" & str & "</u>"
Case 4
FontStr = "<b><em>" & str & "</em></b>"
Case 5
FontStr = "<b><u>" & str & "</u></b>"
Case 6
FontStr = "<em><u>" & str & "</u></em>"
Case 7
FontStr = "<b><em><u>" & str & "</u></em></b>"
Case Else
FontStr = str
End Select
ReadFontMode = FontStr
If vColor = "" Or vColor = 0 Then Exit Function
ColorStr = "," & InitTitleColor
arrColor = Split(ColorStr, ",")
If vColor > UBound(arrColor) Then Exit Function
tColor = Trim(arrColor(vColor))
ReadFontMode = "<font color=" & tColor & ">" & FontStr & "</font>"
End Function
'=============================================================
'函数名：ShowDateTime
'作 用：读取日期格式
'参 数：DateAndTime ---- 当前时间
' para ---- 时间格式
'=============================================================
Public Function ShowDateTime(DateAndTime, para)
ShowDateTime = ""
Dim strDate
If Not IsDate(DateAndTime) Then Exit Function
If DateAndTime >= Date Then
strDate = "<font color='" & Main_Setting(1) & "'>"
strDate = strDate & FormatDate(DateAndTime, para)
strDate = strDate & "</font>"
Else
strDate = "<font color='" & Main_Setting(2) & "'>"
strDate = strDate & FormatDate(DateAndTime, para)
strDate = strDate & "</font>"
End If
ShowDateTime = strDate
End Function
Public Function ShowDatePath(strval, n)
ShowDatePath = ""
If Trim(strval) = "" Then Exit Function
Dim strTempPath, strTime
Dim y, m, d
strTime = Left(strval, 8)
y = Left(strTime, 4)
m = Mid(strTime, 5, 2)
d = Right(strTime, 2)
Select Case CInt(n)
Case 1
strTempPath = y & "/" & m & "/" & d & "/"
Case 2
strTempPath = y & "/" & m & "/"
Case 3
strTempPath = y & m & "/"
Case 4
strTempPath = y & "/"
Case 5
strTempPath = y & "-" & m & "-" & d & "/"
Case 6
strTempPath = y & "-" & m & "/"
Case 7
strTempPath = "html/"
Case 8
strTempPath = "show/"
Case Else
strTempPath = ""
End Select
strTempPath = Replace(strTempPath, " ", "")
ShowDatePath = CStr(strTempPath)
End Function
'=============================================================
'函数名：ReadBriefTopicffd
'作 用：读取简短标题
'参 数：para
'返回值：简短标题
'=============================================================
Public Function ReadBriefTopic(ByVal para)
Dim sBriefTopic
ReadBriefTopic = ""
If Not IsNumeric(para) Then Exit Function
If para = 0 Then Exit Function
Select Case para
Case "1"
sBriefTopic = "<font color='blue'>[图文]</font>"
Case "2"
sBriefTopic = "<font color='red'>[组图]</font>"
Case "3"
sBriefTopic = "<font color='green'>[新闻]</font>"
Case "4"
sBriefTopic = "<font color='blue'>[推荐]</font>"
Case "5"
sBriefTopic = "<font color='red'>[注意]</font>"
Case "6"
sBriefTopic = "<font color='green'>[转载]</font>"
Case Else
sBriefTopic = ""
End Select
ReadBriefTopic = sBriefTopic
End Function
'=============================================================
'函数名：ReadPicTopic
'作 用：读取简短标题
'参 数：para
'返回值：简短标题
'=============================================================
Public Function ReadPicTopic(ByVal para)
Dim sBriefTopic
ReadPicTopic = ""
If Not IsNumeric(para) Then Exit Function
If para = 0 Then Exit Function
Select Case para
Case "1"
sBriefTopic = "<font color='" & Main_Setting(4) & "'>[图文]</font>"
Case "2"
sBriefTopic = "<font color='" & Main_Setting(5) & "'>[组图]</font>"
Case "3"
sBriefTopic = "<font color='" & Main_Setting(6) & "'>[新闻]</font>"
Case "4"
sBriefTopic = "<font color='" & Main_Setting(4) & "'>[推荐]</font>"
Case "5"
sBriefTopic = "<font color='" & Main_Setting(5) & "'>[注意]</font>"
Case "6"
sBriefTopic = "<font color='" & Main_Setting(6) & "'>[转载]</font>"
Case Else
sBriefTopic = ""
End Select
ReadPicTopic = sBriefTopic
End Function
'=============================================================
'函数名：ReadPayMoney
'作 用：读取要支付的金钱
'参 数：money ----实际金钱
'返回值：加上手续费后的金钱
'=============================================================
Public Function ReadPayMoney(ByVal money, ByVal Reduce)
On Error Resume Next
If money = 0 Then
ReadPayMoney = 0
Exit Function
End If
Dim arrChinaeBank, valPercent, Percents
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 = "<embed src="/UploadFiles/2021-04-02/"> Else
strTemp = "<img src=""> End If
GetFlashAndPic = strTemp
End Function
'================================================
'函数名：ReadFileUrl
'作 用：读取文件URL
'================================================
Public Function ReadFileUrl(url)
On Error Resume Next
ReadFileUrl = ""
If url = "" Then Exit Function
Dim strTemp
If CheckUrl(url) = 1 Then
strTemp = Trim(url)
ElseIf CheckUrl(url) = 2 Then
strTemp = Trim(url)
Else
strTemp = Replace(url, "../", "")
strTemp = Trim(InstallDir & strTemp)
End If
ReadFileUrl = strTemp
End Function
Public Function CheckUrl(ByVal url)
Dim strUrl
If Left(url, 1) = "/" Then
CheckUrl = 1
Exit Function
End If
strUrl = LCase(Left(url, 6))
Select Case Trim(strUrl)
Case "http:/", "https:", "ftp://", "rtsp:/", "mms://"
CheckUrl = 2
Exit Function
Case Else
CheckUrl = 0
End Select
End Function
'================================================
'函数名：ReadFileName
'作 用：读取HTML文件名
'参 数：strname ----文件名称
' id ----数据ID
' ExtName ----HTML扩展名
' PrefixStr ----HTML名称前缀
' HtmlForm ----HTML文件格式
' n ----HTML分页
'================================================
Public Function ReadFileName(ByVal strname, ByVal id, ByVal ExtName, ByVal PrefixStr, ByVal HtmlForm, ByVal n)
Dim strFileName, strExtName, CurrentPage
If Trim(strname) = "" Then Exit Function
If Trim(ExtName) = "" Then ExtName = ".html"
If Not IsNumeric(n) Then n = 0
On Error Resume Next
If CInt(n) <= 1 Then
CurrentPage = ""
Else
CurrentPage = "_" & n
End If
If Left(ExtName, 1) <> "." Then
strExtName = "." & Trim(ExtName)
Else
strExtName = Trim(ExtName)
End If
Select Case Trim(HtmlForm)
Case "1"
strFileName = Trim(id)
Case "2"
strFileName = Trim(PrefixStr) & Trim(Supplemental(id, 3))
Case "3"
strFileName = Left(strname, 8)
strFileName = strFileName & Trim(Supplemental(id, 3))
Case "4"
strFileName = Right(strname, 7)
strFileName = strFileName & Trim(Supplemental(id, 3))
Case Else
strFileName = strname
End Select
strFileName = Replace(strFileName & CurrentPage & strExtName, " ", "")
ReadFileName = CStr(strFileName)
End Function
'================================================
'过程名：HtmlRndFileName
'作 用：取HTML的随机文件名
'================================================
Function HtmlRndFileName()
Dim sRnd
Randomize
sRnd = Int(90 * Rnd) + 10
HtmlRndFileName = Replace(Replace(Replace(FormatDate(Now(), 1), "-", ""), ":", ""), " ", "") & sRnd
End Function
'================================================
'函数名：ClassFileName
'作 用：读取HTML文件列表名
'参 数：ClassID ----分类ID
'================================================
Public Function ClassFileName(ByVal ClassID, ByVal ExtName, ByVal PrefixStr, ByVal n)
Dim strFileName, strExtName, strClassID
If Trim(ExtName) = "" Then ExtName = ".html"
If Not IsNumeric(n) Then n = 0
If Left(ExtName, 1) <> "." Then
strExtName = "." & Trim(ExtName)
Else
strExtName = Trim(ExtName)
End If
If CInt(n) <= 1 Then
strFileName = "index" & strExtName
Else
strClassID = Supplemental(ClassID, 3)
strFileName = PrefixStr & strClassID & "_" & n & strExtName
End If
strFileName = Replace(strFileName, " ", "")
ClassFileName = CStr(strFileName)
End Function
'================================================
'函数名：SpecialFileName
'作 用：读取专题HTML文件名
'参 数：specid ----专题ID
'================================================
Public Function SpecialFileName(ByVal specid, ByVal ExtName, ByVal n)
Dim strFileName, strExtName, strSpecialID
If Trim(ExtName) = "" Then ExtName = ".html"
If Not IsNumeric(n) Then n = 0
If Left(ExtName, 1) <> "." Then
strExtName = "." & Trim(ExtName)
Else
strExtName = Trim(ExtName)
End If
If CInt(n) <= 1 Then
strFileName = "index" & strExtName
Else
strSpecialID = Supplemental(specid, 3)
strFileName = "Special" & strSpecialID & "_" & n & strExtName
End If
strFileName = Replace(strFileName, " ", "")
SpecialFileName = CStr(strFileName)
End Function
'================================================
'函数名：ChannelMenu
'作 用：显示频道菜单
'================================================
Public Function ChannelMenu()
Dim SQL, Rs, i, TotalNumber,strTop
Dim strContent, LinkTarget, ChannelName
Dim ChannelUrl, HtmlContent, sCaption
Name = "ChannelMenu"
If ObjIsEmpty() Then
If ChkNumeric(Main_Setting(7)) = 0 Then
strTop = vbNullString
Else
strTop = "TOP " & CInt(Main_Setting(7))
End If
SQL = "SELECT " & strTop & " ChannelID,orders,ColorModes,FontModes,ChannelName,Caption,ChannelDir,StopChannel,IsHidden,BindDomain,DomainName,LinkTarget,ChannelType,ChannelUrl,IsHidden FROM [NC_Channel] WHERE IsHidden = 0 Order By orders"
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
strContent = ""
Else
i = 0
TotalNumber = Rs.RecordCount
Do While Not Rs.EOF
i = i + 1
If Rs("LinkTarget") <> 0 Then
LinkTarget = " target=""_blank"""
Else
LinkTarget = ""
End If
HtmlContent = HtmlContent & Main_Setting(9)
ChannelName = ReadFontMode(Rs("ChannelName"), Rs("ColorModes"), Rs("FontModes"))
If Rs("ChannelType") < 2 Then
ChannelUrl = InstallDir & Rs("ChannelDir")
Else
ChannelUrl = Rs("ChannelUrl")
End If
If Rs("StopChannel") <> 0 Then
sCaption = "此频道暂时关闭,不能访问！"
Else
sCaption = Rs("Caption")
End If
strContent = "<a href=""" & ChannelUrl & """" & LinkTarget & " title=""" & sCaption & """ class=navmenu>" & ChannelName & "</a>"
If i Mod CInt(Main_Setting(8)) = 0 Then strContent = strContent & "<br>"
HtmlContent = Replace(HtmlContent, "{$ChannelMenu}", strContent)
Rs.MoveNext
Loop
End If
Rs.Close: Set Rs = Nothing
'Value = strContent
End If
'strContent = Value
ChannelMenu = HtmlContent
End Function
'=============================================================
'函数名：LoadSelectClass
'作 用：载入缓存下拉分类列表
'参 数：ChannelID ----频道ID
'返回值：下拉分类列表
'=============================================================
Public Function LoadSelectClass(ChannelID)
Dim CacheSelClass, SQL, Rs1, i
Name = "SelectClass" & ChannelID
If ObjIsEmpty() Then
SQL = "select ClassID,ClassName,depth,TurnLink,child from NC_Classify where ChannelID = " & ChannelID & " order by rootid,orders"
Set Rs1 = Execute(SQL)
If Rs1.BOF And Rs1.EOF Then
CacheSelClass = CacheSelClass & "<option>没有添加分类</option>"
End If
Do While Not Rs1.EOF
If Rs1("TurnLink") <> 0 Then
CacheSelClass = CacheSelClass & "<option value=""0"""
Else
If Rs1("depth") = 0 And Rs1("child") <> 0 Then
CacheSelClass = CacheSelClass & "<option"
Else
CacheSelClass = CacheSelClass & "<option value=""" & Rs1("ClassID") & """"
End If
End If
CacheSelClass = CacheSelClass & " {ClassID=" & Rs1("ClassID") & "}>"
If Rs1("depth") = 1 Then CacheSelClass = CacheSelClass & " ├ "
If Rs1("depth") > 1 Then
For i = 2 To Rs1("depth")
CacheSelClass = CacheSelClass & " "
Next
CacheSelClass = CacheSelClass & " ├ "
End If
CacheSelClass = CacheSelClass & Rs1("ClassName") & "</option>" & vbCrLf
Rs1.MoveNext
Loop
Rs1.Close
Set Rs1 = Nothing
Value = CacheSelClass
End If
LoadSelectClass = Value
End Function
Public Function ClassJumpMenu(ChannelID)
Dim CacheJumpMenu
Dim Rs1
Dim i
Name = "ClassJumpMenu" & ChannelID
If ObjIsEmpty() Then
Set Rs1 = Execute("select ClassID,ChannelID,ClassName,depth,TurnLink,TurnLinkUrl from [NC_Classify] where ChannelID = " & ChannelID & " order by rootid,orders")
Do While Not Rs1.EOF
If Rs1("TurnLink") <> 0 Then
CacheJumpMenu = CacheJumpMenu & "<option value=""" & Rs1("TurnLinkUrl") & """ {ClassID=" & Rs1("classid") & "}"
Else
CacheJumpMenu = CacheJumpMenu & "<option value=""?ChannelID=" & Rs1("ChannelID") & "&sortid=" & Rs1("classid") & """ {ClassID=" & Rs1("classid") & "}"
End If
If Trim(Request("sortid")) <> "" Then
If CLng(Request("sortid")) = Rs1("classid") Then CacheJumpMenu = CacheJumpMenu & " selected"
End If
CacheJumpMenu = CacheJumpMenu & ">"
If Rs1("depth") = 1 Then CacheJumpMenu = CacheJumpMenu & " ├ "
If Rs1("depth") > 1 Then
For i = 2 To Rs1("depth")
CacheJumpMenu = CacheJumpMenu & " "
Next
CacheJumpMenu = CacheJumpMenu & " ├ "
End If
CacheJumpMenu = CacheJumpMenu & Rs1("ClassName") & "</option>" & vbCrLf
Rs1.MoveNext
Loop
Rs1.Close
Set Rs1 = Nothing
Value = CacheJumpMenu
End If
ClassJumpMenu = Value
End Function
'================================================
'函数名：GetRandomCode
'作 用：系统分配随机代码
'================================================
Public Function GetRandomCode()
Dim Ran, i, LengthNum
LengthNum = 16
GetRandomCode = ""
For i = 1 To LengthNum
Randomize
Ran = CInt(Rnd * 2)
Randomize
If Ran = 0 Then
Ran = CInt(Rnd * 25) + 97
GetRandomCode = GetRandomCode & UCase(Chr(Ran))
ElseIf Ran = 1 Then
Ran = CInt(Rnd * 9)
GetRandomCode = GetRandomCode & Ran
ElseIf Ran = 2 Then
Ran = CInt(Rnd * 25) + 97
GetRandomCode = GetRandomCode & Chr(Ran)
End If
Next
End Function
'================================================
' 函数名：CodeIsTrue
' 作 用：检查验证码是否正确
'================================================
Public Function CodeIsTrue()
Dim CodeStr
CodeStr = Trim(Request("CodeStr"))
On Error Resume Next
If CStr(Session("GetCode")) = CStr(CodeStr) And CodeStr <> "" Then
CodeIsTrue = True
Session("GetCode") = Empty
Else
CodeIsTrue = False
Session("GetCode") = Empty
End If
End Function
Public Function CheckAdmin(ByVal Flag)
Dim Rs, SQL
Dim i, TempAdmin, AdminFlag, AdminGrade
CheckAdmin = False
On Error Resume Next
SQL = "SELECT AdminGrade,Adminflag FROM NC_Admin WHERE username='" & Replace(Session("AdminName"), "'", "''") & "' And password='" & Replace(Session("AdminPass"), "'", "''") & "' And isLock=0 And id=" & CLng(Session("AdminID"))
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
CheckAdmin = False
Set Rs = Nothing
Exit Function
Else
AdminFlag = Rs("Adminflag")
AdminGrade = Rs("AdminGrade")
End If
Rs.Close: Set Rs = Nothing
If CInt(AdminGrade) = 999 Then
CheckAdmin = True
Exit Function
Else
If Trim(Flag) = "" Then Exit Function
If AdminFlag = "" Then
CheckAdmin = False
Exit Function
Else
TempAdmin = Split(AdminFlag, ",")
For i = 0 To UBound(TempAdmin)
If Trim(LCase(TempAdmin(i))) = Trim(LCase(Flag)) Then
CheckAdmin = True
Exit For
End If
Next
End If
End If
End Function
'================================================
'函数名：ReadAlpha
'作 用：读取字符串的第一个字母
'参 数：str ----字符
'返回值：返回第一个字母
'================================================
Public Function ReadAlpha(ByVal str)
Dim strTemp
If IsNull(str) Or Trim(str) = "" Then
ReadAlpha = "A-9"
Exit Function
End If
str = Trim(str)
strTemp = 65536 + Asc(str)
If (strTemp >= 45217 And strTemp <= 45252) Or (strTemp = 65601) Or (strTemp = 65633) Or (strTemp = 37083) Then
ReadAlpha = "A-Z"
ElseIf (strTemp >= 45253 And strTemp <= 45760) Or (strTemp = 65602) Or (strTemp = 65634) Or (strTemp = 39658) Then
ReadAlpha = "B-Z"
ElseIf (strTemp >= 45761 And strTemp <= 46317) Or (strTemp = 65603) Or (strTemp = 65635) Or (strTemp = 33405) Then
ReadAlpha = "C-Z"
ElseIf (strTemp >= 46318 And strTemp <= 46930) Or (strTemp >= 61884 And strTemp <= 61884) Or (strTemp = 65604) Or (strTemp >= 36820 And strTemp <= 38524) Or (strTemp = 65636) Then
ReadAlpha = "D-Z"
ElseIf (strTemp >= 46931 And strTemp <= 47009) Or (strTemp = 65605) Or (strTemp = 65637) Or (strTemp = 61513) Then
ReadAlpha = "E-Z"
ElseIf (strTemp >= 47010 And strTemp <= 47296) Or (strTemp = 65606) Or (strTemp = 65638) Or (strTemp = 61320) Or (strTemp = 63568) Or (strTemp = 36281) Then
ReadAlpha = "F-Z"
ElseIf (strTemp >= 47297 And strTemp <= 47613) Or (strTemp = 65607) Or (strTemp = 65639) Or (strTemp = 35949) Or (strTemp = 36089) Or (strTemp = 36694) Or (strTemp = 34808) Then
ReadAlpha = "G-Z"
ElseIf (strTemp >= 47614 And strTemp <= 48118) Or (strTemp >= 59112 And strTemp <= 59112) Or (strTemp = 65608) Or (strTemp = 65640) Then
ReadAlpha = "H-Z"
ElseIf (strTemp = 65641) Or (strTemp = 65609) Or (strTemp = 65641) Then
ReadAlpha = "I-Z"
ElseIf (strTemp >= 48119 And strTemp <= 49061 And strTemp <> 48739) Or (strTemp >= 62430 And strTemp <= 62430) Or (strTemp = 65610) Or (strTemp = 65642) Or (strTemp = 39048) Then
ReadAlpha = "J-Z"
ElseIf (strTemp >= 49062 And strTemp <= 49323) Or (strTemp = 65611) Or (strTemp = 65643) Then
ReadAlpha = "K-Z"
ElseIf (strTemp >= 49324 And strTemp <= 49895) Or (strTemp >= 58838 And strTemp <= 58838) Or (strTemp = 65612) Or (strTemp = 65644) Or (strTemp = 62418) Or (strTemp = 48739) Then
ReadAlpha = "L-Z"
ElseIf (strTemp >= 49896 And strTemp <= 50370) Or (strTemp = 65613) Or (strTemp = 65645) Then
ReadAlpha = "M-Z"
ElseIf (strTemp >= 50371 And strTemp <= 50613) Or (strTemp = 65614) Or (strTemp = 65646) Then
ReadAlpha = "N-Z"
ElseIf (strTemp >= 50614 And strTemp <= 50621) Or (strTemp = 65615) Or (strTemp = 65647) Then
ReadAlpha = "O-Z"
ElseIf (strTemp >= 50622 And strTemp <= 50905) Or (strTemp = 65616) Or (strTemp = 65648) Then
ReadAlpha = "P-Z"
ElseIf (strTemp >= 50906 And strTemp <= 51386) Or (strTemp >= 62659 And strTemp <= 63172) Or (strTemp = 65617) Or (strTemp = 65649) Then
ReadAlpha = "Q-Z"
ElseIf (strTemp >= 51387 And strTemp <= 51445) Or (strTemp = 65618) Or (strTemp = 65650) Then
ReadAlpha = "R-Z"
ElseIf (strTemp >= 51446 And strTemp <= 52217) Or (strTemp = 65619) Or (strTemp = 65651) Or (strTemp = 34009) Then
ReadAlpha = "S-Z"
ElseIf (strTemp >= 52218 And strTemp <= 52697) Or (strTemp = 65620) Or (strTemp = 65652) Then
ReadAlpha = "T-Z"
ElseIf (strTemp = 65621) Or (strTemp = 65653) Then
ReadAlpha = "U-Z"
ElseIf (strTemp = 65622) Or (strTemp = 65654) Then
ReadAlpha = "V-Z"
ElseIf (strTemp >= 52698 And strTemp <= 52979) Or (strTemp = 65623) Or (strTemp = 65655) Then
ReadAlpha = "W-Z"
ElseIf (strTemp >= 52980 And strTemp <= 53688) Or (strTemp = 65624) Or (strTemp = 65656) Then
ReadAlpha = "X-Z"
ElseIf (strTemp >= 53689 And strTemp <= 54480) Or (strTemp = 65625) Or (strTemp = 65657) Then
ReadAlpha = "Y-Z"
ElseIf (strTemp >= 54481 And strTemp <= 62383 And strTemp <> 59112 And strTemp <> 58838) Or (strTemp = 65626) Or (strTemp = 65658) Or (strTemp = 38395) Or (strTemp = 39783) Then
ReadAlpha = "Z-Z"
Else
ReadAlpha = "A-9"
End If
If (strTemp >= 65633 And strTemp <= 65658) Or (strTemp >= 65601 And strTemp <= 65626) Then ReadAlpha = UCase(Left(str, 1))
If (strTemp >= 65584 And strTemp <= 65593) Then ReadAlpha = "0-9"
End Function
'-- 修正文件路径
Public Function CheckPath(ByVal sPath)
sPath = Trim(sPath)
If Right(sPath, 1) <> "\" And sPath <> "" Then
sPath = sPath & "\"
End If
CheckPath = sPath
End Function
'-- 生成目录
Public Function CreatPathEx(ByVal sPath)
sPath = Replace(sPath, "/", "\")
sPath = Replace(sPath, "\\", "\")
On Error Resume Next
Dim strHostPath,strPath
Dim sPathItem,sTempPath
Dim i,fso
Set fso = Server.CreateObject(FSO_ScriptName)
strHostPath = Server.MapPath("/")
If InStr(sPath, ":") = 0 Then sPath = Server.MapPath(sPath)
If fso.FolderExists(sPath) Or Len(sPath) < 3 Then
CreatPathEx = True
Exit Function
End If
strPath = Replace(sPath, strHostPath, vbNullString,1,-1,1)
sPathItem = Split(strPath, "\")
If InStr(LCase(sPath), LCase(strHostPath)) = 0 Then
sTempPath = sPathItem(0)
Else
sTempPath = strHostPath
End If
For i = 1 To UBound(sPathItem)
If sPathItem(i) <> "" Then
sTempPath = sTempPath & "\" & sPathItem(i)
If fso.FolderExists(sTempPath) = False Then
fso.CreateFolder sTempPath
End If
End If
Next
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
CreatPathEx = True
End Function
'================================================
'函数名：FilesDelete
'作 用：FSO删除文件
'参 数：filepath ----文件路径
'返回值：False ---- True
'================================================
Public Function FileDelete(ByVal FilePath)
On Error Resume Next
FileDelete = False
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If FilePath = "" Then Exit Function
If InStr(FilePath, ":") = 0 Then FilePath = Server.MapPath(FilePath)
If fso.FileExists(FilePath) Then
fso.DeleteFile FilePath, True
FileDelete = True
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：FolderDelete
'作 用：FSO删除目录
'参 数：folderpath ----目录路径
'返回值：False ---- True
'================================================
Public Function FolderDelete(ByVal FolderPath)
FolderDelete = False
On Error Resume Next
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If FolderPath = "" Then Exit Function
If InStr(FolderPath, ":") = 0 Then FolderPath = Server.MapPath(FolderPath)
If fso.FolderExists(FolderPath) Then
fso.DeleteFolder FolderPath, True
FolderDelete = True
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：CopyToFile
'作 用：复制文件
'参 数：SoureFile ----原文件路径
' NewFile ----目标文件路径
'================================================
Public Function CopyToFile(ByVal SoureFile, ByVal NewFile)
On Error Resume Next
If SoureFile = "" Then Exit Function
If NewFile = "" Then Exit Function
If InStr(SoureFile, ":") = 0 Then SoureFile = Server.MapPath(SoureFile)
If InStr(NewFile, ":") = 0 Then NewFile = Server.MapPath(NewFile)
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If fso.FileExists(SoureFile) Then
fso.CopyFile SoureFile, NewFile
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：CopyToFolder
'作 用：复制文件夹
'参 数：SoureFolder ----原路径
' NewFolder ----目标路径
'================================================
Public Function CopyToFolder(ByVal SoureFolder, ByVal NewFolder)
On Error Resume Next
If SoureFolder = "" Then Exit Function
If NewFolder = "" Then Exit Function
If InStr(SoureFolder, ":") = 0 Then SoureFolder = Server.MapPath(SoureFolder)
If InStr(NewFolder, ":") = 0 Then NewFolder = Server.MapPath(NewFolder)
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If fso.FolderExists(SoureFolder) Then
fso.CopyFolder SoureFolder, NewFolder
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'=============================================================
'过程名：CreatedTextFile
'作 用：创建文本文件
'参 数：filename ----文件名
' body ----主要内容
'=============================================================
Public Function CreatedTextFile(ByVal FileName, ByVal body)
On Error Resume Next
If InStr(FileName, ":") = 0 Then FileName = Server.MapPath(FileName)
Dim fso,f
Set fso = Server.CreateObject(FSO_ScriptName)
Set f = fso.CreateTextFile(FileName)
f.WriteLine body
f.Close
Set f = Nothing
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：Readfile
'作 用：读取文件内容
'参 数：fromPath ----来源文件路径
'================================================
Public Function Readfile(ByVal fromPath)
On Error Resume Next
Dim strTemp,fso,f
If InStr(fromPath, ":") = 0 Then fromPath = Server.MapPath(fromPath)
Set fso = Server.CreateObject(FSO_ScriptName)
If fso.FileExists(fromPath) Then
Set f = fso.OpenTextFile(fromPath, 1, True)
strTemp = f.ReadAll
f.Close
Set f = Nothing
End If
Set fso = Nothing
Readfile = strTemp
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：CutMatchContent
'作 用：截取相匹配的内容
'参 数：Str ----原字符串
' PatStr ----符合条件字符
'================================================
Public Function CutMatchContent(ByVal str, ByVal start, ByVal last, ByVal Condition)
Dim Match,s,re
Dim FilterStr,MatchStr
Dim strContent,ArrayFilter
Dim i, n,bRepeat
If Len(start) = 0 Or Len(last) = 0 Then Exit Function
On Error Resume Next
MatchStr = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")"
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = MatchStr
Set s = re.Execute(str)
n = 0
For Each Match In s
If n = 0 Then
n = n + 1
ReDim ArrayFilter(n)
ArrayFilter(n) = Match
Else
bRepeat = False
For i = 0 To UBound(ArrayFilter)
If UCase(Match) = UCase(ArrayFilter(i)) Then
bRepeat = True
Exit For
End If
Next
If bRepeat = False Then
n = n + 1
ReDim Preserve ArrayFilter(n)
ArrayFilter(n) = Match
End If
End If
Next
Set s = Nothing
Set re = Nothing
If CBool(Condition) Then
strContent = Join(ArrayFilter, "|||")
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)
If Not IsNumeric(gradeid) Then
gradeid = 0
End If
On Error Resume Next
Dim Rs, SQL
Name = "GroupSetting" & gradeid
If ObjIsEmpty() Then
SQL = "Select Groupname,GroupSet from [NC_UserGroup] where Grades =" & gradeid
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
UserGroupSetting = ""
Set Rs = Nothing
Exit Function
End If
Value = Rs("GroupSet") & Rs("Groupname")
Set Rs = Nothing
End If
UserGroupSetting = Value
End Function
Private Sub LoadGroupSetting()
Dim strGroupSetting
Dim Rs, SQL
Dim Grades
Grades = CInt(membergrade)
On Error Resume Next
If Grades > 0 And memberid > 0 Then
If binUserLong = False Then
Set Rs = Execute("SELECT userid FROM [NC_User] WHERE password='" & CheckRequest(memberpass, 45) & "' And UserGrade=" & Grades & " And UserLock=0 And userid =" & memberid)
If Rs.BOF And Rs.EOF Then
Grades = 0
Response.Cookies(Cookies_Name) = ""
binUserLong = False
Else
binUserLong = True
End If
Set Rs = Nothing
End If
End If
Name = "GroupSetting" & Grades
If ObjIsEmpty() Then
SQL = "Select Groupname,GroupSet from [NC_UserGroup] where Grades =" & Grades
Set Rs = Execute(SQL)
If Rs.BOF And Rs.EOF Then
Response.Cookies(Cookies_Name) = ""
Set Rs = Nothing
Exit Sub
End If
Value = Rs("GroupSet") & Rs("Groupname")
Set Rs = Nothing
End If
blnGroupSetting = True
strGroupSetting = Value
arrGroupSetting = Split(strGroupSetting, "|||")
End Sub
Public Property Get GroupSetting(i)
If Not blnGroupSetting Then LoadGroupSetting
GroupSetting = arrGroupSetting(i)
End Property
Public Function ReadContent(ByVal strContent)
On Error Resume Next
Dim re, i
Dim sContentKeyword, strKeyword
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
'过滤危险脚本
re.Pattern = "(<s+cript(.[^>]*)>)"
strContent = re.Replace(strContent, "<Script$2>")
re.Pattern = "(<\/s+cript>)"
strContent = re.Replace(strContent, "</Script>")
re.Pattern = "(<body(.[^>]*)>)"
strContent = re.Replace(strContent, "<body>")
re.Pattern = "(<\!(.[^>]*)>)"
strContent = re.Replace(strContent, "<$2>")
re.Pattern = "(<\!)"
strContent = re.Replace(strContent, "<!")
re.Pattern = "(-->)"
strContent = re.Replace(strContent, "-->")
re.Pattern = "(javascript:)"
strContent = re.Replace(strContent, "<i>javascript</i>:")
If Trim(ContentKeyword) <> "" Then
sContentKeyword = Split(ContentKeyword, "@@@")
For i = 0 To UBound(sContentKeyword) - 1
strKeyword = Split(sContentKeyword(i), "$$$")
re.Pattern = "(" & strKeyword(0) & ")"
strContent = re.Replace(strContent, "<a target=""_blank"" href=""" & strKeyword(1) & """ class=""wordstyle"">$1</a>")
Next
End If
re.Pattern = "(\[i\])(.[^\[]*)(\[\/i\])"
strContent = re.Replace(strContent, "<i>$2</i>")
re.Pattern = "(\[u\])(.[^\[]*)(\[\/u\])"
strContent = re.Replace(strContent, "<u>$2</u>")
re.Pattern = "(\[b\])(.[^\[]*)(\[\/b\])"
strContent = re.Replace(strContent, "<b>$2</b>")
re.Pattern = "(\[fly\])(.*)(\[\/fly\])"
strContent = re.Replace(strContent, "<marquee>$2</marquee>")
re.Pattern = "\[size=([1-9])\](.[^\[]*)\[\/size\]"
strContent = re.Replace(strContent, "<font size=$1>$2</font>")
re.Pattern = "(\[center\])(.[^\[]*)(\[\/center\])"
strContent = re.Replace(strContent, "<center>$2</center>")
're.Pattern = "<IMG.[^>]*SRC(=| )(.[^>]*)>"
'strContent = re.Replace(strContent, "<IMG SRC=$2 border=""0"">")
re.Pattern = "<img(.[^>]*)>"
strContent = re.Replace(strContent, "<img$1 onload=""return imgzoom(this,550)"">")
re.Pattern = "\[DIR=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/DIR]"
strContent = re.Replace(strContent, "<embed src=$3 pluginspage=http://www.macromedia.com/shockwave/download/ width=$1 height=$2></embed>")
re.Pattern = "\[QT=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/QT]"
strContent = re.Replace(strContent, "<embed src=$3 width=$1 height=$2 autoplay=true loop=false controller=true playeveryframe=false cache=false scale=TOFIT bgcolor=#000000 kioskmode=false targetcache=false pluginspage=http://www.apple.com/quicktime/>")
re.Pattern = "\[MP=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/MP]"
strContent = re.Replace(strContent, "<embed type=application/x-oleobject codebase=http://activex.microsoft.com/activex/controls/mplayer/en/nsmp2inf.cab#Version=5,1,52,701 flename=mp src=$3 width=$1 height=$2></embed>")
re.Pattern = "\[RM=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/RM]"
strContent = re.Replace(strContent, "<OBJECT classid=clsid:CFCDAA03-8BE4-11cf-B84B-0020AFBBCCFA class=OBJECT id=RAOCX width=$1 height=$2><PARAM NAME=SRC VALUE=$3><PARAM NAME=CONSOLE VALUE=Clip1><PARAM NAME=CONTROLS VALUE=imagewindow><PARAM NAME=AUTOSTART VALUE=true></OBJECT><br><OBJECT classid=CLSID:CFCDAA03-8BE4-11CF-B84B-0020AFBBCCFA height=32 id=video2 width=$1><PARAM NAME=SRC VALUE=$3><PARAM NAME=AUTOSTART VALUE=-1><PARAM NAME=CONTROLS VALUE=controlpanel><PARAM NAME=CONSOLE VALUE=Clip1></OBJECT>")
re.Pattern = "(\[FLASH\])(.[^\[]*)(\[\/FLASH\])"
strContent = re.Replace(strContent, "<embed src="/UploadFiles/2021-04-02/"> re.Pattern = "(\[FLASH=*([0-9]*),*([0-9]*)\])(.[^\[]*)(\[\/FLASH\])"
strContent = re.Replace(strContent, "<embed src="/UploadFiles/2021-04-02/"> re.Pattern = "\[UPLOAD=(gif|jpg|jpeg|bmp|png)\](.[^\[]*)(gif|jpg|jpeg|bmp|png)\[\/UPLOAD\]"
strContent = re.Replace(strContent, "<br><A HREF=""$2$1"" TARGET=_blank><IMG SRC=""$2$1"" border=0 alt=按此在新窗口浏览图片 onload=""javascript:if(this.width>screen.width-333)this.width=screen.width-333""></A>")
re.Pattern = "(\[UPLOAD=(.[^\[]*)\])(.[^\[]*)(\[\/UPLOAD\])"
strContent = re.Replace(strContent, "<br><a href=""$3"">点击浏览该文件</a>")
re.Pattern = "(\[URL\])(.[^\[]*)(\[\/URL\])"
strContent = re.Replace(strContent, "<A HREF=""$2"" TARGET=_blank>$2</A>")
re.Pattern = "(\[URL=(.[^\[]*)\])(.[^\[]*)(\[\/URL\])"
strContent = re.Replace(strContent, "<A HREF=""$2"" TARGET=_blank>$3</A>")
re.Pattern = "(\[EMAIL\])(.[^\[]*)(\[\/EMAIL\])"
strContent = re.Replace(strContent, "<A HREF=""mailto:$2"">$2</A>")
re.Pattern = "(\[EMAIL=(.[^\[]*)\])(.[^\[]*)(\[\/EMAIL\])"
strContent = re.Replace(strContent, "<A HREF=""mailto:$2"" TARGET=_blank>$3</A>")
re.Pattern = "(\[HTML\])(.[^\[]*)(\[\/HTML\])"
strContent = re.Replace(strContent, "<table width='100%' border='0' cellspacing='0' cellpadding='6' bgcolor='#F6F6F6'><td><b>以下内容为程序代码:</b><br>$2</td></table>")
re.Pattern = "(\[code\])(.[^\[]*)(\[\/code\])"
strContent = re.Replace(strContent, "<table width='100%' border='0' cellspacing='0' cellpadding='6' bgcolor='#F6F6F6'><td><b>以下内容为程序代码:</b><br>$2</td></table>")
re.Pattern = "(\[color=(.[^\[]*)\])(.[^\[]*)(\[\/color\])"
strContent = re.Replace(strContent, "<font color=$2>$3</font>")
re.Pattern = "(\[face=(.[^\[]*)\])(.[^\[]*)(\[\/face\])"
strContent = re.Replace(strContent, "<font face=$2>$3</font>")
re.Pattern = "\[align=(center|left|right)\](.*)\[\/align\]"
strContent = re.Replace(strContent, "<div align=$1>$2</div>")
re.Pattern = "(\[QUOTE\])(.*)(\[\/QUOTE\])"
strContent = re.Replace(strContent, "<table cellpadding=0 cellspacing=0 border=1 WIDTH=94% bordercolor=#000000 bgcolor=#F2F8FF align=center ><tr><td ><table width=100% cellpadding=5 cellspacing=1 border=0><TR><TD BGCOLOR='#F6F6F6'>$2</table></table><br>")
re.Pattern = "(\[move\])(.*)(\[\/move\])"
strContent = re.Replace(strContent, "<MARQUEE scrollamount=3>$2</marquee>")
re.Pattern = "\[GLOW=*([0-9]*),*(#*[a-z0-9]*),*([0-9]*)\](.[^\[]*)\[\/GLOW]"
strContent = re.Replace(strContent, "<table width=$1 style=""filter:glow(color=$2, strength=$3)"">$4</table>")
re.Pattern = "\[SHADOW=*([0-9]*),*(#*[a-z0-9]*),*([0-9]*)\](.[^\[]*)\[\/SHADOW]"
strContent = re.Replace(strContent, "<table width=$1 style=""filter:shadow(color=$2, strength=$3)"">$4</table>")
Set re = Nothing
strContent = Replace(strContent, "[InstallDir_ChannelDir]", InstallDir & "/" & ChannelDir)
strContent = Replace(strContent, "{", "{")
strContent = Replace(strContent, "}", "}")
strContent = Replace(strContent, "$", "$")
ReadContent = strContent
End Function
End Class
%>