www.gusucode.com > 信阳2009天气预报程序 1.0码程序 > index.asp

    <%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%><%Option Explicit
response.Charset="utf-8"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''  设置区  ''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'设置 静态文件名
const filename="index.html"

'设置 模板路径/文件名
const template="yker.htm"
'静态文件编码
const filecode="gb2312"

'模板文件编码
const templatecode="gb2312"

'天气预报信息更新周期 单位：小时
const updatetime=6

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''  结束  ''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

%>
<% 
Class clsThief
'____________________
Private value_    '窃取到的内容
Private src_      '要偷的目标URL地址
Private isGet_    '判断是否已经偷过

public property let src(str) '赋值—要偷的目标URL地址/属性
src_=str
end property

public property get value '返回值—最终窃取并应用类方法加工过的内容/属性
value=value_
end property

Public Property get Version
	Version="先锋海盗类 Version 2005"
End Property

private sub class_initialize()
value_=""
src_=""
isGet_= false
end sub
	
private sub class_terminate()
end sub

private Function BytesToBstr(body,Cset) '中文处理
dim objstream
set objstream = Server.CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode =3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText 
objstream.Close
set objstream = nothing
End Function

public sub steal() '窃取目标URL地址的HTML代码/方法
if src_<>"" then
	dim Http
	set Http=server.createobject("MSXML2.XMLHTTP")
	Http.open "GET",src_ ,false
	Http.send()
	if Http.readystate<>4 then 
		exit sub
	end if
	value_=BytesToBSTR(Http.responseBody,"gb2312")
	isGet_= True
	set http=nothing
	if err.number<>0 then err.Clear
else 
	response.Write("<script>alert(""请先设置src属性！"")</script>")
end if
end sub

'删除偷到的内容中里面的换行、回车符以便进一步加工/方法
public sub noReturn() 
if isGet_= false then call steal()
value_=replace(replace(value_ , vbCr,""),vbLf,"")
end sub

'对偷到的内容中的个别字符串用新值更换/方法
public sub change(oldStr,str) '参数分别是旧字符串,新字符串
if isGet_= false then call steal()
value_=replace(value_ , oldStr,str)
end sub

'按指定首尾字符串对偷取的内容进行裁减（不包括首尾字符串）/方法
public sub cut(head,bot) '参数分别是首字符串,尾字符串
if isGet_= false then call steal()
		if instr(value_ , head)>0 and instr(value_ , bot)>0 then
			value_=mid(value_ ,instr(value_ ,head)+len(head),instr(value_ ,bot)-instr(value_ ,head)-len(head))
		else
			value_= "<p align=""center"">函数cut指定裁减内容不存在,请重新定义"
		end if
end sub

'按指定首尾字符串对偷取的内容进行裁减（包括首尾字符串）/方法
public sub cutX(head,bot) '参数分别是首字符串,尾字符串
if isGet_= false then call steal()
		if instr(value_,head)>0 and instr(value_,bot)>0 then
			value_=mid(value_ ,instr(value_ ,head),instr(value_ ,bot)-instr(value_ ,head)+len(bot))
		else
			value_= "<p align=""center"">函数cutX指定裁减的内容不存在"
		end if
end sub

'按指定首尾字符串位置偏移指针对偷取的内容进行裁减/方法
public sub cutBy(head,headCusor,bot,botCusor) 
'参数分别是首字符串,首偏移值,尾字符串,尾偏移值,左偏移用负值,偏移指针单位为字符数
if isGet_= false then call steal()
		if instr(value_,head)>0 and instr(value_,bot)>0 then
			value_=mid(value_ ,instr(value_ ,head)+len(head)+headCusor,instr(value_ ,bot)-1+botCusor-instr(value_ ,head)-len(head)-headcusor)
		else
			value_= "<p align=""center"">函数cutBy指定裁减内容不存在"
		end if
end sub

'按指定首尾字符串对偷取的内容用新值进行替换（不包括首尾字符串）/方法
public sub filt(head,bot,str) '参数分别是首字符串,尾字符串,新值,新值位空则为过滤
if isGet_= false then call steal()
		if instr(value_,head)>0 and instr(value_,bot)>0 then
			value_=replace(value_,mid(value_ ,instr(value_ ,head)+len(head) , instr(value_ ,bot)-instr(value_ ,head)-len(head)),str)
		else
			value_= "<p align=""center"">函数filt指定替换的内容不存在"
		end if
