用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 

但請記住，如果您從同一個發件人那裏獲得多個附件的電子郵件，那麼您將最終覆蓋現有的文件。