Need a example program for QR code genearation

Baski007 · May 7th 2020

hi all,

Need a demo workbook for QR code generation in excel vba ..can someone suggest

gue2013 · May 15th 2020

mqay be this helps?

trunten · May 17th 2020

Not really tested much but would this help at all?

Code

Option Explicit
Sub eg()
Dim img
Set img = qr("www.google.co.uk", 320)
End Sub
Function qr(ByVal url As String, Optional ByVal pixelWidth As Long = 60) As Variant
Dim xhr, img, ff&, pixelHeight&, path$, bs() As Byte
pixelHeight = pixelWidth
Set xhr = CreateObject("MSXML2.XMLHTTP")
path = Environ("TMP") & "\qr.png"
On Error Resume Next
Kill path
On Error GoTo 0
url = "https://api.qrserver.com/v1/create-qr-code/?data=" & url & "&size=" & pixelWidth & "x" & pixelHeight
xhr.Open "GET", url, False
xhr.send
If xhr.Status = 200 Then
bs = xhr.responsebody
ff = FreeFile
Open path For Binary Access Write As #ff
Put #ff, 1, bs
Close #ff
Set img = ActiveSheet.Pictures.Insert(path)
Erase bs
On Error Resume Next
Kill path
On Error GoTo 0
End If
Set xhr = Nothing
If IsEmpty(img) Then
qr = False
Else
Set qr = img
End If
End Function

Display More

trunten · May 17th 2020

Example workbook attached

trunten · May 18th 2020

Probably should've occurred to me the first time round, but here's an update which encodes the qr url first!

Updated function code:

Code

Function qr(ByVal url As String, Optional ByVal pixelWidth As Long = 60) As Variant
Dim xhr, img, ff&, pixelHeight&, path$, bs() As Byte
pixelHeight = pixelWidth
Set xhr = CreateObject("MSXML2.XMLHTTP")
path = Environ("TMP") & "\qr.png"
On Error Resume Next
Kill path
On Error GoTo 0
url = "https://api.qrserver.com/v1/create-qr-code/?data=" & WorksheetFunction.EncodeURL(url) & "&size=" & pixelWidth & "x" & pixelHeight
xhr.Open "GET", url, False
xhr.send
If xhr.Status = 200 Then
bs = xhr.responsebody
ff = FreeFile
Open path For Binary Access Write As #ff
Put #ff, 1, bs
Close #ff
Set img = ActiveSheet.Pictures.Insert(path)
Erase bs
End If
Set xhr = Nothing
If IsEmpty(img) Then
qr = False
Else
Set qr = img
End If
End Function

Display More

Share