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

Open in new window

Afzal KhanSoftware ProfessionalAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Do you mean that you only want to save the attachment from the latest email with the subject "My Daily Report" only i.e. you need to save only one attachment from that folder and exit the loop?
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Also will the name of the attachment always be the same?
0
Afzal KhanSoftware ProfessionalAuthor Commented:
Yes
0
Newly released Acronis True Image 2019

In announcing the release of the 15th Anniversary Edition of Acronis True Image 2019, the company revealed that its artificial intelligence-based anti-ransomware technology – stopped more than 200,000 ransomware attacks on 150,000 customers last year.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay, give this a try...
I have added a comment like "'<---------------NEW LINE" for every new line I have added in the code, tweak them if required.
Assuming all other lines you added works for you.

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 Items As Object
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
Dim fso As Object

    Application.ScreenUpdating = False  '<---------------NEW LINE
    Application.DisplayAlerts = False   '<---------------NEW LINE
       
   ' 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)
    
    Set Items = srcOLFolder.Items       '<---------------NEW LINE
    Items.Sort "[ReceivedTime]", True   '<---------------NEW LINE
    
        ' Looping through each item in the Source Outlook Folder
    For Each objMsg In srcOLFolder.Items
    
        'Check if the Subject of the email is "My Daily Report"
        If LCase(objMsg.Subject) = "My Daily Report" Then   '<---------------NEW LINE
            
            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
            Exit For    '<---------------NEW LINE
        End If          '<---------------NEW LINE
    Next objMsg
ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set srcOLFolder = Nothing
Set objOL = Nothing
Application.ScreenUpdating = True       '<---------------NEW LINE
    Application.DisplayAlerts = True    '<---------------NEW LINE
End Sub

Open in new window

0
Afzal KhanSoftware ProfessionalAuthor Commented:
Run time error "438"

Object doesn't upport property or method

At below line:

Application.ScreenUpdating = False  '<---------------NEW LINE

Also one correction :

My Subject name " My Daily Report" and Attachment name- "My Report"
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay, try this...

Since you know the Subject and the Attachment name, I have commented out few unnecessary lines of codes.

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 Items As Object
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
Dim fso As Object
      
   ' 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)
    
    Set Items = srcOLFolder.Items       '<---------------NEW LINE
    Items.Sort "[ReceivedTime]", True   '<---------------NEW LINE
    
    ' Looping through each item in the Source Outlook Folder
    For Each objMsg In srcOLFolder.Items
    
        'Check if the Subject of the email is "My Daily Report"
        If LCase(objMsg.Subject) = "My Daily Report" Then   '<---------------NEW LINE
        
            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
                    
                    strFile = objAttachments.Item(i).FileName
                    
                    'Checking if the attachment's name contain "My Report"
                    If InStr(LCase(strFile), "my report") > 0 Then  '<---------------NEW LINE
                    
'                    '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
                        GoTo ExitSub
                    End If
                
nexti:
                Next i
            End If
            
        End If
    Next objMsg
ExitSub:

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

Open in new window

0
Afzal KhanSoftware ProfessionalAuthor Commented:
Thanks .

Program is getting subject name properly but as :
 Set objAttachments = objMsg.Attachments
            lngCount = objAttachments.Count

So seems it is matching subject name with attachment.
As my Subject name " My Daily Report" and Attachment name- "My Report" so it is not going in loop.

Also it is taking Signature images as attachment count , I need only the attached  "My Report.xlsx" file.

Help needed.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Change line#75
If LCase(objMsg.Subject) = "My Daily Report" Then

Open in new window

TO THIS
If LCase(objMsg.Subject) = "my daily report" Then

Open in new window


Then insert few breakpoints on few lines such as below and then execute the macro by pressing the F8 key.

Line#77 --> The code will only reach to this point if the Subject of the email is My Daily Report
Line#92 --> When code passes this line, hover your mouse over strFile variable and see what filename is popped up
Line#95 --> Code will only pass this condition if the file name contains a string "My Report"
0
Afzal KhanSoftware ProfessionalAuthor Commented:
Now it is working but its not overwriting the attachment every time , it is saving the first attachment that came on that folder
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Add these three lines between line#114 and line#116
strFile = strFolderpath & strFile '<-- line#114
On Error Resume Next
Kill strFolderpath & strFile
On Error GoTo 0
' Save the attachment as a file. <--- line#116

Open in new window

0
Afzal KhanSoftware ProfessionalAuthor Commented:
Subodh sir it is still not updating the recent attachments, it taking the first attachment in folder.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Change the line#69 to this
Items.Sort "[SentOn]", True

Open in new window

and see if that works.
0
Afzal KhanSoftware ProfessionalAuthor Commented:
No it is not working
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
What is not working? Producing an error?

BTW the Test folder contains sent items. Right?
0
Afzal KhanSoftware ProfessionalAuthor Commented:
Actually "Test" folder receiving daily 2-3 emails with Subject name " My Daily Report" and Attachment name- "My Report"

The attachment is .xls file .

So what the requirement is to save only one copy of "My Report" xls in folder , overwrite with only latest email xls .

Not working means  I  have deleted all previous copy on destination folder and changed the content of xls and moved to "Test" folder and ran the program , it is still saving the first xls that was in source "Test " folder not the recent chnaged one.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
If you are receiving those emails in your Test folder, you don't need to change the line#69 a suggested above.

Actually the code will sort the emails of the Test folder on the received time and it will save the attachment from the first email from the sorted emails which should be the latest one. Is it not happening?
0
Afzal KhanSoftware ProfessionalAuthor Commented:
Yes that is the issue , its not happening, it not taking the latest one.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Please give this a try. I have tested it and it is working as desired.
Sub SaveLatestAttachment()
Dim olApp As Outlook.Application
Dim oMail As Outlook.MailItem
Dim NS As Outlook.NameSpace
Dim oFolder As Outlook.Folder
Dim SaveInFolderName As String
Dim SaveInFolder As String
Dim subFolderName As String
Dim strFile As String
Dim Item As Object
Dim Items As Outlook.Items
Dim x()
Dim i As Long

SaveInFolderName = CreateObject("WScript.Shell").SpecialFolders(16)
subFolderName = "EmailAttachments"
SaveInFolder = SaveInFolderName & "\" & subFolderName & "\"

Set olApp = New Outlook.Application
Set NS = olApp.GetNamespace("MAPI")
Set oFolder = NS.GetDefaultFolder(olFolderInbox).Parent.Folders("Test")
ReDim x(1 To oFolder.Items.Count, 1 To 4)
Set Items = oFolder.Items
Items.Sort "[ReceivedTime]", True
For Each Item In Items
    If TypeOf Item Is Outlook.MailItem Then
        Set oMail = Item
        If LCase(oMail.Subject) = "my daily report" Then
            If oMail.Attachments.Count > 0 Then
                For i = 1 To oMail.Attachments.Count
                    strFile = oMail.Attachments(i).FileName
                    If InStr(LCase(strFile), "my report") > 0 Then
                        MsgBox oMail.ReceivedTime
                        strFile = SaveInFolder & strFile
                        On Error Resume Next
                        Kill strFile
                        On Error GoTo 0
                        oMail.Attachments(i).SaveAsFile strFile
                        GoTo ExitSub
                    End If
                Next i
            End If
        End If
    End If
Next Item
ExitSub:
Set olApp = Nothing
MsgBox "Task Completed Successfully.", vbInformation
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Afzal KhanSoftware ProfessionalAuthor Commented:
Thanks ,absolutely working !!!
0
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
Rather then running a procedure like above I would have registered an event handler for the specific folder, which then processes exactly that single received mail.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.