Outlook 2010 VBA 宏保存附件

Question

當電子郵件進入 Outlook 中的某個子文件夾時，我在ThisOutlookSession有以下代碼來保存電子郵件中的 PDF 附件。

我以為我沒有正確使用 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 Application_Startup() 替換 Sub Initialize_handler() 行

或者使用這種格式

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