Saving QR Image as JPG

[Bib195]

Hello Everyone,
I'm Using Excel Function IMAGE( ) to create a QR Code through an Online API link. Now I'm trying to save this created image as JPG with all the ways I know & Failed. using this IMAGE function is not placing the created code as { Insert Picture in Cell } mode, so all Chart & Shape commands are not working - at least for me with my little experience in VBA. As you will notice with the attached Screenshot, the Formula-Bar shows the IMAGE( ) I'm using!
Is there a solution to this issue as I'm stuck with it for the past 5 days...

 

[NdNoviceHlp]

Hi again Ehab. The following code can be placed in module code. It saves all the pics in sheet1 to the wb file path (Adjust the sheet name to suit). You need to add a name for each pic to the cell in the column to the right of the pic. HTH. Dave

Dim Wsht As Worksheet
Public Sub test()
'pics in Sheet1 "A"; file name in sheet2 "B"
Dim MyChart As Chart
Dim sh As Shape
'change sheet name to suit
Set Wsht = ActiveWorkbook.Sheets("Sheet1")
On Error GoTo below
Application.ScreenUpdating = False
'add temp chart
Charts.Add.Location Where:=xlLocationAsObject, Name:="Sheet1"
Wsht.ChartObjects(Wsht.ChartObjects.Count).Name = "MYChart"
With Wsht
For Each sh In .Shapes
If sh.Type = msoPicture Or sh.Type = msoLinkedPicture Then
'make jpg files. Pics in any column with file name to right column
Call CreateJPG(sh.Name, CStr(.Range(sh.TopLeftCell.Address).Offset(, 1)), sh)
End If
Next sh
End With
'remove temp chart
Wsht.ChartObjects("MYChart").Delete
below:
Application.ScreenUpdating = True
If Err.Number <> 0 Then
MsgBox "Error"
End If
End Sub

Sub CreateJPG(PicName As String, FileNm As String, Shp As Shape)
'make image files
'picname is XL picture name; FileNm is name of file; Shp is pic in cell
Dim xRgPic As Shape
Wsht.Activate
Set xRgPic = Wsht.Shapes(PicName)
xRgPic.CopyPicture
'delete prev pic
With Wsht.ChartObjects("MYChart").Chart
    Do While .Shapes.Count > 0
        .Shapes(1).Delete
    Loop
'size chart to Rng cell
.Parent.Height = Shp.Height
.Parent.Width = Shp.Width
.Parent.Top = Shp.Top
.Parent.Left = Shp.Left
End With
'make file in wb path
With Wsht.ChartObjects("MYChart")
.Activate
.Chart.Paste
.Chart.Export ThisWorkbook.Path & "\" & ValidFilePath(FileNm) & ".jpg", "JPG"
End With
End Sub

Public Function ValidFilePath(Arg As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
    .Pattern = "[\\/:\*\?""<>\|]"
    .Global = True
    ValidFilePath = .Replace(Arg, "_")
End With
Set RegEx = Nothing
End Function

To operate, run the "Test" macro.

 

[Logit]

Dave ... I'm following this thread with interest. A different OP (?) posted a very similar question (QR Code connundrum) to which I
provided an answer.

Tried your macros here and they don't function as designed. It appears the macros are going through various steps (watching the screen flicker, etc) but nothing ... not even a QR
code appearing ... no errors.

Suggestions ? I'm running Excel 2007

 

[NdNoviceHlp]

Hi Logit. Thanks for the feedback. The code doesn't produce any QR code pics. My read was that *Bib195 already created and inserted the QR code as pics in the worksheet. I didn't trial the code with QR pics. I assumed that a pic was a pic. Anyways, if you have some QR code pics in a sheet I'd be interested to know what this part of the above code outputs....

With Wsht
For Each sh In .Shapes
'If sh.Type = msoPicture Or sh.Type = msoLinkedPicture Then
MsgBox sh.Type
'make jpg files. Pics in any column with file name to right column
'Call CreateJPG(sh.Name, CStr(.Range(sh.TopLeftCell.Address).Offset(, 1)), sh)
'End If
Next sh
End With

I would think that a QR code inserted as an image would be a shape of some type. Dave

 

[Logit]

Here is the file I presented to the other OP a few days ago.

Internxt Drive – Private & Secure Cloud Storage

I missed the need to already have the images in the sheet prior to running your code. The images in my file are presented as PNG files.

 

[NdNoviceHlp]

The QR codes are msopicture (Type 13). The code I posted works as expected. You need to put a pic name in the column to the right of the QR code rows. The pic files are outputted to your wb directory. The code to produce the QR code looks quite impressive but the API needs to be updated to accommodate 64 bit installations. Thanks Logit for posting a trial document. Dave

 

[NdNoviceHlp]

I found the api...

#If VBA7 Then
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
        ByVal pCaller As LongPtr, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As LongPtr, _
        ByVal lpfnCB As LongPtr) As LongPtr
#Else
    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
#End If

Dave

 

[NdNoviceHlp]

Well isn't that interesting. I ran your code after updating the API and now the picture type is msoLinkedPicture (Type 11). Hmmm? Dave

 

[Bib195]

Hi again Ehab. The following code can be placed in module code. It saves all the pics in sheet1 to the wb file path (Adjust the sheet name to suit). You need to add a name for each pic to the cell in the column to the right of the pic. HTH. Dave

Dim Wsht As Worksheet
Public Sub test()
'pics in Sheet1 "A"; file name in sheet2 "B"
Dim MyChart As Chart
Dim sh As Shape
'change sheet name to suit
Set Wsht = ActiveWorkbook.Sheets("Sheet1")
On Error GoTo below
Application.ScreenUpdating = False
'add temp chart
Charts.Add.Location Where:=xlLocationAsObject, Name:="Sheet1"
Wsht.ChartObjects(Wsht.ChartObjects.Count).Name = "MYChart"
With Wsht
For Each sh In .Shapes
If sh.Type = msoPicture Or sh.Type = msoLinkedPicture Then
'make jpg files. Pics in any column with file name to right column
Call CreateJPG(sh.Name, CStr(.Range(sh.TopLeftCell.Address).Offset(, 1)), sh)
End If
Next sh
End With
'remove temp chart
Wsht.ChartObjects("MYChart").Delete
below:
Application.ScreenUpdating = True
If Err.Number <> 0 Then
MsgBox "Error"
End If
End Sub

Sub CreateJPG(PicName As String, FileNm As String, Shp As Shape)
'make image files
'picname is XL picture name; FileNm is name of file; Shp is pic in cell
Dim xRgPic As Shape
Wsht.Activate
Set xRgPic = Wsht.Shapes(PicName)
xRgPic.CopyPicture
'delete prev pic
With Wsht.ChartObjects("MYChart").Chart
    Do While .Shapes.Count > 0
        .Shapes(1).Delete
    Loop
'size chart to Rng cell
.Parent.Height = Shp.Height
.Parent.Width = Shp.Width
.Parent.Top = Shp.Top
.Parent.Left = Shp.Left
End With
'make file in wb path
With Wsht.ChartObjects("MYChart")
.Activate
.Chart.Paste
.Chart.Export ThisWorkbook.Path & "\" & ValidFilePath(FileNm) & ".jpg", "JPG"
End With
End Sub

Public Function ValidFilePath(Arg As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
    .Pattern = "[\\/:\*\?""<>\|]"
    .Global = True
    ValidFilePath = .Replace(Arg, "_")
End With
Set RegEx = Nothing
End Function

To operate, run the "Test" macro.

Hi Dave,
Thanks a million for your support...
It worked like a dream.... You did it Again
Your Help is always appreciated.
Ehab

 

[NdNoviceHlp]

You are welcome Ehab. Thanks for posting your outcome. Enjoy the festive season. Dave