[Excel VBA] Generate QR Code (2)

 Excel   VBA    QR Code  

▌Introduction

---

延續上一篇[Excel VBA] Generate QR Code(1)的程式碼，我們在需要產生多個QR Code的需求中，便需要建立一個專用的資料夾來存放不同的QR Code圖片，以讓Excel在每個QR Code的Reference link不至於參考到同一張圖片。

我們將學習以下VBA之應用：

1.  產生多個QR Code

2.  如何操作非工作(Activate)中之WorkSheet儲存格

3.  如何建立資料夾

▋相關文章

[Excel VBA] Generate QR Code (1)

[Excel VBA] Generate QR Code (2)

▌Implement

---

▋目標

我們將以下每筆資料(共四筆)分別產出一張QR Code並放到另外一張工作表：QR Code。

並且在儲存後下次重新打開，儲存的四張QR Code是正確的。

▋設定工作表及儲存格名稱

請先設定好兩張工作表(WorkSheet)的名稱，然後在QR Code工作表，設定以下儲存格名稱分別為

Agile1, Agile2 ~ Agile4

▋在產生QR Code按鈕的事件程式碼，以迴圈讀取每筆資料

Private Sub QRCodeGen_Click()     Dim idx As Integer     For idx = 1 To 4         genQRcode(idx)     Next idx End Sub

▋主程式

Private Sub genQRcode(idx As Integer)     Dim qrcodeValue As String     qrcodeValue = ActiveSheet.Cells(idx, 1).value 'QR Code value     ' Set image path     Dim qrcodeImgDir As String ' QR Code圖片資料夾位置     Dim qrcodeImgPath As String ' QR Code圖片位置     qrcodeImgDir = ActiveWorkbook.Path & "\" & Format(DateTime.Now, "yyyy-MM-dd")         ' Set different image name for every QR Code     qrcodeImgPath = qrcodeImgDir & "\" & "qrcode" & "_" & idx & Format(DateTime.Now, "hhmmss") & ".png"     ' Create image folder     If Dir(qrcodeImgDir, vbDirectory) = "" Then         createDirectory qrcodeImgDir     End If     'Create QR Code image     Call getQRCodeImg(qrcodeImgPath, qrcodeValue)     'Set QR Code image to  another WorkSheet     Dim sheet As Worksheet     Dim cellName As String     Dim qrcodeRange As Range       Set sheet = ActiveWorkbook.Sheets("QR Code") ' Get another WorkSheet       cellName = "Agile" & idx       Set qrcodeRange = sheet.Range(cellName)       Call deleteCell(sheet, qrcodeRange)     Call appendQRCode(sheet, qrcodeRange, qrcodeImgPath) End Sub

▋建立存放QR Code圖片的資料夾

Sub createDirectory(directoryPath)     MkDir directoryPath End Sub

▋更新函式： 傳入放QR Code的工作表和儲存格

Private Sub appendQRCode(sheet As Worksheet, qrcodeRange As Range, qrcodeImgPath As String)     Dim img As Picture     Set img = sheet.Pictures.Insert(qrcodeImgPath)     With img         .ShapeRange.LockAspectRatio = msoFalse         '.Top = ActiveSheet.Cells(33, 10).Top         '.Left = ActiveSheet.Cells(33, 10).Left         .Left = qrcodeRange.Left + 5         .Top = qrcodeRange.Top + 5     End With End Sub Private Sub deleteCell(sheet As Worksheet, curcell As Range)     Dim sh As Shape     For Each sh In sheet.Shapes         If sh.TopLeftCell.Address = curcell.Address Then sh.Delete     Next End Sub

▋產生QR Code

此函式沒有變更，只列出來供參考。

Private Sub getQRCodeImg(imgPath As String, value As String)     Dim fileNum As Long     Dim apiUri As String     Dim fileData() As Byte     Dim tmpImgPath As String     Dim winHttpReq As Object     Set winHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")     apiUri = "https://chart.googleapis.com/chart?cht=qr&chs=130x130&chl=" + value     winHttpReq.Open "GET", apiUri, False     winHttpReq.Send     fileData = winHttpReq.ResponseBody     Open imgPath For Binary Access Write As #1     Put #1, 1, fileData     Close #1 End Sub

▌Demo

▌Reference

---