Save Image from excel

Question

Hi,
I want to export images from an excel sheet. Cell A1 would be the input of the folder name where the images would be saved.Column C will contain images. Once a user click on a button all the images that are in column C will be exported to the folder name
mentioned in cell A1. The image name would be decided based on their appearance in excel sheet. E.G. 1st image in C column would have file name as Image 1,2nd image Image 2 and so on... until last image found in C column.  I have one piece of code but
I am getting Out of memory error.Any help would be appreciated.
Const saveSceenshotTo As String = "C:\Users\Deb\Desktop\" ' change path to where you want to save
Const pictureFormat As String = ".jpg" ' change file extension
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
' run this sub to export pictures
Private Sub CommandButton1_Click()
Dim i As Long
i = 1
Dim pic As Shape
For Each pic In ActiveSheet.Shapes
pic.Copy
MyPrintScreen (saveSceenshotTo & Range("A" & i).Text & pictureFormat)
i = i + 1
Next
End Sub
Public Sub MyPrintScreen(FilePathName As String)
Dim IID_IDispatch As GUID
Dim uPicInfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPtr
.hPal = 0
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
SavePicture IPic, FilePathName
End Sub
Thanks!!
 

Answer 1

The following macro will do the following...
1) Check to make sure that the path in E1 is a valid one.
2) Check whether the folder in A1 already exists within the directory specified in E1.
3) If a folder does not already exist, one is created, and the images are exported into the newly created folder.
4) If a folder already exists, the user is advised, and the procedure ends.
Option Explicit
Sub ExportPictures()
Dim oShape As Shape
Dim oChrtObj As ChartObject
Dim sPath As String
Dim sFolder As String
Dim sPathAndFolder As String
Dim sErrMsg As String
Dim PicCnt As Long
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
On Error GoTo ErrHandler
Application.ScreenUpdating = False
sPath = Range("E1").Value
sFolder = Range("A1").Value
If Len(Dir(sPath, vbDirectory)) > 0 Then
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
Else
sErrMsg = "The specified path is invalid."
GoTo ErrHandler
End If
sPathAndFolder = sPath & sFolder
If Len(Dir(sPathAndFolder, vbDirectory)) = 0 Then
MkDir sPathAndFolder
Else
sErrMsg = "A folder called '" & sFolder & "' already exists."
GoTo ErrHandler
End If
PicCnt = 0
With ActiveSheet.ChartObjects.Add(0, 0, 250, 250)
.Border.LineStyle = 0
For Each oShape In ActiveSheet.Shapes
If oShape.Type = msoPicture Then
If Not Intersect(oShape.TopLeftCell, Columns("C")) Is Nothing Then
PicCnt = PicCnt + 1
oShape.Copy
With .Chart
With .ChartArea
.Width = oShape.Width + 2
.Height = oShape.Height + 2
End With
.Paste
.Export Filename:=sPathAndFolder & "\" & "Image " & PicCnt & ".jpg", FilterName:="jpg"
.Pictures(1).Delete
End With
End If
End If
Next oShape
.Delete
End With
MsgBox "Images exported: " & PicCnt, vbInformation
ExitTheSub:
Application.ScreenUpdating = True
Set oShape = Nothing
Set oChrtObj = Nothing
Exit Sub
ErrHandler:
If Len(sErrMsg) > 0 Then
MsgBox sErrMsg, vbInformation, "Unable to Continue"
GoTo ExitTheSub
Else
If Err <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Error"
Resume ExitTheSub
End If
End If
End Sub
Hope this helps!
Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"