📄 admin_areacollection.asp
字号:
strTemplate = strTemplate & "<META http-equiv=Content-Type content=text/html; charset=gb2312><link href='" & InstallDir & "Skin/DefaultSkin.css' rel='stylesheet' type='text/css'>" & vbCrLf
strTemplate = strTemplate & "</head>" & vbCrLf
strTemplate = strTemplate & "<body>" & vbCrLf
strTemplate = strTemplate & vbCrLf & AreaCode & vbCrLf
strTemplate = strTemplate & "</body>" & vbCrLf
strTemplate = strTemplate & "</html>" & vbCrLf
strTemplate = Resumeblank(strTemplate)
If CreateMultiFolder(InstallDir & "AreaCollection") = False Then '如果支持创建目录
FoundErr = True
ErrMsg = ErrMsg & "<li>不能创建 AreaCollection 文件夹,请检查是否给FSO权限或是否给网站目录写入权限。</li>"
Exit Sub
End If
Call WriteToFile(InstallDir & "AreaCollection/" & AreaFile, strTemplate)
If SaveType = "AreaCollectionAdd" Then
sql = "SELECT TOP 1 * FROM PE_AreaCollection Where Type=0"
Set rsArea = Server.CreateObject("adodb.recordset")
rsArea.Open sql, Conn, 1, 3
rsArea.addnew
Else
sql = "SELECT TOP 1 * FROM PE_AreaCollection where AreaID=" & AreaID & " and Type=0"
Set rsArea = Server.CreateObject("adodb.recordset")
rsArea.Open sql, Conn, 1, 3
End If
rsArea("AreaName") = AreaName
rsArea("AreaFile") = AreaFile
rsArea("AreaIntro") = AreaIntro
rsArea("Code") = Code
rsArea("StringReplace") = StringReplace
rsArea("AreaUrl") = AreaUrl
rsArea("LableStart") = LableStart
rsArea("LableEnd") = LableEnd
rsArea("StringReplace") = StringReplace
rsArea("FilterProperty") = FilterProperty
rsArea("UpFileType") = UpFileType
rsArea("AreaPassed") = True
rsArea("Type") = 0
rsArea.Update
rsArea.Close
Set rsArea = Nothing
If SaveType = "AreaCollectionAdd" Then
Call WriteSuccessMsg("添加区域项目成功！", "Admin_AreaCollection.asp?Action=AreaCollectionManage")
Else
Call WriteSuccessMsg("修改区域项目成功！", "Admin_AreaCollection.asp?Action=AreaCollectionManage")
End If
Call CloseConn
End Sub
'=================================================
'过程名：AreaCollectionManage()
'作 用：区域采集管理
'=================================================
Sub AreaCollectionManage()
Dim sql, rs, Action
Dim rsArea, mrs, SaveType, FoundErr
Dim AreaID, AreaName, AreaFile, AreaIntro, Code, StringReplace, AreaUrl
Dim LableStart, LableEnd, FilterProperty, AreaPassed
Response.Write "<br>" & vbCrLf
Response.Write "<table class=""border"" border=""0"" cellspacing=""1"" width=""100%"" cellpadding=""0"">" & vbCrLf
Response.Write "<form name=""myform"" method=""POST"" action=""Admin_AreaCollection.asp"">" & vbCrLf
Response.Write " <tr class=""title"" style=""padding: 0px 2px;"">" & vbCrLf
Response.Write " <td width=""20"" height=""22"" align=""center""> ID </td>" & vbCrLf
Response.Write " <td width=""80"" align=""center""> 区域采集名称 </td>" & vbCrLf
Response.Write " <td width=""150"" align=""center""> 区域采集简介 </td>" & vbCrLf
Response.Write " <td width=""100"" align=""center"">区域文件名</td>" & vbCrLf
Response.Write " <td width=""200"" align=""center"">调用代码</td> " & vbCrLf
Response.Write " <td width=""80"" height=""22"" align=""center""> 常 规 操 作 " & vbCrLf
Response.Write " <td width=""40"" align=""center""> 检测 </td>" & vbCrLf
Response.Write " </tr>" & vbCrLf
sql = "SELECT * From PE_AreaCollection Where Type=0"
Set rs = Server.CreateObject("adodb.recordset")
rs.Open sql, Conn, 1, 1
If rs.BOF And rs.EOF Then
Response.Write "<tr class='tdbg' height='50'><td colspan='7' align='center'>系统中暂无区域采集项目！</td></tr></table>"
Else
Do While Not rs.EOF
AreaID = rs("AreaID")
AreaName = rs("AreaName")
AreaFile = rs("AreaFile")
AreaIntro = rs("AreaIntro")
AreaPassed = rs("AreaPassed")
Response.Write "<tr class=""tdbg"" onmouseout=""this.className='tdbg'"" onmouseover=""this.className='tdbgmouseover'"" style=""padding: 0px 2px;"">" & vbCrLf
Response.Write " <td width=""20"" align=""center"" height=""40"">" & AreaID & " </td>" & vbCrLf
Response.Write " <td width=""80"" align=""center"">" & AreaName & "</td> " & vbCrLf
Response.Write " <td width=""150"" align=""center"">" & AreaIntro & "</td> " & vbCrLf
Response.Write " <td width=""100"" align=""center"">" & AreaFile & "</td> " & vbCrLf
Response.Write " <td width=""200"" align=""center""><TEXTAREA NAME='Content' onMouseOver=""this.select()"" style='width:250px;height:50px'>" & "<iframe marginwidth=0 marginheight=0 frameborder=0 src='" & InstallDir & "AreaCollection/" & AreaFile & "'></iframe> " & "</TEXTAREA></td> " & vbCrLf
Response.Write " <td width=""80"" align=""center"">"
Response.Write " <a href='Admin_AreaCollection.asp?Action=AreaCollectionModify&AreaID=" & AreaID & "' onclick=""javascript:esave.style.visibility='visible';"">修改</a> "
Response.Write " <a href='Admin_AreaCollection.asp?Action=AreaCollectionDel&AreaID=" & AreaID & "' onClick=""return confirm('确定要删除此项目吗？');"">删除</a><br>"
Response.Write " <a href='Admin_AreaCollection.asp?Action=AreaCollectionCreateFile&AreaID=" & AreaID & "' onclick=""javascript:esave.style.visibility='visible';"">刷新</a> "
Response.Write " <a href='Admin_AreaCollection.asp?Action=AreaCollectionPreviewFile&AreaID=" & AreaID & "' >预览</a>"
Response.Write "</td> " & vbCrLf
Response.Write " <td width=""40"" align=""center"">" & vbCrLf
If AreaPassed = True Then
Response.Write "<b>√</b>"
Else
Response.Write "<FONT color='red'><b>×</b></FONT>"
End If
Response.Write " </td>" & vbCrLf
Response.Write "</tr> " & vbCrLf
rs.MoveNext
Loop
Response.Write "<tr class='tdbg'>" & vbCrLf
Response.Write " <td colspan='9' height='32' align='center'>" & vbCrLf
Response.Write " <INPUT id=""Action"" type=""hidden"" value=""AreaCollectionCreateFile"" name='Action'>" & vbCrLf
Response.Write " <input type=""submit"" value="" 刷新所有区域采集文件 "" name=""submit"" onclick=""javascript:esave.style.visibility='visible';""> </td>"
Response.Write " </td></tr>" & vbCrLf
Response.Write "</form>" & vbCrLf
Response.Write "</table>" & vbCrLf
Response.Write "<br>" & vbCrLf
Response.Write "<table border='0' cellpadding='0' cellspacing='1' width='100%' class='border'>" & vbCrLf
Response.Write " <tr class='tdbg'>" & vbCrLf
Response.Write " <td width='120' align='right' class='tdbg5'><strong>功能说明： </strong></td>" & vbCrLf
Response.Write " <td>区域采集,就是采集网站页面某个固定区域,将区域代码保存为内联页提供给模板调用,刷新区域采集就可时时更新.<br><FONT color='red'>用途:</FONT> 打破大网站的垄断资源,举例:销售排行榜,股票信息,违章车辆,奥运奖牌等这些信息是不会提供接口的,通过区域采集就可时时更新最新报道。</td>" & vbCrLf
Response.Write " </tr>" & vbCrLf
Response.Write "</table>" & vbCrLf
Response.Write "<br>" & vbCrLf
Response.Write " <div id=""esave"" style=""position:absolute; top:50px; left:200px; z-index:1;visibility:hidden""> " & vbCrLf
Response.Write " <TABLE WIDTH=400 BORDER=0 CELLSPACING=0 CELLPADDING=0>" & vbCrLf
Response.Write " <TR><td width=""20%""></td>" & vbCrLf
Response.Write " <TD width=""60%""> " & vbCrLf
Response.Write " <TABLE WIDTH=100% height=100 BORDER=0 CELLSPACING=1 CELLPADDING=0>" & vbCrLf
Response.Write " <TR> " & vbCrLf
Response.Write " <td bgcolor=""#0033FF"" align=center><b><marquee align=""middle"" behavior=""alternate"" scrollamount=""5""><font color=#FFFFFF>正在加载采集项目,请稍候...</font></marquee></b></td>" & vbCrLf
Response.Write " </tr>" & vbCrLf
Response.Write " </table>" & vbCrLf
Response.Write " </td><td width='20%'></td>" & vbCrLf
Response.Write " </tr>" & vbCrLf
Response.Write " </table>" & vbCrLf
Response.Write " </div>" & vbCrLf
Response.Write " <table WIDTH=400 height=130 BORDER=0 CELLSPACING=0 CELLPADDING=0><tr><td></td></tr></table>" & vbCrLf
End If
rs.Close
Set rs = Nothing
Call CloseConn
End Sub
'=================================================
'方法名：AreaCollectionDel()
'作 用：区域采集删除
'=================================================
Sub AreaCollectionDel()
Dim AreaID, AreaFile
AreaID = Trim(Request("AreaID"))
If AreaID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "<li>请指定项目ID</li>"
Else
AreaID = PE_CLng(AreaID)
End If
If FoundErr = True Then
Call WriteErrMsg(ErrMsg, ComeUrl)
Exit Sub
End If
Dim rsArea, FileName
Set rsArea = Server.CreateObject("adodb.recordset")
rsArea.Open "select * from PE_AreaCollection where AreaID=" & AreaID & " and Type=0", Conn, 1, 3
If rsArea.BOF And rsArea.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "<li>找不到指定的项目"
Else
AreaFile = rsArea("AreaFile")
If FoundErr = False Then
rsArea.Delete
rsArea.Update
End If
End If
rsArea.Close
Set rsArea = Nothing
If FoundErr = True Then
Call WriteErrMsg(ErrMsg, ComeUrl)
Exit Sub
End If
If ObjInstalled_FSO = True Then
FileName = Server.MapPath(InstallDir & "AreaCollection/" & AreaFile)
If fso.FileExists(FileName) Then
fso.DeleteFile FileName
End If
End If
Call CloseConn
Call WriteSuccessMsg("删除“" & AreaFile & "”JS文件成功！", ComeUrl)
End Sub
'=================================================
'方法名：AreaCollectionPreviewFile()
'作 用：区域采集预览
'=================================================
Sub AreaCollectionPreviewFile()
Dim AreaID, sqlJs, rsArea
AreaID = Trim(Request("AreaID"))
If AreaID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "<li>参数丢失！</li>"
Exit Sub
Else
AreaID = PE_CLng(AreaID)
End If
sqlJs = "select * from PE_AreaCollection where AreaID=" & AreaID & " and Type=0"
Set rsArea = Conn.Execute(sqlJs)
If rsArea.BOF And rsArea.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "<li>找不到指定的JS文件！</li>"
rsArea.Close
Set rsArea = Nothing
Exit Sub
End If
Response.Write "<br><table width='100%' border='0' align='center' cellpadding='2' cellspacing='1' class='border'>"
Response.Write " <tr class='title'>"
Response.Write " <td height='22' colspan='2' align='center'><strong>预览采集区域文件效果----" & rsArea("AreaName") & "</strong></td>"
Response.Write " </tr>"
Response.Write " <tr class='tdbg'>"
Response.Write " <td height='25' align='center'><iframe marginwidth=0 marginheight=0 frameborder=0 width='600' height='350' src='" & InstallDir & "AreaCollection/" & rsArea("AreaFile") & "'></iframe></td>"
Response.Write " </tr>"
Response.Write " <tr class='tdbg'>"
Response.Write " <td height='25' align='center'><a href='Admin_AreaCollection.asp?Action=AreaCollectionManage'>返回</a></td>"
Response.Write " </tr>"
Response.Write " </table>"
rsArea.Close
Set rsArea = Nothing
End Sub
'=================================================
'方法名：AreaCollectionCreateFile()
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -