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, )) = "https" Then

         GetTitle = "暂不支持https协议"
         Exit Function
     End If

     '都不能构成完整的http协议，起码也得 a.cc
     If Len(url) <  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 <>
         DoEvents
     Wend
     strHtml = LCase(BytesToBstr(xmlHttp.responseBody))
     GetTitle = Split(Split(strHtml, "<title>")(), "</title>")()
     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 =
         .Mode =
         .Open
         .Write Bytes
         .Position =
         .Type =
         .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) + 

         If Length <  Then
             IsUTF8 = False
             Exit Function
         ElseIf Bytes() = &HEF And Bytes() = &HBB And Bytes() = &HBF Then
             IsUTF8 = True
             Exit Function
         End If

         Do While i <= Length -
             If Bytes(i) <  Then
                 i = i +
                 AscN = AscN +
             ElseIf (Bytes(i) And &HE0) = &HC0 And (Bytes(i + ) And &HC0) = &H80 Then
                 i = i + 

             ElseIf i +  < Length Then
                 If (Bytes(i) And &HF0) = &HE0 And (Bytes(i + ) And &HC0) = &H80 And (Bytes(i + ) And &HC0) = &H80 Then
                      i = i +
                 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