QR codes....... again

[picklefactory]

Hi folks
I thought this would be much simpler than it has turned out, so as ever..... I need help please.
OK, what I want sounds simple, I'd just like to have cells in a column of values (eg 21166985-48-14580) and on rows where the column isn't empty, create in the next adjacent column the text as a QR code. So for example, if cell A1 contained the value "1234", then B1 would have a QR code for 1234, if A2 value is "STUMPED" then B2 would be QR for "STUMPED"... which I am. I thought it would be as simple as a basic bar code where I could just use a font, but not so for QR codes. It needs to be a QR, as I might have up to 16 or 17 characters, which creates too long a linear bar code. I have tried the info I found on Mr Excel QR code generator modification, but that only creates a QR code from a single cell input, not something that will create what I need from a column of values.
Is it possible to alter that code to do something more, it's way too complicated for my meagre ability, or is there something much simpler?
Thanks

 

[Georgiboy]

Maybe the below will help:

Sub GenerateQR()
    Dim URL As String
    Dim PlaceAtCell As Range
    Dim rCell As Range
    Dim pNum As Long
    
    For Each rCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
        pNum = pNum + 1
        URL = "https://barcode.tec-it.com/barcode.ashx?data=" & rCell.Value & "&code=EPCQRCode&eclevel=M"
        ActiveSheet.Pictures.Insert(URL).Name = CStr(pNum)
        Set PlaceAtCell = rCell.Offset(, 1)
        With ActiveSheet.Pictures(CStr(pNum))
            .ShapeRange.LockAspectRatio = msoTrue
            .Left = PlaceAtCell.Left + 1
            .Width = PlaceAtCell.Width - 1
            .Top = PlaceAtCell.Top + 1
            .Height = PlaceAtCell.Height - 1
        End With
    Next rCell
End Sub

 

[picklefactory]

Maybe the below will help:

Sub GenerateQR()
    Dim URL As String
    Dim PlaceAtCell As Range
    Dim rCell As Range
    Dim pNum As Long
   
    For Each rCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
        pNum = pNum + 1
        URL = "https://barcode.tec-it.com/barcode.ashx?data=" & rCell.Value & "&code=EPCQRCode&eclevel=M"
        ActiveSheet.Pictures.Insert(URL).Name = CStr(pNum)
        Set PlaceAtCell = rCell.Offset(, 1)
        With ActiveSheet.Pictures(CStr(pNum))
            .ShapeRange.LockAspectRatio = msoTrue
            .Left = PlaceAtCell.Left + 1
            .Width = PlaceAtCell.Width - 1
            .Top = PlaceAtCell.Top + 1
            .Height = PlaceAtCell.Height - 1
        End With
    Next rCell
End Sub

Thanks Georgi
I'm on my way home now, and I'll try that later. I was hoping for something that didn't require internet connection, but I won't rule anything out yet.....
Appreciate your time , thank you

 

[Sequoyah]

Hi all,
if you need a solution working without an internet connection, the best way is to use a third-party software. Here is an example using SimpleCodeGenerator, a free tool that doesn't require installation, available here:

QR Code Generator for Windows 10 / 7 / Vista / XP

Simple tool for Windows that allows you to quickly generate QR Code for scanning with App on your Smartphone

www.nirsoft.net

Just adjust the path in the code

Sub GenerateQR_NirSoft()
    
'https://www.mrexcel.com/board/threads/qr-codes-again.1224859/post-5991315
    
Dim S               As String, GenPath As String, destPath As String, MyText As String, dQ As String
Dim LastRow         As Integer, i As Integer
Dim Pic             As Object
Dim pNum            As Long
    
GenPath = "C:\Users\Sequoyah\Desktop\SimpleCodeGenerator.exe /ErrorCorrection 4 /MinVersion 1 /MaxVersion 40 /Clipboard " '<<==== Adjust th PATH

