excel批量提取網頁標題

最近時間比較忙，有時候很多網頁需要臨時保存，以便空閑的時候查看。單純的保存網頁鏈接會讓人很枯燥，所以需要自動批量提取標題。

為了這個小功能去寫個小程序有點不划算，所以就利用excel實現了這個功能。

 

先上圖：

 

 

代碼如下：

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 = "http://" & Replace(Trim(url), "http://", "")
    
    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

 

【說明】：因為目前保存的網頁都是文章類型，所以就直接避免處理https安全連接了。

 

相關知識點：excel批量提取網頁標題,excel自動提取網頁標題,vb自動識別網頁編碼,vb字符串utf8轉gbk