QR Code Encoder VBA library

[YasserKhalil]

Hello everyone

Can yo guide me to this topic, please?
QR Code Encoder VBA library

I have no great experience at this topic. Can you provide me with links that could help as I tried some links but with no luck
What I need is to generate QRCode but without the help of googleapis?

I found this code but I don't have the library

Code: Select all

Sub CreateQRCode()

Dim qr As New QRCodeEncoder
Dim img As Object

Set img = qr.Encode("https://www.google.com")
img.Save "C:\qrcode.png", vbNull

End Sub

[HansV]

See the attached example. Code (with one correction) from VbQRCodegen.

You should edit the code to specify the path etc.

QR.xlsm

[YasserKhalil]

Great. Thank you very much.
I have one question. Is it possible to use this as UDF and generate the QRCode into cell as I tried but I got only numbers in the cell?

Code: Select all

=QRCodegenBarcode("Yasser")

[HansV]

Perhaps in Microsoft 365, not in older versions.

[YasserKhalil]

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 ?

[HansV]

You wrote "What I need is to generate QRCode but without the help of googleapis?" in your first post.
The class module in your latest reply uses GoogleAPIs to create the QR code...

Apart from that: if you look at the code of the class module, you'll see that the exposed properties are named Picture_Size and Display_Text instead of PictureSize and DisplayText. The latter are the private internal names.
Also, the method to create a QR code is named Generate_QRCode, not InsertQRCode, and it takes a range object as argument.
Also, you need to set Is_Updateable to True.

Code: Select all

Sub GenerateQRCode()
    Dim qr As New QRCodeGenerator
    qr.QRValue = "YasserKhalil"
    qr.Picture_Size = 200
    qr.Display_Text = "Example URL"
    qr.Is_Updateable = True
    qr.Generate_QRCode Range("B2")
End Sub

[YasserKhalil]

I know it is using googpleapis but I found it better after some research. Generally, I have modified the previous post and now I am stuck at how to fit the picture to cell ?

[YasserKhalil]

Now I modified it

Code: Select all

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)
        oPic.ShapeRange.LockAspectRatio = msoFalse
        If Err Then
            Err.Clear
            vLeft = oRng.Left
            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, oRng.Width, oRng.Height)
    oPic.Name = PictureName
End Sub

Thanks a lot my tutor.

Last point, how can loop with such class module to loop through cells in column A and insert the qrcode in column B?

[YasserKhalil]

This is my try but I am not sure if I am right or there is a better way

Code: Select all

Sub Test_QRCodeGenerator()
    Dim qr As New QRCodeGenerator, lr As Long, i As Long
    qr.Picture_Size = 150
    qr.Is_Updateable = True
    With ActiveSheet
        lr = .Cells(Rows.Count, "A").End(xlUp).Row
        For i = 1 To lr
            qr.QRValue = .Cells(i, "A").Value
            qr.Generate_QRCode Cells(i, "B")
        Next i
    End With
End Sub

[HansV]

That's it.

[YasserKhalil]

I tried to change the color of the shape to vbBlue using these lines, but that doesn't work and I still got black QRCode

Code: Select all

    With oPic.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 255)
        .Solid
    End With

[HansV]

That's because it is a picture.
Google's QR code generator does not support color.

[YasserKhalil]

I also tried the following lines but with no luck

Code: Select all

    With shp
        With .PictureFormat
            .ColorType = msoColorTypeRGB
            .TransparencyColor = RGB(0, 0, 255)
        End With
    End With

[YasserKhalil]

That's because it is a picture.
Google's QR code generator does not support color.

I tried the code after generating the qrcode. So the code is not part of the original code.

Code: Select all

    Dim shp As Shape
    Set shp = ActiveSheet.Shapes("imgQRCode")
    With shp
        With .PictureFormat
            .ColorType = msoColorTypeRGB
            .TransparencyColor = RGB(0, 0, 255)
        End With
    End With

[HansV]

Did it work?

[YasserKhalil]

No, in fact. The following code works but not as expected. It just set the background to gray. I don't want to change the background. I want to control the Recolor method, but when recording a macro, I got nothing

Code: Select all

    Dim shp As Shape
    Set shp = ActiveSheet.Shapes("imgQRCode")
    With shp
        .Fill.Visible = msoFalse
        .Fill.Solid
        .Fill.BackColor.RGB = RGB(0, 0, 255)
        With .PictureFormat
            .Brightness = 0.3
            .TransparencyColor = RGB(0, 0, 255)
        End With
    End With

[HansV]

Unless you find a way to manipulate the picture itself, it won't work.

[YasserKhalil]

But the last code works partially to manipulate the picture itself.

[HansV]

The background, not the QR code.

[YasserKhalil]

But I can change the color manually (select the shape > Picture Format tab > Color > Recolor section > From the third line I can select Blue) but when recording these steps, I got nothing.