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画像を取得できるので、なかなか便利だと思います。

オトカドール 3rdドリームをプレイしてきたよ(6)前のページ

2016年2月の人気記事次のページ

関連記事

  1. Office関連

    Office 2010 開発者用リファレンスをHTML形式で”快適に”閲覧す…

    前回の記事で7-Zipを使ってHXS形式のOffice製品のヘルプを解…

  2. Office アドイン

    [Office用アプリ]メールアプリの配置方法

    OutlookやOutlook Web App上で動作するメールアプリ…

  3. Office関連

    PowerShellからNetOfficeを使ってWordやPowerPointを操作する方法

    前回の記事関連で、WordやPowerPointもドンとこいで…

  4. Office関連

    ソースコードを番号行付きのテーブルに変換するWordマクロ

    Word文書内のソースコードを、他の文書と区別して目立たせたいときに役…

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP