Question

这是我在stackoverflow上的第一篇文章，并且我遇到一个问题，即如果发件人的域不是来自我公司的域（我公司的域，即info@mycompany.com），我的语法仅保存电子邮件附件，而仅保存附件是从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

--------------------------------- update ------------- -----------------------------

我包含了显示错误的代码，当我运行它时，我没有看到弹出的任何错误代码。来自内部电子邮件域（即info@mycompany.com）的附件仍未下载到我指定的文件夹中，而来自外部电子邮件域（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

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

Answer 1

SenderEmailAddress property does not contain a standard email address for internal contacts

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

添加发件人电子邮件地址

1 个答案: