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

替换子Application_Startup（）

行子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