end sub

'按指定首尾字符串对偷取的内容用新值进行替换（包括首尾字符串）/方法
public sub filtX(head,bot,str) '参数分别是首字符串,尾字符串,新值,新值为空则为过滤
if isGet_= false then call steal()
		if instr(value_,head)>0 and instr(value_,bot)>0 then
		      value_=replace(value_,mid(value_ ,instr(value_ ,head),instr(value_ ,bot)-instr(value_ ,head)+len(bot)),str)
		else
			value_= "<p align=""center"">函数filtX指定替换的内容不存在"
		end if
end sub

'按指定首尾字符串位置偏移指针对偷取的内容新值进行替换/方法
public sub filtBy(head,headCusor,bot,botCusor,str) 
'参数分别是首字符串,首偏移值,尾字符串,尾偏移值,新值,左偏移用负值,偏移指针单位为字符数,新值为空则为过滤
if isGet_= false then call steal()
		if instr(value_,head)>0 and instr(value_,bot)>0 then
			value_=replace(value_ ,mid(value_ ,instr(value_ ,head)+len(head)+headCusor,instr(value_ ,bot)-1+botCusor-instr(value_ ,head)-len(head)-headcusor),str)
		else
			value_= "<p align=""center"">函数filtBy指定替换的内容不存在"
		end if
end sub

'对符合条件的内容进行分块采集并组合,最终内容为以<!--lkstar-->隔断的大文本/方法
'通过属性value得到此内容后你可以用split(value,"<!--lkstar-->")得到你需要的数组
public sub rebuild(str) '参数是你目标页面反复出现的特征字符
if isGet_= false then call steal()
value_= replace(value_,str,vbcrlf&"<!--lkstar-->"&vbcrlf)
end sub

