Saving multipal picture from Excelfile

F

freek.h

New member
Joined
Aug 10, 2018
Messages
5
Reaction score
0
Points
0
Excel Version(s)
office 365
Hi there,

I have a excel file with a lot of pictures placed in cells. Pictures were copied into the cells and then made the right size. Each picture line has a number.
Is there a way to save each picture as a jpg file in a map on my computer with the number as filename? Example: 50456.jpg

Hope someone can help me with this.

Thanx,
Freek

Verstuurd vanaf mijn SM-T713 met Tapatalk
 
Welcome to the forum!

By picture line, do you mean row number that it is anchored to?
 
View attachment images-file.xlsxA very late respond on your request, but hereby i send you a example file.
The picture in column C has to be saved as a single picture in a specified location with the name given in column E

Hopefully there is a simple way to do this. Origanaly the file has more than 1.300 pictures/images.
 
Thanx Heyjoe but this is not de solution i am looking for.
Each picture has to be saved seperatly als a JPG-file.

Hopefully there is someone out there who knows a tric to do so.

Freek
 
Is there someone who can help me with my problem?
 
If you mean save to a folder rather than map, change the value of p in the Main() sub. Copy the two sets of code to two modules.

Run Main() with the sheet with the shapes active.

Code: 
Sub Main()  
  Dim s As Shape, p$, fn$
  
  p = "c:\t\pics\"
  
  For Each s In ActiveSheet.Shapes
    fn = wExtractNumber(s.Name)
    If fn <> 0 Then
      OBJtoJPGfile s, p & fn & ".jpg"
    End If
  Next s
End Sub


'https://access-excel.tips/excel-vba-extract-number-alphabet/
Function wExtractNumber(sinput) As Double
  Dim i As Integer, result As Double
  For i = 1 To Len(sinput)
    If IsNumeric(Mid(sinput, i, 1)) Then
      result = result & Mid(sinput, i, 1)
    End If
  Next i
  wExtractNumber = result
End Function

Code: 
'Jaafar Tribak, https://www.mrexcel.com/forum/excel-questions/1086541-vba-screen-shot-given-range-every-worksheet-file.html

Private Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type


Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type


Private Type GdiplusStartupInput
   GdiplusVersion As Long
    #If VBA7 Then
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As LongPtr
    #Else
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
    #End If
   SuppressExternalCodecs As Long
End Type


Private Type EncoderParameter
   GUID As GUID
   NumberOfValues As Long
   Type As Long
   #If VBA7 Then
    Value As LongPtr
   #Else
    Value As Long
   #End If
End Type


Private Type EncoderParameters
   Count As Long
   Parameter As EncoderParameter
End Type




#If VBA7 Then
    Private Declare PtrSafe Function OleCreatePictureIndirectAut _
      Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" _
      (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro _
      Lib "olepro32.dll" Alias "OleCreatePictureIndirect" _
      (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function CopyImage _
      Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, _
      ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function LoadLibrary _
      Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary _
      Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    
    'GDI+ APIS.
    Private Declare PtrSafe Function GdiplusStartup _
      Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP _
      Lib "GDIPlus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As LongPtr) As LongPtr
    Private Declare PtrSafe Function GdipSaveImageToFile _
      Lib "GDIPlus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
#Else
    Private Declare Function OleCreatePictureIndirectAut _
      Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" _
      (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro _
      Lib "olepro32.dll" Alias "OleCreatePictureIndirect" _
      (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) 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
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long


    'GDI+ APIS.
    Private Declare Function GdiplusStartup _
      Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP _
      Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
    Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
    Private Declare Function GdipSaveImageToFile _
      Lib "GDIPlus" (ByVal Image As Long, ByVal Filename As Long, clsidEncoder As GUID, _
      encoderParams As Any) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
#End If


Private Const IMAGE_BITMAP = 0
Private Const PICTYPE_BITMAP = 1
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2
Private Const S_OK = 0




Public Sub PicTureToJPGFile(ByVal Pict As IPicture, ByVal Filename As String, Optional ByVal Quality As Byte = 100)
    #If VBA7 Then
        Dim lGDIP As LongPtr, lBitmap As LongPtr
    #Else
        Dim lGDIP As Long, lBitmap As Long
    #End If


    Dim tSI As GdiplusStartupInput, lRes As Long
    Dim tJpgEncoder As GUID, tParams As EncoderParameters


   tSI.GdiplusVersion = 1
   lRes = GdiplusStartup(lGDIP, tSI)


   If lRes = 0 Then
      lRes = GdipCreateBitmapFromHBITMAP(Pict.handle, 0, lBitmap)
      If lRes = 0 Then
         CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
         tParams.Count = 1
        With tParams.Parameter
          CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
          .NumberOfValues = 1
          .Type = 4
          .Value = VarPtr(Quality)
        End With
         lRes = GdipSaveImageToFile(lBitmap, StrPtr(Filename), tJpgEncoder, tParams)
         GdipDisposeImage lBitmap
      End If
      GdiplusShutdown lGDIP
   End If
   
   If lRes Then
      Err.Raise 5, , "Cannot save the image. GDI+ Error:" & lRes
   End If
End Sub




Public Function CreatePicture(ByVal obj As Object) As IPicture
    #If VBA7 Then
        Dim hCopy As LongPtr, hPtr As LongPtr, hLib As LongPtr
    #Else
        Dim hCopy As Long, hPtr As Long, hLib As Long
    #End If


    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
    Dim iPic As IPicture, lRet As Long
    
    On Error GoTo errHandler


    obj.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hCopy
        .hPal = 0
    End With
    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
    Else
        lRet = OleCreatePictureIndirectPro(uPicinfo, IID_IDispatch, True, iPic)
    End If
    FreeLibrary hLib
    If lRet = S_OK Then
        Set CreatePicture = iPic
    End If
errHandler:
    EmptyClipboard
    CloseClipboard
   
    If Err Then
      Err.Raise 5, , "Cannot Create Picture."
     End If
End Function


Sub OBJtoJPGfile(obj As Object, ByVal Filename As String, Optional ByVal Quality As Byte = 100)
  DoEvents
  PicTureToJPGFile CreatePicture(obj), Filename, Quality
End Sub
 
Thank you Kenneth. The code(s) don't work completely. It triggers an error in the second code "Err.Raise 5, , "Cannot save the image. GDI+ Error:" & lRes".
As mentioned before the file originally has more then 1.300 image lines. It would be preferred that there is no limit in the code and that the filename used to save the file would be the same as mentioned in column in the file.
 
It "worked" without error in your test file for me.

To add the filename.jpg value from 2nd column to the right of the shape, change Main() to:
Code: 
Sub Main()  
  Dim s As Shape, p$, fn$
  
  p = "c:\t\pics\"
  
  For Each s In ActiveSheet.Shapes
    fn = s.TopLeftCell.Offset(, 2)
    If LCase(Right(fn, 3)) = "jpg" Then
      OBJtoJPGfile s, p & fn
    End If
  Next s
End Sub
 
You must log in or register to reply here.
Back
Top