outlook vba在子文件夹中选择消息 [英] outlook vba select messages in sub-folder

问题描述

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

• 帐户1：Hotmail


• 帐户2：Gmail

我想创建一个名为模拟用户的宏来完成以下操作：

• 在hotmail或gmail帐户中左键单击。


• 突出显示以前选择的文件夹中的所有消息。
>

• 显示带有从此文件夹中选择的电子邮件数量的messageBox
  

我尝试了几种方法来定义该文件夹，但它不工作。我怀疑它会在默认的PST上工作，但那不是我正在使用的。即使尝试使用下面的方法来确定我想要使用的特定文件夹。它确实打印出一条路径，但我无法直接使用它作为变量值。

有什么建议？

===信息===

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

1. Hotmail
   
   
   
   • aaaaa
   
   
   • FolderPath：\@hotmail.com\aaaaa
   
   

-

2. Gmail
   
   
   
   • 名称：bbbbb
   
   
   • FolderPath：\@gmail.com\bbbbb
   
   

---

 '请将您的值添加到Const emailAccount和Const folderToSelect 
'首先，启动：start_macro 
'
'宏将循环所有文件夹，并将检查两件事情，文件夹名称和帐户名称，
'当两者匹配时，将使该文件夹成为活动文件夹，然后将从中选择所有电子邮件
'，并在最后发行选定项目的数量不需要其他引用
'比def ault 
 
 Option Explicit 
 
 #If VBA7 Then 
 Public Declare PtrSafe Sub Sleep Libkernel32（ByVal dwMilliseconds As LongPtr）'For 64 Bit Systems 
 #Else 
公共声明子睡眠库kernel32（ByVal dwMilliseconds As Long）'用于32位系统
 #End如果
 
 
 
 '请为电子邮件帐户和文件夹名称提供适当的值
 Const emailAccount =[e-mail]
 Const folderToSelect =文件夹
 
 
 
'声明一些公共变量
 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在some_folders中
 Set fld_10 = a_fld 
调用loop_subfolders_2（fld_10）
下一个a_fld 
 
结束Sub 
 
 Sub final_sub（）
如果不是（my_folder是Nothing ）然后
设置myExplorer = Application.ActiveExplorer 
设置Application.ActiveExplorer.CurrentFolder = my_folder 
调用select_all_items（my_folder）
 Else 
 MsgBox没有可用的文件夹指定账户!!! 
 End If 
 
 
 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 
 
对于每个fld_1在col_folders中
如果为Left（fld_1.FolderPath，2）=\\则
 arr_1 = Split（fld_1.FolderPath，\）
'Debug.Print fld_1.Name& vbTab& arr_1（2）& vbTab& fld_1.FolderPath 
如果InStr（LCase（emailAccount），@ gmail.com）> 0然后
如果LCase（folderToSelect）= LCase（fld_1.Name）然后
如果LCase（emailAccount）= LCase（arr_1（2））或arr_1（2）=个人文件夹则
设置my_folder = fld_1 
调用final_sub 
否则
调用loop_subfolders_2（fld_1）
 End If 
否则
调用loop_subfolders_2（fld_1）
 End如果
否则
如果LCase（folderToSelect）= LCase（fld_1.Name）和LCase（emailAccount）= LCase（arr_1（2））然后
 Set my_folder = fld_1 
 Call final_sub 
其他
呼叫loop_subfolders_2（fld_1）
结束如果
结束如果
结束如果
下一个fld_1 
 
结束Sub 
 
 Sub select_all_items（my_folder作为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 
 
如果CLng（Left（Application.Version，2））> = 14那么
 On Error继续下一步还有其他文件夹不包含邮件项目
对于每个an_item在my_items 
如果myExplorer.IsItemSelectableInView（an_item）然后
 myExplorer.AddToSelection an_item 
其他
结束如果
下一个an_item 
出错转到0 
其他
 myExplorer.Activate 
如果b> = 2那么
对于a = 1到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 
设置mySelection = myExplorer.Selection 
 MsgBox mySelection.Count 
 
 End Sub 
  

 函数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）=\\然后
FolderPath = Right（FolderPath，Len（FolderPath） - 2）
End If
'将folderpath转换为数组
FoldersArray = Split （FolderPath，\）
Set TestFolder = Application.Session.Folders.item（FoldersArray（0））
如果Not TestFolder是Nothing然后
For i = 1 To UBound（FoldersArray ，1）
Dim SubFolders As Outlook.Folders
Set SubFolders = TestFolder.Folders
Set TestFolder = SubFolders.item（FoldersArray（i））
如果TestFolder是Nothing然后
Set GetFolder = Nothing
End If
下一个
结束如果
'返回TestFolder
Set GetFolder = TestFolder
退出函数

GetFolder_Error：
'MsgBox（Ordner ）
Set GetFolder = Nothing
Exit Function
End Function


对我来说，这适用于所有文件夹，无论是Primary还是其他Box（但它们都是Exchange，但我不认为这些文件）

如这些工作：

pre $ 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（someaccount \inbox）


Outlook 2007 is configured with two email accounts:

• Account#1: Hotmail
• Account#2: Gmail

I would like to create a macro named simulating a user doing the following:

• Left click on a within either the hotmail or gmail account.
• Highlight all messages within the folder previously selected.
• display a messageBox with the number of emails selected from this folder

I have tried several methods to define the folder, but its not working. My suspicion is it would work on the default PST, but that isn't what I'm using. Even tried using the method below to identify the specific folder I want to use. It does print out a path, but I am not able to use that as a variable value directly.

Any suggestions?

=== Information ===

The following macro was used to obtain information about the account & folder locations: http://www.gregthatcher.com/Scripts/VBA/Outlook/GetFolderInfo.aspx

1. Hotmail
   • Name: aaaaa
   • FolderPath: \@hotmail.com\aaaaa

-

2. Gmail
   • Name: bbbbb
   • FolderPath: \@gmail.com\bbbbb

---

' 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

解决方案

does this one work?

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

for me this works with all Folders, no matter if Primary or other box (but all of them being Exchange, but I do not think this maters)

e.g. These work:

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("someaccount\inbox")

这篇关于outlook vba在子文件夹中选择消息的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！