excel - 添加发件人电子邮件地址

Question

这是我在 stackoverflow 上的第一篇文章，我遇到了一个问题，如果发件人的域不是来自我公司的域（我公司的域，即 [e-mail]），我的语法只保存电子邮件附件，并且只保存收到的附件来自 yahoo、gmail 等。如何编辑我的代码以便保存所有附件而不管域如何？

 Private Sub btn_extractemails_Click()

Dim OlApp As Object
Dim OlMail As Object
Dim OlItems As Object
Dim OlFolder As Object
Dim j As Integer
Dim strFolder As String
    
On Error Resume Next
Set OlApp = GetObject(, "Outlook.Application")

If Err.Number = 429 Then
    Set OlApp = CreateObject("Outlook.Application")
End If

strFolder = "C:\Users\p00113357\Desktop\Attaches\"

Set OlFolder = OlApp.getnamespace("MAPI").Folders("EEO").Folders("Inbox").Folders("Incoming")

Set OlItems = OlFolder.Items

For Each OlMail In OlItems
    If OlMail.Attachments.Count > 0 Then
        For j = 1 To OlMail.Attachments.Count
            OlMail.Attachments.Item(j).SaveAsFile strFolder & "\" & OlMail.SenderEmailAddress & OlMail.Attachments.Item(j).Filename
        Next j
    End If
Next

Set OlFolder = Nothing
Set OlItems = Nothing
Set OlMail = Nothing
Set OlApp = Nothing

MsgBox "Done", vbInformation

End Sub

- - - - - - - - - - - - - - - - -更新 - - - - - - - - --------------------------

我包含了代码来显示我的错误，当我运行它时，我没有看到任何错误代码弹出。来自内部电子邮件域（即 [e-mail]）的附件未下载到我指定的文件夹而来自外部电子邮件域（雅虎、gmail 等）的附件正在下载的问题仍在发生。下面是我尝试获取错误代码。

Private Sub btn_extractemails_Click()

Dim OlApp As Object
Dim OlMail As Object
Dim OlItems As Object
Dim OlFolder As Object
Dim j As Integer
Dim strFolder As String

Set OlApp = GetObject(, "Outlook.Application")

If Err.Number = 429 Then
    Set OlApp = CreateObject("Outlook.Application")
End If

**On Error GoTo 0
On Error Resume Next**
strFolder = "C:\Users\p00113357\Desktop\Attaches\"

Set OlFolder = OlApp.getnamespace("MAPI").Folders("EEO").Folders("Inbox")

Set OlItems = OlFolder.Items

For Each OlMail In OlItems

    If OlMail.Attachments.Count > 0 Then
        For j = 1 To OlMail.Attachments.Count
            OlMail.Attachments.Item(j).SaveAsFile strFolder & "\" & OlMail.SenderEmailAddress & "-" & OlMail.Attachments.Item(j).Filename
        Next j
    End If
Next

Set OlFolder = Nothing
Set OlItems = Nothing
Set OlMail = Nothing
Set OlApp = Nothing

MsgBox "Done", vbInformation

End Sub

谢谢

- - - - - - - - - - - - - -更新 - - - - - - - - - - - ----------------------

按照@notin 建议的帖子中的指示，我尝试编辑我的代码，但它仍然无法正常工作。我稍微改变了语法，在将代码行按正确的顺序/位置放置后它就起作用了，感谢@notin 和 Josh P 在我的第一篇文章中提供的帮助。展望未来，我将在发布时遵循最佳实践

Private Sub btn_extractemails_Click()

Dim OlApp As Object
Dim OlMail As Object
Dim OlItems As Object
Dim OlFolder As Object
Dim j As Integer
Dim strFolder As String

Set OlApp = GetObject(, "Outlook.Application")

If Err.Number = 429 Then
    Set OlApp = CreateObject("Outlook.Application")
End If

On Error GoTo 0
On Error Resume Next
strFolder = "C:\Users\p00113357\Desktop\Attaches\"

Set OlFolder = OlApp.getnamespace("MAPI").Folders("EEO").Folders("Inbox")

Set OlItems = OlFolder.Items

For Each OlMail In OlItems

    If OlMail.Attachments.Count > 0 Then
     If OlMail.SenderEmailType = "EX" Then
        For j = 1 To OlMail.Attachments.Count
                    OlMail.Attachments.Item(j).SaveAsFile strFolder & "\" & OlMail.Sender.GetExchangeUser().PrimarySmtpAddress & "-" & OlMail.Attachments.Item(j).Filename
        Next j
     End If
    End If
Next

Set OlFolder = Nothing
Set OlItems = Nothing
Set OlMail = Nothing
Set OlApp = Nothing

MsgBox "Done", vbInformation

End Sub

标签： excelvbaoutlookemail-attachmentsnaming

Answer 1

SenderEmailAddress 属性不包含内部联系人的标准电子邮件地址

If OlMail.SenderEmailType = "EX" then而是使用OlMail.Sender.GetExchangeUser().PrimarySmtpAddress.

Option Explicit
            
Private Sub btn_extractemails_Click()

Dim OlApp As Object
Dim OlMail As Object
Dim OlItems As Object
Dim OlFolder As Object
Dim j As Integer
Dim strFolder As String

Dim strPathFile As String


' This is a rare valid use of
On Error Resume Next
' Bypass expected error if Outlook is not open

Set OlApp = GetObject(, "Outlook.Application")

If err.Number = 429 Then
    Set OlApp = CreateObject("Outlook.Application")
End If

' Return to normal error handling to see unexpected errors
On Error GoTo 0


strFolder = "C:\Users\p00113357\Desktop\Attaches\"

Set OlFolder = OlApp.GetNamespace("MAPI").folders("EEO").folders("Inbox")

Set OlItems = OlFolder.Items

For Each OlMail In OlItems

    If OlMail.Attachments.Count > 0 Then
        
        ' The expectation is internal addresses will not have the @ type format
        '  instead the format will be similar to "/O=APPLE/CN=RECIPIENTS/CN=JOBSS6738"
        '  https://stackoverflow.com/questions/36900156/senderemailaddress-property-does-not-contain-a-standard-email-address-for-intern
        Debug.Print "OlMail.SenderEmailAddress: " & OlMail.SenderEmailAddress
        
        For j = 1 To OlMail.Attachments.Count
        
            ' Note the double backslash has no impact. Do not fix. Better to have two than none.
            Debug.Print strFolder & "\" & OlMail.SenderEmailAddress & "-" & OlMail.Attachments.Item(j).Filename
            
            ' If the SenderEmailAddress is in a format similar to "/O=APPLE/CN=RECIPIENTS/CN=JOBSS6738" then
            '   Error: "Cannot save the attachment. Path does not exist. Verify the path is correct."
            
            OlMail.Attachments.Item(j).SaveAsFile strFolder & "\" & OlMail.SenderEmailAddress & "-" & OlMail.Attachments.Item(j).Filename
            
        Next j
    End If
Next

Set OlFolder = Nothing
Set OlItems = Nothing
Set OlMail = Nothing
Set OlApp = Nothing

MsgBox "Done", vbInformation

End Sub