QR Code connundrum

Y

YansaneYansane

New Member
Joined
Nov 1, 2024
Messages
34
Office Version
  1. 2019
Platform
  1. Windows
  2. Web
Hi Tech,

I have this code to Generate a QR Code... :eek:
Please any help to make it work. Thanks

I have an 11-column table. Data from the previous 10 columns to be concatenated into a QR Code and inserted into the 11th column, column "M".
===============================
Sub InsertQRCode()
Dim ws As Worksheet
Dim lastRow As Long
Dim qrContent As String
Dim qrURL As String
Dim qrImg As Picture
Dim cell As Range
Dim qrWidth As Long, qrHeight As Long
Dim imgTop As Double, imgLeft As Double
Set ws = ThisWorkbook.Sheets("Dash")
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
For Each cell In ws.Range("B10:B" & lastRow)
qrContent = ""
For i = 2 To 12 ' Columns B to L are columns 2 to 12
qrContent = qrContent & ws.Cells(cell.Row, i).Value & " "
Next i
qrContent = WorksheetFunction.EncodeURL(qrContent)
qrURL = "https://chart.googleapis.com/chart?chs=150x150&cht=qr&chl=" & qrContent
Debug.Print qrURL
On Error Resume Next ' In case of URL issues
Set qrImg = ws.Pictures.Insert(qrURL)
On Error GoTo 0 ' Reset error handling
If Not qrImg Is Nothing Then
qrWidth = 100 ' Define desired width (adjust as necessary)
qrHeight = 100 ' Define desired height (adjust as necessary)
qrImg.ShapeRange.LockAspectRatio = msoFalse
qrImg.Width = qrWidth
qrImg.Height = qrHeight
imgTop = ws.Cells(cell.Row, "M").Top + (ws.Cells(cell.Row, "M").Height - qrHeight) / 2
imgLeft = ws.Cells(cell.Row, "M").Left + (ws.Cells(cell.Row, "M").Width - qrWidth) / 2
qrImg.Top = imgTop
qrImg.Left = imgLeft
Else
MsgBox "Failed to insert QR Code for row " & cell.Row, vbCritical
End If
Next cell
End Sub
===============================
 

Attachments

  • Table N.jpg
    Table N.jpg
    68.7 KB · Views: 18
Sort by date Sort by votes
Which columns are you expecting the QR code to include ? B:K or just the grades or ????
 
Upvote 0
Try this :

