Generate a dynamic image link and Display in Sheet using VBA

Restyl

New Member
Joined
Feb 2, 2016
Messages
16
I want to use Google Chart API to generate QR codes based on a cell value. Here is what my sheet looks like:
f09cd7c5b38745989642b1374694c0cc.png


My VBA code automatically generates the Stock Number every time the part # is changed. I need the QR Code column to be a QR code for the Stock Number to the right of it. I pasted the values of the Stock Number column in the QR Code Column to symbolize what the QR Code's encoded value should be.

How can I use Google Charts' API to generate a QR Code for each entry based on the Stock Number, and display the actual image in my sheet in the QR code column using VBA?

https://chart.googleapis.com/chart?chs=150x150&cht=qr&chl=I1&choe=UTF-8
 
Last edited:

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Code:
' http://www.vbaexpress.com/forum/showthread.php?t=43015
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
Function DownloadFile(url As String, LocalFileName As String) As Boolean
    If URLDownloadToFile(0, url, LocalFileName, 0, 0) = 0 Then
        DownloadFile = True
    End If
End Function
 
Sub DownloadQRcode(url As String, pngName As String, size As Integer)
     ' Pixel Size S, M, L: 160, 260, 360
    DownloadFile "http://chart.apis.google.com/chart?cht=qr&chs=" & size & "x" & size & "&chl=" & url, pngName
End Sub
 
Sub Test_DownloadQRcode()
    DownloadQRcode "http://www.vbaexpress.com/forum/showthread.php?t=43015", "c:\temp\VBAExpress QR Codes 43105.png", 160
    Shell "cmd /c ""c:\temp\VBAExpress QR Codes 43105.png"""
End Sub


Sub Test2_DownloadQRcode()
    DownloadQRcode "Hello World!" & "%0D%0A" & "by Kenneth Hobson", "c:\temp\HelloWorld.png", 360
    Shell "cmd /c ""c:\temp\HelloWorld.png"""
End Sub
 
Upvote 0
Thank you, could you post example of how to use this code after putting it into my module??
 
Upvote 0
I find it best to ask many questions and provide one solution. If a picture object, would you want a link to the file or an embedded image?
 
Upvote 0
Ok, last question, are you updating column I by a sheet Change event for column B or other means? If the former, please post the code.

I would probably use a Change event for column B to trigger the qrcodes routine.
 
Upvote 0
I don't have time to work up a sheet change event example right now. I added another sub to make it easier to use and a test sub as an example to run for the activecell's row.
Code:
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
Function DownloadFile(url As String, LocalFileName As String) As Boolean
    If URLDownloadToFile(0, url, LocalFileName, 0, 0) = 0 Then
        DownloadFile = True
    End If
End Function

Sub QRcodeToPicUTF8(url As String, pngPath As String, _
  pngName As String, aRange As Range, _
  Optional size As Integer = 150)
  'Pixel Size S, M, L: 160, 260, 360
  
  Dim pngFN As String, s As Shape, sName As String
  
  If Right(pngPath, 1) <> "\" Then pngPath = pngPath & "\"
  If Len(Dir(pngPath)) = 0 Then
    MsgBox pngPath & " does not exist.", vbCritical, "Macro Ending"
    Exit Sub
  End If
  
  pngFN = pngPath & pngName & ".png"
  DownloadFile "http://chart.apis.google.com/chart?cht=qr&chs=" & _
    size & "x" & size & "&chl=" & url & "&choe=UTF-8", pngFN
      
  If Len(Dir(pngFN)) = 0 Then
    MsgBox pngFN & " does not exist.", vbCritical, "Macro Ending"
    Exit Sub
  End If
  
  On Error Resume Next
  sName = "QR " & aRange.Address(False, False)
  ActiveSheet.Shapes(sName).Delete
  
  'Fit to aRange
  'Set s = ActiveSheet.Shapes.AddPicture(pngFN, _
    msoFalse, msoCTrue, aRange.Left, aRange.Top, _
    aRange.Width, aRange.RowHeight)
    
  'Fit to set dimensions: 150x150 pixels, _
    Row height: 77.25, Column Width: 14.14
  Set s = ActiveSheet.Shapes.AddPicture(pngFN, _
    msoFalse, msoCTrue, aRange.Left, aRange.Top, _
    77.25, aRange.Height)
  s.Name = sName
End Sub

Sub Test_QRcodeToPicUTF8()
  QRcodeToPicUTF8 "L" & ActiveCell.Row, Environ("temp"), _
  "QR " & ActiveCell.Address(False, False), Range("J" & ActiveCell.Row)
End Sub
 
Upvote 0
Thank you so much Kenneth!! I've modified your code to do what I want, but having an issue with the image being centered both horizontally and vertically within the cell. How can this be programmed? Below is a picture of the issue (H2) and the modified code I'm using:

V4mdpK0.png

Code:
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
Function DownloadFile(url As String, LocalFileName As String) As Boolean
    If URLDownloadToFile(0, url, LocalFileName, 0, 0) = 0 Then
        DownloadFile = True
    End If
End Function


Sub QRcodeToPicUTF8(url As String, pngPath As String, _
  pngName As String, aRange As Range, _
  Optional size As Integer = 150)
  'Pixel Size S, M, L: 160, 260, 360
  
  Dim pngFN As String, s As Shape, sName As String
  
  If Right(pngPath, 1) <> "\" Then pngPath = pngPath & "\"
  If Len(Dir(pngPath)) = 0 Then
    MsgBox pngPath & " does not exist.", vbCritical, "Macro Ending"
    Exit Sub
  End If
  
  pngFN = pngPath & pngName & ".png"
  DownloadFile "http://chart.apis.google.com/chart?cht=qr&chs=" & _
    size & "x" & size & "&chl=" & url & "&choe=UTF-8", pngFN
      
  If Len(Dir(pngFN)) = 0 Then
    MsgBox pngFN & " does not exist.", vbCritical, "Macro Ending"
    Exit Sub
  End If
  
  On Error Resume Next
  sName = "QR " & aRange.Address(False, False)
  ActiveSheet.Shapes(sName).Delete
  
  'Fit to aRange
  'Set s = ActiveSheet.Shapes.AddPicture(pngFN, _
    msoFalse, msoCTrue, aRange.Left, aRange.Top, _
    aRange.Width, aRange.RowHeight)
    
  'Fit to set dimensions: 150x150 pixels, _
    Row height: 77.25, Column Width: 14.14
  Set s = ActiveSheet.Shapes.AddPicture(pngFN, _
    msoFalse, msoCTrue, aRange.Left, aRange.Top, _
    77.25, aRange.Height)
  s.name = sName
End Sub

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 4 Then
    If Target.Offset(0, 5).Value = "" Then
            Target.Offset(0, 5).Value = Application.WorksheetFunction.Max(Columns("I")) + 1
    End If
[B]    If Target.Offset(0, 4).Value = "" Then[/B]
[B]            QRcodeToPicUTF8 "" & Target.Offset(0, 5), Environ("temp"), _[/B]
[B]            "QR " & ActiveCell.Address(False, False), Target.Offset(0, 4)[/B]
[B]    End If[/B]
End If
End Sub

The way this code works is, when Part # (Column D) is updated, the Stock Number (column I) gets the next available number in sequence and a QR code (Column H) for that assigned number is generated and displayed in its respective column.
 
Upvote 0

Forum statistics

Threads
1,213,491
Messages
6,113,963
Members
448,536
Latest member
CantExcel123

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