Question

历史上我使用Excel和Lotus Notes来做这件事，公司正在通过Outlook 2016作为其标准电子邮件客户端进行过渡。

我们每天都会从多个分支机构的冰箱部门收到邮箱报告。每个分支都是单独的电子邮件，但有些附件的名称相同。

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

我在堆栈溢出处找到了一个脚本，我修改了该脚本以将附件从Outlook保存到Network文件夹中。这很好。

这是脚本

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

但是我可以搜索到无法找到适合的内容或将其添加到脚本中。

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

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

Answer 1

变化：

 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

Answer 2

尝试这样

将以下内容添加到变量

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

这里有两个功能

'// 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

祝你好运 - ： - ）

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

2 个答案: