📄 admin_areacollection.asp
字号:
'作 用：区域采集生成文件
'=================================================
Sub AreaCollectionCreateFile()
Dim AreaID, AreaName, AreaFile, AreaIntro, Code, StringReplace, AreaUrl
Dim LableStart, LableEnd, FilterProperty, UpFileType, AreaPassed
Dim AreaCode
Dim sql, Script_Property, rsArea, rsArea2, strTemplate
Dim Timing_AreaCollection, TimingCreate '定时生成区域采集
Dim strSucMsg
AreaID = PE_Clng(Trim(Request("AreaID")))
Timing_AreaCollection = Trim(Request("Timing_AreaCollection"))
TimingCreate = Trim(Request("TimingCreate"))
If AreaID = 0 Then
sql = "select * from PE_AreaCollection where AreaPassed=" & PE_True & " and Type=0"
Else
sql = "select * from PE_AreaCollection where AreaID=" & AreaID & " and Type=0"
AreaID = PE_CLng(AreaID)
End If
Set rsArea = Conn.Execute(sql)
If rsArea.BOF And rsArea.EOF Then
ErrMsg = ErrMsg & "<li>找不到指定的区域文件！</li>"
rsArea.Close
Set rsArea = Nothing
Call WriteErrMsg(ErrMsg, ComeUrl)
If Timing_AreaCollection = "1" Then
Response.Write "<center><FONT style='font-size:12px' color='red'>请稍等,5秒钟后系统开始定时生成。</FONT></center>"
Response.Write "<meta http-equiv=""refresh"" content=5;url=""Admin_Timing.asp?Action=DoTiming&TimingCreate=" & TimingCreate & """>"
End If
Exit Sub
Else
Do While Not rsArea.EOF
FoundErr = False
ErrMsg = ""
AreaID = rsArea("AreaID")
AreaFile = rsArea("AreaFile")
Code = rsArea("Code")
StringReplace = rsArea("StringReplace")
AreaUrl = rsArea("AreaUrl")
LableStart = rsArea("LableStart")
LableEnd = rsArea("LableEnd")
FilterProperty = rsArea("FilterProperty")
UpFileType = rsArea("UpFileType")
AreaPassed = rsArea("AreaPassed")
If FoundErr <> True Then
AreaCode = GetHttpPage(AreaUrl, PE_CLng(Code)) '获得列表源代码
If AreaCode <> "" Then
AreaCode = GetBody(AreaCode, LableStart, LableEnd, True, True) '获得列表代码
AreaCode = ReplaceStringPath(AreaCode, AreaUrl, UpFileType)
If AreaCode = "" Then
FoundErr = True
ErrMsg = ErrMsg & "<li>在截取区域代码的时发生错误。</li>"
End If
Else
FoundErr = True
ErrMsg = ErrMsg & "<li>在获取:" & AreaUrl & "网页源码时发生错误。</li>"
End If
End If
If FoundErr = True Then
sql = "update PE_AreaCollection set AreaPassed=" & PE_False & " where AreaID=" & AreaID & " and Type=0"
Set rsArea2 = Conn.Execute(sql)
Set rsArea2 = Nothing
End If
Dim arrAreaCode, arrAreaCode2, i
If StringReplace <> "" Then
arrAreaCode = Split(StringReplace, "$$$")
For i = 0 To UBound(arrAreaCode)
arrAreaCode2 = Split(arrAreaCode(i), "|||")
AreaCode = Replace(AreaCode, arrAreaCode2(0), arrAreaCode2(1))
Next
End If
AreaCode = FilterScript(AreaCode, FilterProperty)
strTemplate = "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.0 Transitional//EN'>" & vbCrLf
strTemplate = strTemplate & "<html>" & vbCrLf
strTemplate = strTemplate & "<head>" & vbCrLf
strTemplate = strTemplate & "<title> New Document </title>" & vbCrLf
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>"
Else
Call WriteToFile(InstallDir & "AreaCollection/" & AreaFile, strTemplate)
strSucMsg = strSucMsg & "<li>生成“" & AreaFile & "”区域文件成功！</li>"
End If
rsArea.MoveNext
Loop
End If
rsArea.Close
Set rsArea = Nothing
Response.Write "<br>"
If Timing_AreaCollection = "1" Then
Response.Write "<center><FONT style='font-size:12px' color='red'>请稍等,5秒钟后系统开始定时生成。</FONT></center>"
Response.Write "<meta http-equiv=""refresh"" content=5;url=""Admin_Timing.asp?Action=DoTiming&TimingCreate=" & TimingCreate & """>"
Else
Call WriteSuccessMsg(strSucMsg, "Admin_AreaCollection.asp?Action=AreaCollectionManage")
End If
End Sub
Function IsOptionSelected(ByVal Compare1, ByVal Compare2)
If Compare1 = Compare2 Then
IsOptionSelected = " selected"
Else
IsOptionSelected = ""
End If
End Function
'**************************************************
'过程名：WriteAreaCollection
'作 用：显示批量生成文件情况
'参 数：无
'**************************************************
Function WriteAreaCollectionMsg(sErrMsg, AreaBit)
Dim strMsg
strMsg = strMsg & "<br>" & vbCrLf
strMsg = strMsg & "<table cellpadding=2 cellspacing=1 border=0 width=100% class='border' align=center>" & vbCrLf
If AreaBit = "$True$" Then
strMsg = strMsg & " <tr align='center' class='title' ><td><strong> 恭 喜 您！</strong></td></tr>" & vbCrLf
Else
strMsg = strMsg & " <tr align='center' class='title' ><td><font color=red><strong>错误信息！</strong></font></td></tr>" & vbCrLf
End If
strMsg = strMsg & " <tr class='tdbg'><td height='50' valign='top' ><br>" & sErrMsg & "</td></tr>" & vbCrLf
strMsg = strMsg & "</table>" & vbCrLf
WriteAreaCollectionMsg = strMsg
End Function
'**************************************************
'函数名：Resumeblank
'作 用：Html代码校正
'返回值：校正后的Html 代码
'**************************************************
Function Resumeblank(ByVal Content)
If Content = "" Then
Resumeblank = Content
Exit Function
Else
Content = Trim(Content)
End If
Dim strHtml, strHtml2, i, Num, Numtemp, strTemp, arrContent
strHtml = Replace(Content, "<DIV", "<div")
strHtml = Replace(strHtml, "</DIV>", "</div>")
strHtml = Replace(strHtml, "<TABLE", "<table")
strHtml = Replace(strHtml, "</TABLE>", vbCrLf & "</table>" & vbCrLf)
strHtml = Replace(strHtml, "<TBODY>", "")
strHtml = Replace(strHtml, "</TBODY>", "" & vbCrLf)
strHtml = Replace(strHtml, "<TR", "<tr")
strHtml = Replace(strHtml, "</TR>", vbCrLf & "</tr>" & vbCrLf)
strHtml = Replace(strHtml, "<TD", "<td")
strHtml = Replace(strHtml, "</TD>", "</td>")
strHtml = Replace(strHtml, "<" & "!--", vbCrLf & "<" & "!--")
strHtml = Replace(strHtml, "<SELECT", vbCrLf & "<Select")
strHtml = Replace(strHtml, "</SELECT>", vbCrLf & "</Select>")
strHtml = Replace(strHtml, "<OPTION", vbCrLf & " <Option")
strHtml = Replace(strHtml, "</OPTION>", "</Option>")
strHtml = Replace(strHtml, "<INPUT", vbCrLf & " <Input")
strHtml = Replace(strHtml, "<" & "script", vbCrLf & "<" & "script")
strHtml = Replace(strHtml, "&", "&")
strHtml = Replace(strHtml, "{$--", vbCrLf & "<" & "!--$")
strHtml = Replace(strHtml, "--}", "$--" & ">")
arrContent = Split(strHtml, vbCrLf)
For i = 0 To UBound(arrContent)
Numtemp = False
If InStr(arrContent(i), "<table") > 0 Then
Numtemp = True
If strTemp <> "<table" And strTemp <> "</table>" Then
Num = Num + 2
End If
strTemp = "<table"
ElseIf InStr(arrContent(i), "<tr") > 0 Then
Numtemp = True
If strTemp <> "<tr" And strTemp <> "</tr>" Then
Num = Num + 2
End If
strTemp = "<tr"
ElseIf InStr(arrContent(i), "<td") > 0 Then
Numtemp = True
If strTemp <> "<td" And strTemp <> "</td>" Then
Num = Num + 2
End If
strTemp = "<td"
ElseIf InStr(arrContent(i), "</table>") > 0 Then
Numtemp = True
If strTemp <> "</table>" And strTemp <> "<table" Then
Num = Num - 2
End If
strTemp = "</table>"
ElseIf InStr(arrContent(i), "</tr>") > 0 Then
Numtemp = True
If strTemp <> "</tr>" And strTemp <> "<tr" Then
Num = Num - 2
End If
strTemp = "</tr>"
ElseIf InStr(arrContent(i), "</td>") > 0 Then
Numtemp = True
If strTemp <> "</td>" And strTemp <> "<td" Then
Num = Num - 2
End If
strTemp = "</td>"
ElseIf InStr(arrContent(i), "<" & "!--") > 0 Then
Numtemp = True
End If
If Num < 0 Then Num = 0
If Trim(arrContent(i)) <> "" Then
If i = 0 Then
strHtml2 = String(Num, " ") & arrContent(i)
ElseIf Numtemp = True Then
strHtml2 = strHtml2 & vbCrLf & String(Num, " ") & arrContent(i)
Else
strHtml2 = strHtml2 & vbCrLf & arrContent(i)
End If
End If
Next
Resumeblank = strHtml2
End Function
%>
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -