|
'================================================
'函数名：CheckRemoteUrl
'作 用： 判断远程URL
'================================================
Public Function CheckHTTP(ByVal URL)
Dim Retrieval
On Error Resume Next
Set Retrieval = CreateObject("MSXML2.XMLHTTP")
With Retrieval
.Open "HEAD", URL, False
.send
If .readyState <> 4 Then
CheckHTTP = False
Set Retrieval = Nothing
Exit Function
End If
If .Status < 300 Then
CheckHTTP = True
Set Retrieval = Nothing
Exit Function
Else
CheckHTTP = False
Set Retrieval = Nothing
Exit Function
End If
End With
If Err.Number <> 0 Then
CheckHTTP = False
Err.Clear
Set Retrieval = Nothing
Exit Function
End If
Set Retrieval = Nothing
Exit Function
End Function
'================================================
'函数名：GetHTTPPage
'作 用：获取HTTP页
'参 数：url ----远程URL
'返回值：远程HTML代码
'================================================
Public Function GetRemoteData(ByVal URL, ByVal Cset)
If Len(Cset) < 2 Then Cset = "GB2312"
Dim strHeader
Dim l
On Error Resume Next
Dim Retrieval
Dim ObjStream
Set ObjStream = CreateObject("ADODB.Stream")
ObjStream.Type = 1
ObjStream.Mode = 3
ObjStream.Open
Set Retrieval = CreateObject("MSXML2.XMLHTTP")
With Retrieval
.Open "GET", URL, False
.setRequestHeader "Referer", URL
.send
If .readyState <> 4 Then Exit Function
If .Status > 300 Then Exit Function
'--获取目标网站文件头
strHeader = .getResponseHeader("Content-Type")
strHeader = UCase(strHeader)
ObjStream.Write (.responseBody)
End With
Set Retrieval = Nothing
If Len(strHeader) > 0 Then
'--获取目标文件编码
l = InStrRev(strHeader, "CHARSET=", -1, 1)
If l > 0 Then
Cset = Right(strHeader, Len(strHeader) - l - 7)
Else
Cset = Cset
End If
End If
ObjStream.Position = 0
ObjStream.Type = 2
ObjStream.Charset = Trim(Cset)
GetRemoteData = ObjStream.ReadText
ObjStream.Close
Set ObjStream = Nothing
Exit Function
End Function
'================================================
'函数名：FindMatch
'作 用：截取相匹配的内容
'返回值：截取后的字符串
'================================================
Public Function FindMatch(ByVal str, ByVal start, ByVal last)
Dim Match
Dim s
Dim FilterStr
Dim MatchStr
Dim strContent
Dim ArrayFilter()
Dim i, n
Dim bRepeat
If Len(start) = 0 Or Len(last) = 0 Then Exit Function
On Error Resume Next
MatchStr = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")"
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = MatchStr
Set s = re.Execute(str)
n = 0
For Each Match In s
If n = 0 Then
n = n + 1
ReDim ArrayFilter(n)
ArrayFilter(n) = Match
Else
bRepeat = False
For i = 0 To UBound(ArrayFilter)
If UCase(Match) = UCase(ArrayFilter(i)) Then
bRepeat = True
Exit For
End If
Next
If bRepeat = False Then
n = n + 1
ReDim Preserve ArrayFilter(n)
ArrayFilter(n) = Match
End If
End If
Next
Set s = Nothing
Set re = Nothing
strContent = Join(ArrayFilter, "|||")
strContent = Replace(strContent, start, "")
strContent = Replace(strContent, last, "")
FindMatch = Replace(strContent, "|||", vbNullString, 1, 1)
Exit Function
End Function
'================================================
'函数名：CutFixed
'作 用：截取固定的字符串
'参 数：strHTML ----原字符串
' start ------ 开始字符串
' last ------ 结束字符串
'================================================
Public Function CutFixed(ByVal strHTML, ByVal start, ByVal last)
Dim s
Dim Match
Dim strPattern
Dim strContent
Dim t, l
t = Len(start): l = Len(last)
If t = 0 Or l = 0 Then Exit Function
strPattern = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")"
On Error Resume Next
Dim re
Set re = New RegExp
re.IgnoreCase = False
re.Global = False
re.Pattern = strPattern
Set s = re.Execute(strHTML)
For Each Match In s
strContent = Match.Value
Next
Set s = Nothing
Set re = Nothing
CutFixed = Mid(strContent, t + 1, Len(strContent) - l - t)
Exit Function
End Function
'================================================
'函数名：CutFixate
'返回值：截取后的字符串
'================================================
Public Function CutFixate(ByVal strHTML, ByVal start, ByVal last)
Dim s
Dim Match
Dim strPattern
Dim strContent
Dim t, l
t = Len(start): l = Len(last)
If t = 0 Or l = 0 Then Exit Function
strPattern = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")"
On Error Resume Next
Dim re
Set re = New RegExp
re.IgnoreCase = False
re.Global = False
re.Pattern = strPattern
Set s = re.Execute(strHTML)
For Each Match In s
strContent = Match.Value
Next
Set s = Nothing
Set re = Nothing
CutFixate = Trim(strContent)
Exit Function
End Function
共7页: 上一页 [1] 2 [3] [4] [5] [6] [7] 下一页
| 
