Office関連

Google Charts APIを使ってQRコードの画像を取得するVBAマクロ

@ITの記事に「Tech TIPS:Google Chart APIを使ってQRコードを作る」というものがあったので、VBAから実行してみました。
(細かいパラメーターは上記記事参照)

Option Explicit

Public Sub Sample()
  Const png As String = "C:\Test\MyQR.png"
  GetQRImage size:=200, _
             data:="漢字ひらがなカタカナabc", _
             pngpath:=png, _
             margin:=0
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(png) = True Then
      If MsgBox("取得した画像ファイルを開きますか?", vbYesNo) = vbYes Then
        CreateObject("Shell.Application").ShellExecute png
      End If
    End If
  End With
End Sub

Private Sub GetQRImage(ByVal size As Long, _
                       ByVal data As String, _
                       ByVal pngpath As String, _
                       Optional ByVal code As String = "UTF-8", _
                       Optional ByVal errlevel As String = "L", _
                       Optional ByVal margin As Long = 4)
'Google Chart APIを使ってQRコードをPNG画像として取得
'※ URLエンコード処理にScriptControlを使っているため32ビット版Officeのみ利用可能
'https://developers.google.com/chart/infographics/docs/qr_codes
'https://google-developers.appspot.com/chart/infographics/docs/post_requests
'http://www.atmarkit.co.jp/ait/articles/1602/26/news037.html
  Dim url As String
  Dim body As Variant
  Dim dat As Variant
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  
  url = "https://chart.googleapis.com/chart"
  dat = "cht=qr&chs=" & size & "x" & size & _
        "&chl=" & EncodeURL(data) & _
        "&choe=" & code & _
        "&chld=" & errlevel & "|" & margin
  On Error Resume Next
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", url, False
    .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
    .Send dat
    Select Case .Status
      Case 200
        body = .ResponseBody
        With CreateObject("ADODB.Stream")
          .Type = adTypeBinary
          .Open
          .Write body
          .SaveToFile pngpath, adSaveCreateOverWrite
          .Close
        End With
    End Select
  End With
  If Err.Number <> 0 Then
    MsgBox "エラーが発生しました。" & vbNewLine & _
           "エラー内容:" & Err.Description, _
           vbCritical + vbSystemModal, _
           "エラー番号:" & Err.Number
  End If
  On Error GoTo 0
End Sub

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

@ITの記事と違ってPOSTで処理していますが、やり方は同じです。
簡単にQR画像を取得できるので、なかなか便利だと思います。

関連記事

  1. Office関連

    [リボン・カスタマイズ]アクティブシートにより表示するグループを切り替える。

    Excelで、選択しているシートによって表示するグループを切り替えたい…

  2. Google関連

    [Google Apps Script]ショートカットファイルを作成する

    リリースノートによると、先月のGoogle Apps Scriptのア…

  3. Google関連

    [Google Apps Script]スプレッドシートで検索と置換を行う

    Google スプレッドシートには、検索と置換機能(Ctrl + F)…

  4. Office関連

    Microsoft Graph ExplorerがMicrosoft アカウント(MSA)に対応しま…

    Azure AD v2.0 エンドポイントによって、個人用Micros…

  5. Office関連

    [Excel VBA]PrintPreview後に印刷するとCtrl+;の日付形式が変わる?

    MSDNフォーラムで面白い質問がありました。・Excel …

  6. Office関連

    [Word VBA]ルビ(ふりがな)ダイアログの操作に挑む

    2016/10/28 追記:改良版のマクロを書きました。…

コメント

  • コメント (0)

  • トラックバックは利用できません。

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

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP