Save Images to Folder

[punit83]

Hello Everyone !

I have few excel with heavy database in which there is one column of images and one column with its model number. Is there any guide to save all images in bulk with it model # describe in other column.
( Many times there are merge cells also )

Any help will be a great time saving help.

Thank in advance from newbie

 

[NdNoviceHlp]

Hi punit83. Here's a variation of the code posted at this link..

Save picture macro

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 AB1123121232

www.mrexcel.com

You will need to adjust the code to your folder path. The code assumes that your pictures are on sheet 1 with the names of the pictures (used as file names) 2 columns to the right of the top left of the pic. The code uses a chart to copy your pic and then export it as a JPEG file to your folder location. Seemed to work in my testing but I'm not sure what will happen with merged cells. Dave

Sub test()
'pics in Sheet1. File names 2 columns to right of pic
Dim MyChart As Chart
Dim sh As Shape
On Error GoTo below
Application.ScreenUpdating = False
'add temp chart
Charts.Add.Location Where:=xlLocationAsObject, Name:="Sheet1"
Sheets("Sheet1").ChartObjects(Sheets("Sheet1").ChartObjects.Count).Name = "MYChart"
With Sheets("Sheet1")
For Each sh In .Shapes
If sh.Type = msoPicture Or sh.Type = msoLinkedPicture Then
'****make jpg files. Pics in any column with file name 2 columns to right
Call CreateJPG(sh.Name, CStr(.Range(sh.TopLeftCell.Address).Offset(, 2)), sh)
End If
Next sh
End With
'remove temp chart
Sheets("Sheet1").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, FolderLoc As String
'****adjust folderpath to suit
FolderLoc = "C:\testfolder\"
ThisWorkbook.Worksheets("sheet1").Activate
Set xRgPic = ThisWorkbook.Worksheets("sheet1").Shapes(PicName)
xRgPic.CopyPicture
'size chart to Rng cell
With Sheets("Sheet1").ChartObjects("MYChart").Chart
.Parent.Height = Shp.Height
.Parent.Width = Shp.Width
.Parent.Top = Shp.Top
.Parent.Left = Shp.Left
End With
'make file in wb path
With Sheets("Sheet1").ChartObjects("MYChart")
.Activate
.Chart.Paste
.Chart.Export FolderLoc & 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 place the code in sheet code and run the Test sub.

 

[punit83]

Hi punit83. Here's a variation of the code posted at this link..

Save picture macro

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 AB1123121232

www.mrexcel.com

You will need to adjust the code to your folder path. The code assumes that your pictures are on sheet 1 with the names of the pictures (used as file names) 2 columns to the right of the top left of the pic. The code uses a chart to copy your pic and then export it as a JPEG file to your folder location. Seemed to work in my testing but I'm not sure what will happen with merged cells. Dave

Sub test()
'pics in Sheet1. File names 2 columns to right of pic
Dim MyChart As Chart
Dim sh As Shape
On Error GoTo below
Application.ScreenUpdating = False
'add temp chart
Charts.Add.Location Where:=xlLocationAsObject, Name:="Sheet1"
Sheets("Sheet1").ChartObjects(Sheets("Sheet1").ChartObjects.Count).Name = "MYChart"
With Sheets("Sheet1")
For Each sh In .Shapes
If sh.Type = msoPicture Or sh.Type = msoLinkedPicture Then
'****make jpg files. Pics in any column with file name 2 columns to right
Call CreateJPG(sh.Name, CStr(.Range(sh.TopLeftCell.Address).Offset(, 2)), sh)
End If
Next sh
End With
'remove temp chart
Sheets("Sheet1").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, FolderLoc As String
'****adjust folderpath to suit
FolderLoc = "C:\testfolder\"
ThisWorkbook.Worksheets("sheet1").Activate
Set xRgPic = ThisWorkbook.Worksheets("sheet1").Shapes(PicName)
xRgPic.CopyPicture
'size chart to Rng cell
With Sheets("Sheet1").ChartObjects("MYChart").Chart
.Parent.Height = Shp.Height
.Parent.Width = Shp.Width
.Parent.Top = Shp.Top
.Parent.Left = Shp.Left
End With
'make file in wb path
With Sheets("Sheet1").ChartObjects("MYChart")
.Activate
.Chart.Paste
.Chart.Export FolderLoc & 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 place the code in sheet code and run the Test sub.

Thank you so much sir.


It also worked for me

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave