QRCode生成マクロ（画像貼込式・値更新対応）

Cmn_MakeQR.vb

Option Explicit

'--- Win32 API 関数の宣言 ---
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _
                                                                         ByVal dwMilliseconds As Long) As Long
    Private Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
                                                                 ByVal bInheritHandle As Long, _
                                                                 ByVal dwProcessId As Long) As Long
    Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
#Else
    Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _
                                                                 ByVal dwMilliseconds As Long) As Long
    Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
                                                         ByVal bInheritHandle As Long, _
                                                         ByVal dwProcessId As Long) As Long
    Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
#End If

'--- Win32 API 定数の宣言 ---
Public Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Public Const INFINITE As Long = &HFFFF

'--- Shell（DOSプログラムの実行完了を待つ） ---
Private Sub WaitRun(ByRef pProg As String, _
                    ByRef pStyle As Integer)
    Dim TaskId As Long                                                                             'タスクID
    Dim hProc As Long                                                                              'プロセスハンドル

    ' 外部プログラムの実行
    TaskId = Shell(pProg, vbHide)
    ' プロセスハンドルの取得
    hProc = OpenProcess(PROCESS_ALL_ACCESS, 0, TaskId)
    ' プロセスハンドルが返されたかを判定
    If hProc <> 0 Then
        ' プロセスのシグナル待ち
        Call WaitForSingleObject(hProc, INFINITE)
        ' プロセスクローズ
        CloseHandle hProc
    End If
End Sub

'--- ロジック：QRコードの作成 ---
Public Function makeQRCode(ByRef strcode As String, _
                           ByRef DstCell As Range)
    'Tempフォルダパス取得(画像ファイル書き込み用)
    Dim strTempPath As String: strTempPath = Environ("temp") & "\test.bmp"
    Dim hikisuu As String
    Const Height_cm As Long = 3
    Const Width_cm As Long = 3

    'エラー訂正率L、セルサイズ20でQR生成することを引数指定
    hikisuu = "/O""" & strTempPath & """ /T""" & strcode & """ /S20 /L0"

    'Psyteq QR Image for DOSを利用して画像生成する
    Call WaitRun("""" & Environ("windir") & "\system32\mkqrimg.exe"" " & hikisuu, vbHide)

    '今貼ってある画像がターゲット先のセルに貼ってあるなら削除する
    Call QRPictDelete(DstCell)

    '保存したQR画像をExcelシートへ張り付ける
    With ActiveWorkbook.ActiveSheet.Pictures.Insert(strTempPath)
        .Top = DstCell.Top
        .Left = DstCell.Left
        .Height = Application.CentimetersToPoints(Height_cm)
        .Width = Application.CentimetersToPoints(Width_cm)
    End With
End Function

'--- 指定したセルの左上座標にある画像を削除 ---
Private Sub QRPictDelete(ByRef DstCell As Range)
    Dim pAdd As String: pAdd = DstCell.Address
    Dim Pic As Picture
    '
    For Each Pic In ActiveWorkbook.ActiveSheet.Pictures
        If Pic.TopLeftCell.Address = pAdd Then
            Pic.Delete
        End If
    Next
End Sub