Save picture macro

[doriannjeshi]

Hello,

I need a macro to save the pics in a column with the adjacent cell name in a specified folder locally

picture is in column A but is not showing here

Book16
	A	B
1		1231
2		1232
Sheet2

 

[doriannjeshi]

- So to explain it better the picture in a1 should be saved as .jpg locally with the name of b1, and so for all the column A

 

[NdNoviceHlp]

Hi doriannjeshi. If you have pictures in sheet2 "A" with picture names in corresponding "B" rows of sheet2, this seems to work. I'm not sure what you mean by save files locally so they are just saved in the same location as your wb. HTH. Dave

Sub test()
'pics in Sheet2 "A"; file name in sheet2 "B"
Dim MyChart As Chart
Dim sh As Shape
'add temp chart
Charts.Add.Location Where:=xlLocationAsObject, Name:="Sheet2"
Sheets("Sheet2").ChartObjects(Sheets("Sheet2").ChartObjects.Count).Name = "MYChart"
With Sheets("Sheet2")
For Each sh In .Shapes
If sh.Type = msoPicture Then
'make jpg files
Call CreateJPG(sh.Name, CStr(.Range(sh.TopLeftCell.Address).Offset(, 1)))
End If
Next sh
End With
'remove temp chart
Sheets("Sheet2").ChartObjects("MYChart").Delete
End Sub

Sub CreateJPG(PicName As String, FileNm As String)
'make image files
'picname is XL picture name; FileNm is name of file
Dim xRgPic As Shape
ThisWorkbook.Worksheets("sheet2").Activate
Set xRgPic = ThisWorkbook.Worksheets("sheet2").Shapes(PicName)
xRgPic.CopyPicture
With Sheets("Sheet2").ChartObjects("MYChart")
.Activate
.Chart.Paste
.Chart.Export ThisWorkbook.Path & "\" & FileNm & ".jpg", "JPG"
End With
End Sub

To operate, run the Test sub.

 

[doriannjeshi]

the macro stops at:
Runtime error 9
subscript out of range
ThisWorkbook.Worksheets("sheet2").Activate

 

[NdNoviceHlp]

Hi again doriannjeshi. I'm not certain what the issue is. I trialed the code successfully before posting and I just re-tried it again for the same results on office 2019 on Windows 10 Pro. Are your pictures and file names on sheet 2 as there really isn't any reason for that line to crap out. Runtime error 9 "Subscript out of range” error occurs because the object we are trying to access does not exist. Dave

 

[Skyybot]

the macro stops at:
Runtime error 9
subscript out of range
ThisWorkbook.Worksheets("sheet2").Activate

Try:

Workbooks(1).Worksheets("Sheet2").Activate

 

[doriannjeshi]

Hi, I tried on a different file and machine, same problem, it creates an empty graphic and stops. When I switched columns, it names this graphic properly but stops at the error

I tried this line too but same result
Workbooks(1).Worksheets("Sheet2").Activate

 

[Skyybot]

Instead of

Call CreateJPG(sh.Name, CStr(.Range(sh.TopLeftCell.Address).Offset(, 1)))

Try this:

Call CreateJPG(sh.Name, CStr(Range(sh.TopLeftCell.Address).Offset(, 1))) '<------Removed period before Range

 

[doriannjeshi]

Again error script out of range at this line
Workbooks(1).Worksheets("Sheet2").Activate

 

[NdNoviceHlp]

Might as well trial just this....

Sheets("Sheet2").Activate

Dave