☰

Excel Outlook VBA 将未读电子邮件保存到网络文件夹

tag-icon • tag-icon microsoft-excel microsoft-outlook vba
Excel Outlook VBA 将未读电子邮件保存到网络文件夹

我能够在 Excel 中构建一个 Outlook VBA 脚本，该脚本会将特定 Outlook 子文件夹中的“未读”邮件附件保存到我的网络上的文件夹中，然后将该邮件标记为“已读”。

我也想保存电子邮件。我在尝试将 Outlook 消息保存到我的网络时遇到了问题。我所能想到的最接近的方法是添加下面粗体的代码。尽管我没有得到想要的输出。

例如，附件被保存到文件夹 H:\Testing\XY\，我想将 Outlook 消息保存到 H:\Testing\XY\Emails" 文件夹。同时，我只希望保存电子邮件，并附上主题名称和收到电子邮件的日期。但是，当我运行 VBA 代码时，电子邮件被保存到文件夹 H:\Testing\XY\，文件名为 Emails.msg。

附件已按我的意愿保存。如能帮助完成此操作，我将不胜感激。

Sub SaveEmailAndAttach()

Dim myOlapp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myFolder As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim myMail As Outlook.MailItem
Dim avDate() As String
Dim vDate As String
Dim i As Long
Dim myEmailPath As String

ReDim Preserve avDate(3)

Set myOlapp = CreateObject("Outlook.Application")
Set myNamespace = myOlapp.GetNamespace("MAPI")

Const myAttachPath As String = "H:\Testing\XY\"
**myEmailPath = enviro & "H:\Testing\XY\Emails"**

Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox).Folders("Auto").Folders("Manual")
For Each myItem In myFolder.Items
    If myItem.UnRead = True Then
        avDate = Split(CStr(myItem.ReceivedTime), "/")
        vDate = avDate(0) & "-" & avDate(1) & "-" & Mid(avDate(2), 1, 4)

        If myItem.Attachments.Count <> 0 Then
            For Each myAttachment In myItem.Attachments

            If UCase(Right(myAttachment.Filename, 4)) = "XLSX" Then
                i = i + 1
                myAttachment.SaveAsFile (myAttachPath & vDate & " " & myAttachment.Filename)

                End If
                Next
                **myItem.SaveAs myEmailPath & " " & vDate & ".msg"**
                myItem.UnRead = False
        End If
    End If
Next
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub

答案1

您已经接近了。主要问题是缺少\。myEmailPath添加 （并删除多余的enviro &）会导致以下声明：

Const myEmailPath = "H:\Testing\XY\Emails\"


您保存电子邮件的代码现在应该可以正常工作了。但是，我擅自扩展了它，以便根据您的要求还包括主题：

myItem.SaveAs myEmailPath & vDate & " " & myItem.Subject & ".msg"

但是，由于主题可能包含文件名中禁止使用的字符，因此最好删除这些字符。以下代码将执行此操作（适用于 Windows）：

'v0.1.1
Dim strSubject As String: strSubject = myItem.Subject
Dim varForbiddenChar
For Each varForbiddenChar In Split("\ / : * ? "" < > |")
  strSubject = Replace(strSubject, varForbiddenChar, "-")
Next varForbiddenChar

当然，字符剥离代码需要在保存电子邮件的代码之前插入，并且那代码需要修改如下：

myItem.SaveAs myEmailPath & vDate & " " & strSubject & ".msg"

答案2

为了帮助其他人使用 Outlook 中的 VBA 来实现 Excel 的功能，让我继续上述讨论，并提供一些我自己的输入来完成答案。

这个问题是关于：

1- 将个人 Outlook 子文件夹中的“未读”邮件保存到共享网络目录上的文件夹中

2-将消息标记为“已读”。

3- 将电子邮件标记为蓝色类别（可选）

请注意，以 .msg 格式保存的电子邮件包含电子邮件中的附件。

希望这对你也有帮助 ;-)

 `Sub SavePersonnalInboxEmail()
 'requires reference to Microsoft Outlook 16.0 Object Library
 'requires reference to Microsoft Scripting Runtime
 Dim myOlapp As Outlook.Application
 Dim myNamespace As Outlook.Namespace
 Dim myFolder As Outlook.MAPIFolder
 Dim myItem As Outlook.MailItem
 Dim avDate() As String
 Dim i As Long
 Dim myEmailPath As String
 Dim varForbiddenChar
 ReDim Preserve avDate(3)
 Dim olItems As Outlook.Items
 Dim xObjItem As Object
 Dim vDate, xPath As String
 Dim strSubject, xFileName, xName As String
 Dim objOwner As Outlook.Recipient
 Dim fso As New FileSystemObject
 Dim VPN As String
 Dim olExplorer As Outlook.Explorer
 Dim selectedItem As Object

 Set myOlapp = CreateObject("Outlook.Application")
 Set myNamespace = myOlapp.GetNamespace("MAPI")

 '**********Check that you can reach the shared network directory *********************
Set fso = CreateObject("Scripting.FileSystemObject")
VPN = fso.FolderExists("H:\Testing\XY\Emails\")
If VPN = False Then
    MsgBox "The shared network is unavailable", vbCritical + vbOKOnly, "Error"
End If

    Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox).Folders("Auto").Folders("Manual")
    Set olItems = myFolder.Items

myEmailPath = "H:\Testing\XY\Emails\"

' ********* Loop to select the chosen email *****************
For Each myItem In myFolder.Items

If myItem.SenderName = "DrewDaddio" Then
    
    If myItem.UnRead = True Then
        If InStr(1, myItem.Subject, "Test") Then
        

' ********* Select the email with the cursor ****************
            Set olExplorer = myOlapp.ActiveExplorer
            olExplorer.Activate
            olExplorer.ClearSelection
            Set selectedItem = myItem
            olExplorer.AddToSelection selectedItem

 '************* Save the email in the shared network drive including attachment *************
            For Each xObjItem In Outlook.ActiveExplorer.Selection
                avDate = Split(CStr(myItem.ReceivedTime), "/")
                vDate = avDate(0) & "-" & avDate(1) & "-" & Mid(avDate(2), 1, 2)

                For Each varForbiddenChar In Split("\ / : * ? "" < > |")
                         strSubject = Replace(myItem.Subject, varForbiddenChar, "-")
                Next varForbiddenChar

                If xObjItem.Class = olMail Then
                    Set myItem = xObjItem
                    xName = vDate & "_" & strSubject & ".msg"
                    xFileName = myEmailPath
                    xPath = xFileName + xName
                    xObjItem.SaveAs xPath, olMSG
                End If

                myItem.UnRead = False
                myItem.Categories = "Blue category"   'optional
                myItem.Save
                strAddress = ""
                strSubject = ""
                vDate = ""
                Exit Sub
            Next
        End If
    End If
End If
Next
End sub`

相关内容