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関連

    「入門レベルでは決して足りない実務に必須のスキルとは ExcelVBA 実戦のための技術」レビュー

    久しぶりにVBA参考書籍のレビューです。今回は沢内晴彦氏が執筆され…

  2. Office関連

    ビジネスITアカデミーの無料VBAセミナーに行ってきました。

    Excel MVPの伊藤さんやWord MVPの新田さんのブログ記事で…

  3. Office関連

    Office 2013 Consumer Preview(カスタマー プレビュー)をインストールして…

    2012/10/26 追記:RTM版公開に伴い記事を追加しました。…

  4. Office関連

    [Office]シンプルリボンのアンケートへの回答でAmazonギフト券が当たるチャンス

    「Office の新しい外観」にある通り、一部のOffice環境では、…

  5. Office関連

    [Excel]XLOOKUP関数でより簡単に値を検索できるようになりました!

    下記記事の通り、2019年8月末にVLOOKUP関数やHLOOKUP関…

  6. Office関連

    Office 2019 Commercial Preview版のインストール方法

    「Microsoft、「Office 2019 Commercial …

コメント

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

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

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

PAGE TOP