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

    [リボン・カスタマイズ]カスタムタブを共有する。

    ※ 2015/2/18 コードに一部誤りがあったので修正しました。…

  2. Office関連

    「あのコマンドどこだっけ? for Office 2013」の紹介

    Word MVPの新田さんのブログでも紹介していただいている自作フリー…

  3. Office関連

    Locationヘッダの情報を取得するVBAマクロ

    通常、下記のようなリダイレクトされるWebページを開いたとき、…

  4. Office アドイン

    [Office用アプリ]JavaScript API for Officeのポスター

    JavaScript API for Officeのオブジェクト、メソ…

  5. Office関連

    PowerShellからNetOfficeを使ってExcelを操作する方法

    先日、Excel MVPの伊藤さんがPowerShellからExcel…

  6. 情シス

    [Google Apps Script]メールをemlとして保存する

    今回の記事は「情シスSlack Advent Calendar 201…

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

Translate

Chinese (Simplified)Chinese (Traditional)EnglishFrenchGermanJapaneseKoreanRussianSpanish

最近の記事

アーカイブ

PAGE TOP