Outlook – Automatically save attachments from mail on a network drive

microsoft-outlookvba

Every morning I receive an automatically generated e-mail from a server, it includes a spreadsheet attachment.
I made a rule in outlook that captures these emails. Now, I would like to make a macro to rename the attached file (. Xls) to =today() and saves it in a folder on a network drive. This macro must run every weekday at 8:00.
I've made a lot of VBA in Excel, but have no experience in outlook.
Might this be possible? And does anyone know how to do it?

Kind regards
Staal

Best Answer

Why delay the save until 8:00?

In the rule that "captures these emails" save with "run a script".

Sub saveAttachtoDisk(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment
Dim saveFolder As String

saveFolder = "D:\temp"  ' change to your path

For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder & "\" & Format(Now, "yyyy-mm-dd") & ".xls"
Next

End Sub

Edit based on comment:

Not sure you would want to do this inside saveAttachtoDisk but to manipulate the Workbook once it is saved, there is Excel.

Try GetObject, if there is an error then use CreateObject("Excel.Application") http://support.microsoft.com/kb/288902

Then something like this, or whatever way works for you since you know Excel VBA.

Workbooks.Open(name of file)

Worksheets(1).Name = "Sheet 1"

Edit 2 based on comment:

You have to pass a parameter.

Open a mailitem then F8 here.

Sub saveAttachtoDisk_test
Dim currItem as mailitem
set curritem = activeinspector.currentitem
saveAttachtoDisk curritem
set currItem = nothing
end sub

Related Solutions

Outlook – Create new folder for new sender name and move message into new folder

This often asked question is answered here.

http://www.jpsoftwaretech.com/automatically-triage-emails-by-sender-name/

Uses ItemAdd to do what Newmail, now NewMailEx, would do.

In the ThisOutlookSesion module

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace

  ' set object reference to default Inbox
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
' fires when new item added to default Inbox
' (per Application_Startup)

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim targetFolder As Outlook.MAPIFolder
  Dim senderName As String

  ' don't do anything for non-Mailitems
  If TypeName(item) <> "MailItem" Then GoTo ProgramExit

  Set Msg = item

  ' move received email to target folder based on sender name
  senderName = Msg.senderName

  If CheckForFolder(senderName) = False Then  ' Folder doesn't exist
    Set targetFolder = CreateSubFolder(senderName)
  Else
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set targetFolder = _
    objNS.GetDefaultFolder(olFolderInbox).Folders(senderName)
  End If

  Msg.Move targetFolder

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error Goto 0

If Not FolderTocheck Is Nothing Then
  CheckForFolder = True
End If

ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

Set CreateSubFolder = olInbox.Folders.Add(strFolder)

ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Outlook – Automatically save attachments from mail matching a specific rule

To do what you want, you will need to mix a little VBA and Rules together. Not sure what version of Outlook you are using, so no guarantees here. This was tested on Outlook 2010.

This article will help you get things setup -Rule to automatically save attachment in Outlook .

The code below is modified specific to your saving the file with the name format of yyyy-mm-dd.

Public Sub SaveToDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat

dateFormat = Format(Now, "yyyy-mm-dd")

'Change this path to the your folder location
saveFolder = "c:\temp\"

objAtt.SaveAsFile saveFolder & "\" & dateFormat & ".xls"

Set objAtt = Nothing

End Sub

Once you set up this rule to run this script, it will save any attachment from this person each time it receives one (and gives it a .xls extension). If you wish to change that, you will have to modify your rule or turn it off.

Best Answer

Related Solutions

Outlook – Create new folder for new sender name and move message into new folder

Outlook – Automatically save attachments from mail matching a specific rule

Related Question