Results 1 to 9 of 9

Thread: Saving multipal picture from Excelfile

  1. #1
    Seeker freek.h's Avatar
    Join Date
    Aug 2018
    Posts
    5
    Articles
    0
    Excel Version
    office 365

    Saving multipal picture from Excelfile



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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

  2. #2
    Conjurer Kenneth Hobson's Avatar
    Join Date
    Mar 2014
    Location
    Tecumseh, OK
    Posts
    129
    Articles
    0
    Excel Version
    365
    Welcome to the forum!

    By picture line, do you mean row number that it is anchored to?

  3. #3
    Seeker freek.h's Avatar
    Join Date
    Aug 2018
    Posts
    5
    Articles
    0
    Excel Version
    office 365
    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.

  4. #4
    Acolyte Heyjoe's Avatar
    Join Date
    Jan 2019
    Location
    USA
    Posts
    52
    Articles
    0
    Excel Version
    2019
    freek.h

    Let me know if this video can help you.

    Picture Lookup in Excel (Step-by-Step Tutorial)

    https://trumpexcel.com/picture-lookup/

    Heyjoe

  5. #5
    Seeker freek.h's Avatar
    Join Date
    Aug 2018
    Posts
    5
    Articles
    0
    Excel Version
    office 365
    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

  6. #6
    Seeker freek.h's Avatar
    Join Date
    Aug 2018
    Posts
    5
    Articles
    0
    Excel Version
    office 365
    Is there someone who can help me with my problem?

  7. #7
    Conjurer Kenneth Hobson's Avatar
    Join Date
    Mar 2014
    Location
    Tecumseh, OK
    Posts
    129
    Articles
    0
    Excel Version
    365
    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

  8. #8
    Seeker freek.h's Avatar
    Join Date
    Aug 2018
    Posts
    5
    Articles
    0
    Excel Version
    office 365
    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.

  9. #9
    Conjurer Kenneth Hobson's Avatar
    Join Date
    Mar 2014
    Location
    Tecumseh, OK
    Posts
    129
    Articles
    0
    Excel Version
    365
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •