Faviconをダウンロードするマクロ

ホーム
Office関連, Excel, Word
Faviconをダウンロードするマクロ

2012.07.4

Faviconをダウンロードするマクロ

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