Copy Picture From Excel to Folder

[billboy]

I am using the following function and Sub to copy pictures from an excel sheet to a folder on my computer. I found the function while googling, so I cant claim to totally understand it.

The problem is that my count Activesheets.Pictures is 24 but only 17 are copied. I am thinking it is because the function copys bitmaps and not toher types of files, although I am not totally sure, just a guess

Option Explicit
 
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 Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    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 Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
     
    Function PictureFromObject(Target As Object) As IPictureDisp
        Dim hPtr As Long, PicType As Long, hCopy As Long
         
        Const CF_BITMAP = 2
        Const CF_PALETTE = 9
        Const CF_ENHMETAFILE = 14
        Const IMAGE_BITMAP = 0
        Const LR_COPYRETURNORG = &H4
        Const PICTYPE_BITMAP = 1
        Const PICTYPE_ENHMETAFILE = 4
        Target.CopyPicture
        PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE)
        If IsClipboardFormatAvailable(PicType) <> 0 Then
            If OpenClipboard(0) > 0 Then
                hPtr = GetClipboardData(PicType)
                If PicType = CF_BITMAP Then
                    hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
                Else
                    hCopy = CopyEnhMetaFile(hPtr, vbNullString)
                End If
                CloseClipboard
                If hPtr <> 0 Then
                    Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
                     
                    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 = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
                        .hPic = hCopy
                    End With
                     
                    OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
                    Set PictureFromObject = IPic
                End If
            End If
        End If
    End Function

Private Sub CommandButton2_Click()

Dim pic As Picture
Dim i As Integer
Dim str As String
Dim path As String
path = "C:\Documents and Settings\Bill\My Documents\RealtyCompLogos\"

For Each pic In ActiveSheet.Pictures

str = pic.Name

MsgBox str & " of" & " " & ActiveSheet.Pictures.Count


On Error Resume Next
 SavePicture PictureFromObject(ActiveSheet.Pictures(str)), path & pic.Name '& ".bmp"
On Error GoTo 0

Next pic

End Sub

Does anyone have any idea or understanding of the function or the reason why I am only getting 17 pictures when there are 24 ?

Thanks for any help

[seenu_1st]

this is another way to save picture from sheet, this method export the pics to chart then save the chart, just try this

Dim MyChart As String, MyPicture As String
Dim PicWidth As Single, PicHeight As Single
Dim shp As Shape

Application.ScreenUpdating = False
For Each shp In Sheet1.Shapes
    MyPicture = shp.Name
    shp.Select

    PicHeight = shp.Height
    PicWidth = shp.Width

    Charts.Add
    ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet3"
    Selection.Border.LineStyle = 0
    MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)

    With ActiveSheet
        With .Shapes(MyChart)
            .Width = PicWidth
            .Height = PicHeight
        End With
        Sheet1.Shapes(MyPicture).Copy

        With ActiveChart
            .ChartArea.Select
            .Paste
        End With

        .ChartObjects(1).Chart.Export Filename:="d:\seenu\" & MyPicture & ".jpg", FilterName:="jpg"
        .Shapes(MyChart).Cut
    End With
Next
Sheet1.Activate
Application.ScreenUpdating = True

[westconn1]

Does anyone have any idea or understanding of the function or the reason why I am only getting 17 pictures when there are 24 ?

first remove on error resume next, then if an error occurs the code will break, as it is any error on saving will be ignored, if errors occur you would then need to find the cause

post again with any error descriptions

[billboy]

The break occurs on this line when there is no link to a picture

Set myPict = .Parent.Pictures.Insert(filename)

filename = ""

Correction>>>> This error is from soemthing else it belongs to a different post sorry......

There is NO error I am only getting 17 pictures when there are 22 on the sheet

[westconn1]

There is NO error I am only getting 17 pictures when there are 22 on the sheet

then i guess as you delete the pictures, it messes up with the indexes of the collection of shapes and some are missed
put a counter in your loop to count how many picture objects are found

try removing the pictures from the end of the collection first

for cnt = sheet1.shapes.count to 1 step - 1
   'code to delete sheet1.shapes(cnt)
next

[billboy]

I am not using indexes I am deleting by name

For Each pic In ActiveSheet.Pictures
str = pic.Name
MsgBox str & " of" & " " & ActiveSheet.Pictures.Count
On Error Resume Next
 SavePicture PictureFromObject(ActiveSheet.Pictures(str)), path & pic.Name & ".bmp"
On Error GoTo 0

Next pic

[seenu_1st]

@billboy, hav u tried the post#2?

[billboy]

@billboy, hav u tried the post#2?

No i am still trying to figure out my original code doesnt work
Hoping someone will come along that understands the function.
I beleive its in the function

[seenu_1st]

try this

Private Sub CommandButton1_Click()
Dim shp As Shape, str As String, path As String, Sht As Worksheet

path = "d:\seenu\"
Set Sht = ThisWorkbook.Worksheets("Sheet1")

For Each shp In Sht.Shapes
    str = shp.Name
    If Not str Like "Command*" Then 'to avoid command buttons
        SaveShape path, str, Sht
    End If
Next
End Sub

Sub SaveShape(path As String, PicName As String, Sht As Worksheet)
SavePicture PictureFromObject(Sht.Shapes(PicName)), path & "\" & PicName & ".bmp"
End Sub

[westconn1]

post a sample workbook with included pictures and code (.xls format), zip first, and i will check it out

[billboy]

post a sample workbook with included pictures and code (.xls format), zip first, and i will check it out

Thanks I appreciate your generous offer to help with this, but I would rather not share the whole workbook and I wouldnt even know weere to begin to create a "sample"

Is there a way to determine what type of pictures are in the excel workbook,? Perhaps that would help me narrow down the problem

Thanks again

[seenu_1st]

@billboy
Hav u tried the Post#9?

[billboy]

Seenu,

No not yet I have gotten a little side tracked with another problem on different project
I wil ltry that ASAP though


Thanks

[westconn1]

Is there a way to determine what type of pictures are in the excel workbook,?

yes!