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

mougの過去ログ検索サイト「mougle」を開設しました。前のページ

外部からOutlookのマクロを実行するマクロ次のページ

関連記事

  1. Office アドイン

    [Office用アプリ]アプリ開発コンテストの案内

    2013/9/9 追記:コンテストの受賞者が発表されました。おかげ…

  2. Office関連

    日本標準時(JST)を取得するVBAマクロ

    先日、もり(@moripro3)さんのツイートに対して下記のような返信…

  3. Office関連

    PHPWordを使ってPHPからWordファイルを出力してみる。

    最近オトカドールやルミティアジュエルやらの記事ばかり書いていますが、今…

  4. Office関連

    フォルダ(サブフォルダ含む)内の特定の拡張子のファイルに処理を行うVBAマクロ

    「Wordマクロ サブフォルダ ファイル処理」といったキーワードでのア…

  5. Office関連

    ページ番号を取得するWordマクロ

    Wordマクロで選択位置のページ番号を取得する場合、簡単なのはSele…

コメント

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

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

Time limit is exhausted. Please reload CAPTCHA.

Translate

Chinese (Simplified)Chinese (Traditional)EnglishFrenchGermanJapaneseKoreanRussianSpanish

最近の記事

アーカイブ

PAGE TOP