Outlook 宏将 PDF 附件移动到硬盘

Question

我的目标是：在收到的电子邮件中，将任何 PDF 附件移动到硬盘文件夹，并在其末尾附加日期。

我有一个使用规则运行的宏，但该规则经常出错并关闭，所以我将把它放在这个 Outlook 会话中。

我修改了这个我发现做我需要的宏，但是它给了我编译错误：Next without 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