Export All Pictures in Spreadsheet as Filename in Cell Range

[l0aded]

Hey guys,

I am trying to write a code to mass export pictures on an excel sheet as a certain filename in the A column (Pictures in G column if relevant). I found a code on overflow stack that seems to partially do this but it doesn't seem to export correctly. It isn't grabbing all the pictures and it isn't naming them correctly (seems like it is randomly grabbing random A cells). Any ideas on what is wrong or a more efficient way to code this?

Thanks.

Const saveSceenshotTo As String = "C:\Users\username\Desktop\macro testing\" ' 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
Sub ExportPicturesToFiles()
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

[Aussiebear]

I've never seen IPicture before. And I was also wondering if Next Pic rather than just Next could assist.

[snb]

This does the trick:

Sub M_snb()
    With Sheets(1).ChartObjects.Add(10, 40, 60, 60).Chart
       For Each sh In Sheets(1).Shapes
            sh.CopyPicture
            .Paste
            .Export ThisWorkbook.Path & "\" & sh.Name & ".gif", "GIF"
        Next
        .Parent.Delete
    End With
End Sub

[l0aded]

This does the trick:

Sub M_snb()
    With Sheets(1).ChartObjects.Add(10, 40, 60, 60).Chart
       For Each sh In Sheets(1).Shapes
            sh.CopyPicture
            .Paste
            .Export ThisWorkbook.Path & "\" & sh.Name & ".gif", "GIF"
        Next
        .Parent.Delete
    End With
End Sub

I'll give it a shot at work tomorrow.

[l0aded]

I've never seen IPicture before. And I was also wondering if Next Pic rather than just Next could assist.

Hmm I'll give it a shot.

[Aussiebear]

The next "thing" is probably being perdandic, but the IPicture is something new

[l0aded]

So I realized what is going on in the code. It is not based on where the picture is located on the spreadsheet but rather when it was inputted. So it is saving them in the order they are being pasted in. Is there a way to mofiy the code so that is based on location of picture (highest to lowest) or is there a code that can re-paste the pictures in order of where they are in the spread sheet?

Thanks.

[l0aded]

Found a simpler code that seems to work better. Saves pictures with name of A column cell in line with top of the pictures:

Sub ExportPictures()


For Each oShape In ActiveSheet.Shapes
    strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value
    oShape.Select
    'Picture format initialization
    Selection.ShapeRange.PictureFormat.Contrast = 0.5: Selection.ShapeRange.PictureFormat.Brightness = 0.5: Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic: Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse: Selection.ShapeRange.Fill.Visible = msoFalse: Selection.ShapeRange.Line.Visible = msoFalse: Selection.ShapeRange.Rotation = 0#: Selection.ShapeRange.PictureFormat.CropLeft = 0#: Selection.ShapeRange.PictureFormat.CropRight = 0#: Selection.ShapeRange.PictureFormat.CropTop = 0#: Selection.ShapeRange.PictureFormat.CropBottom = 0#: Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft: Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
    '/Picture format initialization
    Application.Selection.CopyPicture
    Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
    Set oChartArea = oDia.Chart
    oDia.Activate
    With oChartArea
        .ChartArea.Select
        .Paste
        .Export ("C:\Users\Oliver Han\Desktop\macro testing\" & strImageName & ".jpg")
    End With
    oDia.Delete 'oChartArea.Delete
Next


End Sub

[snb]

I thought I gave you a simpler code in #4 ?

Avoid 'Select' and 'Activate' in VBA !

[l0aded]

I thought I gave you a simpler code in #4 ?

Avoid 'Select' and 'Activate' in VBA !

Sorry I gave it a shot but couldn't apply it for some reason. Thanks though.