powereasy.comment.asp

个人网站比较简短

                strHTM = strHTM & Replace(Replace(Replace(Replace(strCommentList2, "{$CommentName}", strUserName), "{$Content}", ReplaceText(rsComment("Content"), 3)), "{$WriteTime}", rsComment("WriteTime")), "{$Score}", rsComment("Score"))
                
                If rsComment("ReplyContent") <> "" Then
                    strHTM = strHTM & Replace(Replace(Replace(strCommentReply2, "{$AdminName}", rsComment("ReplyName")), "{$ReplyTime}", rsComment("ReplyTime")), "{$ReplyContent}", rsComment("ReplyContent"))
                End If

                strHTM = strHTM & "     </table>" & vbCrLf
                strHTM = strHTM & "      <table width='100%' border='0' align='center' cellpadding='0' cellspacing='0'>" & vbCrLf
                strHTM = strHTM & "        <tr>" & vbCrLf
                strHTM = strHTM & "          <td class='main_shadow'>" & vbCrLf
                strHTM = strHTM & "          </td>" & vbCrLf
                strHTM = strHTM & "        </tr>" & vbCrLf
                strHTM = strHTM & "      </table>" & vbCrLf
                rsComment.MoveNext
                iCount = iCount + 1
                If iCount >= MaxPerPage Then Exit Do
            Loop
            strHTM = strHTM & "<br>"
        Case 3
            Do While Not rsComment.EOF
                If rsComment("UserType") = 1 Then
                    strUserName = "【<a href='" & strInstallDir & "ShowUser.asp?UserName=" & rsComment("UserName") & "'>" & rsComment("UserName") & "</a>】"
                Else
                    strUserName = "【<span title=""类别：游客" & vbCrLf & "姓名：" & rsComment("UserName") & vbCrLf & "信箱：" & rsComment("Email") & vbCrLf & "Oicq：" & rsComment("Oicq") & vbCrLf & "主页：" & rsComment("Homepage") & """ style=""cursor:hand"">" & rsComment("UserName") & "</span>】"
                End If
                
                strHTM = strHTM & ("<div class=""comment_body"">" & vbCrLf)
                strHTM = strHTM & ("<div class=""comment_user"">评论人：" & strUserName & "</div>" & vbCrLf)
                strHTM = strHTM & ("<div class=""comment_time"">评论时间：" & rsComment("WriteTime") & "</div>" & vbCrLf)
                strHTM = strHTM & ("<div class=""comment_score"">打分：" & rsComment("Score") & "分</div>" & vbCrLf)
                strHTM = strHTM & ("<div class=""comment_content"">" & ReplaceText(rsComment("Content"), 3) & "</div>" & vbCrLf)
                If rsComment("ReplyContent") <> "" Then
                    strHTM = strHTM & ("<div class=""comment_adminreply"">★&nbsp;管理员『" & rsComment("ReplyName") & "』于" & rsComment("ReplyTime") & "回复道：&nbsp;&nbsp;&nbsp;&nbsp;" & rsComment("ReplyContent") & "</div>" & vbCrLf)
                End If
                strHTM = strHTM & "</div>" & vbCrLf
                rsComment.MoveNext
                iCount = iCount + 1
                If iCount >= MaxPerPage Then Exit Do
            Loop
        End Select
    End If
    rsComment.Close
    Set rsComment = Nothing
    If XmlText("Site", "Comment/ShowPageType", "Chinese") = "English" Then
        strHTM = strHTM & ShowPage_en(strFileName, totalPut, MaxPerPage, CurrentPage, True, True, XmlText("Site", "Comment/ShowPageChar", "Comment"), False)
    Else
        strHTM = strHTM & ShowPage(strFileName, totalPut, MaxPerPage, CurrentPage, True, True, XmlText("Site", "Comment/ShowPageChar", "条评论"), False)
    End If
    If CommentShowType < 3 Then
       strHTM = strHTM & ("</td></tr><tr height='40'><td align='center' colspan='2'>【<a href='" & InfoUrl & "'>返回" & ChannelShortName & "内容页</a>】</td></tr>")
    Else
       strHTM = strHTM & ("<div class=""comment_backurl"">【<a href='" & InfoUrl & "'>返回" & ChannelShortName & "内容页</a>】")
    End If
    ShowCommentList = strHTM
End Function
'=================================================
'过程名：ShowJS_Comment()
'作  用：评论输入判断
'参  数：无
'=================================================
Function ShowJS_Comment(IsLogin)
    Dim strJS
    strJS = "<script language='JavaScript' type='text/JavaScript'>" & vbCrLf
    strJS = strJS & "function Check(){" & vbCrLf
    If IsLogin = False Then
        strJS = strJS & "  if (document.form1.Name.value==''){" & vbCrLf
        strJS = strJS & "    alert('请输入姓名！');" & vbCrLf
        strJS = strJS & "    document.form1.Name.focus();" & vbCrLf
        strJS = strJS & "    return false;" & vbCrLf
        strJS = strJS & "  }" & vbCrLf
    End If
    strJS = strJS & "  if (document.form1.Content.value==''){" & vbCrLf
    strJS = strJS & "    alert('请输入内容！');" & vbCrLf
    strJS = strJS & "    document.form1.Content.focus();" & vbCrLf
    strJS = strJS & "    return false;" & vbCrLf
    strJS = strJS & "  }" & vbCrLf
    strJS = strJS & "  return true;  " & vbCrLf
    strJS = strJS & "}" & vbCrLf
    strJS = strJS & "</script>" & vbCrLf
    ShowJS_Comment = strJS
End Function

'=================================================
'函数名：SaveComment()
'作  用：保存评论
'参  数：无
'=================================================
Sub SaveComment()
    Dim trs, NeedCheck
    Set trs = Conn.Execute(sql)
    If trs.BOF And trs.EOF Then
        FoundErr = True
        ErrMsg = ErrMsg & Replace(XmlText("Site", "Comment/Err2", "<br>找不到指定的{$ChannelShortName}"), "{$ChannelShortName}", ChannelShortName)
        Exit Sub
    End If
    'InfoTitle = trs(0)
    EnableComment = trs("EnableComment") Or UserEnableComment
    NeedCheck = trs("CheckComment") And (Not UserCheckComment)
    'ClassID = trs(3)
    Set trs = Nothing
    If EnableComment <> True Then
        FoundErr = True
        ErrMsg = ErrMsg & XmlText("Site", "Comment/Err4", "<br><li>对不起，您没有本栏目发表评论的权限！</li>")
        Exit Sub
    End If

    Dim rsComment, tClass
    Dim CommentUserType, CommentUserName, CommentUserSex, CommentUserEmail, CommentUserOicq
    Dim CommentUserIcq, CommentUserMsn, CommentUserHomepage, CommentUserScore, CommentUserContent
    If UserLogined = False Then
        CommentUserType = 0
        CommentUserName = PE_HTMLEncode(Trim(Request("Name")))
        If CommentUserName = "" Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>输入姓名有误！</li>"
            Exit Sub
        End If
        CommentUserSex = PE_HTMLEncode(Trim(Request("Sex")))
        CommentUserOicq = PE_HTMLEncode(Trim(Request("Oicq")))
        CommentUserIcq = PE_HTMLEncode(Trim(Request("Icq")))
        CommentUserMsn = PE_HTMLEncode(Trim(Request("Msn")))
        CommentUserEmail = PE_HTMLEncode(Trim(Request("Email")))
        CommentUserHomepage = ReplaceUrlBadChar(Trim(Request("Homepage")))
        If CommentUserHomepage = "http://" Or IsNull(CommentUserHomepage) Then CommentUserHomepage = ""
    Else
        CommentUserType = 1
        CommentUserName = UserName
    End If

    CommentUserScore = PE_CLng(Request.Form("Score"))
    CommentUserContent = Trim(Request.Form("Content"))
    If CommentUserContent = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>请输入内容</li>"
        Exit Sub
    End If

    'CommentUserContent = ReplaceText(ReplaceBadChar(FilterJS(CommentUserContent)), 3)
    CommentUserContent = PE_HTMLEncode(CommentUserContent)
    Set rsComment = Server.CreateObject("adodb.recordset")
    sql = "select top 1 * from PE_Comment"
    rsComment.Open sql, Conn, 1, 3
    rsComment.addnew
    rsComment("ModuleType") = ModuleType
    rsComment("InfoID") = InfoID
    rsComment("UserType") = CommentUserType
    rsComment("UserName") = CommentUserName
    rsComment("Sex") = CommentUserSex
    rsComment("Oicq") = CommentUserOicq
    rsComment("Icq") = CommentUserIcq
    rsComment("Msn") = CommentUserMsn
    rsComment("Email") = CommentUserEmail
    rsComment("Homepage") = CommentUserHomepage
    rsComment("IP") = UserTrueIP
    rsComment("Score") = CommentUserScore
    rsComment("Content") = ReplaceBadUrl(CommentUserContent) '过滤非法系统URL
    rsComment("WriteTime") = Now()
    rsComment("Passed") = (Not NeedCheck)
    rsComment.Update
    rsComment.Close
    Set rsComment = Nothing
    Conn.Execute ("update PE_Channel set CommentCount=CommentCount+1 where ChannelID=" & ChannelID & "")
    Select Case ModuleType
    Case 1
        Conn.Execute ("update PE_Article set CommentCount=CommentCount+1 where ArticleID=" & InfoID & "")
    Case 2
        Conn.Execute ("update PE_Soft set CommentCount=CommentCount+1 where SoftID=" & InfoID & "")
    Case 3
        Conn.Execute ("update PE_Photo set CommentCount=CommentCount+1 where PhotoID=" & InfoID & "")
    Case 5
        Conn.Execute ("update PE_Product set CommentCount=CommentCount+1 where ProductID=" & InfoID & "")
    End Select
    If NeedCheck = False Then
        Call WriteSuccessMsg(XmlText("Site", "Comment/SusMsg1", "发表评论成功！"), ComeUrl)
    Else
        Call WriteSuccessMsg(XmlText("Site", "Comment/SusMsg2", "发表评论成功！请等候管理员的审核！审核后才会显示"), ComeUrl)
    End If
End Sub


'=================================================
'过程名：GetCommentJS
'作  用：显示相关评论的JS代码
'参  数：CommentNum  ----最多显示多少个评论
'=================================================
Sub GetCommentJS(CommentNum)
    Dim rsComment, sqlComment, strComment, strUserName
    If CommentNum > 0 And CommentNum <= 100 Then
        sqlComment = "select top " & CommentNum
    Else
        sqlComment = "select top 10 "
    End If
    sqlComment = sqlComment & " * from PE_Comment where ModuleType=" & ModuleType & " and InfoID=" & InfoID & " and Passed=" & PE_True & " order by CommentID desc"
    
    Set rsComment = Server.CreateObject("ADODB.Recordset")
    rsComment.Open sqlComment, Conn, 1, 1
    If rsComment.BOF And rsComment.EOF Then
        strComment = XmlText("Site", "Comment/Err3", "&nbsp;&nbsp;&nbsp;&nbsp;没有任何评论")
    Else
        strComment = "<table width='100%' align='center' border='0' cellspacing='1' cellpadding='2' class='comment_border'>"
        strComment = strComment & XmlText("Site", "Comment/ShowCommentListJs", "<tr class='comment_title' align='center'><td>评论人</td><td>评论内容</td><td>评论时间</td><td>打分</td></tr>")
        Dim strCommentList, strCommentReply1, strCommentReply2
        strCommentList = XmlText("Site", "Comment/ShowCommentJs", "<tr bgcolor='white'><td align='center' width='80'>{$CommentName}</td><td>{$Content}</td><td align='center' width='120'>{$WriteTime}</td><td align='center' width='40'>{$Score}分</td></tr>")
        strCommentReply1 = XmlText("SupplyInfo", "AdminReplayTypeJs", "<tr><td>&nbsp;</td><td colspan='5'><font color='009900'>★</font>&nbsp;发布人『<font color='blue'>{$AdminName}</font>』于 {$ReplyTime} 回复道：&nbsp;&nbsp;&nbsp;&nbsp;{$ReplyContent}<br></td></tr>")
        strCommentReply2 = XmlText("Site", "Comment/AdminReplayTypeJs", "<tr><td>&nbsp;</td><td colspan='5'><font color='009900'>★</font>&nbsp;管理员『<font color='blue'>{$AdminName}</font>』于 {$ReplyTime} 回复道：&nbsp;&nbsp;&nbsp;&nbsp;{$ReplyContent}<br></td></tr>")
        Do While Not rsComment.EOF
            If rsComment("UserType") = 1 Then
                strUserName = "【<a href='" & strInstallDir & "ShowUser.asp?UserName=" & rsComment("UserName") & "'><font color='green'>" & rsComment("UserName") & "</font></a>】"
            Else
                strUserName = "【<span title='类别：游客" & "\n" & "姓名：" & rsComment("UserName") & "\n" & "信箱：" & rsComment("Email") & "\n" & "Oicq：" & rsComment("Oicq") & "\n" & "主页：" & rsComment("Homepage") & "' style='cursor:hand'>" & rsComment("UserName") & "</span>】"
            End If
            
            strComment = strComment & Replace(Replace(Replace(Replace(strCommentList, "{$CommentName}", strUserName), "{$Content}", FilterJS(Replace(ReplaceText(rsComment("Content"), 3), vbCrLf, "\n"))), "{$WriteTime}", rsComment("WriteTime")), "{$Score}", rsComment("Score"))
            If rsComment("ReplyContent") <> "" Then
                If ModuleType = 6 Then
                    strComment = strComment & Replace(Replace(Replace(strCommentReply1, "{$AdminName}", rsComment("ReplyName")), "{$ReplyTime}", rsComment("ReplyTime")), "{$ReplyContent}", Replace(rsComment("ReplyContent"), vbCrLf, "\n"))
                Else
                    strComment = strComment & Replace(Replace(Replace(strCommentReply2, "{$AdminName}", rsComment("ReplyName")), "{$ReplyTime}", rsComment("ReplyTime")), "{$ReplyContent}", Replace(rsComment("ReplyContent"), vbCrLf, "\n"))
                End If
            End If
            rsComment.MoveNext
        Loop
        rsComment.Close
        Set rsComment = Nothing
        strComment = strComment & "</table>"
        strComment = strComment & Replace(XmlText("Site", "Comment/ShowMore", "<div align='center'><a href='{$strFileName}'>查看评论详细内容及更多评论</a></div>"), "{$strFileName}", ChannelUrl & "/" & strFileName)
    End If
    Response.Write "document.write(""" & Replace(strComment, """", "\""") & """);"
