Vba Outlook下载附件宏跳过奇数文件
我继承了一段在Outlook 2010中从用户窗体运行的代码。代码应将所选电子邮件中的所有附件保存在公用文件夹中,并保存到用户的C驱动器中 用户向我保证(在过去3年中),他们必须在早上的第一件事“预热宏”。他们说,如果他们选择100封电子邮件,宏将忽略一些附件。但是,如果他们从选择10封电子邮件开始,宏将起作用。然后他们在下一次跑步中选择20,并不断增加 我成功地复制了一次,但只有一次,我不明白为什么 如有任何建议或分享经验,将不胜感激Vba Outlook下载附件宏跳过奇数文件,vba,download,outlook,attachment,Vba,Download,Outlook,Attachment,我继承了一段在Outlook 2010中从用户窗体运行的代码。代码应将所选电子邮件中的所有附件保存在公用文件夹中,并保存到用户的C驱动器中 用户向我保证(在过去3年中),他们必须在早上的第一件事“预热宏”。他们说,如果他们选择100封电子邮件,宏将忽略一些附件。但是,如果他们从选择10封电子邮件开始,宏将起作用。然后他们在下一次跑步中选择20,并不断增加 我成功地复制了一次,但只有一次,我不明白为什么 如有任何建议或分享经验,将不胜感激 Sub DownloadFiles() Dim objFS
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
是的,如果您没有给代码足够的时间来保存附件,这是非常有可能的。最简单的修复方法是在
objAttachments.Item(iLoop).SaveAsFile strFile
之后添加DoEvents
另一种方法是在该行之后使用DIR
,检查文件是否已实际保存
Debug.Print DIR(strFile)
像这样的
Do While Dir(strFile) = ""
DoEvents
Loop