How to setup VBscript to run in a specific folder in Outlook [duplicate] - vba

How can I in an Outlook VBA macro iterate all email items in a specific Outlook folder (in this case the folder belongs not to my personal inbux but is a sub-folder to the inbox of a shared mailbox.
Something like this but I've never done an Outlook macro...
For each email item in mailboxX.inbox.mySubfolder.items
// do this
next item
I tried this but the inbox subfolder is not found...
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders("myGroupMailbox")
Set objFolder = objFolder.Folders("Inbox\mySubFolder1\mySubFolder2")
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If new_msg.Subject Like "*myString*" Then
strBody = myItem.Body
Dim filePath As String
filePath = "C:\myFolder\test.txt"
Open filePath For Output As #2
Write #2, strBody
Close #2
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
Next Item
End Sub

In my case the following worked:
Sub ListMailsInFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Foldername").Folders("Subfoldername")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Likewise, you can as well iterate through calender items:
Private Sub ListCalendarItems()
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olRecItems = olNS.GetDefaultFolder(olFolderTasks)
strFilter = "[DueDate] > '1/15/2009'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
For Each Item In olFilterRecItems
If TypeName(Item) = "TaskItem" Then
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Note that this example is using filtering and also .GetDefaultFolder(olFolderTasks) to get the builtin folder for calendar items. If you want to access the inbox, for example, use olFolderInbox.

The format is:
Set objFolder = objFolder.Folders("Inbox").Folders("mySubFolder1").Folders("mySubFolder2")
As advised in a comment "move the next item line to before the ProgramExit label"

Sub TheSub()
Dim objNS As Outlook.NameSpace
Dim fldrImAfter As Outlook.Folder
Dim Message As Outlook.MailItem
'This gets a handle on your mailbox
Set objNS = GetNamespace("MAPI")
'Calls fldrGetFolder function to return desired folder object
Set fldrImAfter = fldrGetFolder("Folder Name Here", objNS.Folders)
For Each Message In fldrImAfter.Items
MsgBox Message.Subject
Next
End Sub
Recursive function to loop over all folders until the specified folder name is found....
Function fldrGetFolder( _
strFolderName As String _
, objParentFolderCollection As Outlook.Folders _
) As Outlook.Folder
Dim fldrSubFolder As Outlook.Folder
For Each fldrGetFolder In objParentFolderCollection
'MsgBox fldrGetFolder.Name
If fldrGetFolder.Name = strFolderName Then
Exit For
End If
If fldrGetFolder.Folders.Count > 0 Then
Set fldrSubFolder = fldrGetFolder(strFolderName,
fldrGetFolder.Folders)
If Not fldrSubFolder Is Nothing Then
Set fldrGetFolder = fldrSubFolder
Exit For
End If
End If
Next
End Function

Related

Set mails read if they were read in another folder

I'm trying to make an outlook macro, which will 'update' the mails. I have an Inbox folder and an another one. (2 mail accunts)
There is a rule, which is copying the mail from another folder to my inbox.
My goal is to set the mail as read in another folder, if it was read in the Inbox folder.
Sub precitane()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim mydeffolder As Outlook.Folder
Dim items As Object
Dim defitems As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myDestFolder = myNameSpace.Folders("") 'mymail
Set mydeffolder = myNameSpace.GetDefaultFolder(olFolderInbox)
For Each items In myDestFolder.items
For Each defitems In mydeffolder.items
If TypeOf items Is Outlook.MailItem & TypeOf defitems Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = items
Dim defMail As Outlook.MailItem: Set defMail = defitems
If oMail.SenderEmailAddress = "" & defMail.SenderEmailAddress = "" & defMail.Body = oMail.Body & defMail.UnRead = False Then
oMail.UnRead = True
oMail.Save
End If
End If
Next
Next
On Error GoTo 0
End Sub
"" contains my mail...
It looks like you tried with code from other than VBA.
I broke the If statement into separate parts as it is easier to follow and to debug.
Option Explicit
Sub precitane()
Dim myDestFolder As Folder
Dim mydeffolder As Folder
Dim item As Object
Dim defItem As Object
Set myDestFolder = Session.Folders("mailAddress2").Folders("Inbox").Folders("Test")
Set mydeffolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test3")
For Each item In myDestFolder.items
If TypeOf item Is MailItem Then
For Each defItem In mydeffolder.items
If TypeOf defItem Is MailItem Then
If item.senderEmailAddress = defItem.senderEmailAddress Then
If item.Body = defItem.Body Then
If item.UnRead = False Then
defItem.UnRead = False
'If necessary
'item.Save
Exit For
End If
End If
End If
End If
Set defItem = Nothing
Next
End If
Set item = Nothing
Next
Debug.Print "Done."
End Sub

Folder path to enterprise vault using VBA for email migration

I have a long list of folders and to many rules for outlook to handle using the standard rules manager. I wrote code that would classify and move items to folders but recently I was migrated to an Enterprise Vault. I am trying to find the folder path to update my code. I tried something like
Outlook.Application.GetNamespace("MAPI").Folders("Vault - DOE, JOHN").Folders("My Migrated PSTs").Folders("PR2018")
but honestly I have no idea what the correct path should be. Everything I find online deals with pulling selected items out of the vault and not moving items into it. Below is an excerpt of the existing code. This is on Office 365/Outlook 2016.
Sub Sort_Test(Item)
Dim Msg As Object
Dim Appt As Object
Dim Meet As Object
Dim olApp As Object
Dim objNS As Object
Dim targetFolder As Object
On Error GoTo ErrorHandler
Set Msg = Item
Set PST = Outlook.Application.GetNamespace("MAPI").Folders("PR2018")
checksub = Msg.Subject
checksend = Msg.Sender
checksendname = Msg.SenderName
checksendemail = Msg.SenderEmailAddress
checkbod = Msg.Body
checkto = Msg.To
checkbcc = Msg.BCC
checkcc = Msg.CC
checkcreation = Msg.CreationTime
checksize = Msg.Size
'Classes Folder
If checksub Like "*Files*Lindsey*" Or checksub Like "*Course Login*" _
Or checksend Like "*Award*eBooks*" Then
Set targetFolder = PST.Folders("Education").Folders("Classes")
Msg.Move targetFolder
GoTo ProgramExit
End If
If targetFolder Is Nothing Then
GoTo ProgramExit
' Else
' Msg.Move targetFolder
End If
' Set olApp = Nothing
' Set objNS = Nothing
Set targetFolder = Nothing
Set checksub = Nothing
Set checksend = Nothing
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Try this code:
Sub MoveToFolder()
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim M As Integer
Dim iCount As Integer
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Archived")
Set olCompFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Computer")
For M = 1 To olArcFolder.items.Count
Set myItem = olArcFolder.items(M)
myItem.Display
Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
Set myCopiedInspectors = myInspectors.copy
myCopiedInspectors.Move olCompFolder
myInspectors.Close olDiscard
Next M
Here is a link for you reference:
Do for all open emails and move to a folder

How to use "Always Move Messages in This Conversation" feature from VBA in MS Outlook?

I'm trying to implement a search and move feature in MS Outlook. Search is OK, it works like charm. But, I can find only the Move function to move message into an Outlook folder.
I use the Always Move Messages in This Conversation feature manually. Now, I'd like to use it from macro. Is there any way to use this feature from VBA?
Here is the current implementation but it uses the simple Move feature:
Private Sub btn_Click()
Dim currentMail As Object
Dim F As Outlook.MAPIFolder
Dim Msg$
Set currentMail = Application.ActiveWindow
If TypeOf currentMail Is Outlook.Inspector Then
Set currentMail = obj.CurrentItem
Else
Set currentMail = obj.Selection(1)
End If
currentMail.Move Folder
End Sub
This is what you want
Dim currentMail As MailItem
Dim conv As Conversation
Dim myFolder As Folder 'you have to set it to your target folder
Set conv = currentMail.GetConversation
conv.SetAlwaysMoveToFolder myFolder, myFolder.Store
Not sure if this is what your asking but here is how to move outlook messages in some conversations to sub-folder.
Update SubFolder = Inbox.Folders("Temp") Temp folder
Code will search all messages in same conversation in your outlook and then move it to Temp folder
Option Explicit
Sub MoveConv()
Dim olNs As NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim SelectedItem As Object
Dim Item As Outlook.MailItem ' Mail Item
Dim Folder As Outlook.MAPIFolder ' Current Item's Folder
Dim Conversation As Outlook.Conversation ' Get the conversation
Dim ItemsTable As Outlook.Table ' Conversation table object
Dim MailItem As Object
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
' On Error GoTo MsgErr
' // Must Selected Item.
Set SelectedItem = Application.ActiveExplorer.Selection.Item(1)
' // If Item = a MailItem.
If TypeOf SelectedItem Is Outlook.MailItem Then
Set Item = SelectedItem
Set Conversation = Item.GetConversation
If Not IsNull(Conversation) Then
Set ItemsTable = Conversation.GetTable
For Each MailItem In Conversation.GetRootItems ' Items in the conversation.
If TypeOf MailItem Is Outlook.MailItem Then
Set Item = MailItem
Set Folder = Item.Parent
Set SubFolder = Inbox.Folders("Temp") ' Move to Temp Folder
Debug.Print Item.ConversationID & " In Folder " & Folder.Name
GetConv Item, Conversation
Item.Move SubFolder
End If
Next
End If
End If
MsgErr_Exit:
Set olNs = Nothing
Set Inbox = Nothing
Set Item = Nothing
Set SelectedItem = Nothing
Set MailItem = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "Err." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
Function GetConv(Item As Object, Conversation As Outlook.Conversation)
Dim Items As Outlook.SimpleItems
Dim MailItem As Object
Dim Folder As Outlook.Folder
Dim olNs As NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Conversation.GetChildren(Item)
If Items.Count > 0 Then
For Each MailItem In Items
If TypeOf MailItem Is Outlook.MailItem Then
Set Item = MailItem
Set Folder = Item.Parent
Set SubFolder = Inbox.Folders("Temp")
Debug.Print Item.ConversationID & " In Folder " & Folder.Name
Item.Move SubFolder
End If
GetConv Item, Conversation
Next
End If
End Function

Why can't I access subfolders of a shared mailbox?

My goal is to create a VBA script that fires when a new e-mail arrives to a shared mailbox and does the following things if the title contains specific text:
1. Moves the message to a specified subfolder
2. Saves all Excel attachments to a Desktop folder.
After doing considerable research I came up with the following code and pasted into ThisOutlookSession:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim myOlApp As Outlook.Application
Dim myNms As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myitem As Object
Dim myRecipient As Outlook.Recipient
Dim myExplorer As Outlook.Explorer
Dim SharedFolder As Outlook.MAPIFolder
Dim oMoveTarget As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNms = myOlApp.GetNamespace("MAPI")
Set myFolder = myNms.GetDefaultFolder(olFolderInbox)
Set myExplorer = myOlApp.ActiveExplorer
Set myExplorer.CurrentFolder = myFolder
Set myRecipient = myNms.CreateRecipient("shared mailbox")
Set SharedFolder = myNms.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Set oMoveTarget = SharedFolder.Folders("specific subfolder where messages should be moved")
Set Items = SharedFolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim att As Attachment
Dim FileName As String
Dim intFiles As Integer
Dim myOlApp As Outlook.Application
Dim myNms As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myitem As Object
Dim myRecipient As Outlook.Recipient
Dim myExplorer As Outlook.Explorer
Dim SharedFolder As Outlook.MAPIFolder
Dim oMoveTarget As Outlook.MAPIFolder
If TypeName(item) = "MailItem" Then
Set Msg = item
If InStr(1, item.Subject, "specific text in subject") > 0 Then
For Each att In item.Attachments
If InStr(att.DisplayName, ".xlsx") Then
FileName = "folderpath to desktop location\" & Trim(att.FileName)
att.SaveAsFile FileName
intFiles = intFiles + 1
End If
Next
item.Move oMoveTarget
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I get the following error message when I try to run the code manually (F5) or when Outlook is restarted:
Run-time error '-2147221233 (8004010f)':
The attempted operation failed.
An object could not be found.
The line where the running is stopped is when the specific subfolder (oMoveTarget) is set in Private Sub Application_Startup().
If I omit (or comment out) the reference to a subfolder, the script works: Excel attachments from incoming e-mails to the shared mailbox with a specific subject are saved.
I am allowed to access and run a script on a shared mailbox, but I am denied access to its subfolders.
Is "Download shared folders" check box checked on the Advanced tab of your Exchange account properties dialog?
Try to uncheck it.

Iterate all email items in a specific Outlook folder

How can I in an Outlook VBA macro iterate all email items in a specific Outlook folder (in this case the folder belongs not to my personal inbux but is a sub-folder to the inbox of a shared mailbox.
Something like this but I've never done an Outlook macro...
For each email item in mailboxX.inbox.mySubfolder.items
// do this
next item
I tried this but the inbox subfolder is not found...
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders("myGroupMailbox")
Set objFolder = objFolder.Folders("Inbox\mySubFolder1\mySubFolder2")
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If new_msg.Subject Like "*myString*" Then
strBody = myItem.Body
Dim filePath As String
filePath = "C:\myFolder\test.txt"
Open filePath For Output As #2
Write #2, strBody
Close #2
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
Next Item
End Sub
In my case the following worked:
Sub ListMailsInFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Foldername").Folders("Subfoldername")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Likewise, you can as well iterate through calender items:
Private Sub ListCalendarItems()
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olRecItems = olNS.GetDefaultFolder(olFolderTasks)
strFilter = "[DueDate] > '1/15/2009'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
For Each Item In olFilterRecItems
If TypeName(Item) = "TaskItem" Then
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Note that this example is using filtering and also .GetDefaultFolder(olFolderTasks) to get the builtin folder for calendar items. If you want to access the inbox, for example, use olFolderInbox.
The format is:
Set objFolder = objFolder.Folders("Inbox").Folders("mySubFolder1").Folders("mySubFolder2")
As advised in a comment "move the next item line to before the ProgramExit label"
Sub TheSub()
Dim objNS As Outlook.NameSpace
Dim fldrImAfter As Outlook.Folder
Dim Message As Outlook.MailItem
'This gets a handle on your mailbox
Set objNS = GetNamespace("MAPI")
'Calls fldrGetFolder function to return desired folder object
Set fldrImAfter = fldrGetFolder("Folder Name Here", objNS.Folders)
For Each Message In fldrImAfter.Items
MsgBox Message.Subject
Next
End Sub
Recursive function to loop over all folders until the specified folder name is found....
Function fldrGetFolder( _
strFolderName As String _
, objParentFolderCollection As Outlook.Folders _
) As Outlook.Folder
Dim fldrSubFolder As Outlook.Folder
For Each fldrGetFolder In objParentFolderCollection
'MsgBox fldrGetFolder.Name
If fldrGetFolder.Name = strFolderName Then
Exit For
End If
If fldrGetFolder.Folders.Count > 0 Then
Set fldrSubFolder = fldrGetFolder(strFolderName,
fldrGetFolder.Folders)
If Not fldrSubFolder Is Nothing Then
Set fldrGetFolder = fldrSubFolder
Exit For
End If
End If
Next
End Function