Skip to content

Instantly share code, notes, and snippets.

@lunark lunark/Cmn_MakeQR.vb
Last active Nov 30, 2018

Embed
What would you like to do?
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
You can’t perform that action at this time.