Save all attachments from outlook

Nirvana
Nirvana used Ask the Experts™
on
Hi I am looking for a code which will do the below tasks

1. save all the attachments with has the subject as "string" from a subfolder of outlook,
2. create folder on desktop with current date
3. create a list in excel for all the attachments.

I have found below code which good however my subject is Constant and it there have to be new folder everyday by date

Sub sumit()

    readMails

End Sub


Function readMails()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    
    Dim olItem As Outlook.MailItem
    Dim i As Integer
    Dim b As Integer
    Dim olInbox  As Outlook.MAPIFolder
    Dim olFolder As Outlook.MAPIFolder
    Dim lngCol As Long
    Dim oMsg As Outlook.MailItem
    Dim mainWB As Workbook
    Dim keyword
    Dim Path
    Dim Count
    Dim Atmt
    Dim f_random
    Dim Filename
    'Dim olInbox As inbo
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
     
     Set mainWB = ActiveWorkbook
     
    Set olInbox = olNamespace.GetDefaultFolder(Outlook.olFolderInbox)
    Dim oItems As Outlook.Items
   Set oItems = olInbox.Items
    mainWB.Sheets("Main").Range("A:A").Clear
    mainWB.Sheets("Main").Range("B:B").Clear
    mainWB.Sheets("Main").Range("A1,B1").Interior.ColorIndex = 46
    Path = mainWB.Sheets("Main").Range("J5").Value
    keyword = mainWB.Sheets("Main").Range("J3").Value
    mainWB.Sheets("Main").Range("A1").Value = "Number"
    mainWB.Sheets("Main").Range("B1").Value = "Subject"
    mainWB.Sheets("Main").Range("A1,B1").Borders.Value = 1
    
    
    
    'MsgBox olInbox.Items.Count
   Count = 2
    For i = 1 To oItems.Count
        If TypeName(oItems.Item(i)) = "MailItem" Then
            Set oMsg = oItems.Item(i)
             
             If InStr(1, oMsg.Subject, keyword, vbTextCompare) > 0 Then
             'MsgBox "asfsdfsdf"
                    'MsgBox oMsg.Subject
                    mainWB.Sheets("Main").Range("A" & Count).Value = Count - 1
                    mainWB.Sheets("Main").Range("B" & Count).Value = oMsg.Subject
                    For Each Atmt In oMsg.Attachments
                    f_random = Replace(Replace(Replace(Now, " ", ""), "/", ""), ":", "") & "_"
                    Filename = Path & f_random & Atmt.Filename
                    'MsgBox Filename
                    Atmt.SaveAsFile Filename
                    FnWait (1)

                   ' i = i + 1
                    Next Atmt
                    Count = Count + 1
             End If
        End If
        
        
    Next
    
    'For Each olItem In olInbox.Items
        'Cells(i, 1) = olItem.SenderName ' Sender
        'Cells(i, 2) = olItem.Subject ' Subject
        'Cells(i, 3) = olItem.ReceivedTime ' Received
       ' Cells(i, 4) = olItem.ReceivedByName ' Recepient
        'Cells(i, 5) = olItem.UnRead ' Unread?
        'If StrComp(olItem.Subject, "Special Subject", vbTextCompare) = 0 Then
         'MsgBox IsNull(olItem.Subject)
        'MsgBox "xxxx " & olItem.Subject
        '
        
        
        
        'i = i + 1
        'If (i = 25) Then
            'Exit For
       ' End If
    'Next olItem




End Function
Function FnWait(intTime)

    Dim newHour
    Dim NewMinute
    Dim newSecond
    Dim waitTime
    

    newHour = Hour(Now())

    NewMinute = Minute(Now())

    newSecond = Second(Now()) + intTime

     waitTime = TimeSerial(newHour, NewMinute, newSecond)

 Application.Wait waitTime

End Function

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Karrtik IyerSoftware Architect

Commented:
hi Uday, why do not you go ahead and modify the code that you found to meet your requirements, and while doing that if you face any issues, tell us about the specific problems that you are facing instead of asking us to modify the code to meet your requirements?
Nirvanalearner

Author

Commented:
Hey Karrtik,

I did try to work on my own.. but it is only creating the folder but not saving the attachments. here is the code

Sub GetAttachments()
 Dim ns As Namespace
 Dim SubFolder As MAPIFolder
 Dim Inbox As MAPIFolder
 Dim Item As Object
 Dim Atmt As Attachment
 Dim FileName As String
 Dim i As Integer
 Dim MYSTRING As String
 MYSTRING = Format(Now(), "yyyymmdd")

 
 On Error GoTo GetAttachments_err
 MkDir "C:\Users\444654\Desktop\" & MYSTRING
 Set ns = GetNamespace("MAPI")
 Set Inbox = ns.GetDefaultFolder(olFolderInbox)
 i = 0
 Set SubFolder = Inbox.Folders("WORKORDER")
