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

过去我一直使用Excel和lotus notes来完成这项工作，现在公司正通过Outlook 2016作为其标准电子邮件客户端进行过渡

我们从多家分店的冰箱单元将每日报告发送到邮箱。每个分支都是单独的电子邮件，但某些附件的名称相同

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

我在stack overflow中找到了一个脚本，我修改了该脚本以将Outlook中的附件保存到网络文件夹中。那很好

这是剧本

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

但是，尽可能地搜索，我看不出这将适用于何处，也无法将其添加到脚本中

如何将此函数添加到上面的优秀脚本中以重命名相同的命名附件

我怀疑我错过了一些简单的东西

像这样试试看

将以下内容添加到变量中

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

祝你好运-：-）

改变：

 strFile = strFolderpath & strFile

致：

功能：

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

---

Om3r您的解决方案工作出色。将检查Tim提供的较短版本，看看哪一个最适合我的需要！。干杯

 strFile = strFolderpath & strFile

 strFile = MakeUnique(strFolderpath & strFile)

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