Need help to modify VB outlook program

Hi Experts,

This Program is saving the attachments from Independent Outlook folder to My Dcoumnets "EmailAttchments" folder.


The issue is , loop is checking at every run the whole folder emails one by one , In that folder I will get daily one email that have same subject suppose " My Daily Report" and I need that the program check latest email only and save (overwrite) the latest attachment on destination folder and avoid checking the whole email folder.

Appreciate your help.

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim NS As Outlook.NameSpace
Dim srcOLFolder As Outlook.Folder
Dim i As Long
Dim lngCount As Long
Dim srcOLFolderName As String
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim subFolderName As String
Dim sFileType As String
Dim dtDate As Date
Dim sName As String
       
       
   ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
    'Assuming  a folder called "Email Attachments" in your Document folder
    Set fso = CreateObject("Scripting.FileSystemObject")
    subFolderName = "EmailAttachments"
 
    '--------------------------------------------------
    'create the folder if it doesnt exists:
    Dim ttxtfile, txtfile, WheretosaveFolder
    Dim objFolders As Object
    Set objFolders = CreateObject("WScript.Shell").SpecialFolders
 
    'MsgBox objFolders("mydocuments")
    ttxtfile = objFolders("mydocuments")
    
    Set fso = CreateObject("Scripting.FileSystemObject")
       If Not fso.FolderExists(ttxtfile & "\EmailAttachments\") Then
    Set txtfile = fso.CreateFolder(ttxtfile & "\EmailAttachments\")

    ' ------------------------------------------------------
        ' Set fso = Nothing
    ' ------------------------------------------------------
    WheretosaveFolder = ttxtfile & "\EmailAttachments"
    End If
    '-----------------End---------------------
    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "\" & subFolderName & "\"
    
    If Len(Dir(strFolderpath, vbDirectory)) = 0 Then
        MsgBox "The folder " & subFolderName & " was not found in the Documetn Folder.", vbExclamation, "Cannot Contiue!"
        Exit Sub
    End If
    
    
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = New Outlook.Application
    
    'Assuming the Source Outlook Folder's name is "External" and it is a Independent Folder of INBOX.
    srcOLFolderName = "Test"   'Change the Sub-Folder's name here if required
    
    Set NS = objOL.GetNamespace("MAPI")
    Set srcOLFolder = NS.GetDefaultFolder(olFolderInbox).Parent.Folders(srcOLFolderName)
    
    
        ' Looping through each item in the Source Outlook Folder
    For Each objMsg In srcOLFolder.Items
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
            
        If lngCount > 0 Then
        
           ' Use a count down loop for removing items
           ' from a collection. Otherwise, the loop counter gets
           ' confused and only every other item is removed.
         ' Get datetimestamp
            dtDate = objMsg.SentOn

         sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dtDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-"
         
           For i = lngCount To 1 Step -1
             'Restrict not to save Signature images
             If objAttachments.Item(i).Size > 100000 Then
               ' Get the file name.
               strFile = objAttachments.Item(i).FileName
                
               ' This code looks at the last 4 characters in a filename
                 sFileType = LCase$(Right$(strFile, 4))
            
                 Select Case sFileType
               ' Add additional file types below
                  Case ".jpg", ".png", ".gif"
                   If objAttachments.Item(i).Size < 5200 Then
                       GoTo nexti
                   End If
                 End Select
              
               ' Combine with the path to the Temp folder.
               strFile = strFolderpath & strFile
                
               ' Save the attachment as a file.
               objAttachments.Item(i).SaveAsFile strFile
                End If
           
nexti:
           Next i
        End If
       
    Next objMsg
ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set srcOLFolder = Nothing
Set objOL = Nothing
End Sub

Select allOpen in new window