Sub Test()
MakeQRCode "Excel est un tableur à la base.", vbBlack, vbWhite, 120, Range("A1")
End Sub
Function MakeQRCode(sData As String, iForeCol As Long, iBackCol As Long, _
ByVal iSize As Long, cell As Range) As Boolean
' shg 2017
' VBA only
' Places a QR code of specified size (in pixels), containing the specified data
' (plain ASCII), at the top left of the specified cell
' Returns True if successful
' See http://goqr.me/api/doc/create-qr-code/ for API documentation
Dim iPic As Long
Dim sPic As String
Dim oPic As Picture
Dim sURL As String
' Name as QRCode(n)
On Error Resume Next
Do
Set oPic = Nothing
iPic = iPic + 1
sPic = "QRCode(" & iPic & ")"
Set oPic = cell.Worksheet.Pictures(sPic)
Loop While Not oPic Is Nothing
err.Clear
If iSize > 1000 Then iSize = 1000
If iSize < 10 Then iSize = 10
sURL = "https://api.qrserver.com/v1/create-qr-code/?" & _
"&data=" & sData & _
"&size=" & iSize & "x" & iSize & _
"&charset-source=UTF-8" & _
"&charset-target=UTF-8" & _
"&ecc=L" & _
"&color=" & sRGB(iForeCol) & _
"&bgcolor=" & sRGB(iBackCol) & _
"&margin=0" & _
"&qzone=1" & _
"&format=png"
' Debug.Print sURL
With cell.Worksheet.Pictures.Insert(sURL)
.Name = sPic
.Left = cell.Left
.Top = cell.Top
End With
MakeQRCode = err.Number = 0
End Function
Function sRGB(iRGB As Long) As String
' converts an RGB long to a hex string encoding RRGGBB
sRGB = Right("00000" & Hex(iRGB), 6)
sRGB = Right(sRGB, 2) & Mid(sRGB, 3, 2) & Left(sRGB, 2)
End Function