'类排错模式——在类释放之前应用此方法可以随时查看你截获的内容HTML代码和页面显示效果/方法
public sub debug()
dim tempstr
tempstr="<SCRIPT>function runEx(){var winEx2 = window.open("""", ""winEx2"", ""width=500,height=300,status=yes,menubar=no,scrollbars=yes,resizable=yes""); winEx2.document.open(""text/html"", ""replace""); winEx2.document.write(unescape(event.srcElement.parentElement.children[0].value)); winEx2.document.close(); }function saveFile(){var win=window.open('','','top=10000,left=10000');win.document.write(document.all.asdf.innerText);win.document.execCommand('SaveAs','','javascript.htm');win.close();}</SCRIPT><center><TEXTAREA id=asdf name=textfield rows=32  wrap=VIRTUAL cols=""120"">"&value_&"</TEXTAREA><BR><BR><INPUT name=Button onclick=runEx() type=button value=""查看效果"">&nbsp;&nbsp;<INPUT name=Button onclick=asdf.select() type=button value=""全选"">&nbsp;&nbsp;<INPUT name=Button onclick=""asdf.value=''"" type=button value=""清空"">&nbsp;&nbsp;<INPUT onclick=saveFile(); type=button value=""保存代码""></center>"
response.Write(tempstr)
end sub
end class

Function RegExpTest(patrn, strng)'正则提取
  Dim regEx, Match, Matches, RetStr     ' 建立变量。
  Set regEx = New RegExp         ' 建立正则表达式。
  regEx.Pattern = patrn         ' 设置模式。
  regEx.IgnoreCase = True         ' 设置是否区分字符大小写。
  regEx.Global = True         ' 设置全局可用性。
  Set Matches = regEx.Execute(strng)   ' 执行搜索。
  For Each Match in Matches      ' 遍历匹配集合。
    RetStr = RetStr & Match.Value & "|"
  Next
  if len(RetStr) > 0 then RegExpTest = mid(RetStr,1,len(RetStr)-1)
End Function

function ifExists(fp)'检查文件存在
	Dim fso
    Set fso = Server.CreateObject("Scripting.FileSystemObject")
	If fso.FileExists(server.mappath(fp)) Then
		ifExists = true
	else
		ifExists = false
	end if
	set fso=nothing
end function

function getfd(fp)'取得文件最后修改
	Dim fso,f
	Set fso = CreateObject("Scripting.FileSystemObject")
	Set f = fso.GetFile(server.mappath(fp))
	getfd = f.DateLastModified
	set fso=nothing
end function

sub SaveFile(PathFn,Data)'保存静态文件
	'DATA:文件数据
	'PATH:存放路径  为空是存放在根目
	Dim FS
	Set FS=Server.CreateObject("adodb.stream")
	with FS
		.type=2
		.open
		.charset=filecode
		.writetext=Data
		.savetofile Server.MapPath(PathFn),2
		.close
	end with
	Set FS=Nothing
end sub

function ReadFile(PathFn)'读文件 
	Dim FS
	Set FS=Server.CreateObject("adodb.stream")
	with FS
		.type=2
		.open
		.charset=templatecode
		.LoadFromFile Server.MapPath(PathFn)
		ReadFile = .ReadText
		.close
	end with
	Set FS=Nothing
end function

function chuli(data,types)
	dim i,t,temp
	select case types
		case "riqi"
			t=split(data,"|")
			for i=0 to ubound(t)
				t(i)=year(date())&"-"&t(i)
				t(i)=replace(replace(t(i),"月","-"),"日","")
				temp=temp&t(i)&"|"
			next
			chuli=mid(temp,1,len(temp)-1)
		case "qiwen"
			t=split(data,"|")
			for i=1 to ubound(t)+1
				if i mod 2 = 0 then
				temp=temp&t(i-1)&"|"
				else
				temp=temp&t(i-1)&"～"
				end if
			next
			chuli=mid(temp,1,len(temp)-1)
		case "ico"
			t=split(data,"转")
			for i=0 to ubound(t)
				temp=temp&"<img src=""images/"&t(i)&".gif"" alt="""&t(i)&""" />"
			next
			chuli=temp
	end select
end function

function gettianqi()
	dim myThief,page 
	set myThief=new clsThief 
	myThief.src="http://tianqi.9991.com/d/city/70325.htm"
	myThief.steal
	myThief.noReturn()
	myThief.cut "<table  width=""97%""  border=""0"" cellpadding=""0"" cellspacing=""0"" bgcolor=""#E3F4F9"" style=""border:1px solid #91CFEC;"">","<td height=""25"" colspan=""7"" align=""center"" class=""txt1"">"
	response.Charset="utf-8"
	dim va:va=myThief.value 
	set myThief=nothing

	dim riqi:riqi=chuli(RegExpTest("\d+月\d+日",va),"riqi")
	
	dim xingqi:xingqi=replace(RegExpTest("\([^\)]*",va),"(","")
	
	
	dim tianqi:tianqi=replace(RegExpTest("<td align=""center"">[\u4e00-\u9fa5]+",va),"<td align=""center"">","")


	dim qiwen:qiwen=chuli(replace(replace(RegExpTest("t(\d)>[^<]*",va),"t1>",""),"t2>",""),"qiwen")

	dim fengxiang:fengxiang=replace(RegExpTest("title=""[^""]*",va),"title=""","")

	'response.write riqi&"<br>"&xingqi&"<br>"&tianqi&"<br>"&qiwen&"<br>"&fengxiang
	dim sd,i
	va=split(riqi,"|")
	set sd=server.CreateObject("scripting.Dictionary")
	for i=0 to ubound(va)
		sd.add i,va(i)&"$$$"&split(xingqi,"|")(i)&"$$$"&split(tianqi,"|")(i)&"$$$"&chuli(split(tianqi,"|")(i),"ico")&"$$$"&split(qiwen,"|")(i)&"$$$"&split(fengxiang,"|")(i)
	next
	set gettianqi=sd
	set sd=nothing
end function


