asked on

Save all attachments from outlook

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

Karrtik Iyer

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?

Nirvana

ASKER

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

ASKER CERTIFIED SOLUTION

Excel amusant

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Nirvana

ASKER

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.

Excel amusant

Did you change the folder name in line 20

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

Nirvana

ASKER

yes i did change the the subject still gets the same error. selected reference from tools as well

Excel amusant

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.

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.

Nirvana

ASKER

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!!!

Nirvana

ASKER

Brilliant one thanks a lot!!!!

Excel amusant

Glad it was helpful.

Nirvana

ASKER

is there a way that i can use it for even if its case sensitive. I mean both for "orders" and "ORDERS"

Excel amusant

Put below before the sub saveoutlookattachments

Option Compare Text