End Sub


'**************************************************
'函数名：GetInfoUrl
'作  用：得到文章、下载、图片、商品的Url地址
'参  数：
'返回值：替换后字符串
'**************************************************
Function GetInfoUrl(ByVal tParentDir, ByVal tClassDir, ByVal tUpdateTime, ByVal tInfoID, ByVal tClassPurview, ByVal tInfoPurview, ByVal tInfoPoint)
    If IsNull(tParentDir) Then tParentDir = ""
    If IsNull(tClassDir) Then tClassDir = ""
    If IsNull(tClassPurview) Then tClassPurview = 0
    If IsNull(tInfoPurview) Then tInfoPurview = 0

    Select Case ModuleType
    Case 1
        If UseCreateHTML > 0 And tClassPurview = 0 And tInfoPoint = 0 And tInfoPurview = 0 Then
            GetInfoUrl = ChannelUrl & GetItemPath(StructureType, tParentDir, tClassDir, tUpdateTime) & GetItemFileName(FileNameType, ChannelDir, tUpdateTime, tInfoID) & FileExt_Item
        Else
            GetInfoUrl = ChannelUrl_ASPFile & "/ShowArticle.asp?ArticleID=" & tInfoID
        End If
    Case 2
        If UseCreateHTML > 0 Then
            GetInfoUrl = ChannelUrl & GetItemPath(StructureType, tParentDir, tClassDir, tUpdateTime) & GetItemFileName(FileNameType, ChannelDir, tUpdateTime, tInfoID) & FileExt_Item
        Else
            GetInfoUrl = ChannelUrl_ASPFile & "/ShowSoft.asp?SoftID=" & tInfoID
        End If
    Case 3
        If UseCreateHTML > 0 And tClassPurview = 0 And tInfoPoint = 0 And tInfoPurview = 0 Then
            GetInfoUrl = ChannelUrl & GetItemPath(StructureType, tParentDir, tClassDir, tUpdateTime) & GetItemFileName(FileNameType, ChannelDir, tUpdateTime, tInfoID) & FileExt_Item
        Else
            GetInfoUrl = ChannelUrl_ASPFile & "/ShowPhoto.asp?PhotoID=" & tInfoID
        End If
    Case 5
        If UseCreateHTML > 0 Then
            GetInfoUrl = ChannelUrl & GetItemPath(StructureType, tParentDir, tClassDir, tUpdateTime) & GetItemFileName(FileNameType, ChannelDir, tUpdateTime, tInfoID) & FileExt_Item
        Else
            GetInfoUrl = ChannelUrl_ASPFile & "/ShowProduct.asp?ProductID=" & tInfoID
        End If
    Case 6
        GetInfoUrl = strInstallDir & ChannelDir & "/ShowSupply.asp?SupplyID=" & tInfoID
    End Select
End Function

%>