Skip to content

Instantly share code, notes, and snippets.

@lunark
Last active June 25, 2020 08:37
Show Gist options
  • Save lunark/8281466046a5803b83b47bc02bc9b236 to your computer and use it in GitHub Desktop.
Save lunark/8281466046a5803b83b47bc02bc9b236 to your computer and use it in GitHub Desktop.
QRCode生成マクロ(画像貼込式・値更新対応)
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment