I have found this class module (QRCodeGenerator)
Code: Select all
Private Updateable As Boolean, m_QRValue As String, DisplayText As String, PictureSize As Long
Public Property Let QRValue(Value As String)
m_QRValue = Value
End Property
Public Property Get QRValue() As String
QRValue = m_QRValue
End Property
Public Property Get Value() As String
Value = QRValue
End Property
Public Property Let Value(ByVal sValue As String)
QRValue = sValue
End Property
Public Property Get Picture_Size() As Long
Picture_Size = PictureSize
End Property
Public Property Let Picture_Size(ByVal lSize As Long)
PictureSize = lSize
End Property
Public Property Get Display_Text() As String
Display_Text = DisplayText
End Property
Public Property Let Display_Text(ByVal sText As String)
DisplayText = sText
End Property
Public Property Get Is_Updateable() As Boolean
Is_Updateable = Updateable
End Property
Public Property Let Is_Updateable(ByVal bUpdateable As Boolean)
Updateable = bUpdateable
End Property
Public Sub Generate_QRCode(ByVal oRng As Excel.Range)
Dim vLeft, vTop, oPic As Shape, sURL As String
Const PictureName = "imgQRCode"
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 Exit Sub
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(QRValue) = 0 Then Exit Sub
sURL = sRootURL & sSizeParameter & PictureSize & "x" & PictureSize & sJoinCHR & sTypeChart & sJoinCHR & sDataParameter & UTF8_URL_Encode(VBA.Replace(QRValue, " ", "+"))
Set oPic = oRng.Parent.Shapes.AddPicture(sURL, True, True, vLeft, vTop, PictureSize, PictureSize)
oPic.Name = PictureName
End Sub
Function UTF8_URL_Encode(ByVal sStr As String)
Dim res As String, code As String, i As Long, a As Long
res = vbNullString
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
Code: Select all
Sub Test_QRCodeGenerator()
Dim qr As New QRCodeGenerator
qr.QRValue = "YasserKhalil"
qr.Picture_Size = 200
qr.Display_Text = Empty
qr.Is_Updateable = True
qr.Generate_QRCode Range("F1")
End Sub
The code is working well but how can I resize the picture to fit the cell?
Also what if I have several texts in column A. How can I loop and generated qrcode in column B ?