outlook2016多账户，批量下载指定账户下指定文件夹附件

sunw1984

各位高手
       本人新手一枚，从论坛找到和学习了批量下载指定文件夹附件，非常方便实用，但是现在又遇见新的问题，比如我的Outlook客户端又新绑定了一个账户DEF@XXX.COM (假定原存在账户为ABC@XXX.COM), 请问如何修改以下代码，使得其能够下载指定新增的账户DEF@XXX.COM 下B文件夹内所有附件
     非常感谢不吝赐教

以下是源代码，客户端新增了一个账户后，一运行就卡死

1. Sub downloadatt()
   
2. 
   
3. On Error Resume Next
   
4. 
   
5. 
   
6. Dim olApp As New Outlook.Application
   
7.      Dim nmsName As Outlook.NameSpace
   
8.      Dim vItem As Object
   
9.      Set nmsName = olApp.GetNamespace("MAPI")
   
10.      Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
    
11.      Set fldFolder = myFolder.Folders("M")
    
12.          
    
13.      For Each vItem In fldFolder.Items
    
14. 
    
15.             
    
16.          MyArray = Split(Attachment.DisplayName, ".", -1, 1)
    
17.          strname = MyArray(0) & Format(mymailitem.CreationTime, "_yyyymmdd_hhnnss") & "." & MyArray(1)
    
18.          strname = MyArray(0) & Format(mymailitem.ReceivedTime, "_yyyymmdd_hhnn") & "." & MyArray(1)
    
19.          strname = Right(MyArray(0), InStr(MyArray(0), "G1m")) & "." & MyArray(1)
    
20. 
    
21.          If (fso.FileExists(filefolder & strname) = False) Then
    
22.              temp = i & " " & mymailitem.Subject & "   " & mymailitem.CreationTime & " " & Attachment.DisplayName
    
23.              Attachment.SaveAsFile filefolder & strname
    
24.              temp = mymailitem.CreationTime & " " & filefolder & strname
    
25.              f.Writeline temp
    
26.             
    
27.             msg = msg & temp & vbCrLf
    
28.              wcount = wcount + 1
    
29.         End If
    
30.       
    
31.          For Each att In vItem.Attachments
    
32.                   
    
33.             fn = "C:\Users\W\Documents\8. Report" & att.FileName
    
34.             Do Until Dir(fn) = ""
    
35.                 fn = "C:\Users\W\Documents\8.Report" & n & att.FileName
    
36.                 n = n + 1
    
37.             Loop
    
38.             att.SaveAsFile fn
    
39.          Next
    
40. 
    
41.             
    
42.      Next
    
43.      
    
44.     Set fldFolder = Nothing
    
45.      Set nmsName = Nothing
    
46. 
    
47. 
    
48. 
    
49. End Sub
    

复制代码