LastRow = Range("A" & Rows.Count).End(xlUp).Row
dQ = """"

Application.ScreenUpdating = False

'delete old pic. from cells
For Each Pic In ActiveSheet.Pictures
    If Not Intersect(Pic.TopLeftCell, Columns("B")) Is Nothing Then Pic.Delete
Next Pic

For i = 2 To LastRow
    pNum = pNum + 1
    MyText = " " & dQ & Range("A" & i).Value & dQ & " "
    S = GenPath & MyText & "5"        'Image Size
    
    Shell (S)
    
    With ActiveSheet
        .Paste Destination:=.Range("B" & i), Link:=False
        .Pictures(.Pictures.Count).Name = CStr(pNum)
    End With
    
Next i

End Sub

 

[picklefactory]

Hi folks
Sorry for delay. Weekend got me
OK, tried both with varying results.

Georgi, thank you, I tried that but after running it a couple of times it said I had exceeded the limit from the website, and also added a whole heap of text in the cells where there was no text to convert. This will be an ongoing usage and quite large, so not sure that will work long term.

Sequoyah, thank you also, I just couldn't get that to function at all. I'm obviously doing something stupid. I saved the .exe file on my desktop, copied and pasted your filepath into the code, obviously replacing the start with the filepath from my pc, but nothing would happen at all, even if I tried to run directly from in the VBA window, just nothing.

I have, however, come across a third offering (I've looked in so many places, I don't know where I found this now) which is almost perfect. It does still run from the internet, so not sure if that will cause an issue in the future. It works fine except that every time it runs, it runs for the entire sheet and so creates a duplicate image on top of the previous images, which will just keep increasing. Could anyone see a way in which it will only create an image for cells that do not already contain one? So only for new entries? I've developed the sheet loosely to show a little more of my thinking in actual use. The QR code will actually contain a part number, quantity and unique serial number.

QR Barcode demo.xlsm
	A	B	C	D	E
1	Part Number	Qty	Serial	QR Text	QR Barcode
2	21166985	48	000001	21166985-48-1
3	1875659	32	000002	1875659-32-2
Sheet1

Cell Formulas
Range	Formula
D2	D2	=A2&"-"&B2&"-"&C2
C3	C3	=IF(B3="","",C2+1)
D3	D3	=IF(C3="","",A3&"-"&B3&"-"&C3)

Public Sub Demo001()
Sheet1.Activate
Dim c       As Range
Dim lRow    As Long
lRow = WorksheetFunction.Max(2, Cells(Rows.Count, 1).End(xlUp).Row)
For Each c In Range("E2:E" & lRow)
    If c.Offset(0, -1) <> "" Then
        MakeQRCode sData:=c.Offset(0, -1).Text, _
              iForeCol:=vbBlack, iBackCol:=vbWhite, iSize:=120, cell:=c
    End If
Next c
End Sub


Function MakeQRCode(sData As String, iForeCol As Long, iBackCol As Long, _
                   ByVal iSize, cell As Range) As Boolean
  ' Places a QR code containing the specified data at top left of the specified cell
  ' See http://goqr.me/api/doc/create-qr-code/ for API documentation

  Dim iPic          As Long
  Dim ****          As String
  Dim oPic          As Picture
  Dim sURL          As String

  On Error Resume Next
 
  Do
    Set oPic = Nothing
    iPic = iPic + 1
    **** = "QRCode(" & iPic & ")"
    Set oPic = cell.Worksheet.Pictures(****)
  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 = ****
    .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 RRGGBB
  sRGB = Right("00000" & Hex(iRGB), 6)
  sRGB = Right(sRGB, 2) & Mid(sRGB, 3, 2) & Left(sRGB, 2)
End Function

 

[picklefactory]

In hindsight, this will work perfectly. Now I have a way to easily create one, and giving the working sheet more thought, I don't need to keep all of the QR codes. I'll be using this WB to create labels, so only need to create one QR code at a time for printing and just have a table of the text going into the code.
I think I am solved for now, thank you both for your suggestions

 

[Peter_SSs]

In hindsight, this will work perfectly.

I'm not sure which "this" you are referring to but if it is one of the earlier posts then mark that post as the solution to help future readers.
I have removed the solution mark from post #6 as that doesn't actually contain the solution.

 

[picklefactory]

Hi Peter
Sorry if that was misleading. Post 5 is the solution I'm currently working with for my purposes. It's not perfect, but with my meagre skills it's the one I'm finding easiest to achieve my end result so far..... I'll more than likely be back once I've found something else to confuse me.

 

[Peter_SSs]