I'm trying to get my head around how I would write an inbox to maintain an inbox with subfolders listed by domain e.g. :
Inbox->#client1.com->client1 e-mails
I had a poke around on here and this is close to what I'm trying to get at:
Move e-mails by senderemailaddress outlook macro
Option Explicit
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Folder As Outlook.MAPIFolder '<- has been added
Dim olNs As Outlook.NameSpace
Dim Item As Outlook.MailItem
Dim Items As Outlook.Items
Dim lngCount As Long
' On Error GoTo MsgErr
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Folder = Application.Session.PickFolder
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Inbox.Items.Count To 1 Step -1
Set Item = Inbox.Items.Item(lngCount)
Debug.Print Item.Subject
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "bb#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'bb#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
' // Email_Two
Case "aa#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'aa#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
What it is missing is the automation piece however, I'm looking for a "run and file" approach where it checks if the subfolder exists. (e.g. #client1.com)
If the subfolder does exist and the domain matches, move the e-mail there. If it does not, create new subfolder for the client with a new domain and file it in there.
Can anyone assist?
Simply use Right - Len - Instr and Split Function
Example
Dim FolderName As String
FolderName = Right("bb#gmail.com", _
Len("bb#gmail.com") _
- InStr("bb#gmail.com", "#"))
Debug.Print FolderName 'Immediate Window prints gmail.com
FolderName = "#" & FolderName
Debug.Print FolderName 'Immediate Window prints #gmail.com
Once you have FolderName then check if folder Exists or else create one
If FolderExists(Inbox, FolderName) = True Then
Set SubFolder = Inbox.Folders(FolderName)
Else
Set SubFolder = Inbox.Folders.Add(FolderName)
End If
'// Function - Check folder Exist
Private Function FolderExists(Inbox As MAPIFolder, FolderName As String)
Dim Sub_Folder As MAPIFolder
On Error GoTo Exit_Err
Set Sub_Folder = Inbox.Folders(FolderName)
FolderExists = True
Exit Function
Exit_Err:
FolderExists = False
End Function
Your code should look like
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "bb#gmail.com"
' // Set SubFolder of Inbox
Dim FolderName As String
FolderName = Right("bb#gmail.com", _
Len("bb#gmail.com") _
- InStr("bb#gmail.com", "#"))
Debug.Print FolderName 'Immediate Window prints gmail.com
FolderName = "#" & FolderName
Debug.Print FolderName 'Immediate Window prints #gmail.com
'// Check if folder exist else create one
If FolderExists(Inbox, FolderName) = True Then
Set SubFolder = Inbox.Folders(FolderName)
Else
Set SubFolder = Inbox.Folders.Add(FolderName)
End If
Add your Private Function FolderExists after End Sub
Related
I want to autosave attachments from a sub-folder in Outlook.
I need to only save those in mail with a particular subject line (inStr) and the time received, like today.
I have code, but don't know how to add the conditionals, the subject and time received; and I would like to rename the Excel attachment when I save it.
Option Explicit
Const folderPath = "C:\Documents\nike\My Documents\emailTest\"
Sub CompanyChange()
On Error Resume Next
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Dim Inbox As MAPIFolder
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Dim searchFolder As String
searchFolder = InputBox("What is your subfolder name?")
Dim subFolder As MAPIFolder
Dim Item As Object
Dim Attach As Attachment
Dim FileName As String
Dim i As Integer
If searchFolder <> "inbox" Then
Set subFolder = Inbox.Folders(searchFolder)
i = 0
If subFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In subFolder.Items
For Each Attach In Item.Attachments
Attach.SaveAsFile (folderPath & Attach.FileName)
i = i + 1
Next Attach
Next Item
Else
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", _
vbInformation, "Nothing Found"
Exit Sub
End If
On Error Resume Next
For Each Item In Inbox.Items
For Each Attach In Item.Attachments
FileName = folderPath & Attach.FileName
Attach.SaveAsFile FileName
i = i + 1
Next Attach
Next Item
End If
End Sub
Like this:
Place your if condition before the loop that is saving your files.
For Each Item In subFolder.Items
If Item.Subject = "Subject you want to Macth with" Then 'Condition
For Each Attach In Item.Attachments
Attach.SaveAsFile (folderPath & Attach.FileName)
i = i + 1
Next Attach
End If
Next Item
I want to move some messages from Inbox to a subfolder but this code (that I have copied from other forum) is not working. Can you tell me what is going wrong? Do you think it is not working because of the fact that I have two different accounts in this Outlook?
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim Items As Outlook.Items
Dim lngCount As Long
On Error GoTo MsgErr
Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = Application.ActiveExplorer.CurrentFolder
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Inbox.Items.Count To 1 Step -1
Set Item = Inbox.Items.Item(lngCount)
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
'// Email_One
Case "bb"
// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("BB")
Set Item = Items.Find("[SenderEmailAddress] = 'bb#gmail.com'")
If TypeName(Item) <> "Nothing" Then
// Mark As Read
Item.UnRead = False
// Move Mail Item to sub Folder
Item.Move SubFolder
End If
'// Email_Two
Case "aa"
'// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("AA")
Set Item = Items.Find("[SenderEmailAddress] = 'aa#gmail.com'")
If TypeName(Item) <> "Nothing" Then
'// Mark As Read
Item.UnRead = False
'// Move Mail Item to sub Folder
Item.Move SubFolder
End If
Case Else:
Exit Sub
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
Your Select Case is not set correctly-
Case "bb" should be Case "bb#gmail.com" & Case "aa" should be Case "aa#gmail.com"
also Set SubFolder = Inbox.Folders("BB") BB should be your subfolder name
__
Option Explicit
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Folder As Outlook.MAPIFolder '<- has been added
Dim olNs As Outlook.NameSpace
Dim Item As Outlook.MailItem
Dim Items As Outlook.Items
Dim lngCount As Long
' On Error GoTo MsgErr
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Folder = Application.Session.PickFolder
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Inbox.Items.Count To 1 Step -1
Set Item = Inbox.Items.Item(lngCount)
Debug.Print Item.Subject
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "bb#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'bb#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
' // Email_Two
Case "aa#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'aa#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
Working on a macro for Outlook 2007 which selects messages in a folder.
In example 1 and 2 below the customers folder is selected, then a specific customer folder is selected. The method to define the location seems clumsy. Is there a cleaner way to do this?
Right clicking on the sub-folder and selecting properties, the path shown is: "\mailbox-name\customers\customer-xyz". Referencing the path this way in a macro doesn't work. Is it possible to reference the folder location in a more direct manner?
Set olNamespace = olApp.GetNamespace("MAPI")
' Example-1, Select folder by name from default PST inbox
Set FolderKeep = _
olNamespace.GetDefaultFolder(olFolderInbox).Folders("customers").Folders("customer-XYZ")
' Example-2, Select folder by mailbox name/folder/subfolder
Set FolderKeep = _
olNamespace.Folders("mailbox-name").Folders("customers").Folders("customer-XYZ")
A method of pulling the folder out of a path is described here.
http://www.outlookcode.com/d/code/getfolder.htm
Private Function GetFolder(strFolderpath As String) As Folder
' The path argument needs to be in quotation marks and
' exactly match the folder hierarchy that the user sees in the Folder List.
'
' NOTE: If any folder name in the path string contains a "\" character,
' this routine will not work,
'
' As the developer do not use this. It hides errors.
'On Error GoTo GetFolder_Error
Dim objNS As Namespace
Dim objFolder As Folder
Dim arrFolders() As String
Dim colFolders As Folders
Dim i As Long
Dim uErrorMsg As String
' Remove leading slashes, if any
Do While Left(strFolderpath, 1) = "\"
'Debug.Print strFolderpath
strFolderpath = Right(strFolderpath, Len(strFolderpath) - 1)
Loop
Debug.Print strFolderpath
arrFolders() = Split(strFolderpath, "\")
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then Exit For
Next
End If
Set GetFolder = objFolder
ExitRoutine:
Set colFolders = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Exit Function
GetFolder_Error:
uErrorMsg = "Err.Number: " & Err.Number & vbCr & "Err.Description: " & Err.Description
MsgBox uErrorMsg
Set GetFolder = Nothing
Resume ExitRoutine
End Function
Private Sub GetFolder_Test()
Dim testFolder As Folder
Set testFolder = GetFolder("\mailbox-name\customers\customer-xyz")
If Not (testFolder Is Nothing) Then testFolder.Display
End Sub
This question already has answers here:
For Each loop: Some items get skipped when looping through Outlook mailbox to delete items
(2 answers)
Closed 7 years ago.
I seem to be getting issues with moving emails from inbox to a sub-folder of inbox. I always thought my code was working until today. I noticed it's only moving half of the emails. I do not need a "move all" code, I have a purpose for this but I just need to move each emails and not all at once (I needed to check each emails). Please take a look at my code below. myNamespace.Folders.Item(1).Folders.Item(2) is my main Inbox.
Sub MoveEachInboxItems()
Dim myNamespace As Outlook.NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
For Each Item In myNamespace.Folders.Item(1).Folders.Item(2).Items
Dim oMail As Outlook.MailItem: Set oMail = Item
Item.UnRead = True
Item.move myNamespace.Folders.Item(1).Folders.Item(2).Folders("Other Emails")
Next
End Sub
here is good link
Moves Outlook Mail items to a Sub folder by Email address
Option Explicit
Public Sub Move_Items()
' // Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim Items As Outlook.Items
Dim lngCount As Long
On Error GoTo MsgErr
' Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
' // Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items(lngCount)
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "Email_One#email.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder One")
Set Item = Items.Find("[SenderEmailAddress] = 'Email_One#email.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
' // Email_Two
Case "Email_Two#email.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder Two")
Set Item = Items.Find("[SenderEmailAddress] = 'Email_Two#email.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
Or to move all Mail items Inbox to sub folder
Option Explicit
Public Sub Move_Items()
' // Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim lngCount As Long
Dim Items As Outlook.Items
On Error GoTo MsgErr
' Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
' // Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items(lngCount)
Debug.Print Item.Subject
If Item.Class = olMail Then
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
I created a rule to move emails to sub folders called "outgoing" and "incoming comments". I need to extract the attachments into automatically created local hard drive sub folders named with the subjects of the emails.
The local drive is F:\Outgoing
Loop through the Folder.Items collection and get MailItem objects from each item in the collection. Then for each MailItem, call Attachment.SaveAsFile for each object in MailItem.Attachments.
Option Explicit
Const folderPath = "f:\outgoing\"
Sub GetOutGoingAttachments()
On Error Resume Next
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Dim Inbox As MAPIFolder
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Dim searchFolder As String
searchFolder = InputBox("Search for Outgoing Reports?")
Dim Subfolder As MAPIFolder
Dim Item As Object
Dim Attach As Attachment
Dim FileName As String
Dim i As Integer
If searchFolder <> "inbox" Then
Set Subfolder = Inbox.Folders(searchFolder)
i = 0
If Subfolder.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Subfolder.Items
For Each Attach In Item.Attachments
'
Attach.SaveAsFile (folderPath & Attach.FileName)
i = i + 1
Next Attach
Next Item
'==============================================================================
'to search specific type of file:
' 'For Each Item In Inbox.Items
' For Each Atmt In Item.Attachments
' If Right(Atmt.FileName, 3) = "xls" Then
' FileName = "C:\Email Attachments\" & Atmt.FileName
' Atmt.SaveAsFile FileName
' i = i + 1
' End If
' Next Atmt
' Next Item
'===============================================================================
Else
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
On Error Resume Next
For Each Item In Inbox.Items
For Each Attach In Item.Attachments
FileName = folderPath & Attach.FileName
Attach.SaveAsFile FileName
i = i + 1
Next Attach
Next Item
End If
End Sub