outlook vba选择子文件夹中的消息

Question

Outlook 2007配置了两个电子邮件帐户：

• 帐户#1:Hotmail
• 账号#2：Gmail

我想创建一个名为模拟用户执行以下操作的宏：

• 左键单击hotmail或gmail帐户中的
• 突出显示以前选择的文件夹中的所有邮件
• 显示一个messageBox，其中包含从此文件夹中选择的电子邮件数

我尝试了几种方法来定义文件夹，但都不起作用。我怀疑它会在默认的PST上工作，但这不是我使用的。甚至尝试使用下面的方法来识别我想要使用的特定文件夹。它确实打印出了一个路径，但我不能直接将其用作变量值。

有什么建议吗？

===信息===

以下宏用于获取有关帐户的信息&文件夹位置：http://www.gregthatcher.com/Scripts/VBA/Outlook/GetFolderInfo.aspx

1. Hotmail
   • 姓名：aaaaa
   • 文件夹路径：\@hotmail.com\aaaa

-

2. Gmail
   • 姓名：bbbbb
   • 文件夹路径：\@gmail.com\bbbb

---

' please add your values for Const emailAccount  and  Const folderToSelect
' To begin, launch: start_macro
'
' the macro will loop all folders and will check two things , folder name and account name,
' when both are matched , will make that folder the active one , then will select all emails
' from it and at final will issue number of selected items no other References are required
' than default ones
Option Explicit
#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

' please provide proper values for email account and folder name
Const emailAccount = "[e-mail]"
Const folderToSelect = "folder"

' declare some public variables
Dim mySession As Outlook.NameSpace
Dim myExplorer As Outlook.Explorer
Dim mySelection As Outlook.Selection
Dim my_folder As Outlook.folder
Sub start_macro()
    Dim some_folders As Outlook.Folders
    Dim a_fld As Variant
    Dim fld_10 As Outlook.folder
    Set mySession = Application.Session
    Set some_folders = mySession.Folders
    For Each a_fld In some_folders
        Set fld_10 = a_fld
        Call loop_subfolders_2(fld_10)
    Next a_fld
End Sub
Sub final_sub()
    If Not (my_folder Is Nothing) Then
        Set myExplorer = Application.ActiveExplorer
        Set Application.ActiveExplorer.CurrentFolder = my_folder
        Call select_all_items(my_folder)
    Else
        MsgBox "There is no folder available for specified account !!!"
    End If

    End     'end the macro now
End Sub
Sub loop_subfolders_2(a_folder As Outlook.folder)
    Dim col_folders As Outlook.Folders
    Dim fld_1 As Outlook.folder
    Dim arr_1 As Variant
    Set col_folders = a_folder.Folders
    For Each fld_1 In col_folders
        If Left(fld_1.FolderPath, 2) = "\" Then
            arr_1 = Split(fld_1.FolderPath, "")
            'Debug.Print fld_1.Name & vbTab & arr_1(2) & vbTab & fld_1.FolderPath
            If InStr(LCase(emailAccount), "@gmail.com") > 0 Then
                If LCase(folderToSelect) = LCase(fld_1.Name) Then
                    If LCase(emailAccount) = LCase(arr_1(2)) Or arr_1(2) = "Personal Folders" Then
                        Set my_folder = fld_1
                        Call final_sub
                    Else
                        Call loop_subfolders_2(fld_1)
                    End If
                Else
                    Call loop_subfolders_2(fld_1)
                End If
            Else
                If LCase(folderToSelect) = LCase(fld_1.Name) And LCase(emailAccount) = LCase(arr_1(2)) Then
                    Set my_folder = fld_1
                    Call final_sub
                Else
                    Call loop_subfolders_2(fld_1)
                End If
            End If
        End If
    Next fld_1
End Sub
Sub select_all_items(my_folder As Outlook.folder)
    Dim my_items As Outlook.Items
    Dim an_item As MailItem
    Dim a  As Long, b As Long
    Set my_items = my_folder.Items
    b = my_items.Count
    DoEvents
    'sleep 2000
    Set mySelection = myExplorer.Selection
    If CLng(Left(Application.Version, 2)) >= 14 Then
        On Error Resume Next    '   there are other folders that do not contains mail items
            For Each an_item In my_items
                If myExplorer.IsItemSelectableInView(an_item) Then
                    myExplorer.AddToSelection an_item
                Else
                End If
            Next an_item
        On Error GoTo 0
    Else
        myExplorer.Activate
        If b >= 2 Then
            For a = 1 To b - 1
                SendKeys "{DOWN}"
                'Sleep 50
            Next a
            For a = 1 To b - 1
                 SendKeys "^+{UP}"
'                'Sleep 50
            Next a
        End If
        DoEvents
        'sleep 2000
    End If
    Set my_items = Nothing
    Set mySelection = myExplorer.Selection
    MsgBox mySelection.Count
End Sub

Answer 1

这个能用吗？

Function GetFolder(ByVal FolderPath As String) As Outlook.folder
 Dim TestFolder As Outlook.folder
 Dim FoldersArray As Variant
 Dim i As Integer
On Error GoTo GetFolder_Error
 If Left(FolderPath, 2) = "\" Then
 FolderPath = Right(FolderPath, Len(FolderPath) - 2)
 End If
 'Convert folderpath to array
 FoldersArray = Split(FolderPath, "")
 Set TestFolder = Application.Session.Folders.item(FoldersArray(0))
 If Not TestFolder Is Nothing Then
 For i = 1 To UBound(FoldersArray, 1)
 Dim SubFolders As Outlook.Folders
 Set SubFolders = TestFolder.Folders
 Set TestFolder = SubFolders.item(FoldersArray(i))
 If TestFolder Is Nothing Then
 Set GetFolder = Nothing
 End If
 Next
 End If
 'Return the TestFolder
 Set GetFolder = TestFolder
 Exit Function
GetFolder_Error:
'MsgBox ("Ordner für verschieben nicht gefunden")
 Set GetFolder = Nothing
 Exit Function
End Function

对我来说，这适用于所有文件夹，无论是主框还是其他框（但所有文件夹都是Exchange，但我不认为这很重要）

例如，这些工作：

Set mailitem.SaveSentMessageFolder = GetFolder(mailitem.SentOnBehalfOfName & "inbox")
Dim Subfolder As Outlook.MAPIFolder
Set Subfolder = GetFolder(olfolder.FullFolderPath & "erledigt")

Dim Subfolder As Outlook.MAPIFolder
Set Subfolder = GetFolder("someaccountinbox")