代碼如下：
Option Explicit
Public Function GetTitle(url As String)
Dim xmlHttp As Object
Dim strHtml As String
url = Trim(url)
If LCase(Left(url, 5)) = "https" Then
GetTitle = "暫不支持https協議"
Exit Function
End If
'都不能構成完整的http協議，起碼也得 a.cc
If Len(url) < 5 Then
Exit Function
End If
url = "//" & Replace(Trim(url), "//", "")
Set xmlHttp = CreateObject("Microsoft.XMLHTTP")
xmlHttp.Open "GET", url, True
xmlHttp.send (Null)
While xmlHttp.ReadyState <> 4
DoEvents
Wend
strHtml = LCase(BytesToBstr(xmlHttp.responseBody))
GetTitle = Split(Split(strHtml, "<title>")(1), "</title>")(0)
Set xmlHttp = Nothing
End Function
Private Function BytesToBstr(Bytes)
Dim Unicode As String
If IsUTF8(Bytes) Then '如果不是UTF-8編碼則按照GB2312來處理
Unicode = "UTF-8"
Else
Unicode = "GB2312"
End If
Dim objstream As Object
Set objstream = CreateObject("ADODB.Stream")
With objstream
.Type = 1
.Mode = 3
.Open
.Write Bytes
.Position = 0
.Type = 2
.Charset = Unicode
BytesToBstr = .ReadText
.Close
End With
Set objstream = Nothing
End Function
'判斷網頁編碼函數
Private Function IsUTF8(Bytes) As Boolean
Dim i As Long, AscN As Long, Length As Long
Length = UBound(Bytes) + 1
If Length < 3 Then
IsUTF8 = False
Exit Function
ElseIf Bytes(0) = &HEF And Bytes(1) = &HBB And Bytes(2) = &HBF Then
IsUTF8 = True
Exit Function
End If
Do While i <= Length - 1
If Bytes(i) < 128 Then
i = i + 1
AscN = AscN + 1
ElseIf (Bytes(i) And &HE0) = &HC0 And (Bytes(i + 1) And &HC0) = &H80 Then
i = i + 2
ElseIf i + 2 < Length Then
If (Bytes(i) And &HF0) = &HE0 And (Bytes(i + 1) And &HC0) = &H80 And (Bytes(i + 2) And &HC0) = &H80 Then
i = i + 3
Else
IsUTF8 = False
Exit Function
End If
Else
IsUTF8 = False
Exit Function
End If
Loop
If AscN = Length Then
IsUTF8 = False
Else
IsUTF8 = True
End If
End Function
京公網安備 11010602022020號