将邮件从收件箱移动到特定文件夹

Question

此代码将附件从 Outlook 保存到我电脑中的特定文件夹。

我需要将 Outlook 收件箱中选定的邮件移动到 Outlook 中的文件夹。

最后，我会保存附件并将这封邮件移动到 Outlook 中的文件夹中。

Sub INC_Data()

    Dim ol As Object    'Outlook.Application
    Dim ns As Object    'Outlook.Namespace
    Dim fol As Object   'Outlook.Folder
    Dim i As Object
    Dim mi As Object    'Outlook.MailItem
    Dim at As Object    'Outlook.Attachment
    Dim fso As Object   'Scripting.FileSystemObject
    Dim dir As Object   'Scripting.Folder
    Dim dirName As String
    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object
    Dim f As Integer
    
    'Some Set Ups
    Set fso = CreateObject(Class:="Scripting.FileSystemObject")
    Set ol = CreateObject(Class:="Outlook.Application")
    Set ns = ol.GetNamespace("MAPI")
    Set fol = ns.GetDefaultFolder(olFolderInbox)
    
    'Finding the search item from Oulook Inbox
    For Each i In fol.Items
        If i.Class = 43 Then
            Set mi = i
            If mi.Attachments.Count > 0 And InStr(mi.SenderEmailAddress, "xxxxxxx@inc.ae") Then
                dirName = "D:\XYZ "
                If fso.FolderExists(dirName) Then
                    Set dir = fso.GetFolder(dirName)
                Else
                    Set dir = fso.Createfolder(dirName)
                End If
                'Saving Attachment to a folder
                For Each at In mi.Attachments
                    If Right(at.Filename, 4) = "xlsm" Then
                        at.SaveAsFile dir.Path & "\" & Range("Ad2").Text & ".xlsm"
                    End If
                Next at
            End If
        End If
    Next i
        
End Sub

Answer 1

首先，删除一个对象变量，以便我们可以将其分配到目标文件夹...

Dim olMoveToFolder As Object 'Outlook.Folder

然后，将目标文件夹分配给变量。因此，例如，根据您的文件夹结构，类似这样的内容...

Set olMoveToFolder = ns.Folders("Outlook").Folders("DestinationFolderName")

or

Set olMoveToFolder = fol.Folders("DestinationFolderName")

然后，在保存附件后添加以下行，将您的电子邮件移动到目标文件夹...

mi.Move olMoveToFolder

编辑

虽然我没有对其进行测试，但我已经修改了您的宏以包含以下内容...

1. 已添加语句 Option Explicit 以强制显式 变量声明以帮助捕获任何潜在的错误。注意 此语句必须放在最顶部 模块，在任何程序之前。

2. 为了方便起见，一些变量名已被重命名 清晰度。

3. 变量dir 已被删除，因为它并不是真正需要的， 并且因为它可能与函数Dir() 混淆。

4. 变量dirName 是在遍历邮件之前设置的 项目。

5. 常量olFolderInbox 已替换为值6， 因为您使用的是后期绑定。

这是您的宏，已相应修改...

Option Explicit

Sub INC_Data()
    Dim ol As Object            'Outlook.Application
    Dim ns As Object            'Outlook.Namespace
    Dim inboxFol As Object      'Outlook.Folder
    Dim moveToFolder As Object  'Outlook.Folder
    Dim itm As Object
    Dim mi As Object            'Outlook.MailItem
    Dim att As Object           'Outlook.Attachment
    Dim fso As Object           'Scripting.FileSystemObject
    Dim dirName As String
     
    'Some Set Ups
    Set fso = CreateObject(Class:="Scripting.FileSystemObject")
    Set ol = CreateObject(Class:="Outlook.Application")
    Set ns = ol.GetNamespace("MAPI")
    Set inboxFol = ns.GetDefaultFolder(6) 'olFolderInbox
    Set moveToFolder = ns.Folders("MainFolderName").Folders("MoveToFolderName") 'change the folder names accordingly
    
    dirName = "D:\XYZ"
    If Not fso.FolderExists(dirName) Then
        fso.CreateFolder dirName
    End If

    'Finding the search item from Oulook Inbox
    For Each itm In inboxFol.Items
        If itm.Class = 43 Then
            Set mi = itm
            If mi.Attachments.Count > 0 And InStr(mi.SenderEmailAddress, "xxxxxxx@inc.ae") Then
                'Saving Attachments to a folder
                For Each att In mi.Attachments
                    If Right(att.Filename, 4) = "xlsm" Then
                        att.SaveAsFile dirName & "\" & Range("Ad2").Text & ".xlsm"
                    End If
                Next att
                'Move mail item to destination folder
                mi.Move moveToFolder
            End If
        End If
    Next itm
End Sub