[已解决]OUTLOOK批量下载附件，重复文件名无法全部下载

H若君E

我最近使用OUTLOOK批量下载附件的代码，这个真可以大大提高工作效率。同时 ，带来一个问题，当对方回复的附件名有重复时，比如，ABC三位的附件名是重复的，应该下载3份，最终只有1份。

高手们，应该怎么修改呢？

最佳答案

月排行榜 / 总排行榜

Zipall

2014-3-25 12:12

H若君E 发表于 2014-3-25 11:45
DIR啊，我不太懂，附上代码，能帮忙修改下吗？有时附件名字重复达到4个以上的。

保存附件那段改成这样

1.          For Each att In vItem.Attachments
   
2.             fn = "C:\Users\XXX\Documents" & att.Filename
   
3.             Do Until Dir(fn) = ""
   
4.                 fn = "C:\Users\XXX\Documents" & n & att.Filename
   
5.                 n = n + 1
   
6.             Loop
   
7.             att.SaveAsFile fn
   
8.          Next
   

复制代码

跳转到最佳答案楼层

Zipall

保存附件前用dir(路径+文件名)检查同名文件是否已存在,若已存在则修改当前附件名称.

H若君E

Zipall 发表于 2014-3-25 10:14
保存附件前用dir(路径+文件名)检查同名文件是否已存在,若已存在则修改当前附件名称.

DIR啊，我不太懂，附上代码，能帮忙修改下吗？有时附件名字重复达到4个以上的。

1. Sub 下载电邮附件()
   
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("Current")
    
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. att.SaveAsFile "C:\Users\XXX\Documents" & att.Filename
    
33.          
    
34.          Next
    
35.       
    
36.      Next
    
37.      
    
38.     Set fldFolder = Nothing
    
39.      Set nmsName = Nothing
    
40. 
    
41. 
    
42. 
    
43. End Sub
    

复制代码

Zipall

H若君E 发表于 2014-3-25 11:45
DIR啊，我不太懂，附上代码，能帮忙修改下吗？有时附件名字重复达到4个以上的。

保存附件那段改成这样

1.          For Each att In vItem.Attachments
   
2.             fn = "C:\Users\XXX\Documents" & att.Filename
   
3.             Do Until Dir(fn) = ""
   
4.                 fn = "C:\Users\XXX\Documents" & n & att.Filename
   
5.                 n = n + 1
   
6.             Loop
   
7.             att.SaveAsFile fn
   
8.          Next
   

复制代码

H若君E

Zipall 发表于 2014-3-25 12:12
保存附件那段改成这样

高手啊，有新情况，现在发现下载后的文件名五花八门，七零八落，惨不忍睹。

想一次性对下载后的附件们直接进行重命名，YYYYMM_OUTLOOKATT_XXXX，YYYYMM是附件所保存的文件夹的名字（如201404），XXXX就是每份附件EXCEL单元格A2的内容，每一份附件单元格A2的内容都是不同的。