On a shared inbox account, I would like to run a script if the email is unread.
I tried this:
Sub UnreadMail()
Dim myEmail As Object
Dim myNamespace As Object
Dim myFolder As Folder
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
For Each myEmail In myFolder
If (myEmail.UnRead) Then
Call SaveAttachToDisk
End If
Next
End Sub
You almost got it, Try using GetSharedDefaultFolder Look at MSDN GetSharedDefaultFolder Method
Option Explicit
Sub UnreadMail()
Dim olNameSpace As Outlook.NameSpace
Dim olShareName As Outlook.Recipient
Dim olShareInbox As Outlook.Folder
Dim olItem As Outlook.MailItem
Set olNameSpace = Application.GetNamespace("MAPI")
Set olShareName = olNameSpace.CreateRecipient("Om3r#Email.com") 'address
Set olShareInbox = olNameSpace.GetSharedDefaultFolder(olShareName, olFolderInbox) 'Inbox
For Each olItem In olShareInbox.Items
If (olItem.UnRead) Then
'Call SaveAttachToDisk
Debug.Print olItem '// Print UnRead Item to Immediate window
End If
Next
End Sub
Related
Im stuck with problem to move active email to subfolder in inbox.
Need to replace ("xxxx#xxx.xxx") to something as olFolderInbox or inbox, etc without type specific email adress in VBA code.
Dim objMail As Outlook.MailItem
Dim objNS As Outlook.NameSpace
Dim objFolderItem As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Set objFolderItem = objNS.Folders.Item("xxxx#xxx.xxx").Folders.Item("tmp")
objMail.Move objMoveItem
Try this
Option Explicit
Public Sub Exampls()
Dim olNs As Outlook.NameSpace
Set olNs = Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim Item As MailItem
Set Item = ActiveExplorer.selection(1)
Item.Move Inbox.Folders("Temp")
End Sub
I have two accounts open in Outlook.
When I send a Mail via the secondary account it appears in the sent folder of the primary account.
I want to move the sent mail to the sent folder of the secondary account whenever I send mail.
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Folder As Outlook.Folder
If TypeName(Item) = "MailItem" Then
If Item.SenderName = "MY SECONDARY EMAIL" Then
Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Dim newFolder As Outlook.Folder
Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("mysecondary#email.de")
objOwner.Resolve
If objOwner.Resolved Then
Set newFolder = NS.GetSharedDefaultFolder(objOwner, olFolderSentMail)
MsgBox (newFolder)
Item.Move newFolder
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
I get this Error message:
-2147024809 - Unfortunately there is a problem. You can try again
It shows that the line Set newFolder = NS.GetSharedDefaultFolder(objOwner, olFolderSentMail) is causing this problem.
The error is MAPI_E_INVALID_PARAMETER. Most likely that means the specified mailbox is not an Exchange mailbox or it belongs to a different Exchange org.
If that mailbox is already opened in the current profile, you can access that Store object (and use Store.GetDefaultFolder) from the Namespace.Stores collection.
Dmitry Streblechenko's answer worked!
Here is how I did it if anyone got the same problem:
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Sub inboxItems_ItemAdd(ByVal Item As Object)
If TypeName(Item) = "MailItem" Then
If Item.SenderName = "SENDERNAME" Then
Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Dim newFolder As Outlook.Folder
Dim colStores As Outlook.Stores
Dim oStore As Outlook.Store
Dim oRoot As Outlook.Folder
Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("secondary#email.de")
Set colStores = Application.Session.Stores
For Each oStore In colStores
Set oRoot = oStore.GetRootFolder
If oStore = "SECONDARY EMAIL NAME" Then
Call EnumerateFolders(oRoot, Item)
End If
Next
End If
End If
End Sub
Sub EnumerateFolders(ByVal oFolder As Outlook.Folder, Item)
Dim folders As Outlook.folders
Dim Folder As Outlook.Folder
Dim foldercount As Integer
Set folders = oFolder.folders
foldercount = folders.Count
For Each Folder In folders
If Folder.FolderPath = "\\SECONDARY EMAIL NAME\Sent Items" Then
Item.Move Folder
End If
Next
End Sub
I want a macro/rule/code that creates a folder in Outlook based on the sender's domain, after that I want it to create a folder based on the sender's name in the sender's domain folder, and then move the mail to that folder.
I am thinking of a folder layout like this:
Inbox\#senders domain\#Senders name\Email.msg
Please refer to this code, however, you may need to change something as your special request.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
' set object reference to default Inbox
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
' fires when new item added to default Inbox
' (per Application_Startup)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String
' don't do anything for non-Mailitems
If TypeName(item) <> "MailItem" Then GoTo ProgramExit
Set Msg = item
' move received email to target folder based on sender name
senderName = Msg.senderName
If CheckForFolder(senderName) = False Then ' Folder doesn't exist
Set targetFolder = CreateSubFolder(senderName)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = _
objNS.GetDefaultFolder(olFolderInbox).Folders(senderName)
End If
Msg.Move targetFolder
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error Goto 0
If Not FolderTocheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
More information, please see,
Create new folder for new sender name and move message into new folder
I have an email account "Fred.Smith#domain.co.uk" (domain being made up).
Outlook shows an archive named " Archive - Fred.Smith#domain.co.uk" where Outlook automatically moves emails after a certain period.
Current code:
Set olRecip = olNS.CreateRecipient("Archive - Fred.Smith#domain.co.uk")
olRecip.Resolve
Set olFolder = olNS.GetSharedDefaultFolder(olRecip, olFolderInbox)
This opens the main inbox. How do I select the archive folder?
"Archive" folder is usually at the root level - like inbox
in that case:
Sub ArchiveItems()
' Moves each of the selected items on the screen to an Archive folder.
Dim olApp As New Outlook.Application
Dim olExp As Outlook.Explorer
Dim olSel As Outlook.Selection
Dim olNameSpace As Outlook.NameSpace
Dim olArchive As Outlook.Folder
Dim intItem As Integer
Set olExp = olApp.ActiveExplorer
Set olSel = olExp.Selection
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArchive = olNameSpace.Folders("myMail#mail.com").Folders("Archive")
For intItem = 1 To olSel.Count
olSel.Item(intItem).Move olArchive
Next intItem
End Sub
to get Inbox you could use default access:
Dim olInbox As Outlook.Folder
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
Note - This will get you the default Inbox folder, if you have a few accounts in outlook you should verify it's really the folder you want - or use the mail specific approach like in Archive folder above
For Debugging - if you want to check all available subfolders
For i = 1 To olInbox.Folders.Count
Debug.Print olInbox.Folders(i).Name
Next i
Should be
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Set ARCHIVE_FOLDER = olNs.Folders("Archive - Fred.Smith#domain.co.uk")
Full Example
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim i As Long
Set olNs = Application.Session
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Set ARCHIVE_FOLDER = olNs.Folders("Archive - Fred.Smith#domain.co.uk") _
.Folders("Inbox")
Debug.Print ARCHIVE_FOLDER.Name
Debug.Print ARCHIVE_FOLDER.FolderPath
Debug.Print ARCHIVE_FOLDER.Store.DisplayName
ARCHIVE_FOLDER.Display
Set Items = ARCHIVE_FOLDER.Items
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject
Next
End Sub
MAPIFolder Object
I am using the following vba code to get emails from my inbox folder and move them to a sub folder called suppliers. At the moment the emails are moved from my default email inbox, but I have an account called purcashing#hewden.co.uk and I want it to get the emails from this inbox and move it to the subfolder called Suppliers in this account.
can someone show me how I would alter GetDefaultFolder to make this happen. thanks
Sub MoveItems()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myInbox.Folders("Supplier")
Set myItem = myItems.Find("[Subject] = 'Introduction'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
Instead of using Namespace.GetDefaultFolder, retrieve the appropriate store from the Namespace.Stores collection and use Store.GetDefaultFolder.
I just used Dmitry's suggestion and it works like a charm.
Hope it helps \o/
Sub GetEmailFromNonDefaultInbox()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim strFilter As String
' let the user choose which account to use
Set myAccounts = myOlApp.GetNamespace("MAPI").Stores
For i = 1 To myAccounts.count
res = MsgBox(myAccounts.Item(i).DisplayName & "?", vbYesNo)
If res = vbYes Then
Set myInbox = myAccounts.Item(i).GetDefaultFolder(olFolderInbox)
Exit For
End If
Next
If myInbox Is Nothing Then Exit Sub ' avoid error if no account is chosen
' query emails by subject
strFilter = "#SQL=""urn:schemas:httpmail:subject"" like '%YOUR SUBJECT%'"
Set myitems = myInbox.Items.Restrict(strFilter)
' show some feedback if no email is found
If myitems.count = 0 Then
MsgBox "Nothing found. Try another account."
Exit Sub
End If
' get the most recent email
myitems.Sort "ReceivedTime", True
Set myitem = myitems.GetFirst
If myitem.Class = olMail Then
' and now you can do whatever you want
MsgBox (myitem.Subject)
End If
End Sub