手動轉的話，案主是寫說時間大概要六小時！真是 OMG… 由於白天都在上班，就先簡單的寫個信給他，問有沒有考慮用程式的，有的話可聯絡我。不過真的就從此無聲無息了…下班後，憑著一股對程式的熱情，快快的把程式寫出來。
一開始覺得很簡單，後來又覺得不簡單，最後又覺得簡單了。其實是不簡單的部份是在於對 Excel 表格操作的部份，抓欄位、產生 QRCODE、下載圖檔，這些都不是問題。Excel VBA 才是不熟悉的部份，好在網路上都有資料找的到。
雖然最後寫出來了，可是案主已經找到人。我還是把我的程式錄影寄給他看了一下，雖然沒回應，不過能夠寫出一些真實需求和有收獲的程式，還是很開心。
文末會附上完整的程式碼、xlsm檔、範例影片。怕 .xlsm 檔有毒的，就把程式碼手貼進自己的 .xlsm 檔吧。
注意：本文及其附件僅適合於32位元的系統！據 shihma 網友回饋，在 Declare 後面加上 PtrSafe 就可以在 64位元系統上執行了，有需要的朋友可以試試。
EXCEL VBA QRCODE 產生巨集
EXCEL 的程式化操作一直是靠 VBA 來完成的，也是本文主要寫的東西。而產生 QRCODE 的部份，基本上是透過 HTTP GET，藉由網路上的服務，來產生 QRCODE 圖檔。雖然這個服務免費、速度又快，但風險就是可能使用太密集，有被阻擋的風險。
所以另外有再研究如何自己產生 QRCODE ，就分另一個 Linux 程式文章再介紹 (這裡)。
程式流程
簡單描述一下程式流程
- 需針對ColumnA的每一儲存格，都產生一個 QRCODE，然後將 QRCODE 放在對應ColumnE的位置。
- 產生 QRCODE 的方式，就是把儲存格內的文字代入 “https://api.qrserver.com/v1/create-qr-code/?size=150×150&data=文字內容“內，然後抓取這個網址的檔案。這就是一個 QRCODE 的 png 檔了，把它抓下存起來。
- 將圖片插入ColumnE相應的位置，並設定圖檔隨著儲存格改變大小和位置。
- 完成。
關鍵技術
中間比較關鍵的技術的地方有幾個
- 如何使用 VBA 插入圖片，並跟該儲存格大小、位置連動
- 如何使用 VBA 下載圖片
- 如何把用戶資料轉成 URL 編碼，因為資料裡可能有空白、特殊符號、中文，這些都需經過轉換才能用於 HTTP GET 的欄位。
- 找到網路上產生 QRCODE 的免費服務
第(4)點算不上什麼關鍵，但有找到這個服務，的確還蠻重要的。很乾脆的直接給你圖檔，沒夾一堆廣告之類的。
程式碼說明
插入圖片(QRCODE圖檔)，並與儲存格大小、位置連動：這部份不難，只是一開始找到的都是舊資料。據說 Office 2007 和之後的版本方法不同。我是 2010，所以還挖了一陣子，當然自己沒那麼熟 VBA 也是原因。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
'dst --> 目標儲存個。下面四行，是把圖檔的位置大小，設定在 '儲存格往內縮5點並填滿的大小。 l = dst.Left + 5 '圖檔x座標=儲存格x座標+5 t = dst.Top + 5 '圖檔y座標=儲存格y座標+5 '如果有何併儲存格, 可用 dst.MergeArea.Width / Height 來取得其大小 w = dst.Width - 10 '圖檔寬度=儲存格寬度-10 (因為左右都要留5點，所以減10) h = dst.Height - 10 '圖檔高度=儲存格高度-10 '將圖檔d:\kkk.png插入指定的位置, 最後4個參數就是上面的變數 '第二個參數 --> 不使用 Link 方式。使用檔案直接插入 '第三個參數 --> 把圖檔存入Excel檔案中。 Set p = Application.ActiveSheet.Shapes.AddPicture("d:\kkk.png", False, True, l, t, w, h) p.Name = "qrcode_graph" '把圖檔命名，方便刪除時辨認 p.Placement = xlMoveAndSize '重要！！加這個才能跟著儲存格的大小變動 |
從網址下載檔案：這部份是網路抓的，主要是呼叫 DLL API。沒仔細研究，直接使用。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000 Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long Private Declare Function InternetReadBinaryFile Lib "wininet.dll" Alias "InternetReadFile" (ByVal hfile As Long, ByRef bytearray_firstelement As Byte, ByVal lNumBytesToRead As Long, ByRef lNumberOfBytesRead As Long) As Integer Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer Function DownloadFile(sUrl As String, filePath As String, Optional overWriteFile As Boolean) Dim hInternet, hSession, lngDataReturned As Long, sBuffer() As Byte, totalRead As Long Const bufSize = 128 ReDim sBuffer(bufSize) hSession = InternetOpen("", 0, vbNullString, vbNullString, 0) If hSession Then hInternet = InternetOpenUrl(hSession, sUrl, vbNullString, 0, INTERNET_FLAG_NO_CACHE_WRITE, 0) Set oStream = CreateObject("ADODB.Stream") oStream.Open oStream.Type = 1 If hInternet Then iReadFileResult = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned) ReDim Preserve sBuffer(lngDataReturned - 1) oStream.Write sBuffer ReDim sBuffer(bufSize) totalRead = totalRead + lngDataReturned Application.StatusBar = "Downloading file. " & CLng(totalRead / 1024) & " KB downloaded" DoEvents Do While lngDataReturned <> 0 iReadFileResult = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned) If lngDataReturned = 0 Then Exit Do ReDim Preserve sBuffer(lngDataReturned - 1) oStream.Write sBuffer ReDim sBuffer(bufSize) totalRead = totalRead + lngDataReturned Application.StatusBar = "Downloading file. " & CLng(totalRead / 1024) & " KB downloaded" DoEvents Loop Application.StatusBar = "Download complete" oStream.SaveToFile filePath, IIf(overWriteFile, 2, 1) oStream.Close End If Call InternetCloseHandle(hInternet) DownloadFile = 0 End Function |
轉換URL編碼：也是從網路上抓的，直接用。確定中文跟空白沒問題。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
Public Function UrlEncode(ByRef szString As String) As String Dim szChar As String Dim szTemp As String Dim szCode As String Dim szHex As String Dim szBin As String Dim iCount1 As Integer Dim iCount2 As Integer Dim iStrLen1 As Integer Dim iStrLen2 As Integer Dim lResult As Long Dim lAscVal As Long szString = Trim$(szString) iStrLen1 = Len(szString) For iCount1 = 1 To iStrLen1 szChar = Mid$(szString, iCount1, 1) lAscVal = AscW(szChar) If lAscVal >= &H0 And lAscVal <= &HFF Then If (lAscVal >= &H30 And lAscVal <= &H39) Or _ (lAscVal >= &H41 And lAscVal <= &H5A) Or _ (lAscVal >= &H61 And lAscVal <= &H7A) Then szCode = szCode & szChar Else szCode = szCode & "%" & Hex(AscW(szChar)) End If Else szHex = Hex(AscW(szChar)) iStrLen2 = Len(szHex) For iCount2 = 1 To iStrLen2 szChar = Mid$(szHex, iCount2, 1) Select Case szChar Case Is = "0" szBin = szBin & "0000" Case Is = "1" szBin = szBin & "0001" Case Is = "2" szBin = szBin & "0010" Case Is = "3" szBin = szBin & "0011" Case Is = "4" szBin = szBin & "0100" Case Is = "5" szBin = szBin & "0101" Case Is = "6" szBin = szBin & "0110" Case Is = "7" szBin = szBin & "0111" Case Is = "8" szBin = szBin & "1000" Case Is = "9" szBin = szBin & "1001" Case Is = "A" szBin = szBin & "1010" Case Is = "B" szBin = szBin & "1011" Case Is = "C" szBin = szBin & "1100" Case Is = "D" szBin = szBin & "1101" Case Is = "E" szBin = szBin & "1110" Case Is = "F" szBin = szBin & "1111" Case Else End Select Next iCount2 szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6) For iCount2 = 1 To 24 If Mid$(szTemp, iCount2, 1) = "1" Then lResult = lResult + 1 * 2 ^ (24 - iCount2) Else: lResult = lResult + 0 * 2 ^ (24 - iCount2) End If Next iCount2 szTemp = Hex(lResult) szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2) End If szBin = vbNullString lResult = 0 Next iCount1 UrlEncode = szCode End Function |
產生取得 QRCODE，並放置指定位置：這個函式會把src儲存格內的文字，產生QRCODE，放在dst儲存格的位置。src內容會先被編成URL可接受的格式，然後使用網路上的文字轉QRCODE服務，產生圖檔。Download 後放置在指定位置，並設定成隨儲存格放大縮小。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
Function get_qrcode(src, dst) On Error Resume Next Dim link$, str As String Text = UrlEncode(src.Value) '將要轉QRCODE的文字進行URL編碼 link = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" + Text '要產生QRCODE的網址 Kill "d:\kkk.png" '刪除前次產生的圖 tmp = DownloadFile(link, "d:\kkk.png", True) '下載 link 網址所指定的檔案，就是我們要的 QRCODE，並存成 d:\kkk.png If Dir("d:\kkk.png") <> "" And FileLen("d:\kkk.png") = 0 Then '如果檔案不存在或大小為0則表示下載錯誤 get_qrcode = 1 ' 下載錯誤，則返回1 Exit Function End If 'dst --> 目標儲存格。下面四行，是把圖檔的位置大小，設定在儲存格往內縮5點並填滿的大小。 l = dst.Left + 5 t = dst.Top + 5 w = dst.Width - 10 h = dst.Height - 10 '將圖檔d:\kkk.png插入指定的位置, 最後4個參數就是上面的變數 '第二個參數 --> 不使用 Link 方式。使用檔案直接插入 '第三個參數 --> 把圖檔存入Excel檔案中。 Set p = Application.ActiveSheet.Shapes.AddPicture("d:\kkk.png", False, True, l, t, w, h) p.Name = "qrcode_graph" '把圖檔命名，方便刪除時辨認 p.Placement = xlMoveAndSize '重要！！加這個才能跟著儲存格的大小變動 get_qrcode = 0 End Function |
主巨集《更新 QRCODE》：我們採取了一點技巧來增加使用的便利性。假設在A1有個文字要轉成 QRCODE，我們會將產生的QRCODE放在A5的位置(其實是在之上，A5還是可以有內容)，然後將A1的內容複製到A5去。當下載次要再產生一次時，會檢查A5是否等於A1(是否有變動)。有的話，則會重新產生，否則不需要。這樣對整列更新時，可有效加快速度，也省去人工決定是否要更新的檢查。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
Sub 更新QR_CODE() '如果是自己選擇多個儲存格，檢查是否都在ColumnA For Each cell In Selection v = cell.Value() If cell.Column <> 1 Then MsgBox ("Cell is not valid") Exit Sub End If Next cell For Each cell In Selection If Len(cell.Value) = 0 Then GoTo nextcell '內容為空的不產生 QRCODE C = cell.Column R = cell.Row Rows(R).RowHeight = 75 '把儲存格的高度設成75，顯示較大的QRCODE '檢查是否儲存格的內容是否有變更，沒有的話就不重新產生。有的話(或第一次)，則產生並插入QRCODE If Cells(R, 5).Value <> cell.Value Then If get_qrcode(cell, Cells(R, 5)) <> 0 Then MsgBox ("get qrcode failed") Else Cells(R, 5).Value = cell.Value End If End If nextcell: Next cell End Sub |
主巨集《移除 QRCODE》：有產生，就有移除的功能。記得剛插入圖檔時有命名嗎？這個函式會找出該名稱的所有圖檔，並把它刪除 。另外在Column5的資料，也會被全部清空(假設最多1000筆)。
|
1 2 3 4 5 6 7 8 |
Sub 移除所有QRCode() For Each Shape In ActiveSheet.Shapes '找出所有的圖型 If Shape.Name = "qrcode_graph" Then Shape.Delete '若名稱符合則刪除 Next Shape For I = 1 To 1000 Cells(I, 5).Value = "" Next I End Sub |
展示影片
展示的影片位在 https://www.youtube.com/watch?v=-rlkrQqnd2o。
獨立程式版
後來有再寫一篇利用獨立程式產生 qrcode，而無需仰賴網路服務的，有需求的可參考這篇。
檔案下載
- EXCEL 自動產生QRCODE純程式碼 (Text檔)
- EXCEL 自動產生QRCODE，完整檔案 (.xlsm) 檔案 –> 會有巨集停用警告，請將它啟用。或者自己再開一個 .xlsm 檔，將上一個文字的檔的內容自己貼上。
- *** 測試時發現在沒有 D 槽的機器上會有問題，請把巨集的內容做取代。把 “d:\kkk.png” 取代成 Environ(“TEMP”) + “\kkk.png”。
請教：您編輯器左側的列計數，是如何叫出來的? 或 您是用哪個編輯器來寫VBA的?
你好，
那個是 WordPress 插件 Crayon Syntax Highlighter 的功能。專門用來顯示程式碼的，可以針對多種程式語言的程式碼做顏色區別，行號也是其功能之一。
您好:
我測試了巨集, QR code 底部會有原來的資料出現, 請問該如何解決? 感謝您!
你好，這是刻意這樣做的，資料若與上層產生QRCode時無異，圖就不會重新產生，這樣可以節省時間。若造成不便，建議可以把字改成白色或把字體改很小，這樣就看不到了。若您還是需要該字移除，可找到【If Cells(R, 5).Value ＜＞ cell.Value Then】這行程式碼，並改成【If 0 ＜＞ 1 Then 】，應該就可以了。前面的回覆有＜＞，因回覆無法使用特殊符號，請自行改為一般小寫的中括號。
你好 在WIin10 64 Office 2016環境下 執行 出現”編譯錯誤 這個專案的程式碼必須更新才能用於64位元系統”
請問這該如何解決
謝謝^^
謝謝您的訊息，的確我是在32位元版本上試的，裡面有用其它的32位元函式庫，所以才有這個問題。我自己只有32位元的，可能沒法試這個問題。你可以參考另一篇文章 https://moon-half.info/p/3145，這裡是用獨立程式作的，應該就可以解決，但不支持中文~
I Have try, and it’s working so fine,
But how to make generate QR in another column? i see the generate only if value in column A and result pictures in column E. Please advice.
Thank you very much,
Since this video/article is a programming tutorial about VBA language, you might need to understand the code in the Excel. If you can open the excel VBA programming interface, please search “cells” and the 2nd argument (which is 5 for now) is the column to put QR image. For the words to generate QR image, it depends on the cells selected. So, I guess this doesn’t need to be modified.
將PtrSafe關鍵字新增至Declare的後面就可以了
謝謝您的回饋~~~
感謝分享
請問QR code產生可以在地2攔(B1)開始產生嗎
把程式 更新QR_CODE() 裡的 cell.Column <> 1 改成 <> 2，再把有 Cells(R,5)的地方改成 Cells(R,6)，這樣可能就可以了。詳細還是要請您自己試試看~~
“如果是自己選擇多個儲存格，檢查是否都在ColumnA”
在你的程式說明中看這句話,這表示只能轉A欄位的資料嗎?
可否有方法,在多筆儲存格的資料轉出多筆的QR code呢?
感謝您
文章目的是提供和說明範例，讀者可以以此做修改。您的需求聽起來可以完成，當然確切的做法還是要看您的需求和格式才知道。您可以試著改改看，或是先研究一下 VBA 的語法，這樣應該可以改出您需要的功能。