function getzhishu()
	dim myThief,page 
	set myThief=new clsThief 
	myThief.src="http://weather.news.qq.com/inc/07_zs214.htm"
	myThief.steal
	myThief.noReturn()
	myThief.cut "<table width=""570"" height=""19""","</div>"
	response.Charset="utf-8"
	dim va:va=myThief.value 
	set myThief=nothing
	dim zs(2)
	zs(0)=replace(RegExpTest("<strong>[^<]*",va),"<strong>","")
	zs(1)=replace(RegExpTest("tred"">[^<]*",va),"tred"">","")
	zs(2)=replace(RegExpTest("width=""180"">[^<]*",va),"width=""180"">","")
	zs(2)=left(zs(2),len(zs(2))-1)
	
	dim i,sd
	va=split(zs(0),"|")
	set sd=server.CreateObject("scripting.Dictionary")
	for i=0 to ubound(va)
		sd.add va(i),split(zs(1),"|")(i)&"$$$"&split(zs(2),"|")(i)
	next
	set getzhishu=sd
	set sd=nothing
end function

sub create	'生成
	if not ifExists(template) then:response.write "读取模板文件出错！":response.end
	dim temp:temp=readfile(template)
	dim alltag:alltag=RegExpTest("\{\$Yker-\[[^\]]*(\]-Yker\$\})",temp)
	
	if instr(alltag,"{$Yker-[更新时间]-Yker$}") > 0 then temp=replace(temp,"{$Yker-[更新时间]-Yker$}",Now())
	'处理指数
	dim zs,i
	set zs=getzhishu()
	dim indexs:indexs=zs.keys
	dim items:items=zs.items
	for i=0 to zs.count-1
		if instr(alltag,"{$Yker-[生活指数("&indexs(i)&")/描述]-Yker$}") > 0 then temp=replace(temp,"{$Yker-[生活指数("&indexs(i)&")/描述]-Yker$}",split(items(i),"$$$")(0))
		if instr(alltag,"{$Yker-[生活指数("&indexs(i)&")/详细描述]-Yker$}") > 0 then temp=replace(temp,"{$Yker-[生活指数("&indexs(i)&")/详细描述]-Yker$}",split(items(i),"$$$")(1))
	next
	set zs=nothing
	
	'处理天气
	set zs=gettianqi()
	items=zs.items
	for i=0 to zs.count-1
		if instr(alltag,"{$Yker-[天气预报("&i&")/日期]-Yker$}") > 0 then temp=replace(temp,"{$Yker-[天气预报("&i&")/日期]-Yker$}",split(items(i),"$$$")(0))
		if instr(alltag,"{$Yker-[天气预报("&i&")/星期]-Yker$}") > 0 then temp=replace(temp,"{$Yker-[天气预报("&i&")/星期]-Yker$}",split(items(i),"$$$")(1))
		if instr(alltag,"{$Yker-[天气预报("&i&")/天气]-Yker$}") > 0 then temp=replace(temp,"{$Yker-[天气预报("&i&")/天气]-Yker$}",split(items(i),"$$$")(2))
		if instr(alltag,"{$Yker-[天气预报("&i&")/图标]-Yker$}") > 0 then temp=replace(temp,"{$Yker-[天气预报("&i&")/图标]-Yker$}",split(items(i),"$$$")(3))
		if instr(alltag,"{$Yker-[天气预报("&i&")/气温]-Yker$}") > 0 then temp=replace(temp,"{$Yker-[天气预报("&i&")/气温]-Yker$}",split(items(i),"$$$")(4))
		if instr(alltag,"{$Yker-[天气预报("&i&")/风向]-Yker$}") > 0 then temp=replace(temp,"{$Yker-[天气预报("&i&")/风向]-Yker$}",split(items(i),"$$$")(5))
	next
	
	set zs=nothing
	savefile filename,temp&vbcrlf&unasc("60,33,45,45,104,116,116,112,58,47,47,119,119,119,46,99,108,115,120,119,46,99,111,109,32,32,98,117,105,108,100,58,50,48,49,48,49,49,49,55,45,45,62")
end sub

function unasc(s)
	if len(s)=0 then exit function
	dim i,t,e:t=split(s,",")
	for i=0 to ubound(t):e=e&chrw(t(i)):next
	unasc=e
end function

sub start	'开始 
	if ifExists(filename) then
		'检查更新时间 
		if datediff("h",getfd(filename),Now())>updatetime then
			create
		end if
	else
		create
	end if
	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
	response.Redirect filename
	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
end sub

start
%>