Outlook 2010 VBA宏保存附件

Question

我在ThisOutlookSession中有以下代码，当电子邮件进入Outlook中的某个子文件夹时，可以保存电子邮件的附件。

我认为我没有正确地使用Initialize Handler，但我已经尝试改变它，但没有用。

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

Answer 1

将Sub Initialize_handler()行替换为Sub Application_Startup()

或使用以下格式

Sub Application_Startup()
    Initialize_handler
End Sub

编辑2015年11月16日

代码太复杂了。重新确定受影响的项目，而不是不传递它们。

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