Psytec社が開発、公開しているQR Code作成プログラムを使い、QR CodeをExcelで表示する方法です。

ご利用に合わせ、コードを修正してください。

Psytec社に感謝！

※注意：PowerShell版ではファイルパスに日本語や半角スペースがあると正しく動作しません

【手順１】 mkqrimg.exe のダウンロード

まず、QR Codeを作成するための外部プログラムmkqrimg.exeをダウンロードします。

Visual C++6.0で開発されており、ソースコードも公開されています。商用でも無料で利用できるし、動作も安定しています。 

プログラム本体はExcel bookファイルと同じフォルダにコピーします。



【手順２】Excel標準モジュールの編集

標準モジュールを一つ追加して以下のコード(Shell関数版 or PowerShell版)をコピーする。

'******  QR Code利用関数 (Shell関数版)******
Option Explicit

Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As LongPtr, _
                                                            ByVal dwMilliseconds As Long) As Long
Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
                                                    ByVal bInheritHandle As Long, _
                                                    ByVal dwProcessId As Long) As LongPtr
Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long

Public Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Public Const INFINITE As Long = &HFFFF

Function QRimg(ByVal str As String, ByRef SZ As Long, ByRef ce As Range) As Boolean
    Dim ThisSh As String
    Dim TopPosition As Double
    Dim LeftPosition As Double
    Dim ThisPath As String
    Dim QRShape As Shape
    Dim TaskId As Long
    Dim hProc  As LongPtr
    
    If Len(str) = 0 Then
        QRimg = False
        Exit Function
    End If
    
    If SZ = 0 Then
        QRimg = False
        Exit Function
    End If
    
    ThisSh = ce.Parent.Name
    TopPosition = ce.Top
    LeftPosition = ce.Left

    ThisPath = Application.ThisWorkbook.Path

    If Dir(ThisPath & "\qrimgtmp.bmp") <> "" Then
        Kill ThisPath & "\qrimgtmp.bmp"
    End If
    
    TaskId = Shell("""" & ThisPath & "\mkqrimg.exe""" & " /O""" & ThisPath & "\qrimgtmp.bmp"" /T""" & str & "")
    
    
    '
    'mkqrimg.exeの終了を待機
    '
    hProc = OpenProcess(PROCESS_ALL_ACCESS, 0, TaskId)
    If hProc <> 0 Then
        Call WaitForSingleObject(hProc, INFINITE)
        CloseHandle hProc
    End If

    Set QRShape = Sheets(ThisSh).Shapes.AddPicture(Filename:=ThisPath & "\qrimgtmp.bmp", _
          LinkToFile:=False, SaveWithDocument:=True, _
          Left:=LeftPosition, Top:=TopPosition, Width:=SZ, Height:=SZ)
  
    If Dir(ThisPath & "\qrimgtmp.bmp") <> "" Then
        Kill ThisPath & "\qrimgtmp.bmp"
    End If
    
    QRimg = True
End Function

Sub QR_sample()
    Dim ce As Range
    
    Set ce = ActiveSheet.Cells(2, 2)

    If QRimg("QR code作成関数です", 40, ce) Then
        MsgBox "QR Codeを作成しました"
    Else
        MsgBox "QR Codeの作成に失敗しました"
    End If

End Sub
'*** ここまで(Shell関数版) ***



'******  QR Code利用関数 (PowerShell関数版)******
'パスに日本語や半角スペースがあると機能しません
Function QRimg(ByVal str As String, ByRef SZ As Long, ByRef ce As Range, Optional ByVal TopBias As Long = 0, Optional ByVal LeftBias As Long = 0) As Boolean
    Dim ThisSh As String
    Dim TopPosition As Double
    Dim LeftPosition As Double
    Dim ThisPath As String
    Dim QRShape As Shape
    Dim WSH As Object
    Dim cmdStr As String
    Dim cmdStrin As String
    Dim Result As Long
   
    Set WSH = CreateObject("WScript.Shell")
    
    If Len(str) = 0 Then
        QRimg = False
        Exit Function
    End If
    
    If SZ = 0 Then
        QRimg = False
        Exit Function
    End If
    
    ThisSh = ce.Parent.Name
    ThisPath = Application.ThisWorkbook.Path
    
    TopBias = 0
    LeftBias = 0
    TopPosition = ce.Top + TopBias
    LeftPosition = ce.Left + LeftBias

    If Dir(ThisPath & "\qrimgtmp.bmp") <> "" Then
        Kill ThisPath & "\qrimgtmp.bmp"
    End If

    cmdStrin = " " & ThisPath & "\mkqrimg.exe" & "  /O'" & ThisPath & "\qrimgtmp.bmp'" & " /T'" & str & "'; "
    cmdStrin = cmdStrin & "exit"
    cmdStr = Chr(34) & "& {" & cmdStrin & "}" & Chr(34)
    Result = WSH.Run("PowerShell -NoExit -nologo -ExecutionPolicy Bypass -Command " & cmdStr, 2, True)

    Set QRShape = Sheets(ThisSh).Shapes.AddPicture(Filename:=ThisPath & "\qrimgtmp.bmp", _
          LinkToFile:=False, SaveWithDocument:=True, _
          Left:=LeftPosition, Top:=TopPosition, Width:=SZ, Height:=SZ)
  
    If Dir(ThisPath & "\qrimgtmp.bmp") <> "" Then
        Kill ThisPath & "\qrimgtmp.bmp"
    End If
    
    QRimg = True
End Function

Sub QR_sample()
    Dim ce As Range
    
    Set ce = ActiveSheet.Cells(2, 2)

    If QRimg("QR code作成関数です", 40, ce) Then
        MsgBox "QR Codeを作成しました"
    Else
        MsgBox "QR Codeの作成に失敗しました"
    End If

End Sub
'*** ここまで(PowerShell関数版) ***


【手順３】 動作確認

サンプルプログラム「QR_sample」を起動します。

現在表示されているシートのB2に QR Codeが表示されれば成功です。



【応用】
QRimg関数の引数は以下のとおりです。

QRimg(QRコード化する文字列 as string, QRコードのサイズ as long, QRコードを表示させるセル as Range) as Boolean



【動作原理】
シェル関数またはPowerShellを使ってmkqrimg.exeを起動し、指定したフォルダにQR Codeのbmpファイルを作成します。
bmpファイルの作成を確認後、bmpファイルをエクセルのワークシートに挿入し、元のbmpファイルを削除します。