Saving email and attachements to hardrive macro/rule

[nickirvine]

Hi,

I'm trying to create a rule in outlook that will automatically move the email and the attachment to a shared hard drive folder if there are certain words in the subject line.

I have used macros before but never in outlook. I assume you can use a rule to run a macro or such like? or is there an easier way around.

I can't use any add-ons as it is a work computer.

I'm sure this must be possible. Any help or guidance will be extremely appreciated.

Thanks for any help.

Nick

[jfournier]

You can use the Application_NewMail event in outlook VBA to run your macro for saving the attachment to a file.
The event doesn't take the latest new mail item as an argument, so you have to get a reference manually. You can do that with this line of code:
[VBA]Dim olObject as Object
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetFirst()[/VBA]

So the event code would go like this:
[VBA]Private Sub Application_NewMail()
Dim olObject As Object
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetFirst()
Call DoSomething(olObject)
End Sub[/VBA]

So you can pass that to a macro and search the title for your key words, and do whatever.
For an example of how that function would work you can look at the "Extract the outlook attachment and sender information" thread in the Outlook Help section.

Hope that helps.

Jon

[nickirvine]

Thanks Jon,

OK I've put a little button on the task bar to run the macro. As I think this is the only way to do it? rather than run it with a rule?

Basically I want to save the email received and the attachment to a folder "emails" on my desktop. Then once saved delete the email from the folder "received" in outlook.

I've tried your code but I'm not sure what I need to adjust. I'm a newbie at macros so any help appreciated.

Thanks for your help.

[jfournier]

You can have the macro run automatically every time an email arrives in your inbox. Just paste the Application_NewMail() macro into the ThisOutlookSession module in the VBE. By naming it Application_NewMail you're telling Outlook VBA to watch the Application object for a NewMail event, and to run that macro whenever a new mail arrives.

This may do what you need:
[VBA]Private Sub Application_NewMail()

On Error GoTo Application_NewMail_Error

'Get a reference to the first item in the inbox
Dim olObject As Object
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetFirst()

'Exit the sub if there is nothing in the inbox. An error will probably be thrown when using the GetFirst method but check anyway
If olObject Is Nothing Then Exit Sub

'Exit the sub if it's not a mail item or appointment item
If Not TypeOf olObject Is Outlook.MailItem Or Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub

'Set the path to your desktop folder here
Const DesktopFolder = "C:\Desktop\"

'Save the email to some destination
olObject.SaveAs DesktopFolder & olObject.Subject & ".rtf", olRTF

'save out attachments
Dim olAttachment As Outlook.Attachment
For Each olAttachment In olObject.Attachments
olAttachment.SaveAsFile DesktopFolder & olAttachment.DisplayName
Next olAttachment

'delete the email
olObject.Delete

Set olAttachment = Nothing
Set olObject = Nothing

On Error GoTo 0
Exit Sub

Application_NewMail_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Application_NewMail of VBA Document ThisOutlookSession"

End Sub[/VBA]

[nickirvine]

that looks like just the thing i need. I cant seem to get it to work though.

I've changed the folder. I've put in thisoutlooksession and saved it but when a new email comes in nothing happens. Is it to do with my version of outlook?

thanks for your help so far.

[jfournier]

What version of Outlook are you using? In the VBE there should be a dropdown box near the top that says "(General)" if you have your cursor outside any subs or functions. If you click that "(General)" dropdown you should see "Application" listed. In the dropdown to the right of that is all the events that can go on the Application object, and there should be one called "NewMail". It may be different on your Outlook version, I don't know...

Do you have macros enabled? Also, to make sure it's not running, put your cursor on the "Private Sub Application_NewMail()" line and hit F9 on your keyboard to create a breakpoint. If the macro runs when a new mail arrives the line should turn yellow, which means it's in debug mode.

[nickirvine]

hi, yeah there is that drop down with application then the second one says NewMail.

It asks me about macros when i load up and i click enable and it does pop up in yellow in debugging mode when i put the break in. Is there something tiny wrong in the code?

or a security related problem?

[jfournier]

I made a mistake when checking the item type. Change the Or in:

If Not TypeOf olObject Is Outlook.MailItem Or Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub

to And, that should get it to run. My computer's having problems saving the file as RTF, so you may need to change the olRTF to olTXT.

[nickirvine]

Thanks for looking at that again jfournier it works now thanks.

Can I ask you a couple more things. It saves the email and the attachment. But as the email starts FW: subject line. It only saves FW as the filename (the big before the : ) I guess this is causing a problem. Is there any where this can be slashed out. Also I need the body of the email saved as well but its not saving any of the body (could be because of the : )

