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

    右クリックから図形の配置 for Office 2013

    HPの掲示板に"右クリックから「配置」を実行できないか?"という質問が…

  2. アイコン一覧

    Office 2013 アイコン一覧(V)

    ・Office 2013 アイコン一覧 NUM…

  3. Google関連

    Google Apps Script 活用トーク #6に参加しました – #GAS活

    5月29日(金)に開催された「Google Apps Script 活…

  4. Office関連

    SkyDriveの同期フォルダーのパスを取得するマクロ

    前回の記事ではSkyDriveの同期フォルダーのパスを取得するWord…

  5. アイコン一覧

    Office 365アイコン(imageMso)一覧(N)

    Office 365のデスクトップ版Officeアプリケーション(Wo…

  6. Office関連

    Office 2016 Previewをインストールしてみました。

    「Microsoft、「Office 2016」と「Skype for…

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP