Outlook 2007 is configured with two email accounts:
I would like to create a macro named simulating a user doing the following:
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
-
' 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 = "[email protected]"
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")