使用SenderName重命名已保存的附件

Question

我正在使用VBA脚本保存文件夹的所有附件。我试图用发件人的名字重命名文件名。但是当我尝试这个时，它会改变文件的格式。如何在不更改文件格式的情况下使用发件人名称重命名文件？

Sub Save_Mail_Attachment()
'''''Variable declarions
Dim ns As NameSpace
Dim inb As Folder
Dim itm As Outlook.MailItem
Dim atch As Attachment

    '''''Variables Initialization
Set ns = Outlook.GetNamespace("MAPI")
Set inb = ns.GetDefaultFolder(olFolderInbox).Folders("Specified Folder")
File_Path = "C:\Attachments\"

'''''Loop Thru Each Mail Item
For Each itm In inb.Items

'''''Loop Thru Each Attachment
    For Each atch In itm.Attachments
        On Error Resume Next
        atch.SaveAsFile File_Path & atch.FileName
        Debug.Print itm.SenderName

    Next atch
Next itm



End Sub

Answer 1

尝试这样......

Option Explicit
Sub Save_Mail_Attachment()
    '''''Variable declarions
    Dim ns As NameSpace
    Dim inb As Folder
    Dim itm As Outlook.MailItem
    Dim atch As Attachment
    Dim File_Path As String '<--- missing
    Dim SenderName As String ' <------ Add

        '''''Variables Initialization
    Set ns = Outlook.GetNamespace("MAPI")
    Set inb = ns.GetDefaultFolder(olFolderInbox).Folders("Specified Folder")

    File_Path = "C:\Attachments\"

    '''''Loop Thru Each Mail Item
    For Each itm In inb.Items

    '''''Loop Thru Each Attachment
        For Each atch In itm.Attachments
'            On Error Resume Next
            SenderName = itm.SenderName '<----- Add
            atch.SaveAsFile File_Path & " " & SenderName & atch.FileName  '<--- Add
            Debug.Print itm.SenderName

        Next atch
    Next itm

End Sub

修改

  

是否可以省略添加的文件名

是的，你可以这样做。

Option Explicit
Sub Save_Mail_Attachment()
    '''''Variable declarions
    Dim ns As NameSpace
    Dim inb As Folder
    Dim itm As Outlook.MailItem
    Dim atch As Attachment
    Dim File_Path As String ' <------
    Dim SenderName As String ' <-----
    Dim Ext As String ' <-----

        '''''Variables Initialization
    Set ns = Outlook.GetNamespace("MAPI")
    Set inb = ns.GetDefaultFolder(olFolderInbox).Folders("Specified Folder")

    File_Path = "C:\Attachments\"

    '''''Loop Thru Each Mail Item
    For Each itm In inb.Items

    '''''Loop Thru Each Attachment
        For Each atch In itm.Attachments

            Ext = Right(atch.FileName, _
                            Len(atch.FileName) - InStrRev(atch.FileName, Chr(46))) '<----

            SenderName = itm.SenderName '<------

            atch.SaveAsFile File_Path & SenderName & Chr(46) & Ext    '<----

            Debug.Print itm.SenderName

        Next atch
    Next itm

End Sub

但请记住，如果您收到多封来自同一发件人的附件的电子邮件，那么您最终会覆盖现有文件。