sys_fun.bas

一个动易的组件源码,3.5的封装,本程序只是搜索部分,另本人己封装了动易3.5的组件,有源码,有意请联系我

Attribute VB_Name = "Sys_Fun"
Public Function showpage(sfilename, totalnumber, MaxPerPage, ShowTotal, ShowAllPages, strUnit)
    Dim n, i, strTemp, strUrl
    If totalnumber Mod MaxPerPage = 0 Then
        n = totalnumber \ MaxPerPage
    Else
        n = totalnumber \ MaxPerPage + 1
    End If
    strTemp = "<table align='center'><tr><td>"
    If ShowTotal = True Then
        strTemp = strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & "&nbsp;&nbsp;"
    End If
    strUrl = JoinChar(sfilename)
    If CurrentPage < 2 Then
            strTemp = strTemp & "首页 上一页&nbsp;"
    Else
            strTemp = strTemp & "<a href='" & strUrl & "page=1'>首页</a>&nbsp;"
            strTemp = strTemp & "<a href='" & strUrl & "page=" & (CurrentPage - 1) & "'>上一页</a>&nbsp;"
    End If

    If n - CurrentPage < 1 Then
            strTemp = strTemp & "下一页 尾页"
    Else
            strTemp = strTemp & "<a href='" & strUrl & "page=" & (CurrentPage + 1) & "'>下一页</a>&nbsp;"
            strTemp = strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>"
    End If
    strTemp = strTemp & "&nbsp;页次：<strong><font color=red>" & CurrentPage & "</font>/" & n & "</strong>页 "
    strTemp = strTemp & "&nbsp;<b>" & MaxPerPage & "</b>" & strUnit & "/页"
    If ShowAllPages = True Then
        strTemp = strTemp & "&nbsp;转到：<select name='page' size='1' onchange=""javascript:window.location='" & strUrl & "page=" & "'+this.options[this.selectedIndex].value;"">"
        For i = 1 To n
            strTemp = strTemp & "<option value='" & i & "'"
            If CInt(CurrentPage) = CInt(i) Then strTemp = strTemp & " selected "
            strTemp = strTemp & ">第" & i & "页</option>"
        Next
        strTemp = strTemp & "</select>"
    End If
    strTemp = strTemp & "</td></tr></table>"
    Response.Write strTemp
End Function
'*************************************************
'函数名：gotTopic
'作  用：截字符串，汉字一个算两个字符，英文算一个字符
'参  数：str   ----原字符串
'       strlen ----截取长度
'返回值：截取后的字符串
'*************************************************
Function gotTopic(str, strlen)
    If str = "" Then
        gotTopic = ""
        Exit Function
    End If
    Dim l, t, c, i
    str = Replace(Replace(Replace(Replace(str, "&nbsp;", " "), "&quot;", Chr(34)), "&gt;", ">"), "&lt;", "<")
    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
            gotTopic = Left(str, i) & "…"
            Exit For
        Else
            gotTopic = str
        End If
    Next
    gotTopic = Replace(Replace(Replace(Replace(gotTopic, " ", "&nbsp;"), Chr(34), "&quot;"), ">", "&gt;"), "<", "&lt;")
End Function

Public Function JoinChar(strUrl)
    If strUrl = "" Then
        JoinChar = ""
        Exit Function
    End If
    If InStr(strUrl, "?") < Len(strUrl) Then
        If InStr(strUrl, "?") > 1 Then
            If InStr(strUrl, "&") < Len(strUrl) Then
                JoinChar = strUrl & "&"
            Else
                JoinChar = strUrl
            End If
        Else
            JoinChar = strUrl & "?"
        End If
    Else
        JoinChar = strUrl
    End If
