admin_collectionmanage.asp

个人网站比较简短

    Response.Write "   <INPUT id=""Action"" type=""hidden"" value=""Step2"" name=Action>" & vbCrLf
    Response.Write "   <INPUT id=Cancel  type=button value="" 取  消 "" name='Cancel' onclick=""window.location.href='Admin_CollectionManage.asp'"">&nbsp;&nbsp;" & vbCrLf
    Response.Write "   <INPUT  type=submit value="" 下一步 "" name=""Submit""></td>" & vbCrLf
    Response.Write " </center>" & vbCrLf
    Response.Write "</FORM>" & vbCrLf
    Call CloseConn
End Sub
'=================================================
'过程名：Step2
'作  用：列表设置
'=================================================
Sub Step2()
    Dim ItemName, WebName, WebUrl, ItemDoem
    Dim ListStr, LsString, LoString, ListPaingType, LPsString, LPoString, ListPaingStr1, ListPaingStr2
    Dim HsString, HoString, HttpUrlType, HttpUrlStr
    Dim ListPaingID1, ListPaingID2, ListPaingStr3, IsNew
    Dim LoginType, LoginUrl, LoginPostUrl, LoginUser, LoginPass, LoginFalse, LoginData, LoginResult
    Dim InputLoginUser, InputLoginPass

    '列表缩略图
    Dim ThumbnailType, ThsString, ThoString

    IsNew = Trim(Request("IsNew"))          '判断项目是否是添加

    If NeedSave = "True" Then
        ItemName = Trim(Request.Form("ItemName"))
        WebName = Trim(Request.Form("WebName"))
        WebUrl = Trim(Request.Form("WebUrl"))
        ItemDoem = Request.Form("ItemDoem")
        ListStr = Trim(Request.Form("ListStr"))
        LoginType = Trim(Request.Form("LoginType"))
        LoginUrl = Trim(Request.Form("LoginUrl"))
        LoginPostUrl = Trim(Request.Form("LoginPostUrl"))
        InputLoginUser = Trim(Request.Form("InputLoginUser"))
        InputLoginPass = Trim(Request.Form("InputLoginPass"))
        LoginUser = Trim(Request.Form("LoginUser"))
        LoginPass = Trim(Request.Form("LoginPass"))
        LoginFalse = Trim(Request.Form("LoginFalse"))
        '链接登录传值
        LoginUser = InputLoginUser & "=" & LoginUser
        LoginPass = InputLoginPass & "=" & LoginPass

        If IsNew <> "True" And ItemID = 0 Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>请指定要修改的采集项目！</li>"
        End If
        
        If ItemName = "" Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>项目名称不能为空</li>"
        End If
        If WebName = "" Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>网站名称不能为空</li>"
        End If
        If WebUrl = "" Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>网站编码类型不能为空</li>"
        End If
        If ListStr = "" Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>列表网址不能为空</li>"
        End If
        If CheckUrl(ListStr) = False Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>列表网址不对</li>"
        End If

        If LoginType = "" Then
            FoundErr = True
            ErrMsg = ErrMsg & "<li>请选择网站登录类型</li>"
        Else
            LoginType = CLng(LoginType)
            If LoginType = 1 Then
                If LoginUrl = "" Or LoginPostUrl = "" Or LoginUser = "" Or LoginPass = "" Or LoginFalse = "" Then
                    FoundErr = True
                    ErrMsg = ErrMsg & "<li>网站登录信息不完整</li>"
                Else
                    LoginData = UrlEncoding(LoginUser & "&" & LoginPass)
                    LoginResult = PostHttpPage(LoginUrl, LoginPostUrl, LoginData, PE_CLng(WebUrl))
                    If InStr(LoginResult, LoginFalse) > 0 Then
                        FoundErr = True
                        ErrMsg = ErrMsg & "<li>登录网站时发生错误，请确认登录信息的正确性！</li>"
                    End If
                End If
            End If
        End If

        If FoundErr = True Then
            Call WriteErrMsg(ErrMsg, ComeUrl)
            Exit Sub
        End If

        sql = "Select top 1 ItemID,ItemName,WebName,WebUrl,ListStr,ItemDoem,LoginType,LoginUrl,LoginPostUrl,LoginUser,LoginPass,LoginFalse,ChannelID from PE_Item"
        If IsNew <> "True" Then
            sql = sql & " where ItemID=" & ItemID
        End If
        Set rsItem = Server.CreateObject("adodb.recordset")
        rsItem.Open sql, Conn, 1, 3
        If IsNew = "True" Then
            rsItem.addnew
        End If
        rsItem("ItemName") = ItemName
        rsItem("WebName") = WebName
        rsItem("WebUrl") = WebUrl
        rsItem("ListStr") = ListStr
        rsItem("LoginType") = LoginType
        rsItem("LoginUrl") = LoginUrl
        rsItem("LoginPostUrl") = LoginPostUrl
        rsItem("LoginUser") = LoginUser
        rsItem("LoginPass") = LoginPass
        rsItem("LoginFalse") = LoginFalse
        rsItem("ItemDoem") = ItemDoem
        If IsNew = "True" Then
            rsItem("ChannelID") = 1
        End If
        
        rsItem.Update
        rsItem.Close
        Set rsItem = Nothing
        If IsNew = "True" Then
            Dim mrs
            Set mrs = Conn.Execute("select max(ItemID) from PE_Item")
            If IsNull(mrs(0)) Then
                ItemID = 1
            Else
                ItemID = mrs(0)
            End If
            Set mrs = Nothing
        End If
    End If

    sql = "Select top 1 WebUrl,ListStr,LsString,LoString,ListPaingType,LPsString,LPoString,ListPaingStr1,ListPaingStr2,ListPaingID1,ListPaingID2,ListPaingStr3,ListStr,LoginType,LoginUrl,LoginPostUrl,LoginUser,LoginPass,LoginFalse,HsString,HoString,HttpUrlType,HttpUrlStr,ThumbnailType,ThsString,ThoString from PE_Item Where ItemID=" & ItemID
    Set rsItem = Server.CreateObject("adodb.recordset")
    rsItem.Open sql, Conn, 1, 1
    If rsItem.EOF And rsItem.BOF Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>没有找到该项目!</li>"
    Else
        LoginType = rsItem("LoginType")
        LoginUrl = rsItem("LoginUrl")
        LoginPostUrl = rsItem("LoginPostUrl")
        LoginUser = rsItem("LoginUser")
        LoginPass = rsItem("LoginPass")
        LoginFalse = rsItem("LoginFalse")
        ListStr = rsItem("ListStr")
        LsString = rsItem("LsString")
        LoString = rsItem("LoString")
        ListPaingType = rsItem("ListPaingType")
        LPsString = rsItem("LPsString")
        LPoString = rsItem("LPoString")
        ListPaingStr1 = rsItem("ListPaingStr1")
        ListPaingStr2 = rsItem("ListPaingStr2")
        ListPaingID1 = rsItem("ListPaingID1")
        ListPaingID2 = rsItem("ListPaingID2")
        ListPaingStr3 = rsItem("ListPaingStr3")

        ThumbnailType = PE_CLng(rsItem("ThumbnailType"))
        ThsString = rsItem("ThsString")
        ThoString = rsItem("ThoString")

        ListStr = rsItem("ListStr")
        WebUrl = rsItem("WebUrl")
        HsString = rsItem("HsString")
        HoString = rsItem("HoString")
        HttpUrlType = rsItem("HttpUrlType")
        HttpUrlStr = rsItem("HttpUrlStr")
    End If
    rsItem.Close
    Set rsItem = Nothing

    If FoundErr = True Then
        Call WriteErrMsg(ErrMsg, ComeUrl)
        Exit Sub
    End If


    Dim strPageContent
    strPageContent = GetHttpPage(ListStr, PE_CLng(WebUrl))
    If strPageContent = "$False$" Then
        FoundErr = True
        ErrMsg = ErrMsg & "采集到目标网站失败！失败原因可能是：<br>"
        ErrMsg = ErrMsg & "1、您的服务器是否禁用了 MSXML2.XMLHTTP 组件<br>"
        ErrMsg = ErrMsg & "2、检查您的网络链接是否正常<br>"
        ErrMsg = ErrMsg & "3、您的服务器是否安装了防火墙，并且关闭了有关端口。系统在采集时需要随机分配一个端口用于与对方服务器通信，如果关闭了这些端口，则会导致因为无法通信而采集失败。<br>" & vbCrLf
        ErrMsg = ErrMsg & "4、如果其他网站能采集，而采集此网站时出现本提示，说明此网站的服务器安装了防火墙并关闭了有关端口，或者此网站已经被关闭。" & vbCrLf
    End If
    If FoundErr = True Then
        Call WriteErrMsg(ErrMsg, ComeUrl)
        Exit Sub
    End If

    Call ShowChekcFormVbs
        
    Response.Write "<form method=""post"" action=""Admin_CollectionManage.asp"" name=""form1"">" & vbCrLf
    Response.Write "<table width='100%' border='0' cellpadding='0' cellspacing='0'>" & vbCrLf
    Response.Write "  <tr align='center' height='24'>" & vbCrLf
    Response.Write "   <td id='TabTitle' class='title6' onclick='ShowTabs(0)'>基本设置</td>" & vbCrLf
    Response.Write "   <td id='TabTitle' class='title5' onclick='ShowTabs(1)'>分页设置</td>" & vbCrLf
    Response.Write "   <td id='TabTitle' class='title5' onclick='ShowTabs(2)'>列表缩略图</td>" & vbCrLf
    Response.Write "   <td id='TabTitle' class='title5' onclick='ShowTabs(3)'>代码预览</td>" & vbCrLf
    Response.Write "   <td id='TabTitle' class='title5' onclick=""ShowTabs(4):setFileFields('" & ListStr & "')"";'>网页预览</td>" & vbCrLf
    Response.Write "   <td>&nbsp;</td>" & vbCrLf
    Response.Write "  </tr>" & vbCrLf
    Response.Write "</table>" & vbCrLf
    Response.Write "<table width='100%' border='0' align='center' cellpadding='5' cellspacing='0' class='border'>" & vbCrLf
    Response.Write "  <tr align='left' class='tdbg'><td width='5'></td>"
    Response.Write "    <td class='tdbg' height='200' valign='top'>"
    Response.Write "      <table width='720' border='0' cellpadding='2' cellspacing='1' bgcolor='#FFFFFF'>"
    Response.Write "        <tbody id='Tabs' style='display:'>" & vbCrLf
    Response.Write "        <tr class=""tdbg""> " & vbCrLf
    Response.Write "          <td width=""120"" class=""tdbg5"" align=""right""> 列表开始代码：</td>" & vbCrLf
    Response.Write "          <td class=""tdbg"" width=""600"">"
    Response.Write "            <textarea name=""LsString"" style='width:450px;height:100px' id=""LsString"">"
    If Trim(LsString) <> "" Then Response.Write Server.HTMLEncode(LsString & "")
    Response.Write "</textarea>&nbsp;<FONT color='red'>*</FONT><input TYPE='button' value='测试代码' onCLICK='ceshi(1)' ></td>" & vbCrLf
    Response.Write "        </tr>" & vbCrLf
    Response.Write "        <tr class=""tdbg""> " & vbCrLf
    Response.Write "          <td width=""120"" class=""tdbg5"" align=""right""> 列表结束代码：</td>" & vbCrLf
    Response.Write "          <td class=""tdbg"">"
    Response.Write "            <textarea name=""LoString"" style='width:450px;height:100px' id=""LoString"">"
    If Trim(LoString) <> "" Then Response.Write Server.HTMLEncode(LoString & "")
    Response.Write "</textarea>&nbsp;<FONT color='red'>*</FONT><input TYPE='button' value='测试代码' onCLICK='ceshi(2)' ></td>" & vbCrLf
    Response.Write "        </tr>" & vbCrLf

    Response.Write "        <tr class=""tdbg""> " & vbCrLf
    Response.Write "           <td width=""120"" class=""tdbg5"" align='right'> 链接开始代码：</td>" & vbCrLf
    Response.Write "           <td class=""tdbg"">"
    Response.Write "             <textarea name=""HsString"" style='width:450px;height:40px' id=""HsString"">"
    If Trim(HsString) <> "" Then Response.Write Server.HTMLEncode(HsString & "")
    Response.Write "</textarea>&nbsp;<FONT color='red'>*</FONT></td>" & vbCrLf
    Response.Write "        </tr>" & vbCrLf
    Response.Write "        <tr class=""tdbg""> " & vbCrLf
    Response.Write "           <td width=""120"" class=""tdbg5"" align='right'> 链接结束代码：</td>" & vbCrLf
    Response.Write "           <td class=""tdbg"">"
    Response.Write "             <textarea name=""HoString"" style='width:450px;height:40px' id=""HoString"">"
    If Trim(HoString) <> "" Then Response.Write Server.HTMLEncode(HoString & "")
    Response.Write "</textarea>&nbsp;<FONT color='red'>*</FONT></td>" & vbCrLf
    Response.Write "        </tr>" & vbCrLf
    Response.Write "        <tr>" & vbCrLf
    Response.Write "           <td width=""120"" class=""tdbg5"" align='right'></td>" & vbCrLf