''This code goes in your ThisOutlookSession module
Option Explicit
Private WithEvents olTestItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olTestItems = objNS.Folders("Mailbox - Wright, Denis").Folders("Test").Items 'change to suit your user name and folder
Set objNS = Nothing
End Sub
Private Sub oltestitems_itemadd(ByVal item As Object)
Dim xlApp As Object
Dim xlWB As Object
'On Error Resume Next
'move the attachment to Attachments_Code_Test
Call GetAttachments("Test", "Attachments_Code_Test") 'Attachments_code_test is your destination folder. Path is provided in the main module.
're-run the Startup routine. Without this I found that the ItemAdd routine only ran once.
Call Application_Startup
End Sub
Private Sub SetTrigger()
Call Application_Startup
End Sub
''End of code for ThisOutlookSession
''This code goes into a new, standard Outlook module. save it as basAutomateExcel.
Option Explicit
Public gstrWhere As String
Public Sub GetAttachments(sFolder As String, sOutDir As String)
On Error GoTo GetAttachments_err
Dim NS As NameSpace
Dim F As MAPIFolder
Dim item As Object
Dim FileName As String
Dim i As Integer
Dim strFile As String
Dim sNewFile As String
Dim sDelAtts As String
Dim sSavePathFS As String
Dim x
Dim sFolderID As String
Dim xlApp As Object
Dim xlWB As Object
Const sPATH = "The full path and name for a processing workbook.xlsm" 'Change to suit, if the attachments require further processing use this workbook.
Set NS = GetNamespace("MAPI")
'for my environment:
Select Case sFolder
Case "Test": Set F = NS.Folders("Mailbox - Wright, Denis").Folders("Test")
End Select
i = 0
If F.Items.Count = 0 Then
MsgBox "There are no messages in this folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
'loop through the items, saving attachments to designated folder
For Each item In F.Items
'the While loop works better than For Each because the attachment list is re-indexed each time you add or remove an attachment
While item.Attachments.Count > 0
strFile = item.Attachments(1).FileName
'use this for directing attachments to the G: drive
FileName = "Directory path\change to suit\" & sOutDir & "\" & strFile
x = Split(FileName, ".")
sNewFile = x(0) & " " & Format(item.ReceivedTime, "yyyymmdd") & "." & x(1)
item.Attachments(1).SaveAsFile sNewFile
sDelAtts = ""
If item.BodyFormat <> olFormatHTML Then
sDelAtts = sDelAtts & vbCrLf & "<file://" & sNewFile & ">"
Else
sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sNewFile & "'>" & sNewFile & "</a>"
End If
' Delete the current attachment. We use a "1" here instead of an "i"
' because the .Delete method will shrink the size of the item.Attachments
' collection for us. Use some well placed Debug.Print statements to see
' the behavior.
item.Attachments(1).Delete
'now rewrite the message to indicate where the attachment was saved
' Modify the body of the item to show the file system location of
' the deleted attachments.
If item.BodyFormat <> olFormatHTML Then
item.Body = item.Body & vbCrLf & vbCrLf _
& "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts
Else
item.HTMLBody = item.HTMLBody & "<p></p><p>" _
& "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>"
End If
' Save the edits to the item. If you forget this line, the attachments will not be deleted.
item.Save
'optional: now process the detached file
If InStr(1, strFile, ".xls") > 0 Then ' only process Excel files: Modification 20120810 DW
Set xlApp = CreateObject("Excel.Application")
xlApp.Workbooks.Open (sPATH)
Set xlWB = xlApp.ActiveWorkbook
'run a macro in the workbook.
'the comma syntax lets you define any parameters required.
Select Case sFolder
Case "Test": xlApp.Run "HarvestTest", sNewFile
End Select
xlApp.ActiveWorkbook.Close (False)
xlApp.Quit
Set xlApp = Nothing
End If
Wend
Next item
GetAttachments_exit:
Set item = Nothing
Set F = Nothing
Set NS = Nothing
gstrWhere = FileName
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!"
'clean up references to prevent locking the file for later emails
xlApp.ActiveWorkbook.Close (False)
xlApp.Quit
Set xlApp = Nothing
Resume GetAttachments_exit
End Sub