If SubFolder.Items.Count = 0 Then
   MsgBox "There are no messages in the Sales Reports folder." _
   , vbInformation, "Nothing Found"
   Exit Sub
End If
Range("A1").Activate
If SubFolder.Items.Count > 0 Then
   For Each Item In SubFolder.Items
   If Item.UnRead Then
      For Each Atmt In Item.Attachments
      If (SubFolder.Items.Count) > i And (Right(Atmt.FileName, 4) = "xlsm") Then
         FileName = "C:\Users\444654\Desktop\" & MYSTRING & "\" & i & Atmt.FileName
         Atmt.SaveAsFile FileName
         ActiveCell.Formula = FileName
         ActiveCell.Offset(1, 0).Select
         i = i + 1
         Item.UnRead = False
         End If
      Next Atmt
       End If
   Next Item
End If
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing

ExitProcedure:
    Exit Sub
   
GetAttachments_err:
   MsgBox "An unexpected error has occurred." _
      & vbCrLf & "Please note and report the following information." _
      & vbCrLf & "Macro Name: GetAttachments" _
      & vbCrLf & "Error Number: " & Err.Number _
      & vbCrLf & "Error Description: " & Err.Description _
      , vbCritical, "Error!"
      Resume ExitProcedure
End Sub

Open in new window

Here is the code. This will do what you need.

Note:

1. Change the folder name  to your folder name.
2. Change the subject "test" to the subject that you want the attachment.




 
 
Sub saveoutlookattachments()

Dim mainWB As Workbook
Dim Atmt As attachment
Dim FileName As String

Set mainWB = ActiveWorkbook
     
   
 
    mainWB.Sheets("Main").Range("A:A").Clear
    mainWB.Sheets("Main").Range("B:B").Clear
    mainWB.Sheets("Main").Range("A1,B1").Interior.ColorIndex = 46
    Path = mainWB.Sheets("Main").Range("J5").Value
    keyword = mainWB.Sheets("Main").Range("J3").Value
    mainWB.Sheets("Main").Range("A1").Value = "Number"
    mainWB.Sheets("Main").Range("B1").Value = "Subject"
    mainWB.Sheets("Main").Range("A1,B1").Borders.Value = 1

    Saveoutlookattachmenttofolder "yourfoldername", "", "" ' change the name to your desired folder.
    
  

    
    
End Sub

Sub Saveoutlookattachmenttofolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim i As Integer
    Dim wsh As Object
    Dim fs As Object
    Dim c As Range
    Dim FileName2 As String

    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    i = 0
  
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

   
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
        If Item.Subject = ("test") Then ' change the subject to desired subject
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Item.Subject & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                
           
                i = i + 1
            End If
            End If
          
            
        Next Atmt
    Next Item
  For Each c In Range("B2")
For Each Item In SubFolder.Items
   For Each Atmt In Item.Attachments
 If Item.Subject = ("test") Then ' change the subject to desired subject
 If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
  FileName2 = Item.SenderName & " " & Item.Subject & " " & Atmt.FileName
   Cells(i, 2).Value = FileName2
   
i = i + 1
 End If
End If

   Next Atmt
    Next Item
   Next c
  
  
              

  
    If i > 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If
    
        

   
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub

ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub

Open in new window

Save_outlook_attachments.xlsb
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Nirvanalearner

Author

Commented:
Thank you very much for the code. I am getting the below error

 An unexpected error has occurred.
• Please note and report the following information.
Macro Name: SaveEmailAttachmentsToFolder
Error Number: -2147221233
Error Description: The attempte
be found.error
Did you change the folder name in line 20

and subject ("Test") in line 77 and 93.
Nirvanalearner

Author

Commented:
yes i did change the the subject still gets the same error. selected reference from tools as well
What about Folder? you need to change the folder name to yours below the screenshot of the line that folder name needs to be changed.

cc.PNG
Is the folder you want to select is a sub-folder to your main Inbox?

I have tested the code and I have no issue.
Nirvanalearner

Author

Commented:
Sorry it is working. it is because of the case sensitive in subject at times i get it as "TEST" and "test". thanks a lot the code is working though.

thanks a ton!!!
Nirvanalearner

Author

Commented:
Brilliant one thanks a lot!!!!
Glad it was helpful.
Nirvanalearner

Author

Commented:
is there a way that i can use it for even if its case sensitive. I mean both for "orders" and "ORDERS"
Put below before the sub saveoutlookattachments

Option Compare Text

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial