<%
class cls_main
Public ScriptName, SqlQueryNum, savelog, system, ResLicence, ResType, ResLanguage, UserClass, strMsg, RefererPage
Public adminName, adminPass, System_Sn, UserTrueIP
Public Reloadtime, MaxCount, CacheName, Cache_Data, sPath
Private LocalCacheName, CacheData, DelCount, ArrSetting
Public MemberUserName, MemberUserID, MemberUserPassword, MemberUserClass, MemberVipType
'类初始化
Private Sub Class_Initialize()
savelog = 0 '设置为1的时候会记录攻击或错误错信息。
SqlQueryNum = 0
Dim Tmpstr, i
Tmpstr = Request.ServerVariables("PATH_INFO")
Tmpstr = Split(Tmpstr, "/")
i = UBound(Tmpstr)
ScriptName = LCase(Tmpstr(i))
RefererPage = Request.ServerVariables("HTTP_REFERER")
adminName = Session("adminName")
adminPass = Session("adminPass")
Reloadtime = 14400
CacheName = Replace(Replace(Replace(Server.MapPath("index.asp"), "index.asp", ""), ":", ""), "\", "")
System_Sn = LCase(Replace(Request.ServerVariables("SERVER_NAME") & Request.ServerVariables("URL"), Split(Request.ServerVariables("SCRIPT_NAME"), "/")(UBound(Split(Request.ServerVariables("SCRIPT_NAME"), "/"))), ""))
UserTrueIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If UserTrueIP = "" Then UserTrueIP = Request.ServerVariables("REMOTE_ADDR")
UserTrueIP = checkStr(UserTrueIP)
If SystemEdition = 3 Then
sPath = "../"
Else
sPath = ""
End If
MemberUserName = checkStr(Request.Cookies(System_Sn)("MemberUserName"))
MemberUserID = checkStr(Request.Cookies(System_Sn)("MemberUserID"))
MemberUserPassword = checkStr(Request.Cookies(System_Sn)("MemberUserPassword"))
MemberUserClass = checkStr(Request.Cookies(System_Sn)("MemberUserClass"))
MemberVipType = checkStr(Request.Cookies(System_Sn)("MemberVipType"))
End Sub
'类结束
Private Sub Class_Terminate()
If IsObject(Conn) Then
'Conn.Close
Set Conn = Nothing
End If
End Sub
Public Property Let Name(ByVal vNewValue)
LocalCacheName = LCase(vNewValue)
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, "Mesky.Cn CacheServer", " please change the CacheName."
End If
End Property
Public Property Get Value()
If LocalCacheName <> "" Then
Cache_Data = Application(CacheName & "_" & LocalCacheName)
If IsArray(Cache_Data) Then
Value = Cache_Data(0)
Else
Err.Raise vbObjectError + 1, "Mesky.Cn CacheServer", " The Cache_Data(" & LocalCacheName & ") Is Empty."
End If
Else
Err.Raise vbObjectError + 1, "Mesky.Cn CacheServer", " please change the CacheName."
End If
End Property
Public Function ObjIsEmpty()
ObjIsEmpty = True
Cache_Data = Application(CacheName & "_" & LocalCacheName)
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 LoadSetting()
Dim Rs
'If Not IsObject(Conn) Then ConnectionDatabase
Set Rs = Execute("Select Setting From Mesky_Setting where isDefault=1")
ArrSetting = Split(Rs("Setting"), "{$}")
Set Rs = Nothing
system = Split(ArrSetting(144), ",")
ResLicence = Split(ArrSetting(141), ",")
ResLanguage = Split(ArrSetting(142), ",")
ResType = Split(ArrSetting(143), ",")
UserClass = Split(ArrSetting(140), ",")
Name = "StyleName"
If ObjIsEmpty Then Call ReloadTemplates
End Sub
Public Function Setting(s)
Setting = ArrSetting(s)
End Function
Public Sub ReloadTemplates()
Dim Rs, i
Set Rs = Execute("select top 1 * from Mesky_Style where isDefault =1")
If Not (Rs.EOF And Rs.BOF) Then
For i = 2 To Rs.Fields.Count - 3
Name = Rs(i).Name
'Response.Write(Rs(i).Name)
Value = Rs(i).Value
Next
End If
Set Rs = Nothing
End Sub
Public Function ReadStylePage(Page)
Name = Page
If ObjIsEmpty Then Call ReloadTemplates
Name = Page
ReadStylePage = Value
End Function
'检查管理员权限
'参数：sName(管理员用户名),sItem(权限项目)(sItem=0 只检查超管权限)
'返回：True/False
Public Function checkPermission(sName, sItem)
checkPermission = False
If sName = "" Or IsNull(sName) Then Exit Function
Dim cRs
Set cRs = Execute("select isAdmin,Permission,Password from Mesky_SiteManager Where UserName='" & checkStr(sName) & "'")
If Not (cRs.EOF And cRs.BOF) Then
If adminPass = cRs(2) Then
If cRs(0) Then checkPermission = True
If sItem <> 0 Then
If ItemInList(cRs(1), sItem) Then checkPermission = True
End If
End If
End If
Set cRs = Nothing
End Function
'
'资源分类下载列表
'参数：catalogID(被默认选择的分类ID)；tableName（数据库表名）
'返回： 字符串 0=RootID;1=CatalogID;2=Depth;3=CatalogName
Public Function GetCatalogSelect(catalogID, fromName)
Dim tRs, s, i
s = " <option value="""">所有分类</option>" & vbCrLf
Set tRs = Execute("select RootID,CatalogID,Depth,CatalogName from " & fromName & " order by rootid,orders")
Do While Not tRs.EOF
s = s & " <option value=""" & tRs(0) & "," & tRs(1) & "," & tRs(2) & "," & tRs(3) & """ "
If catalogID <> 0 Then
If tRs(1) = catalogID Then s = s & "selected"
End If
s = s & ">"
If tRs(2) = 1 Then s = s & " ├ "
If tRs(2) > 1 Then
For i = 2 To tRs(2)
s = s & " │"
Next
s = s & " ├ "
End If
s = s & tRs(3) & "</option>" & vbCrLf
tRs.MoveNext
Loop
Set tRs = Nothing
GetCatalogSelect = s
s = Null
End Function
'相关下载资源
'参数：Keys,cutNum
'for 标准版 and 高级版
Public Function MutualityDownRes(Keys, topNum, ID)
Dim tRs, s
If topNum = 0 Then
Set tRs = Execute("Select ID,ResName,ResVer From Mesky_Down_Resource where (ResName like '%" & Keys & "%') And ID<>" & ID & " and isAuditing=1 order by ID Desc")
Else
Set tRs = Execute("Select top " & topNum & " ID,ResName,ResVer From Mesky_Down_Resource where (ResName like '%" & Keys & "%') And ID<>" & ID & " and isAuditing=1 order by ID Desc")
End If
If tRs.EOF And tRs.BOF Then
s = ""
Else
dim arrA,arrB,i
i = 1
Do While Not tRs.EOF
If i = 1 then
arrA = tRs(0)
arrB = tRs(1) & " " & tRs(2)
Else
arrA = arrA & "###" & tRs(0)
arrB = arrB & "$$$" & tRs(1) & " " & tRs(2)
End If
i = i + 1
tRs.MoveNext
Loop
s = arrA & "|||" & arrB
End If
Set tRs = Nothing
MutualityDownRes = s
s = Null
End Function
'相关文章资源
'参数：Keys,cutNum
'for 标准版 and 高级版
Public Function MutualityCmsRes(Keys, topNum, ID)
Dim tRs, s
If topNum = 0 Then
Set tRs = Execute("Select ID,Title From Mesky_Cms_Resource where Title like '%" & Keys & "%' And ID<>" & ID & " and isAuditing=1 order by ID Desc")
Else
Set tRs = Execute("Select top " & topNum & " ID,Title From Mesky_Cms_Resource where Title like '%" & Keys & "%' And ID<>" & ID & " and isAuditing=1 order by ID Desc")
End If
If tRs.EOF And tRs.BOF Then
s = ""
Else
dim arrA,arrB,i
i = 1
Do While Not tRs.EOF
If i = 1 then
arrA = tRs(0)
arrB = tRs(1)
Else
arrA = arrA & "###" & tRs(0)
arrB = arrB & "$$$" & tRs(1)
End If
i = i + 1
tRs.MoveNext
Loop
s = arrA & "|||" & arrB
End If
Set tRs = Nothing
MutualityCmsRes = s
s = Null
End Function
'相关下载资源
'参数：Keys,cutNum
'for 标准版 and 高级版
Public Function showMutualityDownRes(strRes,cutNum)
If IsNull(strRes) or strRes="" then
showMutualityDownRes = ""
Exit Function
End If
Dim i, s, arrA, arrB
arrA = split(strRes,"|||")(0)
arrB = split(strRes,"|||")(1)
arrA = split(arrA,"###")
arrB = split(arrB,"$$$")
s = "<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""1"">"
For i = 0 to Ubound(arrA)
s = s & "<tr><td>·<a href=""" & sPath & Replace(Setting(77), "{$id}", arrA(i)) & """>" & cutStr(arrB(i), Int(cutNum)) & "</a></td></tr>"
Next
s = s & "</table>"
showMutualityDownRes = s
s = Null
End Function
'相关文章资源
'参数：Keys,cutNum
'for 标准版 and 高级版
Public Function showMutualityCmsRes(strRes,cutNum)
If IsNull(strRes) or strRes="" then
showMutualityCmsRes = ""
Exit Function
End If
Dim i, s, arrA, arrB
arrA = split(strRes,"|||")(0)
arrB = split(strRes,"|||")(1)
arrA = split(arrA,"###")
arrB = split(arrB,"$$$")
s = "<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""1"">"
For i = 0 to Ubound(arrA)
s = s & "<tr><td>·<a href=""" & sPath & Replace(Setting(101), "{$id}", arrA(i)&"_1") & """>" & cutStr(arrB(i), Int(cutNum)) & "</a></td></tr>"
Next
s = s & "</table>"
showMutualityCmsRes = s
s = Null
End Function
Public Function showNews(topNum,cutNum1,cutNum2,isType)
dim tRs,s,i
if Int(isType) = 1 then
Set tRs = Execute("select top "&topNum&" * from Mesky_News where isType = 1 order By ID Desc")
ElseIf Int(isType) = 2 then
Set tRs = Execute("select top "&topNum&" * from Mesky_News where isType = 2 order By ID Desc")
Else
Set tRs = Execute("select top "&topNum&" * from Mesky_News order By ID Desc")
End if
If tRs.Eof and tRs.Bof then
showNews = ""
Else
i = 1
Do While Not tRs.EOF
If i > 1 then s = s & "<br>"
s = s & "·<a href=""ViewNews.asp?ID="&tRs("ID")&"&isType="&isType&""" target=""_blank"">"&cutStr(tRs("Title"),Int(cutNum1))&"</a>"
if Int(cutNum2) > 0 then
s = s & "<br>" & cutStr(tRs("Content"),Int(cutNum2))
End If
s = s &" "& FormatDateTime(tRs("DateAndTime"),2)
i = i + 1
tRs.MoveNext
Loop
End If
showNews = s
s = Null
Set tRs = Nothing
End Function
'资源列表分类导航
'for 标准版 And 高级版
Public Function catalog_nav(rootID, catalogID, depth, fromName)
Dim s, tRs, i, FileName
If rootID = 0 And catalogID = 0 Then
Set tRs = Execute("select catalogID,catalogName,rootID,depth,Child,ResNum from " & fromName & " where depth=0 order by rootID")
Else '根分类 rootID>0
Set tRs = Execute("select catalogID,catalogName,rootID,depth,Child,ResNum from " & fromName & " where rootID=" & rootID & " and depth>0 order by orders")
End If
If tRs.EOF And tRs.BOF Then
s = "Sorry！没有找到相关的分类数据。"
Else
s = "<table width=""80%"" border=""0"" align=""center"">" & vbCrLf
Do While Not tRs.EOF
s = s & "<tr><td>"
If tRs(3) > 1 Then
For i = 2 To tRs(3)
s = s & " "
Next
End If
If rootID = 0 Then
s = s & "<img src=""" & sPath & "images/+.gif"" border=""0"" align=""absmiddle""> "
ElseIf tRs(4) > 0 And rootID > 0 And catalogID > 0 Then
s = s & "<img src=""" & sPath & "images/+.gif"" border=""0"" align=""absmiddle""> "
Else
s = s & "<img src=""" & sPath & "images/-.gif"" border=""0"" align=""absmiddle""> "
End If
If rootID = 0 Then
If LCase(fromName) = "mesky_down_catalog" Then
FileName = Setting(72)
Else
FileName = Setting(97)
End If
s = s & "<a href=""" & sPath & Replace(Replace(FileName, "{$id}", tRs(2)), "{$pages}", "1") & """>" & tRs(1) & "</a> (<font color=red>" & tRs(5) & "</font>)"
Else
If LCase(fromName) = "mesky_down_catalog" Then
FileName = Setting(73)
Else
FileName = Setting(98)
End If
s = s & "<a href=""" & sPath & Replace(Replace(FileName, "{$id}", tRs(0)), "{$pages}", "1") & """>" & tRs(1) & "</a> (<font color=red>" & tRs(5) & "</font>)"
If tRs(0) = catalogID Then s = s & "←"
End If
s = s & "</td></tr>"
tRs.MoveNext
Loop
s = s & "</table>"
End If
Set tRs = Nothing
catalog_nav = s
s = Null
End Function
'当前位置 导航
'for 标准版
Public Function site_nav(catalogID, fromName, GetTitle, GetURL)
Dim s, tRs, catalogName, ParentID, ParentStr, depth, rootID, FileName
If LCase(fromName) = "mesky_down_catalog" Then
s = s & "<a href=""" & sPath & Setting(70) & """>下载首页</a> "
Else
s = s & "<a href=""" & sPath & Setting(95) & """>首页</a> "
End If
If catalogID > 0 Then
Set tRs = Execute("select catalogName,ParentID,ParentStr,depth,rootID from " & fromName & " where catalogID=" & catalogID)
If Not (tRs.EOF And tRs.BOF) Then
catalogName = tRs(0)
ParentID = tRs(1)
ParentStr = tRs(2)
depth = tRs(3)
rootID = tRs(4)
End If
Set tRs = Nothing
If ParentID <> 0 Then
Set tRs = Execute("select catalogID,catalogName,depth,rootID from " & fromName & " where catalogID in(" & ParentStr & ")")
If Not (tRs.EOF And tRs.BOF) Then
Do While Not tRs.EOF
If tRs(2) > 0 Then
If LCase(fromName) = "mesky_down_catalog" Then
FileName = Setting(73)
Else
FileName = Setting(98)
End If
s = s & " → <a href=""" & sPath & Replace(Replace(FileName, "{$id}", tRs(0)), "{$pages}", "1") & """>" & tRs(1) & "</a>"
Else
If LCase(fromName) = "mesky_down_catalog" Then
FileName = Setting(72)
Else
FileName = Setting(97)
End If
s = s & " → <a href=""" & sPath & Replace(Replace(FileName, "{$id}", tRs(3)), "{$pages}", "1") & """>" & tRs(1) & "</a>"
End If
tRs.MoveNext
Loop
End If
Set tRs = Nothing
End If
If depth > 0 Then
If LCase(fromName) = "mesky_down_catalog" Then
FileName = Setting(73)
Else
FileName = Setting(98)
End If
s = s & " → <a href=""" & sPath & Replace(Replace(FileName, "{$id}", catalogID), "{$pages}", "1") & """>" & catalogName & "</a>"
Else
If LCase(fromName) = "mesky_down_catalog" Then
FileName = Setting(72)
Else
FileName = Setting(97)
End If
s = s & " → <a href=""" & sPath & Replace(Replace(FileName, "{$id}", rootID), "{$pages}", "1") & """>" & catalogName & "</a>"
End If
End If
If GetURL <> "" Then
s = s & " → <a href=""" & GetURL & """>" & GetTitle & "</a>"
Else
s = s & " → " & GetTitle
End If
site_nav = s
s = Null
End Function
'资源分类页
'for 标准版 and 高级版
Public Function showDownResCatalog()
Dim s, Rs, sRs, i, x, y, brNum
brNum = 6
s = s & "<table width=""770"" border=""0"" align=""center"" cellpadding=""2"" cellspacing=""1"">" & vbCrLf
Set Rs = Execute("select catalogID,catalogName,rootID,depth from Mesky_Down_catalog where Depth=0 order by rootID")
i = 1
If Not (Rs.EOF And Rs.BOF) Then
Do While Not Rs.EOF
s = s & " <tr class=""tdbg" & i Mod 2 + 1 & """>" & vbCrLf
s = s & " <td width=""100"" align=""center""><a href=""" & sPath & Replace(Replace(Setting(72), "{$id}", Rs(2)), "{$pages}", "1") & """>" & Rs(1) & "</a> <a href=""xml/rss_Down_r" & Rs(2) & ".xml""><img src=""" & sPath & "images/rss.gif"" border=""0"" align=""absmiddle""></a></td>" & vbCrLf
s = s & " <td><table width=""100%"" border=""0"" cellspacing=""1"" cellpadding=""3"">" & vbCrLf
s = s & " <tr>" & vbCrLf
Set sRs = Execute("select catalogID,catalogName,rootID,depth from Mesky_Down_catalog where ParentID=" & Rs(0) & " order by orders")
If Not (sRs.EOF And sRs.BOF) Then
x = 1
Do While Not sRs.EOF
s = s & " <td align=""center"" width=""12.5%""><a href=""" & sPath & Replace(Replace(Setting(73), "{$id}", sRs(0)), "{$pages}", "1") & """>" & sRs(1) & "</a> <a href=""xml/rss_Down_s" & sRs(0) & ".xml"" class=""f11"">(RSS)</a></td>" & vbCrLf
If (x Mod brNum) = 0 Then s = s & "</tr><tr>" & vbCrLf
x = x + 1
sRs.MoveNext
Loop
If (x Mod brNum) > 0 Then
For y = 0 To (brNum - (x Mod brNum))
s = s & "<td align=""center"" width=""12.5%"">.</td>" & vbCrLf
Next
End If
If x = brNum Then
For y = 0 To (brNum - x)
s = s & "<td align=""center"" width=""12.5%"">.</td>" & vbCrLf
Next
End If
End If
Set sRs = Nothing
s = s & " </tr>" & vbCrLf
s = s & " </table></td>" & vbCrLf
s = s & " </tr>" & vbCrLf
i = i + 1
Rs.MoveNext
Loop
End If
Set Rs = Nothing
s = s & "</table>"
showDownResCatalog = s
s = Null
End Function
'资源分类页
'for 标准版 高级版
Public Function showCmsResCatalog()
Dim s, Rs, sRs, i, x, y, brNum
brNum = 5
s = s & "<table width=""770"" border=""0"" align=""center"" cellpadding=""2"" cellspacing=""1"">" & vbCrLf
Set Rs = Execute("select catalogID,catalogName,rootID,depth from Mesky_Cms_catalog where Depth=0 order by rootID")
i = 1
If Not (Rs.EOF And Rs.BOF) Then
Do While Not Rs.EOF
s = s & " <tr class=""tdbg" & i Mod 2 + 1 & """>" & vbCrLf
s = s & " <td width=""100"" align=""center""><a href=""" & sPath & Replace(Replace(Setting(97), "{$id}", Rs(2)),"{$pages}","1") & """>" & Rs(1) & "</a> <a href=""xml/rss_Cms_r" & Rs(2) & ".xml""><img src=""" & sPath & "images/rss.gif"" border=""0"" align=""absmiddle""></a></td>" & vbCrLf
s = s & " <td><table width=""100%"" border=""0"" cellspacing=""1"" cellpadding=""3"">" & vbCrLf
s = s & " <tr>" & vbCrLf
Set sRs = Execute("select catalogID,catalogName,rootID,depth from Mesky_Cms_catalog where ParentID=" & Rs(0) & " order by orders")
If Not (sRs.EOF And sRs.BOF) Then
x = 1
Do While Not sRs.EOF
s = s & " <td align=""center"" width=""12.5%""><a href=""" & sPath & Replace(Replace(Setting(98), "{$id}", sRs(0)),"{$pages}","1") & """>" & sRs(1) & "</a> <a href=""xml/rss_Cms_s" & sRs(0) & ".xml"" class=""f11"">(RSS)</a></td>" & vbCrLf
If (x Mod brNum) = 0 Then s = s & "</tr><tr>"
x = x + 1
sRs.MoveNext
Loop
If (x Mod brNum) > 0 Then
For y = 0 To (brNum - (x Mod brNum))
s = s & "<td align=""center"" width=""12.5%"">.</td>" & vbCrLf
Next
End If
If x = brNum Then
For y = 0 To (brNum - x)
s = s & "<td align=""center"" width=""12.5%"">.</td>" & vbCrLf
Next
End If
End If
Set sRs = Nothing
s = s & " </tr>" & vbCrLf
s = s & " </table></td>" & vbCrLf
s = s & " </tr>" & vbCrLf
i = i + 1
Rs.MoveNext
Loop
End If
Set Rs = Nothing
s = s & "</table>"
showCmsResCatalog = s
s = Null
End Function
'for 标准版 and 高级版 首页
Public Function showDownResAdv(strWhere, strOrder, topNum, cutNum, showDate, showDot, showHrline, showCatalogName)
Dim tRs, s, i, strDot, strHits
If InStr(LCase(strOrder), "hits") > 0 Then
strHits = Replace(Replace(Replace(LCase(strOrder), "desc", ""), "asc", ""), " ", "")
Else
strHits = "HitsTotal"
End If
If (showDot = "" Or showDot = "0") Then
strDot = "·"
Else
strDot = showDot
End If
If strWhere <> "" Then
Set tRs = Execute("Select top " & topNum & " ID,ResName,ResVer,catalogID,catalogName," & strHits & ",UpdateTime From Mesky_Down_Resource where " & strWhere & " and isAuditing=1 order by " & strOrder & "")
Else
Set tRs = Execute("Select top " & topNum & " ID,ResName,ResVer,catalogID,catalogName," & strHits & ",UpdateTime From Mesky_Down_Resource where isAuditing=1 order by " & strOrder & "")
End If
s = "<table width=""99%"" border=""0"" cellspacing=""0"" cellpadding=""2"" align=""center"">" & vbCrLf
If tRs.EOF And tRs.BOF Then
s = s & " <tr>" & vbCrLf
s = s & " <td>Sorry！没有查询到任何记录。</td>" & vbCrLf
s = s & " </tr>" & vbCrLf
Else
Do While Not tRs.EOF
s = s & " <tr>" & vbCrLf
s = s & " <td>" & strDot
If showCatalogName Then '显示分类
s = s & "[<a href=""" & Replace(Replace(Setting(73), "{$id}", tRs(3)), "{$pages}", "1") & """ target=""_blank"">" & tRs(4) & "</a>]"
End If
s = s & " <a href=""" & Replace(Setting(77), "{$id}", tRs(0)) & """ target=""_blank"" Title=""" & tRs(1) & " " & tRs(2) & """>" & cutStr(tRs(1) & " " & tRs(2), Int(cutNum)) & "</a> </td>"
If showDate = "Hits" Then '显示时间还是人气
s = s & "<td width=""30"">" & tRs(5) & "</td>" & vbCrLf
Else
s = s & "<td width=""30"">" & FormatMyDate(tRs(6), showDate) & "</td>" & vbCrLf
End If
s = s & " </tr>" & vbCrLf
If showHrline Then s = s & "<tr><td height=""1"" colspan=""2"" background=""images/bg_dot.gif""></td></tr>" & vbCrLf
tRs.MoveNext
Loop
End If
Set tRs = Nothing
s = s & "</table>" & vbCrLf
showDownResAdv = s
s = Null
End Function
'for 标准版 and 高级版
Public Function showDownRes(strWhere, strOrder, topNum, cutNum, showDot, showHrline)
Dim tRs, s, i, strDot
i = 1
If strWhere <> "" Then
Set tRs = Execute("Select top " & topNum & " ID,ResName,ResVer From Mesky_Down_Resource where " & strWhere & " and isAuditing=1 order by " & strOrder & "")
Else
Set tRs = Execute("Select top " & topNum & " ID,ResName,ResVer From Mesky_Down_Resource where isAuditing=1 order by " & strOrder & "")
End If
If tRs.EOF And tRs.BOF Then
s = ""
Else
s = "<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""1"">" & vbCrLf
Do While Not tRs.EOF
If (showDot = "" Or showDot = "0") Then
strDot = "" & Right("0" & i, 2) & "."
Else
strDot = showDot
End If
s = s & " <tr><td><font color=red>" & strDot & "</font><a href=""" & sPath & Replace(Setting(77), "{$id}", tRs(0)) & """>" & cutStr(tRs(1) & " " & tRs(2), Int(cutNum)) & "</a></td></tr>" & vbCrLf
If showHrline Then s = s & "<tr><td height=""1"" background=""" & sPath & "images/bg_dot.gif""></td></tr>" & vbCrLf
i = i + 1
tRs.MoveNext
Loop
s = s & "</table>"
End If
Set tRs = Nothing
showDownRes = s
s = Null
End Function
'for 标准版 and 高级版 首页
Public Function showCmsResAdv(strWhere, strOrder, topNum, cutNum, showDate, showDot, showHrline, showCatalogName)
Dim tRs, s, i, strDot
If (showDot = "" Or showDot = "0") Then
strDot = "·"
Else
strDot = showDot
End If
If strWhere <> "" Then
Set tRs = Execute("Select top " & topNum & " ID,Title,catalogID,catalogName,Hits,DateAndTime,isComment,RedirectUrl From Mesky_Cms_Resource where " & strWhere & " and isAuditing=1 order by " & strOrder & "")
Else
Set tRs = Execute("Select top " & topNum & " ID,Title,catalogID,catalogName,Hits,DateAndTime,isComment,RedirectUrl From Mesky_Cms_Resource where isAuditing=1 order by " & strOrder & "")
End If
s = "<table width=""99%"" border=""0"" cellspacing=""0"" cellpadding=""2"" align=""center"">" & vbCrLf
If tRs.EOF And tRs.BOF Then
s = s & " <tr>" & vbCrLf
s = s & " <td>Sorry！没有查询到任何记录。</td>" & vbCrLf
s = s & " </tr>" & vbCrLf
Else
Do While Not tRs.EOF
s = s & " <tr>" & vbCrLf
s = s & " <td>" & strDot
If showCatalogName Then '显示分类
s = s & "[<a href=""" & Replace(Replace(Setting(98), "{$id}", tRs(2)),"{$pages}","1") & """ target=""_blank"">" & tRs(3) & "</a>]"
End If
If tRs(7) <> "" then
s = s & " <a href=""" & tRs(7) & """ target=""_blank"" Title=""" & tRs(1) & """>"
Else
s = s & " <a href=""" & Replace(Setting(101), "{$id}", tRs(0)& "_1") & """ target=""_blank"" Title=""" & tRs(1) & """>"
End IF
'显示评论
If tRs(6) = 1 then
s = s & cutStr(tRs(1), Int(cutNum)-4) & "</a> <a href=""../comment_cms.asp?ID="&tRs(0)&""">评论</a></td>"
Else
s = s & cutStr(tRs(1), Int(cutNum)) & "</a></td>"
End IF
If showDate = "Hits" Then '显示时间还是人气
s = s & "<td width=""30"">" & tRs(4) & "</td>" & vbCrLf
Else
s = s & "<td width=""30"">" & FormatMyDate(tRs(5), showDate) & "</td>" & vbCrLf
End If
s = s & " </tr>" & vbCrLf
If showHrline Then s = s & "<tr><td height=""1"" colspan=""2"" background=""images/bg_dot.gif""></td></tr>" & vbCrLf
tRs.MoveNext
Loop
End If
Set tRs = Nothing
s = s & "</table>" & vbCrLf
showCmsResAdv = s
s = Null
End Function
'for 标准版 and 高级版
Public Function showCmsRes(strWhere, strOrder, topNum, cutNum, showDot, showHrline)
Dim tRs, s, i, strDot
i = 1
If strWhere <> "" Then
Set tRs = Execute("Select top " & topNum & " ID,Title,isComment,RedirectUrl From Mesky_Cms_Resource where " & strWhere & " and isAuditing=1 order by " & strOrder & "")
Else
Set tRs = Execute("Select top " & topNum & " ID,Title,isComment,RedirectUrl From Mesky_Cms_Resource where isAuditing=1 order by " & strOrder & "")
End If
If tRs.EOF And tRs.BOF Then
s = ""
Else
s = "<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""1"">" & vbCrLf
Do While Not tRs.EOF
If (showDot = "" Or showDot = "0") Then
strDot = "" & Right("0" & i, 2) & "."
Else
strDot = showDot
End If
If tRs(3)<>"" then
s = s & " <tr><td><font color=red> " & strDot & "</font><a href=""" & tRs(3) & """>"
Else
s = s & " <tr><td><font color=red> " & strDot & "</font><a href=""" & sPath & Replace(Setting(101), "{$id}", tRs(0)& "_1") & """>"
End IF
'显示评论
If tRs(2) = 1 then
s = s & cutStr(tRs(1), Int(cutNum)-4) & "</a> <a href=""../comment_cms.asp?ID="&tRs(0)&""">评论</a></td></tr>" & vbCrLf
Else
s = s & cutStr(tRs(1), Int(cutNum)) & "</a></td></tr>" & vbCrLf
End IF
If showHrline Then s = s & "<tr><td height=""1"" background=""" & sPath & "images/bg_dot.gif""></td></tr>" & vbCrLf
i = i + 1
tRs.MoveNext
Loop
s = s & "</table>"
End If
Set tRs = Nothing
showCmsRes = s
s = Null
End Function
Public Function showDownResImages(strWhere, strOrder, topNum, cutNum, intWidth, intHeight, isWH)
Dim tRs, s, i
i = 1
s = "<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""3"">" & vbCrLf
If strWhere <> "" Then
Set tRs = Execute("Select top " & topNum & " ID,ResName,ResVer,SmallImg From Mesky_Down_Resource where " & strWhere & " and isAuditing=1 and SmallImg<>'' order by " & strOrder & "")
Else
Set tRs = Execute("Select top " & topNum & " ID,ResName,ResVer,SmallImg From Mesky_Down_Resource where isAuditing=1 and SmallImg<>'' order by " & strOrder & "")
End If
If tRs.EOF And tRs.BOF Then
s = s & " <tr>" & vbCrLf
s = s & " <td>Sorry！没有查询到任何记录。</td>" & vbCrLf
s = s & " </tr>" & vbCrLf
Else
If isWH = 1 Then s = s & " </tr>" & vbCrLf
Do While Not tRs.EOF
If isWH = 2 Then s = s & " <tr>" & vbCrLf
s = s & " <td align=""center""><a href=""" & sPath & Replace(Setting(77), "{$id}", tRs(0)) & """ target=""_blank"" Title=""" & tRs(1) & " " & tRs(2) & """><img src=""" & sPath & tRs(3) & """ border=0 width=""" & intWidth & """ height=""" & intHeight & """></a>"
s = s & "<br><a href=""" & sPath & Replace(Setting(77), "{$id}", tRs(0)) & """ target=""_blank"">" & cutStr(tRs(1) & " " & tRs(2), Int(cutNum)) & "</a></td>" & vbCrLf
If isWH = 2 Then s = s & " </tr>" & vbCrLf
tRs.MoveNext
Loop
End If
Set tRs = Nothing
If isWH = 1 Then s = s & " </tr>" & vbCrLf
s = s & "</table>" & vbCrLf
showDownResImages = s
s = Null
End Function
Public Function showCmsResImages(strWhere, strOrder, topNum, cutNum, intWidth, intHeight, isWH)
Dim tRs, s, i
i = 1
s = "<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""3"">" & vbCrLf
If strWhere <> "" Then
Set tRs = Execute("Select top " & topNum & " ID,Title,SmallImg,RedirectUrl From Mesky_Cms_Resource where " & strWhere & " and isAuditing=1 and SmallImg<>'' order by " & strOrder & "")
Else
Set tRs = Execute("Select top " & topNum & " ID,Title,SmallImg,RedirectUrl From Mesky_Cms_Resource where isAuditing=1 and SmallImg<>'' order by " & strOrder & "")
End If
If tRs.EOF And tRs.BOF Then
s = s & " <tr>" & vbCrLf
s = s & " <td>Sorry！没有查询到任何记录。</td>" & vbCrLf
s = s & " </tr>" & vbCrLf
Else
If isWH = 1 Then s = s & " </tr>" & vbCrLf
Do While Not tRs.EOF
If isWH = 2 Then s = s & " <tr>" & vbCrLf
If tRs(3) <> "" then
s = s & " <td align=""center""><a href=""" & tRs(3) & """ target=""_blank"" Title=""" & tRs(1) & """><img src=""" & sPath & tRs(2) & """ border=0 width=""" & intWidth & """ height=""" & intHeight & """></a>"
s = s & "<br><a href=""" & tRs(3) & """>" & cutStr(tRs(1), Int(cutNum)) & "</a></td>" & vbCrLf
Else
s = s & " <td align=""center""><a href=""" & sPath & Replace(Setting(101), "{$id}", tRs(0)& "_1") & """ target=""_blank"" Title=""" & tRs(1) & """><img src=""" & sPath & tRs(2) & """ border=0 width=""" & intWidth & """ height=""" & intHeight & """></a>"
s = s & "<br><a href=""" & sPath & Replace(Setting(101), "{$id}", tRs(0)& "_1") & """>" & cutStr(tRs(1), Int(cutNum)) & "</a></td>" & vbCrLf
End IF
If isWH = 2 Then s = s & " </tr>" & vbCrLf
tRs.MoveNext
Loop
End If
Set tRs = Nothing
If isWH = 1 Then s = s & " </tr>" & vbCrLf
s = s & "</table>" & vbCrLf
showCmsResImages = s
s = Null
End Function
Public Function showCmsResExcerptImages(strWhere, strOrder, topNum, cutNum1, cutNum2, intWidth, intHeight, isWH)
Dim tRs, s, i
i = 1
s = "<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""3"">" & vbCrLf
If strWhere <> "" Then
Set tRs = Execute("Select top " & topNum & " ID,Title,SmallImg,Excerpt,RedirectUrl From Mesky_Cms_Resource where " & strWhere & " and isAuditing=1 and SmallImg<>'' order by " & strOrder & "")
Else
Set tRs = Execute("Select top " & topNum & " ID,Title,SmallImg,Excerpt,RedirectUrl From Mesky_Cms_Resource where isAuditing=1 and SmallImg<>'' order by " & strOrder & "")
End If
If tRs.EOF And tRs.BOF Then
s = s & " <tr>" & vbCrLf
s = s & " <td>Sorry！没有查询到任何记录。</td>" & vbCrLf
s = s & " </tr>" & vbCrLf
Else
If isWH = 1 Then s = s & " </tr>" & vbCrLf
Do While Not tRs.EOF
If isWH = 2 Then s = s & " <tr>" & vbCrLf
s = s & " <td><img src=""" & sPath & tRs(2) & """ border=0 width=""" & intWidth & """ height=""" & intHeight & """ align=""left"">"
If tRs(4) <> "" then
s = s & "<a href=""" & tRs(4) & """>" & cutStr(tRs(1), Int(cutNum1)) & "</a>"
Else
s = s & "<a href=""" & sPath & Replace(Setting(101), "{$id}", tRs(0)& "_1") & """>" & cutStr(tRs(1), Int(cutNum1)) & "</a>"
End If
If Int(cutNum2) > 0 then s = s & "<br>"&cutStr(tRs(3),Int(cutNum2))
s = s & "</td>" & vbCrLf
If isWH = 2 Then s = s & " </tr>" & vbCrLf
tRs.MoveNext
Loop
End If
Set tRs = Nothing
If isWH = 1 Then s = s & " </tr>" & vbCrLf
s = s & "</table>" & vbCrLf
showCmsResExcerptImages = s
s = Null
End Function
'//截取指定长度字符串
'//返回类型：字符串
Public Function cutStr(str, strlen)
If str="" or isnull(str) then Exit Function
Dim l, t, c, i
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
cutStr = Left(str, i) & ".."
Exit For
Else
cutStr = str
End If
Next
cutStr = Replace(cutStr, Chr(10), "")
End Function
Public Sub SystemMsg()
Response.Write "<TABLE width=""75%"" align=""center"">" & vbCrLf
Response.Write " <TR>" & vbCrLf
Response.Write " <TD>" & vbCrLf
Response.Write "<DIV class=ContainerSection>" & vbCrLf
Response.Write " <DIV class=ContainerTopBorder>" & vbCrLf
Response.Write " <DIV class=ContainerTop></DIV>" & vbCrLf
Response.Write " </DIV>" & vbCrLf
Response.Write " <DIV class=ContainerContent> System Message:</DIV> " & vbCrLf
Response.Write " <DIV><br> <B>" & strMsg & "</B><BR><BR>" & vbCrLf
Response.Write " <DIV class=ContainerContent align=""center""><a href=""" & RefererPage & """><<返回上一页</a>" & vbCrLf
Response.Write " </DIV> " & vbCrLf
Response.Write " </DIV>" & vbCrLf
Response.Write " <DIV class=BottomWrapper>" & vbCrLf
Response.Write " <DIV class=ContainerBottomBorder>" & vbCrLf
Response.Write " <DIV class=ContainerBottom></DIV>" & vbCrLf
Response.Write " </DIV>" & vbCrLf
Response.Write " </DIV>" & vbCrLf
Response.Write "</DIV>" & vbCrLf
Response.Write " </TD>" & vbCrLf
Response.Write " </TR>" & vbCrLf
Response.Write "</TABLE>" & vbCrLf
End Sub
Public Function CopyRight()
Dim reval
reval = reval & "Powered By <a href=""http://www.mesky.net"" title=""Powered By Www.Mesky.Net"">动感下载系统（MeskyDMS）V3.0</a>"
CopyRight = reval
reval = Null
End Function
Public Function HtmlHead()
Dim reval
reval = reval & "<!--Published Date:" & Now() & " Powered by Www.Mesky.Net-->" & vbCrLf
reval = reval & "<!--" & vbCrLf
reval = reval & "┌───────────────────── MESKY─┐" & vbCrLf
reval = reval & "│动感下载系统V3.0 —— http://www.mesky.net │" & vbCrLf
reval = reval & "│ 程序购买 QQ：26934364 手机：13586085531 │" & vbCrLf
reval = reval & "└───────────────────────.NET┘" & vbCrLf
reval = reval & "-->" & vbCrLf
HtmlHead = reval
reval = Null
End Function
Public Function DMSVer()
If IsSqlDataBase = 1 Then
DMSVer = "动感下载系统(MeskyDMS) V3.0 Build 050623 SQL版"
Else
DMSVer = "动感下载系统(MeskyDMS) V3.0 Build 050623 Access版"
End If
End Function
Public Function F469e80d32(tr)
If Request.ServerVariables("SERVER_NAME")="127.0.0.1" then
F469e80d32 = "1"
Exit Function
End If
F469e80d32 = "0"
Dim tRs,tempStr, RegCode
tempStr = Request.ServerVariables("SERVER_NAME") & "C0559f8d32"
RegCode = MD5(tempStr, 16)
Set tRs = Execute("select * from Mesky_Key where RegType = " & tr)
If Not (tRs.EOF And tRs.BOF) Then
If tRs("RegCode") <> RegCode Then
F469e80d32 = "2"
ElseIf tRs("RegKey") <> MD5(RegCode & tr & "F469e80d32", 32) Then
F469e80d32 = "0"
ElseIf tRs("RegCode") = RegCode And tRs("RegKey") = MD5(RegCode & tr & "F469e80d32", 32) Then
F469e80d32 = "1"
End If
End If
Set tRs = Nothing
End Function
Public Function C0559f8d32(tr)
C0559f8d32 = 0
End Function
Public Function F469e88d32(tr)
F469e88d32 = 0
End Function
Public Function Execute(Command)
If Not IsObject(Conn) Then ConnectionDatabase
'检查权限,防止注入攻击。
'If InStr(LCase(Command),"Mesky_SiteManager")>0 And Left(ScriptName,6)<> "Mesky_SiteManager" Then
'If savelog=1 Then
'Response.Write SaveSQLLOG(Command,"")
'End If
'Command=Replace(LCase(Command),"Mesky_SiteManager","Mesky<i>"&Chr(95)&"</i>SiteManager")
'End If
If IsDeBug = 0 Then
On Error Resume Next
Set Execute = Conn.Execute(Command)
If Err Then
Err.Clear
Set Conn = Nothing
If savelog = 1 Then
Response.Write SaveSQLLOG(Command, "查询数据的时候发现错误，请检查您的查询代码是否正确。<br>基于安全的理由，只显示本信息，要查看详细的错误信息，请修改您的程序文件conn.asp。把""Const IsDeBug = 0""改为：""Const IsDeBug = 1""")
Else
Response.Write "查询数据的时候发现错误，请检查您的查询代码是否正确。"
End If
Response.End
End If
Else
'Response.Write Command & "<br>"
Set Execute = Conn.Execute(Command)
End If
SqlQueryNum = SqlQueryNum + 1
End Function
'---------------------------------------------------------------------
'时间格式化
'参数：时间，格式模板
'返回：格式化后的字符串
'备注：格式化关键词详解：
' "{Y}" : 4位年
' "{y}" : 2位年
' "{M}" : 不补位的月
' "{m}" : 补位的月,如03,01
' "{D}" : 不补位的日
' "{d}" : 补位的日
' "{H}" : 不补位的小时
' "{h}" : 补位的小时
' "{MI}": 不补位的分钟
' "{mi}": 补位的分钟
' "{S}" : 不补位的秒
' "{s}" : 补位的秒
'---------------------------------------------------------------------
Public Function FormatMyDate(myDate, Template)
If Not IsDate(myDate) Or Template = "" Then
FormatMyDate = ""
Exit Function
End If
Dim mYear, mMonth, mDay, mHour, mMin, mSec
mYear = Year(myDate)
mMonth = Month(myDate)
mDay = Day(myDate)
mHour = Hour(myDate)
mMin = Minute(myDate)
mSec = Second(myDate)
FormatMyDate = Template
FormatMyDate = Replace(FormatMyDate, "{Y}", Year(myDate))
FormatMyDate = Replace(FormatMyDate, "{y}", Right(Year(myDate), 2))
FormatMyDate = Replace(FormatMyDate, "{M}", Month(myDate))
FormatMyDate = Replace(FormatMyDate, "{m}", Right("00" & Month(myDate), 2))
FormatMyDate = Replace(FormatMyDate, "{D}", Day(myDate))
FormatMyDate = Replace(FormatMyDate, "{d}", Right("00" & Day(myDate), 2))
FormatMyDate = Replace(FormatMyDate, "{H}", Hour(myDate))
FormatMyDate = Replace(FormatMyDate, "{h}", Right("00" & Hour(myDate), 2))
FormatMyDate = Replace(FormatMyDate, "{MI}", Minute(myDate))
FormatMyDate = Replace(FormatMyDate, "{mi}", Right("00" & Minute(myDate), 2))
FormatMyDate = Replace(FormatMyDate, "{S}", Second(myDate))
FormatMyDate = Replace(FormatMyDate, "{s}", Right("00" & Second(myDate), 2))
If FormatDateTime(myDate, 1) = FormatDateTime(Date, 1) Then
FormatMyDate = "<font color=red>" & FormatMyDate & "</font>"
End If
'Template = Null
End Function
Rem 判断发言是否来自外部
Public Function ChkPost()
Dim server_v1, server_v2
ChkPost = 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
ChkPost = False
Else
ChkPost = True
End If
End Function
'过滤SQL非法字符
Public Function checkStr(str)
If IsNull(str) Then
checkStr = ""
Exit Function
End If
str = Replace(str, Chr(0), "")
checkStr = Replace(str, "'", "''")
End Function
'显示验证码
Public Function GetCode()
Dim test
On Error Resume Next
'Set test = Server.CreateObject("Adodb.Stream")
'Set test = Nothing
If Err Then
Dim zNum
Randomize Timer
zNum = CInt(8999 * Rnd + 1000)
Session("GetCode") = zNum
GetCode = "<input type=""text"" name=""codestr"" maxlength=""4"" size=""4""> " & Session("GetCode")
Else
GetCode = "<input type=""text"" name=""codestr"" maxlength=""4"" size=""4""> <img src=""getcode.asp"">"
End If
End Function
'检查验证码是否正确
Public Function CodeIsTrue()
Dim CodeStr
CodeStr = Trim(Request("CodeStr"))
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 Createpass()
Dim Ran, i, LengthNum
LengthNum = 16
Createpass = ""
For i = 1 To LengthNum
Randomize
Ran = CInt(Rnd * 2)
Randomize
If Ran = 0 Then
Ran = CInt(Rnd * 25) + 97
Createpass = Createpass & UCase(Chr(Ran))
ElseIf Ran = 1 Then
Ran = CInt(Rnd * 9)
Createpass = Createpass & Ran
ElseIf Ran = 2 Then
Ran = CInt(Rnd * 25) + 97
Createpass = Createpass & Chr(Ran)
End If
Next
End Function
'//从Html标签中取出文本内容
Public Function GetTextFromHtml(strHtml)
strHtml = Replace(Replace(Replace(Replace(strHtml, "<br>", vbCrLf), "<BR>", vbCrLf), "</p>", vbCrLf & vbCrLf), "</P>", vbCrLf & vbCrLf)
Dim strPatrn
strPatrn = "<.*?>"
Dim regEx
Set regEx = New RegExp
regEx.Pattern = strPatrn
regEx.IgnoreCase = True
regEx.Global = True
GetTextFromHtml = regEx.Replace(strHtml, "")
Set regEx = Nothing
End Function
'//检测Email
'//返回:True/False
Public Function CheckEmail(strng)
CheckEmail = False
Dim regEx, Match
Set regEx = New RegExp
regEx.Pattern = "^\w+((-\w+)|(\.\w+))*\@[A-Za-z0-9]+((\.|-)[A-Za-z0-9]+)*\.[A-Za-z0-9]+$"
regEx.IgnoreCase = True
Set Match = regEx.Execute(strng)
If Match.Count Then CheckEmail = True
Set Match = Nothing
Set regEx = Nothing
End Function
'//字符串是否在[0-9]&[a-z]及下划线中（不区分大小写）
'//返回:True/False
Public Function IsChar26AndInt(str)
IsChar26AndInt = True
Dim regEx, Match
Set regEx = New RegExp
regEx.Pattern = "[\W]{1,}?"
regEx.IgnoreCase = True
Set Match = regEx.Execute(str)
If Match.Count >= 1 Then
IsChar26AndInt = False
End If
Set Match = Nothing
Set regEx = Nothing
End Function
'//字符串是否在[a-z]中（不区分大小写）
'//返回:True/False
Public Function IsChar26(str)
IsChar26 = True
Dim regEx, Match
Set regEx = New RegExp
regEx.Pattern = "[^a-zA-Z]{1,}?"
regEx.IgnoreCase = True
Set Match = regEx.Execute(str)
If Match.Count >= 1 Then
IsChar26 = False
End If
Set Match = Nothing
Set regEx = Nothing
End Function
'//字符串是否在[0-9]中（不区分大小写）
Public Function IsIntChar(str)
IsIntChar = True
Dim regEx, Match
Set regEx = New RegExp
regEx.Pattern = "\D{1,}?"
regEx.IgnoreCase = True
Set Match = regEx.Execute(str)
If Match.Count >= 1 Then
IsIntChar = False
End If
Set Match = Nothing
Set regEx = Nothing
End Function
'//Html字符串转Js字符串
Public Function HTMLToJS(strHtml)
If Trim(strHtml) = "" Then
HTMLToJS = ""
Exit Function
End If
strHtml = Replace(strHtml, "\", "\\")
strHtml = Replace(strHtml, """", "\""")
strHtml = Replace(strHtml, vbCrLf, "")
HTMLToJS = strHtml
End Function
'//转换Html关键标签为Html特殊字符串
Public Function HTMLEncode(str)
If Not IsNull(str) Then
str = Replace(str, Chr(13), "")
str = Replace(str, Chr(10) & Chr(10), "<P></P>")
str = Replace(str, Chr(10), "<BR>")
str = Replace(str, ">", ">")
str = Replace(str, "<", "<")
str = Replace(str, "&", "&")
str = Replace(str, " ", " ")
str = Replace(str, """", """)
HTMLEncode = str
str = Null
End If
End Function
Public Function HTMLEncode1(str)
If Not IsNull(str) Then
str = Replace(str, Chr(32) & Chr(32) & Chr(32), " ")
str = Replace(str, Chr(13), "")
str = Replace(str, Chr(10) & Chr(10), "<br>")
str = Replace(str, Chr(10), "<br>")
HTMLEncode1 = str
str = Null
End If
End Function
Function HTMLToData(str)
If IsNull(str) Then
HTMLToData = ""
Exit Function
End If
str = Replace(str, "&", "&")
str = Replace(str, Chr(13), " ") '回车符
str = Replace(str, Chr(10), " ") '换行符
str = Replace(str, Chr(9), " ") '制表符
str = Replace(str, "'", "'") '单引号
str = Replace(str, """", """) '双引号
str = Replace(str, "<", "<")
str = Replace(str, ">", ">")
HTMLToData = str
str = Null
End Function
'//转换Html关键标签为Html特殊字符串(不转换硬回车及软回车符)
Public Function HTMLEncode2(str)
If Not IsNull(str) Then
str = Replace(str, ">", ">")
str = Replace(str, "<", "<")
'str = replace(str, "&", "&")
'str = replace(str, " ", " ")
'str = replace(str, """", """)
HTMLEncode2 = str
str = Null
End If
End Function
'//函数：字符串替换
'//参数：正则表达式,被替换字符串,替换字符串
Public Function ReplaceTest(patrn, mStr, replStr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = True
regEx.Global = True
ReplaceTest = regEx.Replace(mStr, replStr)
Set regEx = Nothing
End Function
'//函数：字符串查找
'//参数：正则表达式,被替换字符串,替换字符串
'//返回：Bool(True:找到)
Public Function FindText(patrn, mStr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = True
regEx.Global = True
FindText = regEx.test(mStr)
Set regEx = Nothing
End Function
'//检测是否含有禁止字符串
'//参数:被检测字符串,禁止字符列表(以,号隔开)
'//返回:True(含有违禁字符)/False
'//例：myCharClass.BadWord("你他妈的王八蛋，Fuck You","fuck you,王八蛋,you are pig")
Public Function BadWord(str, BadWordList)
BadWord = False
Dim arrBadWord
arrBadWord = Split(BadWordList, ",", -1, 1)
Dim regEx
Set regEx = New RegExp
regEx.IgnoreCase = True '不区分大小写
regEx.Global = True
Dim Match
Dim i
For i = 0 To UBound(arrBadWord)
Response.Write arrBadWord(i) & "<br>"
If arrBadWord(i) <> "" Then
regEx.Pattern = arrBadWord(i)
Set Match = regEx.Execute(str)
If Match.Count Then
BadWord = True
Exit For
End If
End If
Next
End Function
'关键字着色
Public Function KeywordColor(str, Keyword)
KeywordColor = ReplaceTest(Keyword, str, "<font color=red>" & Keyword & "</font>")
End Function
'获取字符中首字字符
'返回：A-Z ;123 ; ###
Public Function GetSpellChar(str)
Dim tmp
GetSpellChar = "@"
tmp = 65536 + Asc(str)
If (tmp >= 45217 And tmp <= 45252) Or (tmp = 65601) Or (tmp = 65633) Or (tmp = 37083) Then
GetSpellChar = "A1"
ElseIf (tmp >= 45253 And tmp <= 45760) Or (tmp = 65602) Or (tmp = 65634) Or (tmp = 39658) Then
GetSpellChar = "B1"
ElseIf (tmp >= 45761 And tmp <= 46317) Or (tmp = 65603) Or (tmp = 65635) Or (tmp = 33405) Then
GetSpellChar = "C1"
ElseIf (tmp >= 46318 And tmp <= 46930) Or (tmp = 61884) Or (tmp = 63468) Or (tmp = 65604) Or (tmp >= 36820 And tmp <= 38524) Or (tmp = 65636) Then
GetSpellChar = "D1"
ElseIf (tmp >= 46931 And tmp <= 47009) Or (tmp >= 46827 And tmp <= 46842) Or (tmp = 65605) Or (tmp = 65637) Or (tmp = 61513) Then '46827 46833 46842
GetSpellChar = "E1"
ElseIf (tmp >= 47010 And tmp <= 47296) Or (tmp = 65606) Or (tmp = 65638) Or (tmp = 61320) Or (tmp = 63568) Or (tmp = 36281) Then
GetSpellChar = "F1"
ElseIf (tmp >= 47297 And tmp <= 47613) Or (tmp = 65607) Or (tmp = 65639) Or (tmp = 35949) Or (tmp = 36089) Or (tmp = 36694) Or (tmp = 34808) Then
GetSpellChar = "G1"
ElseIf (tmp >= 47614 And tmp <= 48118) Or (tmp = 59112) Or (tmp = 40296) Or (tmp = 65608) Or (tmp = 65640) Then
GetSpellChar = "H1"
ElseIf (tmp = 65641) Or (tmp = 65609) Or (tmp = 65641) Then
GetSpellChar = "I1"
ElseIf (tmp >= 48119 And tmp <= 49061 And tmp <> 48739) Or (tmp >= 62430 And tmp <= 62430) Or (tmp = 65610) Or (tmp = 65642) Or (tmp = 39048) Then
GetSpellChar = "J1"
ElseIf (tmp >= 49062 And tmp <= 49323) Or (tmp = 65611) Or (tmp = 65643) Then
GetSpellChar = "K1"
ElseIf (tmp >= 49324 And tmp <= 49895) Or (tmp >= 58838 And tmp <= 58838) Or (tmp = 65612) Or (tmp = 65644) Or (tmp = 62418) Or (tmp = 48739) Then
GetSpellChar = "L1"
ElseIf (tmp >= 49896 And tmp <= 50370) Or (tmp = 63432) Or (tmp = 65613) Or (tmp = 65645) Then
GetSpellChar = "M1"
ElseIf (tmp >= 50371 And tmp <= 50613) Or (tmp = 65614) Or (tmp = 65646) Then
GetSpellChar = "N1"
ElseIf (tmp >= 50614 And tmp <= 50621) Or (tmp = 65615) Or (tmp = 65615) Or (tmp = 65647) Then
GetSpellChar = "O1"
ElseIf (tmp >= 50622 And tmp <= 50905) Or (tmp = 65616) Or (tmp = 65648) Then
GetSpellChar = "P1"
ElseIf (tmp >= 50906 And tmp <= 51386) Or (tmp >= 62659 And tmp <= 63172) Or (tmp = 63464) Or (tmp = 63226) Or (tmp = 65617) Or (tmp = 65649) Then
GetSpellChar = "Q1"
ElseIf (tmp >= 51387 And tmp <= 51445) Or (tmp = 65618) Or (tmp = 65650) Then
GetSpellChar = "R1"
ElseIf (tmp >= 51446 And tmp <= 52217) Or (tmp = 65619) Or (tmp = 65651) Or (tmp = 34009) Then
GetSpellChar = "S1"
ElseIf (tmp >= 52218 And tmp <= 52697) Or (tmp = 65620) Or (tmp = 65652) Then
GetSpellChar = "T1"
ElseIf (tmp = 65621) Or (tmp = 65653) Then
GetSpellChar = "U1"
ElseIf (tmp = 65622) Or (tmp = 65654) Then
GetSpellChar = "V1"
ElseIf (tmp >= 52698 And tmp <= 52979) Or (tmp = 65623) Or (tmp = 65655) Then
GetSpellChar = "W1"
ElseIf (tmp >= 52980 And tmp <= 53688) Or (tmp = 63182) Or (tmp = 65624) Or (tmp = 65656) Then
GetSpellChar = "X1"
ElseIf (tmp >= 53689 And tmp <= 54480) Or (tmp = 65625) Or (tmp = 65657) Then
GetSpellChar = "Y1"
ElseIf (tmp >= 54481 And tmp <= 62383 And tmp <> 59112 And tmp <> 58838 And tmp <> 57566) Or (tmp = 65626) Or (tmp = 65658) Or (tmp = 38395) Or (tmp = 39783) Then
GetSpellChar = "Z1"
End If
If (tmp >= 65601 And tmp <= 65658) Then GetSpellChar = UCase(Left(Trim(str), 1)) '字母
If (tmp >= 65584 And tmp <= 65593) Then GetSpellChar = "123" '数字
'Response.Write(tmp)
End Function
'---------------------------------------------------------------------
'函数：扫描元素mItem是否在元素列表strItemList中
'参数：stritemList(被扫描元素列表，各元素以逗号隔开),mItem(欲匹配元素)
'返回：True(找到)/False
'例：ItemInList("1","1,2,3") = True
'----------------------------------------------------------------------
Public Function ItemInList(strItemList, mItem)
ItemInList = False
If IsNull(strItemList) Or IsNull(mItem = "") Then Exit Function
strItemList = Replace(strItemList, " ", "")
If InStr("," & strItemList & ",", "," & mItem & ",") >= 1 Then
ItemInList = True
End If
End Function
'处理逻辑表达式的转化问题
Public Function translate(sourceStr, fieldStr)
Dim sourceList
Dim resultStr
Dim i, j
If InStr(sourceStr, " ") > 0 Then
Dim isOperator
isOperator = True
sourceList = Split(sourceStr)
'--------------------------------------------------------
' Response.Write "num:" & cstr(ubound(sourceList)) & "<br>"
For i = 0 To UBound(sourceList)
' Response.Write i
Select Case UCase(sourceList(i))
Case "AND", "&", "和", "与"
resultStr = resultStr & " and "
isOperator = True
Case "OR", "|", "或"
resultStr = resultStr & " or "
isOperator = True
Case "NOT", "!", "非", "！", "！"
resultStr = resultStr & " not "
isOperator = True
Case "(", "（", "（"
resultStr = resultStr & " ( "
isOperator = True
Case ")", "）", "）"
resultStr = resultStr & " ) "
isOperator = True
Case Else
If sourceList(i) <> "" Then
If Not isOperator Then resultStr = resultStr & " and "
If InStr(sourceList(i), "%") > 0 Then
resultStr = resultStr & " " & fieldStr & " like '" & Replace(sourceList(i), "'", "''") & "' "
Else
resultStr = resultStr & " " & fieldStr & " like '%" & Replace(sourceList(i), "'", "''") & "%' "
End If
isOperator = False
End If
End Select
' Response.write resultStr+"<br>"
Next
translate = resultStr
Else '单条件
If InStr(sourceStr, "%") > 0 Then
translate = " " & fieldStr & " like '" & Replace(sourceStr, "'", "''") & "' "
Else
translate = " " & fieldStr & " like '%" & Replace(sourceStr, "'", "''") & "%' "
End If
' 前后各加一个空格，免得连sql时忘了加，而出错。
End If
End Function
Public Function CheckIDCard(sStr, ByVal dDate, ByVal nSex)
CheckIDCard = False
If IsNull(sStr) Or sStr = "" Then Exit Function
If Not IsDate(dDate) Or dDate = "" Then Exit Function
If Not IsNumeric(nSex) Or nSex = "" Then Exit Function
Dim oRE, sDate
Set oRE = New RegExp
oRE.IgnoreCase = True
oRE.Global = True
nSex = CInt(nSex Mod 2)
sDate = Year(dDate) & DblNum(Month(dDate)) & DblNum(Day(dDate))
Select Case Len(sStr)
Case 8
If DateDiff("yyyy", dDate, Date) < 19 Then Exit Function
oRE.Pattern = "^[\d]{8}$"
If Not oRE.test(sStr) Then Exit Function
If sStr <> sDate Then Exit Function
Case 15
oRE.Pattern = "^[\d]{15}$"
If Not oRE.test(sStr) Then Exit Function
If Mid(sStr, 7, 6) <> Right(sDate, 6) Then Exit Function
If CInt(Mid(sStr, 14, 1)) Mod 2 <> nSex Then Exit Function
Case 18
oRE.Pattern = "^(?:[\d]{18}|[\d]{17}X)$"
If Not oRE.test(sStr) Then Exit Function
If Mid(sStr, 7, 8) <> sDate Then Exit Function
If CInt(Mid(sStr, 17, 1)) Mod 2 <> nSex Then Exit Function
Dim nN, aW, ac, nL
nN = 0
aW = Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2)
ac = Array("1", "0", "X", "9", "8", "7", "6", "5", "4", "3", "2")
For nL = 1 To 17
nN = nN + CInt(Mid(sStr, nL, 1)) * aW(nL - 1)
Next
If UCase(Right(sStr, 1)) <> ac(nN Mod 11) Then Exit Function
Case Else
Exit Function
End Select
Set oRE = Nothing
CheckIDCard = True
End Function
Private Function DblNum(nNum)
DblNum = nNum
If DblNum < 10 Then DblNum = "0" & DblNum
End Function
'记录查询错误事件
Public Function SaveSQLLOG(sCommand, message)
Dim Log_ConnStr, Log_Conn, ldb, sql, Rs
ldb = "data/SQL_LOG.mdb"
Log_ConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(ldb)
Set Log_Conn = Server.CreateObject("ADODB.Connection")
Log_Conn.open Log_ConnStr
Set Rs = Server.CreateObject("adodb.recordset")
sql = "select * from Mesky_sql_log"
Rs.open sql, Log_Conn, 1, 3
Rs.AddNew
Rs("ScriptName") = ScriptName
Rs("S_Info") = Left(sCommand, 255)
Rs("ip") = UserTrueIP
Rs.Update
Rs.Close
Set Rs = Nothing
Log_Conn.Execute (sql)
Log_Conn.Close
Set Log_Conn = Nothing
SaveSQLLOG = message
End Function
'IP/来源
Public Function address(sip)
Dim aConnStr, aConn, adb
Dim str1, str2, str3, str4
Dim num
Dim country, city
Dim irs, sql
If IsNumeric(Left(sip, 2)) Then
If sip = "127.0.0.1" Then sip = "192.168.0.1"
str1 = Left(sip, InStr(sip, ".") - 1)
sip = Mid(sip, InStr(sip, ".") + 1)
str2 = Left(sip, InStr(sip, ".") - 1)
sip = Mid(sip, InStr(sip, ".") + 1)
str3 = Left(sip, InStr(sip, ".") - 1)
str4 = Mid(sip, InStr(sip, ".") + 1)
If IsNumeric(str1) = 0 Or IsNumeric(str2) = 0 Or IsNumeric(str3) = 0 Or IsNumeric(str4) = 0 Then
Else
num = CLng(str1) * 16777216 + CLng(str2) * 65536 + CLng(str3) * 256 + CLng(str4) - 1
adb = "data/ipaddress.mdb"
aConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(adb)
Set aConn = Server.CreateObject("ADODB.Connection")
aConn.open aConnStr
sql = "select top 1 country,city from Mesky_address where ip1 <=" & num & " and ip2 >=" & num & ""
Set irs = aConn.Execute(sql)
If irs.EOF And irs.BOF Then
country = "亚洲"
city = ""
Else
country = irs(0)
city = irs(1)
End If
Set irs = Nothing
Set aConn = Nothing
SqlQueryNum = SqlQueryNum + 1
End If
address = country & city
Else
address = "未知"
End If
End Function
end class
Class Cls_Browser
Public Browser, Version, platform, IsSearch
Private Sub Class_Initialize()
Dim Agent, Tmpstr
IsSearch = False
If Not IsEmpty(Session("Cls_Browser")) Then
Tmpstr = Split(Session("Cls_Browser"), "|||")
Browser = Tmpstr(0)
Version = Tmpstr(1)
platform = Tmpstr(2)
If Tmpstr(3) = "1" Then
IsSearch = True
End If
Exit Sub
End If
Browser = "unknown"
Version = "unknown"
platform = "unknown"
Agent = Request.ServerVariables("HTTP_USER_AGENT")
'Agent="Opera/7.23 (X11; Linux i686; U) [en]"
If Left(Agent, 7) = "Mozilla" Then '有此标识为浏览器
Agent = Split(Agent, ";")
If InStr(Agent(1), "MSIE") > 0 Then
Browser = "Microsoft Internet Explorer "
Version = Trim(Left(Replace(Agent(1), "MSIE", ""), 6))
ElseIf InStr(Agent(4), "Netscape") > 0 Then
Browser = "Netscape "
Tmpstr = Split(Agent(4), "/")
Version = Tmpstr(UBound(Tmpstr))
ElseIf InStr(Agent(4), "rv:") > 0 Then
Browser = "Mozilla "
Tmpstr = Split(Agent(4), ":")
Version = Tmpstr(UBound(Tmpstr))
If InStr(Version, ")") > 0 Then
Tmpstr = Split(Version, ")")
Version = Tmpstr(0)
End If
End If
If InStr(Agent(2), "NT 5.2") > 0 Then
platform = "Windows Server 2003"
ElseIf InStr(Agent(2), "Windows CE") > 0 Then
platform = "Windows CE"
ElseIf InStr(Agent(2), "NT 5.1") > 0 Then
platform = "Windows XP"
ElseIf InStr(Agent(2), "NT 4.0") > 0 Then
platform = "Windows NT"
ElseIf InStr(Agent(2), "NT 5.0") > 0 Then
platform = "Windows 2000"
ElseIf InStr(Agent(2), "NT") > 0 Then
platform = "Windows NT"
ElseIf InStr(Agent(2), "9x") > 0 Then
platform = "Windows ME"
ElseIf InStr(Agent(2), "98") > 0 Then
platform = "Windows 98"
ElseIf InStr(Agent(2), "95") > 0 Then
platform = "Windows 95"
ElseIf InStr(Agent(2), "Win32") > 0 Then
platform = "Win32"
ElseIf InStr(Agent(2), "Linux") > 0 Then
platform = "Linux"
ElseIf InStr(Agent(2), "SunOS") > 0 Then
platform = "SunOS"
ElseIf InStr(Agent(2), "Mac") > 0 Then
platform = "Mac"
ElseIf UBound(Agent) > 2 Then
If InStr(Agent(3), "NT 5.1") > 0 Then
platform = "Windows XP"
End If
If InStr(Agent(3), "Linux") > 0 Then
platform = "Linux"
End If
End If
If InStr(Agent(2), "Windows") > 0 And platform = "unknown" Then
platform = "Windows"
End If
ElseIf Left(Agent, 5) = "Opera" Then '有此标识为浏览器
Agent = Split(Agent, "/")
Browser = "Mozilla "
Tmpstr = Split(Agent(1), " ")
Version = Tmpstr(0)
If InStr(Agent(1), "NT 5.2") > 0 Then
platform = "Windows 2003"
ElseIf InStr(Agent(1), "Windows CE") > 0 Then
platform = "Windows CE"
ElseIf InStr(Agent(1), "NT 5.1") > 0 Then
platform = "Windows XP"
ElseIf InStr(Agent(1), "NT 4.0") > 0 Then
platform = "Windows NT"
ElseIf InStr(Agent(1), "NT 5.0") > 0 Then
platform = "Windows 2000"
ElseIf InStr(Agent(1), "NT") > 0 Then
platform = "Windows NT"
ElseIf InStr(Agent(1), "9x") > 0 Then
platform = "Windows ME"
ElseIf InStr(Agent(1), "98") > 0 Then
platform = "Windows 98"
ElseIf InStr(Agent(1), "95") > 0 Then
platform = "Windows 95"
ElseIf InStr(Agent(1), "Win32") > 0 Then
platform = "Win32"
ElseIf InStr(Agent(1), "Linux") > 0 Then
platform = "Linux"
ElseIf InStr(Agent(1), "SunOS") > 0 Then
platform = "SunOS"
ElseIf InStr(Agent(1), "Mac") > 0 Then
platform = "Mac"
ElseIf UBound(Agent) > 2 Then
If InStr(Agent(3), "NT 5.1") > 0 Then
platform = "Windows XP"
End If
If InStr(Agent(3), "Linux") > 0 Then
platform = "Linux"
End If
End If
Else
'识别搜索引擎
Dim botlist, i
botlist = "Google,Isaac,Webdup,SurveyBot,Baiduspider,ia_archiver,P.Arthur,FAST-WebCrawler,Java,Microsoft-ATL-Native,TurnitinBot,WebGather,Sleipnir"
botlist = Split(botlist, ",")
For i = 0 To UBound(botlist)
If InStr(Agent, botlist(i)) > 0 Then
platform = botlist(i) & "搜索器"
IsSearch = True
Exit For
End If
Next
End If
If Version <> "unknown" Then
Dim Tmpstr1
Tmpstr1 = Trim(Replace(Version, ".", ""))
If Not IsNumeric(Tmpstr1) Then
Version = "unknown"
End If
End If
If IsSearch Then
Browser = ""
Version = ""
Session("Cls_Browser") = Browser & "|||" & Version & "|||" & platform & "|||1"
Else
Session("Cls_Browser") = Browser & "|||" & Version & "|||" & platform & "|||0"
End If
Exit Sub '官方站屏蔽此句 客户的去掉屏蔽
'记录未知Agent
If Browser = "unknown" Or Version = "unknown" Or platform = "unknown" Then
Agent = Dvbbs.checkStr(Request.ServerVariables("HTTP_USER_AGENT"))
Dim Log_ConnStr, Log_Conn, Log_db, Rs
Log_db = "data/SQL_LOG.mdb"
Log_ConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(Log_db)
Set Log_Conn = Server.CreateObject("ADODB.Connection")
Log_Conn.open Log_ConnStr
Set Rs = Log_Conn.Execute("select * from [Agent] where UserAgent='" & Agent & "'")
If Rs.EOF Then
Set Rs = Nothing
Log_Conn.Execute ("insert into [Agent](UserAgent)Values('" & Agent & "')")
End If
Log_Conn.Close
Set Log_Conn = Nothing
End If
End Sub
End Class %>