Office関連

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

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

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

関連記事

  1. Office関連

    WordBasicマクロの資料

    Word 97でVBA機能が搭載される以前のWordでは、WordBa…

  2. Windows 10

    【2017年1月版】Microsoft Edgeを操作するVBAマクロ(DOM編)(2)

    昨日の記事で、Microsoft Edgeを操作するVBAコードを改め…

  3. Office アドイン

    [Officeアドイン]マニフェストファイルをデバッグする方法

    Office アドイン本体はF12ツール等を使ってデバッグすることがで…

  4. Office関連

    外部からOutlookのマクロを実行するマクロ

    外部からOutlookのマクロを実行するマクロ今回は外部からO…

  5. Office関連

    [Office用アプリ]開発ツール「Napa」のインストール方法

    Office 365にはブラウザー上で直接Office用アプリの開発が…

  6. Office関連

    スライドショーをループ再生設定するPowerPointマクロ

    PowerPointでスライドショーを作成するとき、投影した後流しっぱ…

コメント

  1. この記事へのコメントはありません。

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP