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

 

[Skyybot]

Might as well trial just this....

Sheets("Sheet2").Activate

Dave

In case it's not classified a WorkSheet. Good idea.

 

[doriannjeshi]

Might as well trial just this....

Sheets("Sheet2").Activate

Dave

got passed to next line and errors there 9
Set xRgPic = ThisWorkbook.Worksheets("sheet2").Shapes(PicName)

 

[NdNoviceHlp]

Well then change all of the...

ThisWorkbook.Worksheets("sheet2")

to...

Sheets("Sheet2")

Dave

 

[doriannjeshi]

Well then change all of the...

ThisWorkbook.Worksheets("sheet2")

to...

Sheets("Sheet2")

Dave

Now no errors but nothing gets saved in the folder where the workbook is saved

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))) '<------Removed period before Range
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
Sheets("Sheet2").Activate
Set xRgPic = Sheets("Sheet2").Shapes(PicName)
xRgPic.CopyPicture
With Sheets("Sheet2").ChartObjects("MYChart")
.Activate
.Chart.Paste
.Chart.Export ThisWorkbook.Path & "\" & FileNm & ".jpg", "JPG"
End With
End Sub

 

[NdNoviceHlp]

Incremental success. You cant trial putting the period before the Range again. Also trial adding this msgbox and see where the picture address is...

If sh.Type = msoPicture Then
Msgbox sh.TopLeftCell.Address

Dave

 

[jolivanes]

If I understand you right, you have shapes in cells in column A and a name to the right of it in column B.
The shapes should be saved as pictures in the same folder where the workbook that has the shapes has been saved.
It is assumed that all the shapes top left cell is in the cell in question. What that means is that if you have "Joe" in B3 that the picture in Column A does not overlap into the cell above.
Change references as and where required.

Sub SavePictureFromExcel()
Dim sh1 As Worksheet, c As Range, tempChartObj As ChartObject
Dim savePath As String, myPic As Shape, shp As Shape
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
Application.ScreenUpdating = False
For Each c In sh1.Range("B1:B" & sh1.Cells(Rows.Count, 2).End(xlUp).Row)
    For Each shp In sh1.Shapes
        If shp.TopLeftCell.Address = c.Offset(, -1).Address Then Set myPic = shp: Exit For
    Next shp
    Set tempChartObj = sh1.ChartObjects.Add(0, 0, myPic.Width, myPic.Height)
        savePath = ThisWorkbook.Path & "\" & c.Value & ".jpg"
            myPic.Copy
                DoEvents
                    DoEvents
                        tempChartObj.Chart.ChartArea.Select
                            tempChartObj.Chart.Paste
                        DoEvents
                DoEvents
            tempChartObj.Chart.Export savePath
        DoEvents
    DoEvents
tempChartObj.Delete
Set myPic = Nothing
Next c
Application.ScreenUpdating = True
End Sub

 

[NdNoviceHlp]

@jolivanes... your adding and deleting charts within the loop. You only need 1 chart. Dave

 

[jolivanes]

Hi Dave.
Thanks for setting me straight.
I am sure you tested it with maybe 50 pictures and have gotten a difference in time.
Would be interesting to see the difference. Are you willing to share?
Thanks again.

 

[NdNoviceHlp]

It occurred to me that when it works but nothing gets saved in the folder where the file is, that it's likely saving the file elsewhere. Maybe trial...

Msgbox ThisWorkbook.Path & "\" & FileNm & ".jpg"
.Chart.Export ThisWorkbook.Path & "\" & FileNm & ".jpg", "JPG"

or perhaps your file name is no good. You may need to add this...

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

So you would then change this line of code...

.Chart.Export ThisWorkbook.Path & "\" & ValidFilePath(FileNm) & ".jpg", "JPG"

@jolivanes no offense intended. I have not tested with 50 pics and timed it and I don't plan on doing so as I'm not that invested in this project. It just seems a lot more efficient to not be repetitively creating and deleting charts when you really only need just one. Dave

 

[doriannjeshi]

If I understand you right, you have shapes in cells in column A and a name to the right of it in column B.
The shapes should be saved as pictures in the same folder where the workbook that has the shapes has been saved.
It is assumed that all the shapes top left cell is in the cell in question. What that means is that if you have "Joe" in B3 that the picture in Column A does not overlap into the cell above.
Change references as and where required.

Sub SavePictureFromExcel()
Dim sh1 As Worksheet, c As Range, tempChartObj As ChartObject
Dim savePath As String, myPic As Shape, shp As Shape
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
Application.ScreenUpdating = False
For Each c In sh1.Range("B1:B" & sh1.Cells(Rows.Count, 2).End(xlUp).Row)
    For Each shp In sh1.Shapes
        If shp.TopLeftCell.Address = c.Offset(, -1).Address Then Set myPic = shp: Exit For
    Next shp
    Set tempChartObj = sh1.ChartObjects.Add(0, 0, myPic.Width, myPic.Height)
        savePath = ThisWorkbook.Path & "\" & c.Value & ".jpg"
            myPic.Copy
                DoEvents
                    DoEvents
                        tempChartObj.Chart.ChartArea.Select
                            tempChartObj.Chart.Paste
                        DoEvents
                DoEvents
            tempChartObj.Chart.Export savePath
        DoEvents
    DoEvents
tempChartObj.Delete
Set myPic = Nothing
Next c
Application.ScreenUpdating = True
End Sub

View attachment 87441

Hi Jolivanes, do images and shapes differ ? Because I have images in column A that need to be saved as images.
It errors
Run-time error '91':
Object variable or With block variable not set