前景VBA選擇訊息

Question

Outlook 2007中配置了兩個電子郵件帳戶：

• 帳號1：Hotmail的
• 帳號2：Gmail的

我想創建一個名爲模擬用戶執行以下操作的宏：

• 左鍵單擊hotmail或gmail帳戶中的某個。
• 突出顯示先前選擇的文件夾內的所有消息。
• 顯示從該文件夾

我嘗試了好幾種方法來定義的文件夾選擇電子郵件的數量的消息框，但它不工作。我懷疑它會在默認的PST上工作，但那不是我正在使用的。即使嘗試使用下面的方法來確定我想要使用的特定文件夾。它確實打印出一條路徑，但我無法直接使用它作爲變量值。

有什麼建議嗎？

===信息===

下面的宏被用來獲取有關帳戶&文件夾位置信息： http://www.gregthatcher.com/Scripts/VBA/Outlook/GetFolderInfo.aspx

1. 的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 

對我來說這適用於所有的文件夾，無論小學或其他盒子（但它們都是兌換，但我不認爲這事宜中）

例如這些工作：

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")