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