Question

我有一堆文件，我每天扫描并保存。我使用的扫描仪将扫描的文件以PDF格式发送到我的收件箱，然后我打开电子邮件，保存PDF，删除电子邮件我重复这个操作数百次，如果我能节省很多时间可以自动化这个过程。

所以我正在寻找一个适用于Outlook的VBA脚本

将收件箱中所有附加的PDF保存到文件夹，然后
删除电子邮件。

我在网上看过很多关于类似脚本的帖子，但到目前为止我看过的所有内容只会执行操作的第一部分，做类似的事情，或者不适用于PDF。

在做了一些搜索之后，我在网上发现了一些类似于我想要的代码。我根据自己的意愿调整了它并提出了这个问题：

Sub getAttachmentsAndDelete()

Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim msg2 As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strTmpMsg As String
Dim fsSaveFolder As String

fsSaveFolder = "C:\Users\MikeJones\Documents\Scanned\"

'path for creating attachment msg file for stripping
strFilePath = "C:\Users\MikeJones\Documents\Scanned\temp"
strTmpMsg = "KillMe.msg"

'My testing done in Outlok using a "temp" folder underneath Inbox
Set olFolder =
Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("scanned")

If olFolder Is Nothing Then Exit Sub


For Each msg In olFolder.Items

    If msg.Attachments.Count > 0 Then

       While msg.Attachments.Count > 0
          bflag = False
             If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
               bflag = True
               msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
               Set msg2 = Application.CreateItemFromTemplate(strFilePath & 
                   strTmpMsg)
             End If

             If bflag Then
               msg2.Attachments(1).SaveAsFile fsSaveFolder & 
               msg2.Attachments(1).FileName
               msg2.Delete
             Else
                sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
                msg.Attachments(1).SaveAsFile sSavePathFS
             End If

             msg.Attachments(1).Delete

        Wend

        msg.Delete
    End If

Next

End Sub

这有点古怪但完成工作。我唯一的问题是它一次只会提取几封电子邮件/文件，所以我重复了几次循环，现在一次点击就会处理大约150封电子邮件。

Answer 1

在做了一些搜索之后，我在网上发现了一些类似于我想要的代码。我根据自己的意愿调整了它并提出了这个问题：

Sub getAttachmentsAndDelete()

Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim sSavePath, sSaveFolder As String

sSaveFolder = "C:\Users\JohnDoe\Documents\Scanned\"

Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("scanned")
If olFolder Is Nothing Then Exit Sub

For i = olFolder.Items.Count To 1 Step -1
        Set msg = olFolder.Items(i)
        If msg.Attachments.Count > 0 Then
            For j = msg.Attachments.Count To 1 Step -1
                sSavePath = (sSaveFolder & msg.Attachments(j).FileName)
                msg.Attachments(j).SaveAsFile sSavePath
            Next
        End If
    msg.Delete
Next

End Sub

此宏从Outlook文件夹Inbox \ scanning中的邮件中获取附件，并将其保存到我的硬盘上扫描的Documents \。

*编辑2017年11月：感谢niton在我的解决方案中指出了一个缺陷并建议使用For循环而不是For Each循环。我在这里重建了我的算法并清理了代码。此解决方案不再检查邮件中的附件，但会在一封电子邮件中检查多个附件，这就是我想要的。

Answer 2

对于您的方案，处理邮件的附件没有意义。

Sub getAttachmentsAndDelete()

Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
'Dim msg2 As Outlook.MailItem
'Dim att As Outlook.Attachment
Dim strFilePath As String
'Dim strTmpMsg As String
Dim fsSaveFolder As String

fsSaveFolder = "C:\Users\MikeJones\Documents\Scanned\"

'path for creating attachment msg file for stripping
'strFilePath = "C:\Users\MikeJones\Documents\Scanned\temp"
'strTmpMsg = "KillMe.msg"

'My testing done in Outlok using a "temp" folder underneath Inbox
Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("scanned")

If olFolder Is Nothing Then Exit Sub

For Each msg In olFolder.Items

    If msg.Attachments.Count > 0 Then

       While msg.Attachments.Count > 0

          'bflag = False
            ' If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
            '   bflag = True
            '   msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
             '  Set msg2 = Application.CreateItemFromTemplate(strFilePath & 
             '      strTmpMsg)
            ' End If

            ' If bflag Then
            '   msg2.Attachments(1).SaveAsFile fsSaveFolder & 
            '   msg2.Attachments(1).FileName
            '   msg2.Delete
            ' Else

            '  ** Save any attachment pdf or otherwise **
                sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
                msg.Attachments(1).SaveAsFile sSavePathFS
            ' End If

            ' Deleted attachments cannot be recovered.
            '  Only do so if it is necessary.
            '  Here there is no difference
            '   waiting until the entire message is deleted
            ' msg.Attachments(1).Delete

        Wend

        msg.Delete
    End If

Next

End Sub

Re：重复循环。

For Each msg In olFolder.Items是一个前向计数循环。您正在删除邮件。当所有剩余的项目向上移动时，您跳过循环认为刚刚处理过的项目。这使得每次都有一半的项目未经处理。删除或移动时，请使用反向计数循环。

For i = olFolder.Items.count to 1 step -1
    Set msg = olFolder.Items(i)
    If msg.Attachments.Count > 0

或处理第一项，直到零项保持，如在Wend循环中所示。

vba脚本从outlook保存所有附件（PDF）然后删除电子邮件

2 个答案: