重命名相同的名称从Outlook复制时多个电子邮件附件

从历史上看，我使用Excel和莲花笔记来做这件事，因为它是标准的电子邮件客户端，所以公司正在转换到Outlook 2016。

我们每天都会向多个分支机构的冰箱单元收到一封信箱。 每个分支是一个单独的电子邮件，但一些附件命名相同。

我使用了一个脚本来复制LN中的附件，它有一个私有函数，在复制附件的过程中，如果它们具有相同的名称，将会重命名它们。

我在堆栈溢出处发现了一个脚本，我修改它来将附件从Outlook保存到networking文件夹中。 这工作正常。

这是脚本

Public Sub SaveAttachments() Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem 'Object Dim objAttachments As Outlook.Attachments Dim objSelection As Outlook.Selection Dim i As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strDeletedFiles As String ' Get the path to your My Documents folder 'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) strFolderpath = "J:\Clayton\Logistics\Plantwatch\REPORTS\ZDumpSites\" On Error Resume Next ' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.Application") ' Get the collection of selected objects. Set objSelection = objOL.ActiveExplorer.Selection ' Set the Attachment folder. strFolderpath = strFolderpath '& "\Attachments\" ' Check each selected item for attachments. If attachments exist, ' save them to the strFolderPath folder and strip them from the item. For Each objMsg In objSelection ' This code only strips attachments from mail items. ' If objMsg.class=olMail Then ' Get the Attachments collection of the item. Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count strDeletedFiles = "" If lngCount > 0 Then ' We need to use a count down loop for removing items ' from a collection. Otherwise, the loop counter gets ' confused and only every other item is removed. For i = lngCount To 1 Step -1 ' Save attachment before deleting from item. ' Get the file name. strFile = objAttachments.Item(i).FileName ' Combine with the path to the Temp folder. strFile = strFolderpath & strFile ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFile ' Delete the attachment. 'objAttachments.Item(i).Delete 'write the save as path to a string to add to the message 'check for html and use html tags in link If objMsg.BodyFormat <> olFormatHTML Then strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" Else strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _ strFile & "'>" & strFile & "</a>" End If 'Use the MsgBox command to troubleshoot. Remove it from the final code. 'MsgBox strDeletedFiles Next i ' Adds the filename string to the message body and save it ' Check for HTML body If objMsg.BodyFormat <> olFormatHTML Then objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body Else objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody End If objMsg.Save End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub 

我正在尝试将这个函数添加到这个脚本中：

 Private Function UniqueFileName(ByVal Fn As String) As String ' Rename same Name files. Dim Fun As String ' Function return value Dim Sp() As String ' Split file name Dim Ext As Long ' file extension character count Dim i As Integer ' file name index Sp = Split(Fn, ".") If UBound(Sp) Then Ext = Len(Sp(UBound(Sp))) + 1 Fun = stPath & Fn Do While Len(Dir(Fun)) i = i + 1 Fun = stPath & Left(Fn, Len(Fn) - Ext) & _ "(" & CStr(i) & ")" & Right(Fn, Ext) If i > 100 Then Exit Do Loop UniqueFileName = Fun End Function 

但是，尽我所能，我不能看到这将适合或添加到脚本。

我如何将这个function添加到上面的优秀脚本来重命名同名的附件？

我怀疑我错过了一些简单的事情！

Answer 1

更改：

  strFile = strFolderpath & strFile 

至：

  strFile = MakeUnique(strFolderpath & strFile) 

function：

 Function MakeUnique(fPath As String) As String Dim rv As String, fso, fName, fldr, ext, n Set fso = CreateObject("scripting.filesystemobject") rv = fPath ext = "." & fso.getextensionname(fPath) n = 2 Do While fso.fileexists(rv) rv = Left(fPath, Len(fPath) - Len(ext)) & "(" & n & ")" & ext n = n + 1 Loop MakeUnique = rv End Function 

Answer 2

像这样尝试

将以下内容添加到您的variables

 Dim nFileName As String Dim Ext As String 

然后调用函数

  For i = lngCount To 1 Step -1 ' Save attachment before deleting from item. ' Get the file name. strFile = objAttachments.Item(i).FileName ' ============================================================== ' ' // added Ext = Right(strFile, _ Len(strFile) - InStrRev(strFile, Chr(46))) nFileName = FileNameUnique(strFolderpath, strFile, Ext) '================================================================ ' Combine with the path to the Temp folder. strFile = strFolderpath & strFile ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFolderpath & nFileName ' < added 

这里有两个function

 '// Check if the file exists Private Function FileExists(FullName As String) As Boolean Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FileExists(FullName) Then FileExists = True Else FileExists = False End If Exit Function End Function '// If the same file name exist then add (1) Private Function FileNameUnique(sPath As String, _ FileName As String, _ Ext As String) As String Dim lngF As Long Dim lngName As Long lngF = 1 lngName = Len(FileName) - (Len(Ext) + 1) FileName = Left(FileName, lngName) Do While FileExists(sPath & FileName & Chr(46) & Ext) = True FileName = Left(FileName, lngName) & " (" & lngF & ")" lngF = lngF + 1 Loop FileNameUnique = FileName & Chr(46) & Ext Exit Function End Function 

祝你好运 – ：-）