VBA Code: 
Declare Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" _
    (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
    ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub GenerateQRCodes()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim concatenatedData As String
    Dim qrCodeURL As String
    Dim qrCodePath As String
    Dim qrCode As Picture
    Dim rowHeight As Double

    ' Set the worksheet to work on
    Set ws = ThisWorkbook.Sheets(1) ' Adjust the sheet number/name as needed

    ' Find the last row in column A with data
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    ' Loop through each row and concatenate columns A to K
    For i = 2 To lastRow ' Assuming row 1 has headers
        concatenatedData = ""
        
        ' Concatenate data from columns A to K
        Dim j As Integer
        For j = 1 To 11
            concatenatedData = concatenatedData & ws.Cells(i, j).Value & " "
        Next j
        concatenatedData = Trim(concatenatedData) ' Remove trailing spaces

        ' Generate the QR code URL using GoQR.me API
        qrCodeURL = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" & WorksheetFunction.Substitute(concatenatedData, " ", "%20")
        
        ' Define a temporary file path to save the QR code image
        qrCodePath = Environ("TEMP") & "\QRCode_" & i & ".png"

        ' Download the QR code image to the file path
        On Error Resume Next
        URLDownloadToFile 0, qrCodeURL, qrCodePath, 0, 0
        On Error GoTo 0

        ' Insert the QR code image into column M
        Set qrCode = ws.Pictures.Insert(qrCodePath)

        ' Resize the image to 150x150 (or adjust if necessary)
        With qrCode
            .ShapeRange.LockAspectRatio = msoFalse
            .Height = 45
            .Width = 45
            .Top = ws.Cells(i, 12).Top
            .Left = ws.Cells(i, 12).Left
        End With

        ' Adjust the row height to match the QR code height
        rowHeight = qrCode.Height
        ws.Rows(i).rowHeight = rowHeight
    Next i

    MsgBox "QR codes generated successfully!", vbInformation
End Sub
 
Upvote 0
VBA Code: 
Declare Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" _
    (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
    ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub GenerateQRCodes()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim concatenatedData As String
    Dim qrCodeURL As String
    Dim qrCodePath As String
    Dim qrCode As Picture

    ' Set the worksheet to work on
    Set ws = ThisWorkbook.Sheets(1) ' Adjust the sheet number/name as needed

    ' Find the last row in column B with data
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    ' Loop through each row starting from row 9
    For i = 9 To lastRow
        concatenatedData = ""
        
        ' Concatenate data from columns A to K (1 to 11)
        Dim j As Integer
        For j = 1 To 11
            concatenatedData = concatenatedData & ws.Cells(i, j).Value & " "
        Next j
        concatenatedData = Trim(concatenatedData) ' Remove trailing spaces

        ' Generate the QR code URL using GoQR.me API
        qrCodeURL = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" & WorksheetFunction.Substitute(concatenatedData, " ", "%20")
        
        ' Define a temporary file path to save the QR code image
        qrCodePath = Environ("TEMP") & "\QRCode_" & i & ".png"

        ' Download the QR code image to the file path
        On Error Resume Next
        URLDownloadToFile 0, qrCodeURL, qrCodePath, 0, 0
        On Error GoTo 0

        ' Insert the QR code image into column L
        Set qrCode = ws.Pictures.Insert(qrCodePath)

        ' Center the QR code in the cell (Row 9, Column L)
        With qrCode
            .ShapeRange.LockAspectRatio = msoTrue
            .Height = ws.Cells(i, 12).Height * 0.8 ' Scale to fit within cell height
            .Width = .Height ' Keep it square
            .Top = ws.Cells(i, 12).Top + (ws.Cells(i, 12).Height - .Height) / 2 ' Vertically center
            .Left = ws.Cells(i, 12).Left + (ws.Cells(i, 12).Width - .Width) / 2 ' Horizontally center
        End With
    Next i

    MsgBox "QR codes generated successfully!", vbInformation
End Sub
 
Upvote 0
Logit said:
VBA Code: 
Declare Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" _
    (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
    ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub GenerateQRCodes()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim concatenatedData As String
    Dim qrCodeURL As String
    Dim qrCodePath As String
    Dim qrCode As Picture

    ' Set the worksheet to work on
    Set ws = ThisWorkbook.Sheets(1) ' Adjust the sheet number/name as needed

    ' Find the last row in column B with data
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    ' Loop through each row starting from row 9
    For i = 9 To lastRow
        concatenatedData = ""
       
        ' Concatenate data from columns A to K (1 to 11)
        Dim j As Integer
        For j = 1 To 11
            concatenatedData = concatenatedData & ws.Cells(i, j).Value & " "
        Next j
        concatenatedData = Trim(concatenatedData) ' Remove trailing spaces

        ' Generate the QR code URL using GoQR.me API
        qrCodeURL = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" & WorksheetFunction.Substitute(concatenatedData, " ", "%20")
       
        ' Define a temporary file path to save the QR code image
        qrCodePath = Environ("TEMP") & "\QRCode_" & i & ".png"

        ' Download the QR code image to the file path
        On Error Resume Next
        URLDownloadToFile 0, qrCodeURL, qrCodePath, 0, 0
        On Error GoTo 0

        ' Insert the QR code image into column L
        Set qrCode = ws.Pictures.Insert(qrCodePath)

        ' Center the QR code in the cell (Row 9, Column L)
        With qrCode
            .ShapeRange.LockAspectRatio = msoTrue
            .Height = ws.Cells(i, 12).Height * 0.8 ' Scale to fit within cell height
            .Width = .Height ' Keep it square
            .Top = ws.Cells(i, 12).Top + (ws.Cells(i, 12).Height - .Height) / 2 ' Vertically center
            .Left = ws.Cells(i, 12).Left + (ws.Cells(i, 12).Width - .Width) / 2 ' Horizontally center
        End With
    Next i

    MsgBox "QR codes generated successfully!", vbInformation
End Sub
Click to expand...
Hi Logit...

The code is working. It perfectly places the QR Codes for each line item and in Column M (y).

For some reason, it repopulates the QR CODES on top of the previously inserted ones. ... when ran again.
 
Upvote 0
Paste the following in the same module as macro "GenerateQRCodes". Place this macro BELOW the first macro. Connect your command button
to this macro:

VBA Code: 
Sub DeletePicturesInColumnL()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim picTop As Double
    Dim picBottom As Double
    Dim rowTop As Double
    Dim rowBottom As Double
    Dim deleteRow As Long

    ' Specify the worksheet you are working on
    Set ws = ThisWorkbook.ActiveSheet

    ' Loop through each shape on the worksheet
    For Each shp In ws.Shapes
        If shp.Type = msoPicture Then
            ' Get the top and bottom positions of the picture
            picTop = shp.Top
            picBottom = shp.Top + shp.Height

            ' Loop through rows in column L to check if the picture overlaps
            For deleteRow = 9 To ws.Rows.Count
                rowTop = ws.Cells(deleteRow, "L").Top
                rowBottom = ws.Cells(deleteRow, "L").Top + ws.Cells(deleteRow, "L").Height

                ' Check if the picture is within the bounds of the row
                If picTop >= rowTop And picBottom <= rowBottom Then
                    shp.Delete
                    Exit For
                End If
            Next deleteRow
        End If
    Next shp
    
    GenerateQRCodes
    
End Sub
 
Upvote 0
Solution
👍👍👍👍👍👍👍👏👏👏👏👏👏

A thousand thanks Logit. Much appreciated.
 

Attachments

  • Thank You.jpg
    Thank You.jpg
    47.6 KB · Views: 9
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
QR Code creator
Replies
0
Views
133
judgejustin
J
B
  • Question Question
Excel VBA Object Variable or With Block Variable Not Set Error
2
Replies
18
Views
293
Micron
M
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
448
Minh Tuan VN
M
bizzyizzy215
  • Question Question
A VBA that inserts an image into the actual cell
Replies
1
Views
328
saboh12617
S
neilp
  • Solved
Tweak to VBA code to include last line
Replies
6
Views
92
Joe4
Joe4

Forum statistics

Threads
1,226,824
Messages
6,193,162
Members
453,778
Latest member
RDJones45

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top