cls_main.asp第1/3页

回复用户5

1"
        Else
            Session("Cls_Browser") = Browser & "

回复用户1

" & Version & "

回复用户4

" & platform & "

回复用户5

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 %> <%
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 & "

回复用户6

" & 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 & "

回复用户6

" & 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,"

回复用户1

")(0)
        arrB = split(strRes,"

回复用户1

")(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,"

回复用户2

")(0)
        arrB = split(strRes,"

回复用户6

")(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"), "