Outlook宏將PDF附件移動到硬盤驅動器

Question

我的目標是：在收到的電子郵件中，將任何PDF附件移動到硬盤驅動器文件夾中，並附上日期。

我有一個宏運行的規則，但規則不斷錯誤並關閉，所以我打算把它放在這個Outlook會話。

我修改了這個宏，我發現要做我所需要的，但是它給了我編譯錯誤：Next沒有For。

謝謝你對此的幫助。

Option Explicit 

Private WithEvents olInboxItems As Items 

Private Sub Application_Startup() 
Dim objNS As NameSpace 
Set objNS = Application.Session 
' instantiate objects declared WithEvents 
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items 
Set objNS = Nothing 
End Sub 

Private Sub olInboxItems_ItemAdd(ByVal Item As Object) 
On Error Resume Next 
If Item.Attachments.Count > 0 Then 

Dim objAttachments As Outlook.Attachments 
Dim lngCount As Long 
Dim strFile As String 
Dim sFileType As String 
Dim i As Long 
Dim dtDate As Date 
Dim sName As String 
Dim objMsg As Outlook.MailItem 
Dim lcount As Integer 
Dim pre As String 
Dim ext As String 
Dim strFolderpath As String 

Set objAttachments = Item.Attachments 
lngCount = objAttachments.Count 
For i = lngCount To 1 Step -1 

If lngCount > 0 Then 

dtDate = objMsg.SentOn 

sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) 

' Get the file name. 
strFile = sName & objAttachments.Item(i).FileName 

If LCase(Right(strFile, 4)) = ".pdf" Then 

lcount = InStrRev(strFile, ".") - 1 
pre = Left(strFile, lcount) 
ext = Right(strFile, Len(strFile) - lcount) 

' Combine with the path to make the final path 
strFile = strFolderpath & pre & "_" & sName & ext 

' Get the path to your My Documents folder 
strFolderpath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%") 
strFolderpath = strFolderpath & "\1 Inbox\" 

' Combine with the path to the folder. 
strFile = strFolderpath & strFile 

' Save the attachment as a file. 
objAttachments.Item(i).SaveAsFile strFile 

Next i 
End If 
End If 

End Sub 

Answer 1

你不需要規則，嘗試添加這OutlookSession然後重新啓動您的Outlook

Private WithEvents Items As Outlook.Items 

Private Sub Application_Startup() 
    Dim olNs As Outlook.NameSpace 
    Dim Inbox As Outlook.MAPIFolder 

    Set olNs = Application.GetNamespace("MAPI") 
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox) 
    Set Items = Inbox.Items 
End Sub 

Private Sub Items_ItemAdd(ByVal Item As Object) 
    If TypeOf Item Is Outlook.MailItem Then 
     Save_PDF Item 
    End If 
End Sub 

Private Sub Save_PDF(ByVal Item As Object) 
    Dim Atmts As Outlook.Attachments 
    Dim intCount As Long 
    Dim sFileName As String 
    Dim i As Long 
    Dim sDate As String 
    Dim Frmt_Date As String 
    Dim FolderPath As String 

    If Item.Attachments.Count > 0 Then 
     Set Atmts = Item.Attachments 
     intCount = Atmts.Count 

     For i = intCount To 1 Step -1 

      If intCount > 0 Then 
       sDate = Item.SentOn 
       Frmt_Date = Format(sDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) 

       ' Get the file name. 
       sFileName = Atmts.Item(i).FileName 

       If LCase(Right(sFileName, 4)) = ".pdf" Then 

        ' Get the path to your My Documents folder 
        FolderPath = Environ("USERPROFILE") & "\Documents\1 Inbox\" 

        ' Combine with the FolderPath and FileName_DateSentOn 
        sFileName = FolderPath & Frmt_Date & "_" & sFileName 

        ' Save the attachment as a file. 
        Atmts.Item(i).SaveAsFile sFileName 

       End If 
      End If 
     Next i 
    End If 

    Set Items = Nothing 
    Set Atmts = Nothing 

End Sub