Question

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

帐户＃1：Hotmail
帐户＃2：Gmail

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

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

我已经尝试了几种方法来定义文件夹，但它无法正常工作。我怀疑它是否适用于默认的PST，但这并不是我所使用的。甚至尝试使用下面的方法来识别我想要使用的特定文件夹。它确实打印出一条路径，但我无法直接将其用作变量值。

有什么建议吗？

===信息===

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

的Hotmail
- 姓名：aaaaa
- FolderPath：\ @ hotmail.com \ aaaaa

-

的Gmail
- 姓名：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 = "username@hotmail.com"
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，但我不认为这是主要的）

e.g。这些工作：

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选择子文件夹中的消息

1 个答案: