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...

 

[Bib195]

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

Hi There,
I solved my problem using Dave's code BUT after reinserting All the picture (QR Codes) with different name for each Image (Picture), then I posted the name into a cell next to the Image Cell . Without this step, Dave's code will export all Files with the 1st shape only.
Example:
- If you have 10 Images / Pictures inserted into your sheet
- All the 10 Images / Pictures are inserted with the same name, Then
- Dave's Code will export 10 files JPG or PNG file BUT all the 10 files will have the same Image / Picture which is the 1ST Image in the Sheet.
- Accordingly, you need to Name the Images / Pictures different names while inserting it to the Sheet.
- Then Insert the name of the FILE that you want the Image / Picture to be saved as to the chosen folder into the CELL next to the Image Cell.
hope this was clear enough.

 

[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.

Thanks again Dave,
Actually I posted this Thread when I didn't have any replies to my comment into the Other Thread for 2 days.
Anyway, as I mentioned on the other Thread, the Code worked as a dream and everything is working fine thanks to your contribution.
Accept my good sincere wishes for the festive days, all the Best.
Ehab...

 

[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.