PDA

View Full Version : Export All Pictures in Spreadsheet as Filename in Cell Range



l0aded
11-18-2014, 05:54 PM
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
11-19-2014, 01:18 AM
I've never seen IPicture before. And I was also wondering if Next Pic rather than just Next could assist.

snb
11-19-2014, 01:48 AM
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
11-19-2014, 02:18 AM
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
11-19-2014, 02:19 AM
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
11-19-2014, 04:04 AM
The next "thing" is probably being perdandic, but the IPicture is something new

l0aded
11-20-2014, 01:26 PM
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
11-20-2014, 02:17 PM
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
11-20-2014, 03:52 PM
I thought I gave you a simpler code in #4 ? :confused2

Avoid 'Select' and 'Activate' in VBA !

l0aded
11-20-2014, 05:24 PM
I thought I gave you a simpler code in #4 ? :confused2

Avoid 'Select' and 'Activate' in VBA !

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