使用單元格值中的文件名保存 outlook 附件

Question

我實際上試圖將 outlook 附件從特定子文件夾保存到本地路徑。 我能夠將文件按原樣保存到本地路徑。 但是，要求是使用 excel 文件中給出的文件名（即單元格值）保存 xl 附件。 我希望代碼使用 ThisWorkbook 的單元格值中給出的文件名。

讓我知道是否有辦法。 感謝對此的任何支持。

Sub ManualPunchAttachmentsExtract()
    Dim OlFolder As Outlook.MAPIFolder
    Dim OlMail As Object
    Dim OlApp As Outlook.Application
    Dim OlItems As Outlook.Items
    Dim Get_namespace As Outlook.Namespace
    Dim strFolder As String
    Dim i As Integer
    
    ThisWorkbook.Activate
    Sheets("MP File Save").Activate
    Range("H3").Activate
    
    Set OlApp = GetObject(, "Outlook.Application")
    
    If err.Number = 429 Then
        Set OlApp = CreateObject("Outlook.Application")
    End If
    
    strFolder = InputBox("Please Enter the Folder Path alongwith ' \ ' at the end", Path)
    
    'Set Get_namespace = OlApp.GetNamespace("MAPI")
    Set OlFolder = OlApp.GetNamespace("MAPI").Folders("shaikajaz.k@flex.com").Folders("Archive").Folders("Juarez").Folders("Manual Punch")
    Set OlItems = OlFolder.Items
    '.Restrict("[Unread]=true")
    
    For Each OlMail In OlItems
    
         If OlMail.UnRead = False Then
             
         Else
            ThisWorkbook.Activate
            Sheets("MP File Save").Activate
            ActiveCell.Value = OlMail.Subject
            ActiveCell.Offset(0, 1).Value = OlMail.ReceivedTime
            
            If OlMail.attachments.Count > 0 Then
                For i = 1 To OlMail.attachments.Count
                    OlMail.attachments.Item(i).SaveAsFile strFolder & "\" & OlMail.attachments.Item(i).FileName
                    OlMail.UnRead = False
                    ThisWorkbook.Activate
                    ActiveCell.Offset(1, 0).Select
                Next i
            
            Else
            
            End If
         
         End If
                
    Next
MsgBox ("Done")
End Sub

Answer 1

首先，遍歷 Outlook 文件夾中的所有項目並不是一個好主意。 請改用 Items class 的Find / FindNext或Restrict方法。 所以，而不是下面的代碼：

For Each OlMail In OlItems

     If OlMail.UnRead = False Then

用這個：

Private Sub FindAllUnreadEmails(folder As Outlook.MAPIFolder)

    Dim searchCriteria As String = "[UnRead] = true"
    Dim counter As Integer = 0
    Dim mail As Outlook._MailItem = Nothing
    Dim folderItems As Outlook.Items = Nothing
    Dim resultItem As Object = Nothing
   
        If (folder.UnReadItemCount > 0) Then
            
            folderItems = folder.Items
            resultItem = folderItems.Find(searchCriteria)
            While Not IsNothing(resultItem)
                If (TypeOf (resultItem) Is Outlook._MailItem) Then
                    counter += 1
                    mail = resultItem
                    Debug.Print("#" + counter.ToString() + _
                                          " - Subject: " + mail.Subject)
                End If
                resultItem = folderItems.FindNext()
            End While
            
        Else
            Debug.Print("There is no match in the " + _
                                   folder.Name + " folder.")
        End If
End Sub

請注意，附加文件可以具有相同的文件名。 因此，為了唯一標識文件，我建議在將附件保存到磁盤時在文件名中引入任何 ID。

最后，要使用工作簿的內容名稱保存附件，您需要將單元格值傳遞給SaveAsFile方法：

OlMail.attachments.Item(i).SaveAsFile strFolder & "\" & yourWorksheet.Range("B2").Value