The body of the email does save when the : is removed from the subject. Just need a piece of code to remove the :.

Also can the file names of the email and the attachments include the date and time as all the filenames are the same and its overwriting them.

If you could have another look at it for me I would really appreciate it. thanks alot for your help

CODE I HAVE AT THE MOMENT..

[vba]Private Sub Application_NewMail()

On Error GoTo Application_NewMail_Error

'Get a reference to the first item in the inbox
Dim olObject As Object
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetFirst()

'Exit the sub if there is nothing in the inbox. An error will probably be thrown when using the GetFirst method but check anyway
If olObject Is Nothing Then Exit Sub

'Exit the sub if it's not a mail item or appointment item
If Not TypeOf olObject Is Outlook.MailItem And Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub

If InStr(olObject.Subject, "EMAIL") > 0 Then


'Set the path to your desktop folder here
Const DesktopFolder = "C:\DESKTOP"

'Save the email to some destination
olObject.SaveAs DesktopFolder & olObject.Subject & ".txt", olTXT

'save out attachments
Dim olAttachment As Outlook.Attachment
For Each olAttachment In olObject.Attachments
olAttachment.SaveAsFile DesktopFolder & olAttachment.DisplayName
Next olAttachment

'delete the email
olObject.Delete

Set olAttachment = Nothing
Set olObject = Nothing

On Error GoTo 0


Else
End If

Exit Sub



Application_NewMail_Error:

MsgBox "Error " & Err.number & " (" & Err.Description & ") in procedure Application_NewMail of VBA Document ThisOutlookSession"

End Sub
[/vba]

[nickirvine]

Any help on this really appreciated.

[jfournier]

You can eliminate the : character using the replace function:

replace( olObject.Subject , ":" , "" )

You can concatenate on the received time of the mail item by formatting the time as a string:

Format(olObject.ReceivedTime, "mm_dd_yyyy_hh_nn")

so you could have the line to save attachments like so:

olAttachment.SaveAsFile DesktopFolder & Format(olObject.ReceivedTime, "mm_dd_yyyy_hh_nn") & olAttachment.DisplayName

If you wanted to have the file name and then the date/time you'd have to mess around with splitting the file name up between the file name and extension, and then put the date/time in between.
You could do this like so, I think, though I haven't tested it:

dim fileparts() as string
fileparts = split( olattachment.displayname , "." )
for i = lbound( fileparts ) to ubound( fileparts ) - 1
dim AttachOutName as string
attachoutname = attachoutname & "." & fileparts( i )
next i
attachoutname = attachoutname & Format(olObject.ReceivedTime, "mm_dd_yyyy_hh_nn")

attachoutname = attachoutname & "." & fileparts( ubound( fileparts ) )

olAttachment.SaveAsFile DesktopFolder & attachoutname

[nickirvine]

I am getting errors on the last piece of code.

I appreciate your time and help so far. The code Im using is

[vba]Private Sub Application_NewMail()

On Error GoTo Application_NewMail_Error

'Get a reference to the first item in the inbox
Dim olObject As Object
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetFirst()

'Exit the sub if there is nothing in the inbox. An error will probably be thrown when using the GetFirst method but check anyway
If olObject Is Nothing Then Exit Sub

'Exit the sub if it's not a mail item or appointment item
If Not TypeOf olObject Is Outlook.MailItem And Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub

If InStr(olObject.Subject, "EMAIL") > 0 Then


'Set the path to your desktop folder here
Const DesktopFolder = "C:\desktop\"

olObject.Subject = Replace(olObject.Subject, ":", "")

Dim olAttachment As Outlook.Attachment

Dim fileparts() As String
fileparts = Split(olAttachment.DisplayName, ".")
For i = LBound(fileparts) To UBound(fileparts) - 1
Dim AttachOutName As String
AttachOutName = AttachOutName & "." & fileparts(i)
Next i
AttachOutName = AttachOutName & Format(olObject.ReceivedTime, "mm_dd_yyyy_hh_nn")
AttachOutName = AttachOutName & "." & fileparts(UBound(fileparts))
olAttachment.SaveAsFile DesktopFolder & AttachOutName

'Save the email to some destination
'olObject.SaveAs DesktopFolder & olObject.Subject & ".txt", olTXT

'save out attachments


'delete the email
olObject.Delete

Set olAttachment = Nothing
Set olObject = Nothing

On Error GoTo 0


Else
End If

Exit Sub



Application_NewMail_Error:

MsgBox "Error " & Err.number & " (" & Err.Description & ") in procedure Application_NewMail of VBA Document ThisOutlookSession"

End Sub
[/vba]

[nickirvine]

Thanks loads for your help. I have adjusted it succesfully!