End Function
'=================================================
'过程名：GetPicArticleTitle
'作  用：显示图片文章的标题
'参  数：intTitleLen  ----标题最多字符数，一个汉字=两个英文字符
'        intImgWidth   ----图片宽度
'        intImgHeight  ----图片高度
'=================================================
Sub GetPicArticleTitle(intTitleLen, intImgWidth, intImgHeight)
    Dim FileType, TitleStr
    FileType = Right(LCase(rsPic("DefaultPicUrl")), 3)
    TitleStr = gotTopic(rsPic("Title"), intTitleLen)
    strPic = strPic & "<a href='" & rsPic("LayoutFileName") & "?ArticleID=" & rsPic("ArticleID") & "' title='文章标题：" & rsPic("Title") & vbCrLf & "作    者：" & rsPic("Author") & vbCrLf & "更新时间：" & rsPic("UpdateTime") & vbCrLf & "点击次数：" & rsPic("Hits") & "' target='_blank'>"
    If FileType = "swf" Then
        strPic = strPic & "<object classid='clsid:D27CDB6E-AE6D-11cf-96B8-444553540000' codebase=' ' width='" & intImgWidth & "' height='" & intImgHeight & "'><param name='movie' value='" & rsPic("DefaultPicUrl") & "'><param name='quality' value='high'><embed src='" & rsPic("DefaultPicUrl") & "' pluginspage='' type='application/x-shockwave-flash' width='" & intImgWidth & "' height='" & intImgHeight & "'></embed></object>"
    ElseIf FileType = "jpg" Or FileType = "bmp" Or FileType = "png" Or FileType = "gif" Then
       Response.Write "<img border='0' src='" & rsPic("DefaultPicUrl") & " ' width='" & intImgWidth & " ' height='" & intImgHeight & "'>"
    Else
        strPic = strPic & "<img src='images/NoPic2.jpg' width='" & intImgWidth & "' height='" & intImgHeight & "' border='0'>"
    End If
    If rsPic("TitleFontType") = 1 Then
        TitleStr = "<b>" & TitleStr & "</b>"
    ElseIf rsPic("TitleFontType") = 2 Then
        TitleStr = "<em>" & TitleStr & "</em>"
    ElseIf rsPic("TitleFontType") = 3 Then
        TitleStr = "<b><em>" & TitleStr & "</em></b>"
    End If
    If rsPic("TitleFontColor") <> "" Then
        TitleStr = "<font color='" & rsPic("TitleFontColor") & "'>" & TitleStr & "</font>"
    End If
    strPic = strPic & "<br>" & TitleStr & "</a>"
End Sub

