Pasting the most recent JPG into a spreadsheet

[dlo1503]

Hello

I am trying to write a code to input the most recent JPG in a folder into a cell in a spreadsheet. The cell destination will never change. The code currently asks for a folder to select from but this is unnecessary as the folder is always the same (C:\Users\Cad User5\Pictures\Camera Roll)

I would also like the photo to be sized to Cell I2 which is a merged cell from I2 : T26. Currently it runs over the size of the cell.

Many thanks
Daniel

ub 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
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 = ActiveSheet.Range("i2")
On Error GoTo 0
If rngDest Is Nothing Then Exit Sub
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

 

[Yongle]

Remember to use code tags when pasting code

Try this

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 strFilePath As String
    Dim merged As Range
    Set merged = ActiveSheet.Range("I2").MergeArea
    Const strFolderPath As String = "C:\Users\Cad User5\Pictures\Camera Roll"
        
    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 = ActiveSheet.Range("i2")
        On Error GoTo 0
        If rngDest Is Nothing Then Exit Sub
    
        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)
        With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
            .Width = merged.Width
            .Height = WorksheetFunction.Min(.Height, merged.Height)
        End With
    Else
        MsgBox "No .jpg files found in " & strFolderPath, , "Insert Image Error"
    End If
    
End Sub

 

[dlo1503]

Perfect Yongle, works like a dream. Appreciate the help