Insert newest Picture in folder into Spreadsheet

**123rich456** · 06-18-2012, 01:05 PM

Hi,
I wonder if anyone can help?

I am trying to figure out how to insert the newest JPG file from a given folder into a certain location in a spreadsheet.

The pictures are images captured from a camera which are inserted as JPG files into the same folder each time.
I need to be able to insert the most recent file into the spreadsheet.

Any help would be appreciated

**tigeravatar** · 06-18-2012, 02:21 PM

123rich456,

Welcome to the forum!
Give the below code a try. When you run it, you'll be asked to select the folder containing the JPG files. After that, you'll be asked to select the cell that the picture will be placed in. This is the cell that will have the top-left corner of the image.

Sub Insert_Newest_JPG()
    
    Dim rngDest As Range
    Dim FSO As Object
    Dim oFile As Object
    Dim oPic As Object
    Dim dTimeNow As Double
    Dim dTimeSince As Double
    Dim strFolderPath As String
    Dim strFilePath As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = False Then Exit Sub  'Pressed cancel
        strFolderPath = .SelectedItems(1)
    End With
    
    
    dTimeNow = Now
    dTimeSince = 1000000
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    For Each oFile In FSO.GetFolder(strFolderPath).Files
        If Right(oFile.Name, 4) = ".jpg" Then
            If dTimeNow - oFile.DateLastModified < dTimeSince Then
                dTimeSince = dTimeNow - oFile.DateLastModified
                strFilePath = oFile.Path
            End If
        End If
    Next oFile
    
    If Len(strFilePath) > 0 Then
        Set oPic = LoadPicture(strFilePath)
        On Error Resume Next
        Set rngDest = Application.InputBox("Select the estination cell for the image", "Desination Cell", Type:=8)
        On Error GoTo 0
        If rngDest Is Nothing Then Exit Sub 'Pressed cancel
        Set rngDest = rngDest.Cells(1)
        ActiveSheet.Shapes.AddPicture strFilePath, msoFalse, msoTrue, rngDest.Left, rngDest.Top, Round(oPic.Width / 26.458, 0), Round(oPic.Height / 26.458, 0)
    Else
        MsgBox "No .jpg files found in " & strFolderPath, , "Insert Image Error"
    End If
    
End Sub

How to use a macro:

Make a copy of the workbook the macro will be run on
- Always run new code on a workbook copy, just in case the code doesn't run smoothly
- This is especially true of any code that deletes anything
In the copied workbook, press ALT+F11 to open the Visual Basic Editor
Insert | Module
Copy the provided code and paste into the module
Close the Visual Basic Editor
In Excel, press ALT+F8 to bring up the list of available macros to run
Double-click the desired macro (I named this one Insert_Newest_JPG)

**MickG** · 06-18-2012, 02:39 PM

Alter path to Suit
Code places the latest JPG on sheet.

Sub nPic()
   Dim fNam As String
   Dim Pth As String
    Dim fso As Object, f As Object, ff As Object, f1 As Object
    Dim oMax As Date
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("C:\documents and settings\test\Desktop\My Folder\Claydon Map")
    Set ff = f.Files
    Pth = f.Path & "\"
    
    For Each f1 In ff
        If f1.Type = "JPEG Image" Then
            oMax = Application.Max(oMax, FileDateTime(f1))
        If oMax > FileDateTime(f1) Then
            fNam = f1.Name
        End If
End If
Next

Pth = Pth & fNam
Dim MyObj As Picture
If fNam = "False" Then Exit Sub

Set MyObj = ActiveSheet.Pictures.Insert(Pth)

    With MyObj
        With .ShapeRange
'Alter to suit
'        .LockAspectRatio = msoFalse
'        .IncrementRotation 90#
'        .IncrementRotation 180#
'        .Height = 350
'        .Width = 500
        .Top = Range("A1").Top
        .Left = Range("A1").Left
        End With
    .Placement = xlMoveAndSize
    End With

Set MyObj = Nothing
End Sub