悬赏解决批量提取附件问

六月的雨2018

从outlook批量提取附件，从网上看到的解决办法，导入程序如下：
Sub Savetheattachment()
    Dim olApp As New Outlook.Application
    Dim nmsName As Outlook.NameSpace
    Dim vItem As Object
    Set nmsName = olApp.GetNamespace("MAPI")
    Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
    Set fldFolder = myFolder.Folders("BankStatement")

    For Each vItem In fldFolder.Items

       '-----Save Attachment-------
        For Each att In vItem.Attachments
            att.SaveAsFile "C:\EmailTemp\" & att.FileName
        Next
        '------Save Attachment--------
    Next

    Set fldFolder = Nothing
    Set nmsName = Nothing
End Sub

这个能实现提取，但是我的附件都是同名的，这个功能提取的后面附件自动就覆盖了前面的附件。我想实现的功能是，把提取到后面的附件能重命名保存。如果谁能改编下这个程序，实现我的功能，将有红包奉上。谢谢

清风竹-

1. Sub Savetheattachment()
   
2.     Dim olApp As New Outlook.Application
   
3.     Dim nmsName As Outlook.Namespace
   
4.     Dim vItem As Object
   
5.     Set nmsName = olApp.GetNamespace("MAPI")
   
6.     Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
   
7.     Set fldFolder = myFolder.Folders("BankStatement")
   
8.     x = CreateObject("scripting.FileSystemObject").GetFolder("C:\EmailTemp").Files.Count '**********
   
9.     For Each vItem In fldFolder.Items
   
10.        '-----Save Attachment-------
    
11.         For Each att In vItem.Attachments
    
12.             x = x + 1 '**********
    
13.             att.SaveAsFile "C:\EmailTemp" & att.Filename & x '***
    
14.         Next
    
15.         '------Save Attachment--------
    
16.     Next
    
17. 
    
18.     Set fldFolder = Nothing
    
19.     Set nmsName = Nothing
    
20. End Sub
    

复制代码

没有测试，请测试下。