Generate QR code with google chart API using UDF in Excel

posted Jun 4, 2014, 6:21 AM by r   [ updated Jun 4, 2014, 8:23 AM ]
It - could - work!
We would like to share a tricky UDF to generate QR codes on your worksheet.
The technique is simple: you can create a new QR picture or update an existing one by using URL_qrCode_SERIES() formula. The picture itself is generated by Google chart API, so your system needs to have internet connection.
The picture will be updated when the formula is calculated, so when you change the value in the cell with link to be encoded (A9 on the below picture) you will immediately see the picture.


Download the file.

Mandatory arguments:
  • Name of the picture is mandatory, if you set a picture name which already exists on the sheet, it will be updated. (Deleted and re-added.) If you choose a new name, the picture will be positioned next to the caller cell.
  • QR values is also mandatory, usually it is an URL address you want to encode to the QR picture.
Optional arguments:
  • Size of the picture (only one measure, because the shape will be rectangle).
  • DisplayText is the return value of the formula. It will be visible in the cell you write the UFD (caller cell).
  • Updateable argument can be set to False if the picture should not be updated when the referred cell values change. It could be useful if you use the tool offline (without internet connection).


Technology:
The base concept of this UDF technique is the fact that UDFs could modify, delete and add shapes to worksheet.
We use Google chart API to generate the QR code itself. Our UDF composes the URL for the API, and use this URL as the first argument of the Shapes.AddPicture method.

You can use our example file, or you can copy the code to your own files.

Option Explicit
'other technical specifications about google chart API:
'https://developers.google.com/chart/infographics/docs/qr_codes

Function URL_QRCode_SERIES( _
    ByVal PictureName As String, _
    ByVal QR_Value As String, _
    Optional ByVal PictureSize As Long = 150, _
    Optional ByVal DisplayText As String = "", _
    Optional ByVal Updateable As Boolean = True) As Variant

Dim oPic As Shape, oRng As Excel.Range
Dim vLeft As Variant, vTop As Variant
Dim sURL As String

Const sRootURL As String = "https://chart.googleapis.com/chart?"
Const sSizeParameter As String = "chs="
Const sTypeChart As String = "cht=qr"
Const sDataParameter As String = "chl="
Const sJoinCHR As String = "&"

If Updateable = False Then
    URL_QRCode_SERIES = "outdated"
    Exit Function
End If

Set oRng = Application.Caller.Offset(, 1)
On Error Resume Next
Set oPic = oRng.Parent.Shapes(PictureName)
If Err Then
    Err.Clear
    vLeft = oRng.Left + 4
    vTop = oRng.Top
Else
    vLeft = oPic.Left
    vTop = oPic.Top
    PictureSize = Int(oPic.Width)
    oPic.Delete
End If
On Error GoTo 0

If Len(QR_Value) = 0 Then
    URL_QRCode_SERIES = CVErr(xlErrValue)
    Exit Function
End If

sURL = sRootURL & _
       sSizeParameter & PictureSize & "x" & PictureSize & sJoinCHR & _
       sTypeChart & sJoinCHR & _
       sDataParameter & UTF8_URL_Encode(VBA.Replace(QR_Value, " ", "+"))

Set oPic = oRng.Parent.Shapes.AddPicture(sURL, True, True, vLeft, vTop, PictureSize, PictureSize)
oPic.Name = PictureName
URL_QRCode_SERIES = DisplayText
End Function


Function UTF8_URL_Encode(ByVal sStr As String)   
    'http://www.nonhostile.com/howto-convert-byte-array-utf8-string-vb6.asp
    Dim i As Long

    Dim a As Long
    Dim res As String
    Dim code As String
   
    res = ""
    For i = 1 To Len(sStr)
        a = AscW(Mid(sStr, i, 1))
        If a < 128 Then
            code = Mid(sStr, i, 1)
        ElseIf ((a > 127) And (a < 2048)) Then
            code = URLEncodeByte(((a \ 64) Or 192))
            code = code & URLEncodeByte(((a And 63) Or 128))
        Else
            code = URLEncodeByte(((a \ 144) Or 234))
            code = code & URLEncodeByte((((a \ 64) And 63) Or 128))
            code = code & URLEncodeByte(((a And 63) Or 128))
        End If
        res = res & code
    Next i
    UTF8_URL_Encode = res
End Function


Private Function URLEncodeByte(val As Integer) As String
    Dim res As String
    res = "%" & Right("0" & Hex(val), 2)
    URLEncodeByte = res
End Function


Read more:

You may also be interested:


Leave a comment