Outlook下载附件宏跳过奇数文件

Question

我继承了一段从Outlook2010中的用户表单运行的代码。代码应将选定电子邮件中的所有附件保存在公用文件夹中，并保存到用户的C盘。

用户向我保证(在过去的3年里)，他们必须在早上做的第一件事就是“预热宏”。他们说，如果他们选择100封电子邮件，宏将忽略一些附件。但是，如果它们在开始时选择了10封电子邮件，则宏将起作用。然后他们在下一次运行时选择20，并继续增加。

我已经成功地复制了一次，但只复制了一次，我不明白为什么。

任何建议或分享的经验都将非常感谢。

Sub DownloadFiles()
Dim objFS As Object
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim objFolder As Outlook.MAPIFolder
Dim iLoop As Long
Dim lAttCount As Long, lMessageCount As Long, lngCount As Long
Dim iNameCount As Integer, bContinue As Boolean, lSelCount As Long
Dim strFile As String, strFolderpath As String
Dim lVerCount As Long, bVerNew As Boolean, strVFile As String


'call FSO function to create the local folders if they do not exist
Call TallyFolders

lAttCount = 0
lMessageCount = 0
strFolderpath = "C:\MCSUploads\etally\"

Set objSelection = Application.ActiveExplorer.Selection
Set objFS = CreateObject("Scripting.FileSystemObject")

For lSelCount = 1 To objSelection.Count
    Set objAttachments = objSelection.Item(lSelCount).Attachments
    lngCount = objAttachments.Count

    If lngCount > 0 Then

        For iLoop = lngCount To 1 Step -1
            strFile = "No Attachment"
            strFile = objAttachments.Item(iLoop).FileName
            strFile = strFolderpath & strFile

            If objFS.FileExists(strFile) Then
                'append lSelCount to the filename (not extension) to ensure a unique name
                bContinue = True

                For iNameCount = Len(strFile) To 1 Step -1
                    If bContinue And (Mid(strFile, iNameCount, 1) = ".") Then

                       lVerCount = 1
                       bVerNew = False

                       Do Until bVerNew = True
                            strVFile = Left(strFile, iNameCount - 1) & CStr(lVerCount) & Right(strFile, Len(strFile) - iNameCount + 1)
                            If objFS.FileExists(strVFile) Then
                                lVerCount = lVerCount + 1
                            Else
                                bVerNew = True
                            End If
                        Loop

                        bContinue = False
                    End If
                Next iNameCount

                strFile = strVFile
            End If

            objAttachments.Item(iLoop).SaveAsFile strFile
        Next iLoop
    End If
Next lSelCount

FrmDownloadAttachments1.LblMsg.Visible = True

ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
End Sub




Sub TallyFolders()
Dim oFileSystem As Object
Dim FolderRaw As String, FolderComplete As String, FolderProblem As String


Set oFileSystem = CreateObject("Scripting.FileSystemObject")
If Not oFileSystem.FolderExists("C:\MCSUploads") Then oFileSystem.CreateFolder ("C:\MCSUploads")


FolderRaw = "C:\MCSUploads\etally\"
FolderComplete = "C:\MCSUploads\etally\Completed\"
FolderProblem = "C:\MCSUploads\etally\Problems\"
If Not oFileSystem.FolderExists(FolderRaw) Then oFileSystem.CreateFolder (FolderRaw)
If Not oFileSystem.FolderExists(FolderComplete) Then oFileSystem.CreateFolder (FolderComplete)
If Not oFileSystem.FolderExists(FolderProblem) Then oFileSystem.CreateFolder (FolderProblem)



FolderRaw = "C:\MCSUploads\LAR\"
FolderComplete = "C:\MCSUploads\LAR\Completed\"
FolderProblem = "C:\MCSUploads\LAR\Problems\"
If Not oFileSystem.FolderExists(FolderRaw) Then oFileSystem.CreateFolder (FolderRaw)
If Not oFileSystem.FolderExists(FolderComplete) Then oFileSystem.CreateFolder (FolderComplete)
If Not oFileSystem.FolderExists(FolderProblem) Then oFileSystem.CreateFolder (FolderProblem)


FolderRaw = "C:\MCSUploads\MAR\"
FolderComplete = "C:\MCSUploads\MAR\Completed\"
FolderProblem = "C:\MCSUploads\MAR\Problems\"
If Not oFileSystem.FolderExists(FolderRaw) Then oFileSystem.CreateFolder (FolderRaw)
If Not oFileSystem.FolderExists(FolderComplete) Then oFileSystem.CreateFolder (FolderComplete)
If Not oFileSystem.FolderExists(FolderProblem) Then oFileSystem.CreateFolder (FolderProblem)
End Sub

Answer 1

是的，如果你没有给代码足够的时间来保存附件，这是非常有可能的。最简单的解决方法是在objAttachments.Item(iLoop).SaveAsFile strFile之后添加DoEvents。

另一种方法是在该行后面使用DIR来检查文件是否已实际保存。

Debug.Print DIR(strFile)

像这样的东西

Do While Dir(strFile) = ""
    DoEvents
Loop