Solved auto save all the attachments from outlook vba cod

January 4, 2016 at 03:49:58
Specs: Windows 7
looking for code which can save all the attachments as and when received from outlook which has a specific subject as "test". Create a folder by current day and suffex current date and time for each attachment which has been saved. Found few links on however i need this to be automatically saved


See More: auto save all the attachments from outlook vba cod

Report •

January 7, 2016 at 02:02:33
✔ Best Answer
Please try this code, what it does is:

1) Looks for new email in outlook
2) Checks subject line for 'Test' (you can change this to whatever you need)
3) Created a folder with todays day name eg 'Thursday'
4) Saves each attachment with the name and time surfixed

You will need to do the following:

1) Open Outlook
2) Press and hold ALT and tap F11 to open the VBE
3) Double click on 'ThisOutlookSession' in project explorer
4) Paste the code

Note you will need to modify the path letter 'P:\' to wherever you want to save the attachments, there are 3 places to change this within the 'items_itemsAdd function.

Note once you paste the code, please save and close Outlook, then reopen it, the code needs to initialise some variables in order to work, this is done when Outlook is launched.

Private WithEvents Items As Outlook.Items

Dim iExt As String

Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
    Dim TimeDateString As String

    On Error GoTo ErrorHandler
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then
        Set Msg = item
    ' ******************
     If Msg.Subject = "Test" Then
        TimeDateString = Format(Now(), "ddmmyyyy hhmmss")
        If Dir("P:\" & TodaysDay, vbDirectory) = vbNullString Then
            MkDir ("P:\" & TodaysDay)
        End If
        Dim myatt As Attachment

        For Each myatt In Msg.Attachments
            Dim FolderPath As String
            FolderPath = "P:\" & TodaysDay
            myatt.SaveAsFile FolderPath & "\" & TrimedFileName(myatt.FileName) & " " & TimeDateString & iExt
        Next myatt

 End If
    ' ******************
  End If
  Exit Sub
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Function TodaysDay() As String
    Dim TheDay As Integer
    TheDay = Weekday(Format(Now(), "dd/mm/yyyy"))
    Select Case TheDay
        Case 1:
            TodaysDay = "Sunday"
        Case 2:
            TodaysDay = "Monday"
        Case 3:
            TodaysDay = "Tuesday"
        Case 4:
            TodaysDay = "Wednesday"
        Case 5:
            TodaysDay = "Thursday"
        Case 6:
            TodaysDay = "Friday"
        Case 7:
            TodaysDay = "Saturday"
    End Select
End Function
Public Function TrimedFileName(nName As String) As String
    Dim nLen As Integer
    Dim endLen As Integer
    Dim ExtLen As Integer
    nLen = Len(nName)
    For i = nLen To 1 Step -1
        ExtLen = ExtLen + 1
        If Mid(nName, i, 1) = "." Then
            endLen = i - 1
            iExt = Mid(nName, i, ExtLen)
            Exit For
        End If
    Next i
    TrimedFileName = Mid(nName, 1, endLen)
    endLen = 0
    nLen = 0
End Function

Report •

January 7, 2016 at 03:48:20
what happens for next week I mean if its next Thursday will it replace the current file?

Report •

January 7, 2016 at 04:06:25
thats a good question it probably will overwrite the original - but considering that the filename also had the time within it, hh:mm:ss it will be difficult for the filenames to be exactly the same, especially considering the seconds of the time, it is not impossible, but unlikely..

Report •

Related Solutions

Ask Question