Question

我编辑了一个我在网上找到的脚本，可以将电子邮件移到各种文件夹中。

我想进一步将电子邮件移动到单独的PST文件中的文件夹中。

这将在Outlook 2007中运行。

该宏来自这个标题为“已更新”的宏，并且是更清晰的版本：
http://jmerrell.com/2011/05/21/outlook-macros-move-email

我几乎可以肯定这个链接有线索，但我没有经验来正确应用它：
http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/

我当前的宏允许将电子邮件移动到主PST“收件箱”文件夹中的3个不同文件夹位置。

'Outlook VB Macro to move selected mail item(s) to a target folder
Sub MoveToFolder(targetFolder)
On Error Resume Next

Dim ns As Outlook.NameSpace
Dim MoveToFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem

Set ns = Application.GetNamespace("MAPI")

'define path to the target folder; the following assumes the target folder
'is a sub-folder of the main Mailbox folder

'This is the original'
'Set MoveToFolder = ns.Folders("Mailbox").Folders(targetFolder)'
Set MoveToFolder = ns.GetDefaultFolder(olFolderInbox).Folders(targetFolder)


If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox ("No item selected")
    Exit Sub
End If

If MoveToFolder Is Nothing Then
    MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
End If

For Each objItem In Application.ActiveExplorer.Selection
    If MoveToFolder.DefaultItemType = olMailItem Then
        If objItem.Class = olMail Then
            objItem.Move MoveToFolder
        End If
    End If
Next

Set objItem = Nothing
Set MoveToFolder = Nothing
Set ns = Nothing

End Sub

Sub MoveToActive()
MoveToFolder ("Active")
End Sub

Sub MoveToAction()
MoveToFolder ("Action")
End Sub

Sub MoveToOnHold()
MoveToFolder ("OnHold")
End Sub

如何配置第4个选项以将电子邮件移动到其他PST中的文件夹？

例如，我想添加一个名为“存档”的额外按钮，当点击此特定按钮时，它会将电子邮件移动到单独的PST收件箱中的存档文件夹。

Sub MoveToArchive()
MoveToFolder ("Archive")
End Sub

Answer 1

这是一个古老的问题，但这是一个对我有用的解决方案，它从几个来源修改了代码。您可以根据需要对其进行修改。

这允许用户选择任何文件夹，无论是在默认位置下，还是在另一个存档或PST文件中。如果用户在文件夹选择器中选择“取消”，则电子邮件将保存到默认的已发送邮件文件夹中。

Private Sub Application_ItemSend(ByVal Item As Object, _
                                 Cancel As Boolean)
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
    On Error Resume Next
    Set objNS = Application.Session
    If Item.Class = olMail Then
        Set objFolder = objNS.PickFolder

        'save to a folder under the default structure, main PST/archive
        If Not objFolder Is Nothing And IsInDefaultStore(objFolder) And objFolder.DefaultItemType = olMailItem Then
            Set Item.SaveSentMessageFolder = objFolder

        'save to a non-default, different PST/archive
        ElseIf Not IsInDefaultStore(objFolder) Then
            Set objFolder = GetFolderFromPath(objFolder.FolderPath)
            Set Item.SaveSentMessageFolder = objFolder

        'neither, just save to default sent items folder
        Else
            Set objFolder = objNS.GetDefaultFolder(olFolderSentMail)
            Set Item.SaveSentMessageFolder = objFolder
        End If
    End If
    Set objFolder = Nothing
    Set objNS = Nothing
End Sub

Public Function IsInDefaultStore(objOL As Object) As Boolean
    Dim objApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objInbox As Outlook.MAPIFolder
    Dim blnBadObject As Boolean
    On Error Resume Next
    Set objApp = objOL.Application
    If Err = 0 Then
        Set objNS = objApp.Session
        Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
        Select Case objOL.Class
            Case olFolder
                If objOL.StoreID = objInbox.StoreID Then
                    IsInDefaultStore = True
                Else
                    IsInDefaultStore = False
                End If
            Case olAppointment, olContact, olDistributionList, _
                 olJournal, olMail, olNote, olPost, olTask
                If objOL.Parent.StoreID = objInbox.StoreID Then
                    IsInDefaultStore = True
                Else
                    IsInDefaultStore = False
                End If
            Case Else
                blnBadObject = True
        End Select
    Else
        blnBadObject = True
    End If
    If blnBadObject Then
        'if cancel is selected then just leave in sent items, so do nothing.
'        MsgBox "This function isn't designed to work " & _
'               "with " & TypeName(objOL) & _
'                " objects and will return False.", _
'                , "IsInDefaultStore"
        IsInDefaultStore = False
    End If
    Set objApp = Nothing
    Set objNS = Nothing
    Set objInbox = Nothing
End Function

'modified from https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
Function GetFolderFromPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer

    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderFromPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderFromPath = oFolder
    Exit Function

GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

将电子邮件移动到其他数据/ PST文件

1 个答案: