ASP自动采集

将自动采集页放在远程虚拟主机。

方式列举几种：

1、本地做托盘程序，开机自动启动，定时调用采集页面检查。

2、网站整合一个字段，设置检查时间。每个访客来时校对是否大于10分钟，如果大于10分钟自动采集一次，采集完成后更新字段时间。

3、选购个linux主机，用cpanel定时执行php采集页，如果是asp的这个方法跳过。

4、为兄的实在想不到其他办法了。

以上思路你看下能否有用。

输出显示函数即可，也可以将变量存入数据库，这只是一个例子，具体其它功能你举一反三，循环以下即可。

response.write Showipinfo("202.29.90.9")

Function Showipinfo(ip)

'显示IP地址具体地址 参考IP138数据库

Dim urls,str,showipinfos

urls="http://www.ip138.com/ips138.asp?ip="&ip&"&action=2"

str =getHTTPPage(urls)

Showipinfo=strcut(str,"<ul class=""ul1"">","</ul>",2) '截取IP地址来源

showipinfos = Replace(Showipinfo,"本站主数据：","1、")

Showipinfo = Replace(showipinfos,"参考数据一：","2、")

End Function

'****************************************

'

'函数名：GetHttpPage(url) 2011-5-17 xuyang

'功 能：ASP采集网页内容 GB2312 和 UTF-8 通用

'参 数：url地址

'****************************************

Function GetHttpPage(url)

Dim ResStr, ResBody, PageCode

If IsNull(url) = True Or url = "False" Then

GetHttpPage = ""

Exit Function

End If

Dim Http, sStartTime

Set Http = Server.CreateObject("MSXML2.XMLHTTP")

With Http

.Open "GET", url, False

.Send

End With

'Http.open "GET", url, False

'Http.Send (Null)

sStartTime = Now

On Error Resume Next

If Http.Status <>200 Then

Set Http = Nothing

GetHttpPage = ""

Exit Function

End If

Do While Http.ReadyState <>4

If DateDiff("s", sStartTime, Now) >10 Then

GetHttpPage = ""

Exit Function

End If

Loop

If Http.ReadyState = 4 Then

If Http.Status = 200 Then

PageCode = test(url)

GetHttpPage = bytesToBSTR(Http.responseBody, PageCode)

End If

End If

Set Http = Nothing

If Err.Number <>0 Then

Err.Clear

End If

End Function

Function bytesToBSTR(body, Cset)

Dim Objstream

Set Objstream = 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

Function test(sUrl)

Dim ox

Set ox = server.CreateObject("msxml2.xmlhttp")

ox.Open "get", sUrl, False

ox.Send

test = charsetOf(ox.responseBody)

End Function

Function charsetOf(bstr)

Dim p, c, r

If InStrB(bstr, ChrB(0)) >0 Then

charsetOf = "unicode"

Exit Function

End If

c = s2b("charset=")

p = InStrB(1, bstr, c, 1)

If p >0 Then

c = b2s(MidB(bstr, p + LenB(c), 20))

Set r = New RegExp

r.Pattern = "^[’""]?([-\w]+)"

Set c = r.Execute(c)

If c.Count >0 Then

charsetOf = LCase(c(0).SubMatches(0))

Exit Function

End If

End If

Dim n, ucsOnly, ret

ucsOnly = False

n = LenB(bstr)

For p = 1 To n

c = AscB(MidB(bstr, p, 1))

If c And &H80 Then Exit For

If c <&H20 Then

If c <>&HD And c <>&HA And c <>&H9 Then

ucsOnly = True

Exit For

End If

End If

Next

If p >n Then

ret = "ascii"

ElseIf Not ucsOnly Then

If isUtf8(bstr, p, n) Then

ret = "utf-8"

ElseIf isGbk(bstr, p, n) Then

ret = "GB2312"

End If

End If

If IsEmpty(ret) Then

If isUnicode(bstr, p, n) Then

charsetOf = "unicode"

Else

charsetOf = "unknown"

End If

Else

charsetOf = ret

End If

End Function

Function s2b(str)

Dim r, i

For i = 1 To Len(str)

r = r + ChrB(Asc(Mid(str, i, 1)) And &HFF)

Next

s2b = r

End Function

Function b2s(bs)

Dim r, i

For i = 1 To LenB(bs)

r = r + Chr(AscB(MidB(bs, i, 1)))

Next

b2s = r

End Function

Function isUtf8(bs, start, Length)

isUtf8 = True

Dim p, e, c

e = False

For p = start To Length

c = AscB(MidB(bs, p, 1))

If c And &H80 Then

If c And &HE0 = &HC0 Then

If p = Length Then

e = True

Else

p = p + 1

If AscB(MidB(bs, p, 1)) And &H30 <>&HC0 Then e = True

End If

ElseIf c And &HF0 = &HE0 Then

If p = Length Or p = Length - 1 Then

e = True

Else

p = p + 2

If AscB(MidB(bs, p - 1, 1)) And &H30 <>&HC0 Then

e = True

ElseIf AscB(MidB(bs, p, 1)) And &H30 <>&HC0 Then

e = True

End If

End If

Else

e = True

End If

End If

If e Then

isUtf8 = False

Exit Function

End If

Next

End Function

Function isGbk(bs, start, Length)

isGbk = True

Dim p, e, c

e = False

For p = start To Length

c = AscB(MidB(bs, p, 1))

If c And &H80 Then

If p = Length Then

e = True

Else

p = p + 1

If (AscB(MidB(bs, p, 1)) And &H80) = 0 Then e = True

End If

End If

If e Then

isGbk = False

Exit Function

End If

Next

End Function

Function isUnicode(bs, start, Length)

isUnicode = True

Dim p, c

If start Mod 2 = 0 Then

isUnicode = False

Exit Function

End If

For p = start To Length

c = AscB(MidB(bs, p, 1))

If c And &H80 Then

If p = Length Then

isUnicode = False

Exit Function

Else

p = p + 1

End If

End If

Next

End Function

'截取字符串,1.包括起始和终止字符，2.不包括

Function strCut(strContent,StartStr,EndStr,CutType)

Dim strHtml,S1,S2

strHtml = strContent

On Error Resume Next

Select Case CutType

Case 1

S1 = InStr(strHtml,StartStr)

S2 = InStr(S1,strHtml,EndStr)+Len(EndStr)

Case 2

S1 = InStr(strHtml,StartStr)+Len(StartStr)

S2 = InStr(S1,strHtml,EndStr)

End Select

If Err Then

strCute = "<p align=’center’>没有找到需要的内容。</p>"

Err.Clear

Exit Function

Else

strCut = Mid(strHtml,S1,S2-S1)

End If

End Function

---