Outlook 2010 VBA Macro Saving Attachments

Question

I have the following code in ThisOutlookSession to save PDF attachments from emails when the emails go into a certain sub-folder in Outlook.

I thought I wasn't using the Initialize Handler correctly, but I have tried to change it around to no avail.

Public WithEvents myOlItem As Outlook.Items

Dim myOlApp As New Outlook.Application

Public Sub Initialize_handler()
Set myOlItem = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("WAM").Folders("UNPROCESSED").Items
End Sub

Private Sub myOlItem_ItemAdd(ByVal Item As Object)
Dim myOlMItem As Outlook.MailItem
Dim myOlAtts As Outlook.Attachments
Set myOlAtts = myOlMItem.Attachments

Call CallMyProcedure(Item)

End Sub

Sub CallMyProcedure()

Dim itms As Outlook.Items
Dim Itm As Object

' loop through default Inbox items
Set itms = myOlMItem 'Session.GetDefaultFolder(olFolderInbox).Folders("WAM").Folders("UNPROCESSED").Items

For Each Itm In itms
    If TypeName(Itm) = "MailItem" Then
        ' your code is called here
        savePDFtoDisk Itm
    End If
Next Itm
Set objEmail = Nothing
End Sub

Sub savePDFtoDisk(Itm As Outlook.MailItem)

Dim dateFormat 'Dateiname mit Datum.
Dim objAtt As Outlook.Attachment
Dim saveFolder As String

dateFormat = Format(Now, "mm_yyyy")
saveFolder = "\\marnv006\#marnv006\Bm\Master Scheduling\PC 2.2.11 Work Authorizing Memorandum (WAMs)\WAMS added to WAM Track\"

For Each objAtt In Itm.Attachments

    If (InStr(1, objAtt.DisplayName, "WAM", vbTextCompare) > 0) Then

        If LCase(Right(objAtt.FileName, 4)) = ".pdf" Then
            objAtt.SaveAsFile saveFolder & objAtt.DisplayName

            Set objAtt = Nothing

        End If 'Nach PDF filtern.
    End If
Next

End Sub

I'm not sure what else might be wrong but at first glance I see you are passing an argument into CallMyProcedure where none is expected. — Dave
I cannot figure out why it will not work,please help! It would be helpful for us if you could elaborate on what this means. Do you get an error? If so, what line raises the error and what is the error message? — David Zemens

niton niton · Accepted Answer · 2014-09-26T20:03:40

Replace the line Sub Initialize_handler() with Sub Application_Startup()

Or use this format

Sub Application_Startup()
    Initialize_handler
End Sub

Edit 2015 11 16

The code is too convoluted. Redetermining the affected items than failing to pass them along.

Option Explicit

' In ThisOutlookSession
Private WithEvents myOlItem As Items

' Not needed if in Outlook
'Dim myOlApp As New Outlook.Application

'Public Sub Initialize_handler()
Private Sub application_Startup()

Dim myNS As Namespace
Dim myFolder As Folder

Set myNS = GetNamespace("MAPI")

Set myFolder = myNS.GetDefaultFolder(olFolderInbox)
Set myFolder = myFolder.Folders("WAM")
Set myFolder = myFolder.Folders("UNPROCESSED")

Set myOlItem = myFolder.Items

ExitRoutine:
    Set myNS = Nothing
    Set myFolder = Nothing

End Sub

' No need to redetermine items, ItemAdd already knows.

' Note itm to match the savePDFtoDisk code, not item.
Private Sub myOlItem_ItemAdd(ByVal Itm As Object)
'Sub savePDFtoDisk(Itm As Outlook.mailItem)

Dim dateFormat 'Dateiname mit Datum.
Dim objAtt As Outlook.attachment
Dim saveFolder As String

dateFormat = Format(Now, "mm_yyyy")
saveFolder = "\\marnv006\#marnv006\Bm\Master Scheduling\PC 2.2.11 Work Authorizing Memorandum (WAMs)\WAMS added to WAM Track\"

For Each objAtt In Itm.Attachments

    If (InStr(1, objAtt.DisplayName, "WAM", vbTextCompare) > 0) Then

        If LCase(Right(objAtt.Filename, 4)) = ".pdf" Then
            objAtt.SaveAsFile saveFolder & objAtt.DisplayName

            Set objAtt = Nothing

        End If 'Nach PDF filtern.
    End If
Next

End Sub

Outlook 2010 VBA Macro Saving Attachments

1 Answers