It becomes a trend to use QR code to transform complicate words to a QR picture. It would be much more useful if we can do this in Excel and automate this process.
This article is to tell how to achieve this by utilizing online QR code service and save the QR code in your Excel file.
For people who not care about the program detail, at the end the article, the full source code and executable .xlsm are attached. If you have security concern of the .xlsm, you can copy-paste the source code to a fresh .xlsm manually. A demo video (Chinese voice with Youtube English subtitle) is also provided to make it work on your side easier.
USE EXCEL VBA TO GENERATE QRCODE
Excel uses VBA (VB for application) language to do things programmatically. It’s the focus of this article. For QR code generating, we uses HTTP GET via online service to transform text to QR code image. Although this is a free and quick service, the risk is the network / service breaks down. So, remember to use this service properly and hope the provider not shut it down.
Program Flow
The flow is described below,
- For each cell in ColumnA, the program generates a QR code at Column E.
- The way to generate the QR code is to apply the text to URL “https://api.qrserver.com/v1/create-qr-code/?size=150×150&data=YOUR_TEXT_HERE“. Then, download the image of the URL. This is a PNG image file.
- Insert the QR code image into ColumnE and set the cell size same as the image (150×150 in the program).
- Done
Key Techniques
There are couple key techniques.
- How to use VBA to insert pciture and set cell property to align to picture’s size
- How to convert the target string to URL-encoded string. The target string may contain space, special character and UTF-8. These string should be encoded as field in HTTP GET field.
- Find one online service for convert string to QR code image.
The forth item may not be such a key factor. But it does be important. The service we found just give you the picture without showing any advertisement or agreement.
Code Explanation
Insert picture(QRCODE IMG) and adapt to cell position and size：This is no hard but lots of outdate information. It seems the way to achieve is different since Office 2007. The code here is tested on Office 2010.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
'dst --> Target cell. The 4 lines below set the picture size / pos ' 5 pixels inner space of target cell. l = dst.Left + 5 'qr x-pos =cell x-pos + 5 t = dst.Top + 5 'qr y-pos = cell y-pos + 5 w = dst.Width - 10 'qr width = cell width - 10 (left/right 5 px for each) h = dst.Height - 10 'qr height = cell height - 10 'insert qr pic d:\kkk.png at specified pos, the last 4 args are mentioned above '2nd arg --> use real paste instead of link to insert pic '3rd arg --> Save qr img in Excel file Set p = Application.ActiveSheet.Shapes.AddPicture("d:\kkk.png", False, True, l, t, w, h) p.Name = "qrcode_graph" 'name the qr pic for easy deletion later p.Placement = xlMoveAndSize 'Important!! With this, the qr pic auto adapt size to cell |
Download file from URL：Refer to someone’s article in Internet, use DLL to achieve. Not well understood, just use it.
|
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 |
Convert string to URL encoded：Also from Internet, just use it. Confirmed feasible for space and UTF-8
|
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 |
Generate QRCODE and insert at specific location: This function generates QR code of the string in cell ‘src’ and insert at position of cell ‘dst’. The string in ‘src’ is URL encoded and pass to online service to get its QR code. The QR code image is downloaded at place at specified location and adapt its size to selected cell.
|
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) 'Do URL encoding of QR code string link = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" + Text 'The online QR code service URL Kill "d:\kkk.png" 'Delete last QR image tmp = DownloadFile(link, "d:\kkk.png", True) 'Download the file at link. It's the generated QR code image and save as d:\kkk.png If Dir("d:\kkk.png") <> "" And FileLen("d:\kkk.png") = 0 Then 'If file not exists and zero length, something wrong get_qrcode = 1 ' Download error, return 1 Exit Function End If 'dst --> Target cell. Set the QR image size of 5 px inner of target cell l = dst.Left + 5 t = dst.Top + 5 w = dst.Width - 10 h = dst.Height - 10 'Insert QR pic d:\kkk.png to specified location. The last 4 arguments are mentioned above. '2nd arg --> Insert the file instead of linking '3rd arg --> Save the pic in Excel file Set p = Application.ActiveSheet.Shapes.AddPicture("d:\kkk.png", False, True, l, t, w, h) p.Name = "qrcode_graph" 'Name the picture for easy deletion later p.Placement = xlMoveAndSize 'Important!! Use this to make image adapt to cell's size get_qrcode = 0 End Function |
Major Macro <Update QRCODE>: We use some tricks to make it easier to use. Assumed A1 contains a string to convert to QR code, we will put its QR code at A5.(Actually above it, A5 still contains string). Then, we copy the A1’s contain to A5. At the next time we want to generate QR code, the program will check if A1==A5. If they doesn’t match, the new QR code is generated else we pass it. The can effectively accelerate the update speed by doing modified items only.
|
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() 'If multiple cell is selected. Check if all are in Column A 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 'Ignore empty cell C = cell.Column R = cell.Row Rows(R).RowHeight = 75 'Set cell height as 75 to show bigger QR code 'Check if cell modified. Ignore unchanged and generate new or modified items. 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 |
Marjo Macro <Remove QRCODE>: We already have function to generate. So, here is the clean one. We already name QR image while insertion. This function will find out all the picture with the name and delete them. Also, all data in column 5 are removed. (Max 1000 record).
|
1 2 3 4 5 6 7 8 |
Sub 移除所有QRCode() For Each Shape In ActiveSheet.Shapes 'Find all shapes If Shape.Name = "qrcode_graph" Then Shape.Delete 'If name matched, remove it Next Shape For I = 1 To 1000 Cells(I, 5).Value = "" Next I End Sub |
Demo Video (English Subtitle)
The demo image is at https://www.youtube.com/watch?v=-rlkrQqnd2o. Chinese pronunciation with English subtitle available.
File Downloads
- EXCEL auto QRCODE generating source code (Text File)
- EXCEL auto QRCODE generating .xlsm file –> This will show warning for Macro security concern. Please enable it. Or, open a whole new .xlsm and paste the source code (the file1) to it.
- *** While testing the file on new installed, it is found that the code on system without “Drive D” doesn’t work. To fix this, please do the replacement in macro content. “d:kkk.png” should be replaced as Environ(“TEMP”) + “kkk.png”. All the bold part needs to be replaced including the double quote sign.
