WebサイトからFaviconを抜き出すAPIがあったので早速使ってみました。

・Favatar
https://favatar.mention.net/

※ 下記マクロはAPIキーが必須になりますので、「Start using Favatar now!」からAPIキーを事前に取得してください(取得後コード内の”ApiKey”の値を変更)。

Option Explicit

Public Sub Sample()
  GetFavicon "http://渋谷駅.jp/", "C:\Test"
  MsgBox "処理が終了しました。"
End Sub

Private Sub GetFavicon(ByVal Target As String, ByVal SaveFolderPath As String)
'Favicon取得
  Dim url As String
  Dim js As String
  Dim mimeType, data '表示用ダミー
  Const ApiKey As String = "your_key" 'APIキー
  
  url = "http://favatar.mention.net/image?format=json&api_key=" & ApiKey & "&url=" & EncodeURL(Target)
  js = "" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url, False
    .send
    If .Status = 200 Then js = .responseText
  End With
  On Error GoTo 0
  If Len(js) > 0 Then
    If LCase$(Trim$(js)) <> "null" Then
      js = "(" & js & ")"
      With CreateObject("ScriptControl")
        .Language = "JScript"
        If Right$(SaveFolderPath, 1) <> Application.PathSeparator Then SaveFolderPath = SaveFolderPath & Application.PathSeparator
        SaveFavicon SaveFolderPath & GetDomainName(Target) & "." & GetExtension(.CodeObject.eval(js).mimeType), .CodeObject.eval(js).data
      End With
    End If
  End If
End Sub

Private Sub SaveFavicon(ByVal SaveFilePath As String, ByVal base64dat As String)
'Favicon保存
'http://d.hatena.ne.jp/language_and_engineering/20101022/p1 参照
  Dim dat() As Byte
  
  If Len(Dir$(SaveFilePath)) > 0 Then Kill SaveFilePath 'ファイルを事前に削除
  With CreateObject("Microsoft.XMLDOM").createElement("base64-node")
    .DataType = "bin.base64"
    .Text = base64dat
    dat = .nodeTypedValue
  End With
  With CreateObject("ADODB.Stream")
    .Type = 1
    .Open
    .Write dat
    .SaveToFile SaveFilePath
    .Close
  End With
End Sub

Private Function GetDomainName(ByVal url As String) As String
'ドメイン名取得
  Dim v As Variant
  
  If InStr(url, "https://") Then
    v = Split(Replace(url, "https://", ""), "/")
  Else
    v = Split(Replace(url, "http://", ""), "/")
  End If
  GetDomainName = v(LBound(v))
End Function

Private Function GetExtension(ByVal mimeType As String) As String
'拡張子取得(変換テーブルは適当)
  Dim ret As String
  
  Select Case mimeType
    Case "image/x-icon": ret = "ico"
    Case "image/png", "image/x-png": ret = "png"
    Case "image/gif": ret = "gif"
    Case "image/jpeg": ret = "jpg"
    Case "image/bmp", "image/x-MS-bmp": ret = "bmp"
    Case "image/tiff": ret = "tif"
    Case "image/x-emf": ret = "emf"
    Case "image/x-wmf": ret = "wmf"
    Case Else: ret = "ico"
  End Select
  GetExtension = ret
End Function

Private Function EncodeURL(ByVal sWord As String) As String
  With CreateObject("ScriptControl")
    .Language = "JScript"
    EncodeURL = .CodeObject.encodeURIComponent(sWord)
  End With
End Function

上記GetFaviconプロシージャは、引数として対象URLとFaviconの保存先フォルダを指定すると、指定したフォルダにFaviconファイルを保存するもので、Base64エンコードされたFaviconファイルを元のバイナリファイルに変換する処理を行っています。

VBAでBase64デコードする処理を書いたことが無かったので試しに書いてみましたが、正直同様のサービスである「getFavicon.org」を利用した方が楽にFaviconファイルを保存できます。

Option Explicit

Private Declare Function URLDownloadToFileA Lib "urlmon" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Public Sub Sample2()
  GetFavicon "//www.ka-net.org/blog", "C:\Test\", 16, "ico"
End Sub

Private Sub GetFavicon(ByVal Target As String, ByVal SaveFolderPath As String, Optional ByVal Size As Long = 16, Optional ByVal Ext As String = "ico")
  URLDownloadToFileA 0&, "http://www.getfavicon.org/?url=" & Target & "/favicon." & Size & "." & Ext, SaveFolderPath & "favicon." & Ext, 0&, 0&
End Sub

こちらはFavatarと違ってファイル形式やサイズを指定することができますが、私が試した限りではFavatarの方が対応サイトが多いように思います。

VBAマクロでFaviconをダウンロードする機会もそうそう無いかと思いますが、興味がある方は一度試してみてはいかがでしょうか。
(上記コードはエラー処理を行っていませんので、実装する際は適宜処理を追加してください。)