'=================================================
'过程名：ArticleContent
'作  用：显示文章属性、标题、作者、更新日期、点击数等信息
'参  数：intTitleLen  ----标题最多字符数，一个汉字=两个英文字符
'        ShowProperty ----是否显示文章属性（固顶/推荐/普通），True为显示，False为不显示
'        ShowIncludePic ---是否显示“[图文]”字样，True为显示，False为不显示
'        ShowAuthor -------是否显示文章作者，True为显示，False为不显示
'        ShowDateType -----显示更新日期的样式，0为不显示，1为显示年月日，2为只显示月日。
'        ShowHits ---------是否显示文章点击数，True为显示，False为不显示
'        ShowHot ----------是否显示热门文章标志，True为显示，False为不显示
'=================================================
Public Sub ArticleContent(intTitleLen, ShowProperty, ShowIncludePic, ShowAuthor, ShowDateType, ShowHits, ShowHot)
    Dim i, strTemp, TitleStr, Author, AuthorName, AuthorEmail
    i = 0
    Do While Not rsArticle.EOF
        strTemp = "<tr class='listbg'><td>&nbsp;"
        If ShowProperty = True Then
            If rsArticle("OnTop") = 1 Then
                strTemp = strTemp & "<img src='images/article_ontop.gif' alt='固顶文章'>&nbsp;"
            ElseIf rsArticle("Elite") = 1 Then
                strTemp = strTemp & "<img src='images/article_elite.gif' alt='推荐文章'>&nbsp;"
            Else
                strTemp = strTemp & "<img src='images/article_common.gif' alt='普通文章'>&nbsp;"
            End If
        End If
        If ShowIncludePic = True And rsArticle("IncludePic") = 1 Then
            strTemp = strTemp & "<font color=blue>[图文]</font>"
        End If
        Author = rsArticle("Author")
        If InStr(Author, "|") > 0 Then
            AuthorName = Left(Author, InStr(Author, "|") - 1)
            AuthorEmail = Right(Author, Len(Author) - InStr(Author, "|") - 1)
        Else
            AuthorName = Author
            AuthorEmail = ""
        End If
        strTemp = strTemp & "<a href='ShowArticle.asp?ArticleID=" & rsArticle("articleid") & "' title='文章标题：" & rsArticle("Title") & vbCrLf & "作    者：" & AuthorName & vbCrLf & "更新时间：" & rsArticle("UpdateTime") & vbCrLf & "点击次数：" & rsArticle("Hits") & "' target='_blank'>"
        TitleStr = gotTopic(rsArticle("title"), intTitleLen)
        strTemp = strTemp & TitleStr & "</a>"
        If ShowAuthor = True Or ShowDateType > 0 Or ShowHits = True Then
            strTemp = strTemp & "&nbsp;("
            If ShowAuthor = True Then
                If AuthorEmail = "" Then
                    strTemp = strTemp & AuthorName
                Else
                    strTemp = strTemp & "<a href='mailto:" & AuthorEmail & "'>" & AuthorName & "</a>"
                End If
            End If
            If ShowDateType > 0 Then
                If ShowAuthor = True Then
                    strTemp = strTemp & "，"
                End If
                If CDate(FormatDateTime(rsArticle("UpdateTime"), 2)) = Date Then
                    strTemp = strTemp & "<font color=red>"
                Else
                    strTemp = strTemp & "<font color=#999999>"
                End If
                If ShowDateType = 1 Then
                    strTemp = strTemp & Month(rsArticle("UpdateTime")) & "月" & Day(rsArticle("UpdateTime")) & "日</font>"
                Else
                    strTemp = strTemp & FormatDateTime(rsArticle("UpdateTime"), 1) & "</font>"
                End If
            End If
            If ShowHits = True Then
                If ShowAuthor = True Or ShowDateType > 0 Then
                    strTemp = strTemp & "，"
                End If
                strTemp = strTemp & rsArticle("Hits")
            End If
            strTemp = strTemp & ")"
        End If
        If ShowHot = True And rsArticle("Hits") >= HitsOfHot Then
            strTemp = strTemp & "<img src='images/hot.gif' alt='热点文章'>"
        End If
        Response.Write strTemp
        rsArticle.MoveNext
        i = i + 1
        If i >= MaxPerPage Then Exit Do
        strTemp = strTemp & "</td></tr>"
    Loop
End Sub

'**************************************************
'函数名：CheckUserLogined
'作  用：检查用户是否登录
'参  数：无
'返回值：True ----已经登录
'        False ---没有登录
'**************************************************
Public Function CheckUserLogined()
    Dim Logined, UserName, Password, UserLevel, rs, sql
    Logined = True
    UserName = Request.Cookies("asp163")("UserName")
    Password = Request.Cookies("asp163")("Password")
    UserLevel = Request.Cookies("asp163")("UserLevel")
    If UserName = "" Then
        Logined = False
    End If
    If Password = "" Then
        Logined = False
    End If
    If UserLevel = "" Then
        Logined = False
    End If
    If Logined = True Then
        UserName = Replace(Trim(UserName), "'", "")
        Password = Replace(Trim(Password), "'", "")
        UserLevel = CInt(Trim(UserLevel))
        Set rs = Server.CreateObject("adodb.recordset")
        sql = "select * from [User] where LockUser=0 and username='" & UserName & "' and password='" & Password & "'"
        rs.Open sql, Conn, 1, 1
        If rs.BOF And rs.EOF Then
            Logined = False
        Else
            If Password <> rs("password") Or UserLevel < rs("UserLevel") Then
                Logined = False
            End If
        End If
        rs.Close
        Set rs = Nothing
    End If
    CheckUserLogined = Logined
End Function
'****************************************************
'过程名：WriteErrMsg
'作  用：显示错误提示信息
'参  数：无
'****************************************************
Public Sub WriteErrMsg()
    Dim strErr
    strErr = strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbCrLf
    strErr = strErr & "<link href='style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbCrLf
    strErr = strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbCrLf
    strErr = strErr & "  <tr align='center' class='title'><td height='22'><strong>错误信息</strong></td></tr>" & vbCrLf
    strErr = strErr & "  <tr class='tdbg'><td height='100' valign='top'><b>产生错误的可能原因：</b>" & ErrMsg & "</td></tr>" & vbCrLf
    strErr = strErr & "  <tr align='center' class='tdbg'><td><a href='javascript:history.go(-1)'>&lt;&lt; 返回上一页</a></td></tr>" & vbCrLf
    strErr = strErr & "</table>" & vbCrLf
    strErr = strErr & "</body></html>" & vbCrLf
    Response.Write strErr
End Sub
'=================================================
'过程名：ShowArticle
'作  用：分页显示文章标题等信息
'参  数：TitleLen  ----标题最多字符数，一个汉字=两个英文字符
'=================================================
Sub ShowArticle(TitleLen)
    If TitleLen < 0 Or TitleLen > 100 Then
        TitleLen = 62
    End If
    sqlArticle = sqlArticle & "select  A.ArticleID,A.ClassID,L.LayoutID,L.LayoutFileName,A.Title,A.[Key],A.Author,A.CopyFrom,A.UpdateTime,A.Editor,A.TitleFontColor,A.TitleFontType,"
    sqlArticle = sqlArticle & "A.Hits,A.OnTop,A.Hot,A.Elite,A.Passed,A.IncludePic,A.Stars,A.PaginationType,A.ReadLevel,A.ReadPoint,A.DefaultPicUrl from Article A"
    sqlArticle = sqlArticle & " inner join Layout L on A.LayoutID=L.LayoutID where A.Deleted=0 and A.Passed=1 "
    If SpecialID > 0 Then
        sqlArticle = sqlArticle & " and A.SpecialID=" & SpecialID
    End If
    If ClassID > 0 Then
        sqlArticle = sqlArticle & " and A.ClassID=" & ClassID
    End If
    sqlArticle = sqlArticle & " order by A.OnTop,A.ArticleID desc"
    Set rsArticle = Server.CreateObject("ADODB.Recordset")
    rsArticle.Open sqlArticle, Conn, 1, 1
    If rsArticle.BOF And rsArticle.EOF Then
        totalPut = 0
        Response.Write ("<tr class='listbg'><td>没有任何文章</td></tr>")
    Else
        totalPut = rsArticle.RecordCount
        If CurrentPage < 1 Then
            CurrentPage = 1
        End If
        If (CurrentPage - 1) * MaxPerPage > totalPut Then
            If (totalPut Mod MaxPerPage) = 0 Then
                CurrentPage = totalPut \ MaxPerPage
            Else
                CurrentPage = totalPut \ MaxPerPage + 1
            End If
        End If
        If CurrentPage = 1 Then
            Call ArticleContent(TitleLen, True, True, True, 2, True, True)
        Else
            If (CurrentPage - 1) * MaxPerPage < totalPut Then
                rsArticle.Move (CurrentPage - 1) * MaxPerPage
                Dim bookmark
                bookmark = rsArticle.bookmark
                Call ArticleContent(TitleLen, True, True, True, 2, True, True)
            Else
                CurrentPage = 1
                Call ArticleContent(TitleLen, True, True, True, 2, True, True)
            End If
        End If
    End If
    rsArticle.Close
    Set rsArticle = Nothing
End Sub