Goodafternoon,
I am populating an list box with all the emails from Inbox + Subfolders, via Table object. This is working fine.
Then, with Doubleclick events from ListBox1, I am trying to open the email that is been selected. If the loop is going only through Inbox folder, it is going correct. But when I'm trying to loop through SubFolders from Inbox, it is not going. So I am trying to collect(sum) all the emails from Inbox + subfolder in one:
Set InboxItems = SubFolder.Items
But offcorse it is not working. What can be done?
my code:
Option Explicit
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim objNS As Outlook.namespace: Set objNS = GetNamespace("MAPI")
Dim oFolder As Outlook.MAPIFolder: Set oFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim i As Long
Dim j As Long
Dim InboxItems As Outlook.Items
Dim thisEmail As Outlook.MailItem
Dim SubFolder As Outlook.MAPIFolder
Dim myArray() As String
Dim Folders As New Collection
Dim entryID As New Collection
Dim StoreID As New Collection
Call GetFolder(Folders, entryID, StoreID, oFolder)
myArray = ConvertToArray(indexEmailInbox)
For j = 1 To Folders.Count
Set SubFolder = Application.Session.GetFolderFromID(entryID(j), StoreID(j))
Set InboxItems = SubFolder.Items
Next
For i = LBound(myArray) To UBound(myArray)
If Me.ListBox1.Selected(i) = True Then
If TypeName(InboxItems.Item(onlyDigits(myArray(i)))) = "MailItem" Then ' it's an email
'MsgBox onlyDigits(myArray(UBound(myArray) - i - 1))
Set thisEmail = InboxItems.Item(onlyDigits(myArray(UBound(myArray) - i - 1)))
Unload Me
thisEmail.Display
Exit Sub
End If
End If
Next i
End Sub
Function ConvertToArray(ByVal value As String)
value = StrConv(value, vbUnicode)
ConvertToArray = Split(Left(value, Len(value) - 1), "§")
End Function
Sub GetFolder(folders As Collection, entryID As Collection, StoreID As Collection, fld As MAPIFolder)
Dim SubFolder As MAPIFolder
folders.Add fld.FolderPath
entryID.Add fld.entryID
StoreID.Add fld.StoreID
For Each SubFolder In fld.folders
GetFolder folders, entryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
You may .Add items to a collection one at a time.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub collection_Emails_Folder_And_Subfolders()
Dim objFolder As folder
Dim myItemsCol As New Collection
Dim i As Long
Dim myItems As Items
Set objFolder = Session.PickFolder
If objFolder Is Nothing Then
Exit Sub
End If
'Set objFolder = Session.GetDefaultFolder(olFolderInbox)
processFolder objFolder, myItemsCol
' Methods available are limited to:
' Add, Count, Item and Remove
Debug.Print vbCr & "Final total - myItemsCol.Count: " & myItemsCol.Count
' You may access item properties
For i = 1 To myItemsCol.Count
Debug.Print " " & i & ": " & myItemsCol(i).ReceivedTime, myItemsCol(i).subject
Next i
End Sub
Private Sub processFolder(ByVal objFolder As folder, ByVal myItemsCol As Collection)
' https://stackoverflow.com/questions/2272361/can-i-iterate-through-all-outlook-emails-in-a-folder-including-sub-folders
Dim EmailCount As Long
Dim myItem As Object
Dim myItems As Items
Dim i As Long
Dim oFolder As folder
Debug.Print vbCr & "objFolder: " & objFolder
EmailCount = objFolder.Items.Count
Debug.Print " EmailCount...: " & EmailCount
If EmailCount > 0 Then
Set myItems = objFolder.Items
myItems.Sort "[ReceivedTime]", False ' oldest to newest
For i = 1 To myItems.Count
'Debug.Print " " & i & ": " & myItems(i).ReceivedTime, myItems(i).subject
myItemsCol.Add myItems(i)
Next
End If
Debug.Print " Running total: " & myItemsCol.Count
If (objFolder.Folders.Count > 0) Then
For Each oFolder In objFolder.Folders
processFolder oFolder, myItemsCol
Next
End If
End Sub
You should be able to replace InboxItems with myItemsCol.
If TypeName(myItemsCol.Item((onlyDigits(myArray(i)))) = "MailItem" Then ' it's an email
Set thisEmail = myItemsCol.Item(onlyDigits(myArray(UBound(myArray) - i - 1)))
It seems you just need to iterate over all subfolders in Outlook to get the number of items per folder.
Sub Test()
Set objOutlook = CreateObject( "Outlook.Application" )
Set objNamespace = objOutlook.GetNamespace( "MAPI" )
Set folders = objNamespace.DefaultStore.GetRootFolder().Folders
EnumFolders folders
End Sub
Dim counter as Long = 0
' recursively invoked function
Sub EnumFolders(folders)
For Each folder In folders
Debug.Print folder.FolderPath
Debug.Print folder.Count
counter = counter + folder.Items.Count
EnumFolders folder.Folders
Next
End Sub
I have a vast number of folders in my Outlook inbox. I have a macro which will list (in a listbox object) all the folders that have xxxx text in it.
I then manually drill down into the folder heirarchy to select the folder. It is very time consuming given the number of levels of folders I have.
How do I take the text path from my list box entry, and with a double-click, select the folder?
Here's an example path (redacted):
\\john.smith#somemailbox.biz\Inbox\04_Projects\Florida\Data Migration\01_Data Cleansing & Testing
Sub MainProc()
'On Error GoTo On_Error
Dim Session As Outlook.NameSpace
Dim Report As String
Dim Folders As Outlook.Folders
Dim Folder As Outlook.Folder
Dim reply As Integer
Dim NumFolders As Integer
Set Session = Application.Session
Set Folders = Session.Folders
ArrayElem = 0
BugOut = False
'----------------
RowCount = 0
'----------------
ReDim FoldArray(1)
FSearch = InputBox("Enter search text", "Find folders")
'MySearch = "Test21"
'MySearch = InputBox("Type in a folder name", "Folder Search")
'----------------------------------------------------------
' There is only one folder we need in the "Folders" collection
' and this is actually the mailbox
'----------------------------------------------------------
For Each Folder In Folders
If Folder.Name = "john.smith#somemailbox.biz" Then
Call Subsid(Folder)
End If
Next
'For i = LBound(MyArray) To UBound(MyArray)
' msg = msg & MyArray(i) & vbNewLine
'Next i
'MsgBox msg
'MsgBox RowCount
If RowCount <> 0 Then
FindMyForm.TextBox1.BackColor = RGB(204, 255, 204)
FindMyForm.TextBox1.Value = "Here are the folders that contain '" &
FSearch & "'"
Else
FindMyForm.TextBox1.BackColor = RGB(255, 204, 204)
FindMyForm.TextBox1.Value = "I'm afraid there are no folders that
contain '" & FSearch & "'"
End If
FindMyForm.ListBox1.List = FoldArray
FindMyForm.StartUpPosition = 2
FindMyForm.Show
Exiting:
Set Session = Nothing
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Sub
Subsid code:
Private Sub SubSid(CurrentFolder As Outlook.Folder)
Dim SubFolders As Outlook.Folders
Dim SubFolder As Outlook.Folder
Set SubFolders = CurrentFolder.Folders
For Each SubFolder In CurrentFolder.Folders
'SubFolder.Display
If SubFolder.Name = "Inbox" Then
Call ArrayProc(SubFolder)
End If
Next SubFolder
End Sub
Array Population:
Private Sub ArrayProc(CurrentFolder As Outlook.Folder)
Dim SubFolders As Outlook.Folders
Dim SubFolder As Outlook.Folder
Dim StayAtLevel As Boolean
Dim SubString As String
Dim NewString As String
'---------------------------------------------
' We are now at the "INBOX" level of folders
'---------------------------------------------
Set SubFolders = CurrentFolder.Folders
'MsgBox CurrentFolder.FolderPath
For Each SubFolder In SubFolders
If InStr(1, SubFolder.Name, FSearch) Then
ReDim Preserve FoldArray(UBound(FoldArray) + 1)
SubString = SubFolder.FolderPath
NewString = Replace(SubString, "\\John.smith#somemailbox.biz\", "")
FoldArray(ArrayElem) = NewString
ArrayElem = ArrayElem + 1
RowCount = RowCount + 1
End If
Call ArrayProc(SubFolder)
Next SubFolder
End Sub
I need to extract attachments from Emails received in a user preferred time frame.
Say like extract for Emails received between 2PM to 4PM.
Please find the below code I've that extract files perfectly - but it did for all the Emails in the folder.
Please help me to resolve it.
Sub Unzip()
Dim ns As NameSpace 'variables for the main functionality
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Atchmt As Attachment
Dim FileName As Variant
Dim msg As Outlook.MailItem
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Dim FileNameFolder As Variant
Dim Totalmsg As Object
Dim oFrom
Dim oEnd
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("TEST")
Set Totalmsg = msg.ReceivedTime
oFrom = InputBox("Please give start time", ("Shadowserver report"))
oEnd = InputBox("Please give End time", ("Shadowserver report"))
If Totalmsg <= oFrom And Totalmsg >= oEnd Then
For Each msg In SubFolder.Items
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
MsgBox "1"
FileNameFolder = "C:\Users\xxxx\Documents\test\"
FileName = FileNameFolder & Atchmt.FileName
Atchmt.SaveAsFile FileName
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(FileName).Items
Kill (FileName)
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
Next
Next
End If
End Sub
Made a few improvements to improve performance and clarity :
Test received time inside the loop on the messages
Defined related variables as Date (like MsG.ReceivedTime) and improved input messages
Added Option Explicit to avoid mishaps in future coding (VERY GOOD PRACTICE)
Use Environ$("USERPROFILE") to get User directory's path
Reorganize variables and initialisation outside of the loops
Added LCase to be sure to get all zips (including .ZIP)
Code :
Option Explicit
Sub Unzip()
'''Variables for the main functionality
Dim NS As NameSpace
Dim InboX As MAPIFolder
Dim SubFolder As MAPIFolder
Dim MsG As Outlook.MailItem
Dim AtcHmt As Attachment
Dim ReceivedHour As Date
Dim oFrom As Date
Dim oEnd As Date
'''Variables for unzipping
Dim FSO As Object
Dim ShellApp As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ShellApp = CreateObject("Shell.Application")
Dim FileNameFolder As Variant
Dim FileName As Variant
'''Define the Outlook folder you want to scan
Set NS = GetNamespace("MAPI")
Set InboX = NS.GetDefaultFolder(olFolderInbox)
Set SubFolder = InboX.Folders("TEST")
'''Define the folder where you want to save attachments
FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"
'''Define the hours in between which you want to apply the extraction
oFrom = CDate(InputBox("Please give Start time" & vbCrLf & _
"Example: 9AM", ("Shadowserver report"), "9AM"))
oEnd = CDate(InputBox("Please give End time" & vbCrLf & _
"Example: 6PM", ("Shadowserver report"), "6PM"))
For Each MsG In SubFolder.items
ReceivedHour = MsG.ReceivedTime
If oFrom <= TimeValue(ReceivedHour) And _
TimeValue(ReceivedHour) <= oEnd Then
For Each AtcHmt In MsG.Attachments
FileName = AtcHmt.FileName
If LCase(Right(FileName, 3)) <> "zip" Then
Else
FileName = FileNameFolder & FileName
AtcHmt.SaveAsFile FileName
ShellApp.NameSpace(FileNameFolder).CopyHere _
ShellApp.NameSpace(FileName).items
Kill (FileName)
On Error Resume Next
FSO.deletefolder Environ$("Temp") & "\Temporary Directory*", True
End If
Next AtcHmt
End If
Next MsG
End Sub
I am just going to include the part that you need to change. Other lines will be the same. Basically, what you need to do is to set the Totalmsg inside your loop for each msg;
Sub Unzip()
'... copy your code till here
Set SubFolder = Inbox.Folders("TEST")
oFrom = InputBox("Please give start time", ("Shadowserver report"))
oEnd = InputBox("Please give End time", ("Shadowserver report"))
For Each msg In SubFolder.Items
Set Totalmsg = msg.ReceivedTime
If Totalmsg <= oFrom And Totalmsg >= oEnd Then 'You check it for each msg
'rest will be the same until ...
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
Next
End If
Next
End Sub
I want to move messages from the sender to the folder I created for the sender.
The SenderName is displayed as "Doe, John (US)" and my folder would be "Doe, John".
What do I need to do to compare the SenderName to a subfolder name that is two levels below "Inbox". I.e. Inbox→Folder1→"Doe, John".
Public Sub MoveToFolder()
Dim objOutlook As Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim objSubfolder As Outlook.Folder
Dim olsubFolder As Outlook.Folder
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim Msg As Outlook.MailItem
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Set objOutlook = Application
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("Inbox")
Set colFolders = objParentFolder.Folders
For Each obj In Selection
Set objVariant = obj
Dim sfName As Object
Set sfName = Left(objVariant.senderName, Len(objVariant.senderName) - 5)
If objVariant.Class = olMail Then
On Error Resume Next
' Use These lines if the destination folder
' is not a subfolder of the current folder
For Each objSubfolder In colFolders
For Each olsubFolder In objSubfolder
If olsubFolder.Name = sfName Then
Set objDestFolder = objSubfolder
MsgBox "Ductus Exemplo"
'objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
'Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s) from " & _
sfName & "to " & objDestFolder
Else
If objDestFolder Is Nothing Then
MsgBox "No Folder Found for " & sfName
'Set objDestFolder = objSourceFolder.Folders.Add(sfName)
Exit Sub
End If
Next
Next
Next
End If
End Sub
Assumptions
The sender subfolders will be two levels below inbox but not under a single parent folder (i.e. "Doe, John" could appear under Folder1 and "Doe, Jane" under Folder2)
All emails that should be processed by the macro will be selected before executing it
The code should not create subfolders for missing senders - as there are multiple possible "parent" folders - but should output a message containing a list of missing sender folders
Conditions that trigger the end of a sender name:
A hyphen following or preceding a space (i.e. "Doe, John - US" = "Doe, John" and "Huntington-Whiteley, Rosie - CAN" = Huntington-Whiteley, Rosie")
The second instance of a comma (i.e. "Doe, John, CPA" = "Doe, John")
The second instance of a space (i.e. "Doe, John Q" = "Doe, John")
An apostrophe preceded or followed by a space (i.e. "O'Leary, John" = "O'Leary, John" but "Doe, John 'US'" = "Doe, John")
Any other non-alphabetical character (i.e. "Doe, John: US" = "Doe, John"
Proposed Solution
This code will satisfy all of the above conditions, and will output a single message at the end denoting any senders for whom folders could not be found (as opposed to a separate message for each email). It has been tested on Outlook 2013/Windows 10.
Public Sub MoveToFolder()
Dim objSelection As Selection
Set objSelection = Application.ActiveExplorer.Selection
Dim iSelected As Integer, iMoved As Integer
iSelected = objSelection.Count 'Get a total for output message
Dim StrOutput As String, StrUnmoved As String, StrName As String
StrUnmoved = "Unmoved Item Count by Sender" & vbNewLine & "============================"
Dim objNS As NameSpace
Dim objParentFolder As Folder, objSubFolder As Folder, objDestFolder As Folder
Dim BFound As Boolean, iLoc As Integer
Set objNS = Application.GetNamespace("MAPI")
Set objParentFolder = objNS.GetDefaultFolder(olFolderInbox)
'Only execute code if the parent folder has subfolders
If objParentFolder.Folders.Count > 0 Then
'Loop through all selected items
For Each Item In objSelection
If Item.Class = 43 Then
'This is an email.
BFound = False
StrName = GetSenderName(Item.SenderName)
For Each objSubFolder In objParentFolder.Folders
If objSubFolder.Folders.Count > 0 Then
On Error Resume Next
Set objDestFolder = Nothing
Set objDestFolder = objSubFolder.Folders(StrName)
On Error GoTo 0
If Not objDestFolder Is Nothing Then
'Folder found.
Item.Move objDestFolder
iMoved = iMoved + 1
BFound = True
Exit For
End If
End If
Next
If Not BFound Then
'Sender folder not found. Check if we have already logged this sender.
iLoc = 0
iLoc = InStr(1, StrUnmoved, StrName)
If iLoc > 0 Then
'Existing sender name. Increment current total.
StrUnmoved = Left(StrUnmoved, iLoc + Len(StrName) + 1) & _
Format(CInt(Mid(StrUnmoved, iLoc + Len(StrName) + 2, 5)) + 1, "00000") & Right(StrUnmoved, Len(StrUnmoved) - iLoc - Len(StrName) - 6)
Else
'New sender name.
StrUnmoved = StrUnmoved & vbNewLine & StrName & ": 00001"
End If
End If
End If
Next
If iMoved = iSelected Then
StrOutput = "All " & iSelected & " items moved to appropriate subfolders."
Else
'Remove extraneous zeroes
StrUnmoved = Replace(StrUnmoved, ": 000", ": ")
StrUnmoved = Replace(StrUnmoved, ": 00", ": ")
StrUnmoved = Replace(StrUnmoved, ": 0", ": ")
StrOutput = iMoved & "/" & iSelected & " items moved to appropriate subfolders; see below for unmoved details." & vbNewLine & vbNewLine & StrUnmoved
End If
MsgBox StrOutput
Else
MsgBox "There are no subfolders to the default inbox. Script will now exit."
End If
End Sub
Function GetSenderName(StrFullSender As String) As String
'Only take action if a non-null string is passed
If Len(StrFullSender) > 1 Then
StrFullSender = Trim(StrFullSender) 'Trim extraneous spaces
Dim StrOutput As String
'Find first case of the end of the name
Dim iChar As Integer
Dim iCommaCount As Integer
Dim iSpaceCount As Integer
For iChar = 1 To Len(StrFullSender)
Select Case Asc(Mid(StrFullSender, iChar, 1))
Case 65 To 90, 97 To 122 '192 to 246, 248 to 255 'Include 192-246 and 248-255 if you will receive emails from senders with accents or other symbols in their names
'No action necessary - this is a letter
Case 45, 151 'Hyphen or EM Dash - could be a hyphenated name
If Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1)) <> _
Trim(Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1))) Then Exit For
'There is a space on one or both sides of the hyphen. This is a valid stop.
Case 44
iCommaCount = iCommaCount + 1
If iCommaCount > 1 Then Exit For
Case 32
iSpaceCount = iSpaceCount + 1
If iSpaceCount > 1 Then Exit For
Case 39
If Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1)) <> _
Trim(Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1))) Then Exit For
'There is a space on one or both sides of the apostrophe. This is a valid stop.
Case Else
Exit For
End Select
Next
StrOutput = Trim(Left(StrFullSender, iChar - 1))
GetSenderName = StrOutput
End If
End Function
The goal appears to be organizing selected mail items based on the SenderName when invoked.
Have put a bit further as you can move items within a folder of choice when nothing in selection moved (ie. selected meeting items only).
When picking a folder to process items, the folder cannot be the main sub folder or it's child folders.
Option Explicit
Private Const SUB_FDR As String = "Folder1" ' The name of main sub-folder under Inbox to move mails to
Sub MoveSenderToFolder()
Dim oNS As NameSpace, oMainFDR As Folder, oSubFDR As Folder
Dim oItem As Variant, iMoved As Long
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
On Error GoTo 0
If oNS Is Nothing Then
MsgBox "Cannot get MAPI namespace from Outlook! Abortting!", vbCritical + vbOKOnly, "MoveSenderToFolder()"
Else
' Proceed to Set Folders
Set oMainFDR = oNS.GetDefaultFolder(olFolderInbox)
' Get the sub folder "SUB_FDR" under Inbox
If Not oMainFDR Is Nothing Then Set oSubFDR = GetSubFolder(oMainFDR, SUB_FDR)
If oSubFDR Is Nothing Then
MsgBox "Cannot get the main sub folder """ & SUB_FDR & """ under """ & oMainFDR.Name & """"
Else
iMoved = 0
' [1] Process the Selected items
For Each oItem In ActiveExplorer.Selection
MoveItemToFolder oItem, oSubFDR, iMoved
Next
' [2] Ask to process a Folder if no MailItems are moved from Selection
If iMoved = 0 Then
If vbYes = MsgBox("Would you like to select a folder to move mail items?", vbQuestion + vbYesNo, "MoveSenderToFolder()") Then
Set oMainFDR = oNS.PickFolder ' Reuse oMainFDR object to the selected folder
' Only proceed if it's a folder not within Main Sub folder.
If Len(Replace(oMainFDR.FolderPath, oSubFDR.FolderPath, "")) = Len(oMainFDR.FolderPath) Then
For Each oItem In oMainFDR.Items
MoveItemToFolder oItem, oSubFDR, iMoved
Next
Else
MsgBox "Will not process folder/subfolders of the main folder """ & SUB_FDR & """", vbInformation + vbOKOnly, "MoveSenderToFolder()"
End If
End If
End If
Set oSubFDR = Nothing
Set oMainFDR = Nothing
End If
Set oNS = Nothing
MsgBox iMoved & " item(s) are moved.", vbInformation + vbOKOnly, "MoveSenderToFolder()"
End If
End Sub
' Move input item to a sub folder and increment counter
Private Sub MoveItemToFolder(ByRef oItem As Variant, ByRef oSubFDR As Folder, ByRef iMoved As Long)
Dim oMail As MailItem, sName As String, oTargetFDR As Folder
If TypeName(oItem) = "MailItem" Then
Set oMail = oItem
sName = GetSenderName(oMail)
Set oTargetFDR = GetSubFolder(oSubFDR, sName)
If oTargetFDR Is Nothing Then
MsgBox "Cannot get Target folder """ & oSubFDR.FolderPath & "\" & sName & """"
Else
oMail.Move oTargetFDR
iMoved = iMoved + 1
End If
Set oMail = Nothing
End If
End Sub
' Extract the Sender Name before any brackets
Private Function GetSenderName(ByRef oItem As MailItem) As String
Dim sName As String
sName = oItem.SenderName
If InStr(1, sName, "(", vbTextCompare) > 1 Then sName = Split(sName, "(")(0)
If InStr(1, sName, "<", vbTextCompare) > 1 Then sName = Split(sName, "<")(0)
If InStr(1, sName, "[", vbTextCompare) > 1 Then sName = Split(sName, "[")(0)
If InStr(1, sName, "{", vbTextCompare) > 1 Then sName = Split(sName, "{")(0)
GetSenderName = Trim(sName)
End Function
' Given a name, get the sub-folder object from a main folder (create if required)
Private Function GetSubFolder(ByRef oParentFDR As Folder, ByVal sName As String) As Folder
On Error Resume Next
Dim oFDR As Folder
Set oFDR = oParentFDR.Folders(sName)
If oFDR Is Nothing Then Set oFDR = oParentFDR.Folders.Add(sName)
Set GetSubFolder = oFDR
End Function
CODE UPDATE based on OP's comment
Searches all the sub folders within Inbox for the Sender's Name. If not found, prompts to create from Folder Picker.
Option Explicit
Private oNS As NameSpace
Sub MoveSenderToFolder()
Dim oMainFDR As Folder, oSubFDR As Folder
Dim oItem As Variant, iMoved As Long
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
On Error GoTo 0
If oNS Is Nothing Then
MsgBox "Cannot get MAPI namespace from Outlook! Abortting!", vbCritical + vbOKOnly, "MoveSenderToFolder()"
Else
' Proceed to Set Folders
Set oMainFDR = oNS.GetDefaultFolder(olFolderInbox)
If Not oMainFDR Is Nothing Then
iMoved = 0
' [1] Process the Selected items
For Each oItem In ActiveExplorer.Selection
MoveItemToFolder oItem, oMainFDR, iMoved
Next
' [2] Ask to process a Folder if no MailItems are moved from Selection
If iMoved = 0 Then
If vbYes = MsgBox("Would you like to select a folder to move mail items?", vbQuestion + vbYesNo, "MoveSenderToFolder()") Then
Set oSubFDR = oNS.PickFolder ' Reuse oMainFDR object to the selected folder
For Each oItem In oSubFDR.Items
MoveItemToFolder oItem, oMainFDR, iMoved
Next
Set oSubFDR = Nothing
End If
End If
Set oSubFDR = Nothing
Set oMainFDR = Nothing
End If
Set oNS = Nothing
MsgBox iMoved & " item(s) are moved.", vbInformation + vbOKOnly, "MoveSenderToFolder()"
End If
End Sub
' Get Folder object based on a Name and a root folder
Private Function GetSenderFolder(ByRef oRootFDR As Folder, ByVal sName As String) As Folder
Dim oFDR As Folder, oFDR2 As Folder
For Each oFDR In oRootFDR.Folders
If oFDR.Name = sName Then
Set oFDR2 = oFDR
Exit For
End If
Next
If oFDR Is Nothing Then
For Each oFDR In oRootFDR.Folders
Set oFDR2 = GetSenderFolder(oFDR, sName)
If Not oFDR2 Is Nothing Then Exit For
Next
End If
Set GetSenderFolder = oFDR2
End Function
' Move input item (Mail Items only) to a sub folder and increment counter
Private Sub MoveItemToFolder(ByRef oItem As Variant, ByRef oRootFDR As Folder, ByRef iMoved As Long)
Dim oMail As MailItem, sName As String, oTargetFDR As Folder
If TypeName(oItem) = "MailItem" Then
Set oMail = oItem
sName = GetSenderName(oMail)
Set oTargetFDR = GetSenderFolder(oRootFDR, sName)
If oTargetFDR Is Nothing Then
If vbYes = MsgBox("Cannot get Target folder """ & oRootFDR.FolderPath & "\" & sName & """" & vbLf & _
"Would you like to create the folder from folder of your choice?", vbQuestion + vbYesNo) Then
Set oTargetFDR = CreateSubFolder(sName)
End If
End If
If Not oTargetFDR Is Nothing Then
oMail.Move oTargetFDR
iMoved = iMoved + 1
End If
Set oMail = Nothing
End If
End Sub
' Extract the Sender Name before any brackets
Private Function GetSenderName(ByRef oItem As MailItem) As String
Dim sName As String
sName = oItem.SenderName
If InStr(1, sName, "(", vbTextCompare) > 1 Then sName = Split(sName, "(")(0)
If InStr(1, sName, "<", vbTextCompare) > 1 Then sName = Split(sName, "<")(0)
If InStr(1, sName, "[", vbTextCompare) > 1 Then sName = Split(sName, "[")(0)
If InStr(1, sName, "{", vbTextCompare) > 1 Then sName = Split(sName, "{")(0)
GetSenderName = Trim(sName)
End Function
' Given a name, Create the sub-folder object from Folder Picker
Private Function CreateSubFolder(ByVal sName As String) As Folder
On Error Resume Next
Dim oFDR As Folder
Set oFDR = oNS.PickFolder
If Not oFDR Is Nothing Then Set oFDR = oFDR.Folders.Add(sName)
Set CreateSubFolder = oFDR
End Function
Update Folder Name Folders("Folder1")
Option Explicit
Sub File_olItems()
Dim olNameSpace As Outlook.NameSpace
Dim olSourceFolder As Outlook.Folder
Dim olDestFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As MailItem
Dim vItem As Variant
Dim NameSender As String
Dim i As Long
Set olNameSpace = Application.GetNamespace("MAPI")
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
Set olSourceFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("Folder1")
For Each olItem In Selection
Set vItem = olItem
If vItem.Class = olMail Then
Debug.Print vItem.SentOnBehalfOfName
NameSender = vItem.SentOnBehalfOfName
If NameSender = ";" Then
NameSender = vItem.SenderName
End If
If InStr(1, NameSender, "(", vbTextCompare) > 1 Then
NameSender = Split(NameSender, "(")(0)
Debug.Print NameSender
End If
On Error Resume Next
Set olDestFolder = olSourceFolder.Folders(NameSender)
If olDestFolder Is Nothing Then
Set olDestFolder = olSourceFolder.Folders.Add(NameSender)
End If
vItem.Move olDestFolder
' // count items moved
i = i + 1
Set olDestFolder = Nothing
End If
Next olItem
' // Display the number of items that were moved.
MsgBox "Moved " & i & " Mail Items."
Set currentExplorer = Nothing
Set olItem = Nothing
Set Selection = Nothing
Set olNameSpace = Nothing
Set olSourceFolder = Nothing
End Sub
I've got a code from here and I'm tweaking it for my need. My need is quite simple: I need it to download if it has the name of the Daily Tracker I'm keeping track of (as it changes daily with the Format(Now)). The problem is that it is not finding the attachment.
The code can find the email if I substitute the ElseIf to Next part for oOlItm.Display, but won't download the attachment.
Sub AttachmentDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim NewFileName As String
NewFileName = "Daily Tracker " & Format(Now, "dd/MM/yyyy")
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
For Each oOlItm In oOlInb.Items
If InStr(oOlItm.Subject, NewFilename)) <> 0 Then
ElseIf oOlItm.Attachments.Count <> 0 Then
For Each oOlAtch In oOlItm.Attachments
oOlAtch.SaveAsFile (AttachmentPath)
Exit For
Next
Else
MsgBox "No attachments found"
End If
Exit For
Next
End Sub
The email:
This should work for you:
Sub AttachmentDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim oOlResults As Object
Dim x As Long
Dim NewFileName As String
NewFileName = "Daily Tracker " & Format(Now, "dd-MM-yyyy")
'You can only have a single instance of Outlook, so if it's already open
'this will be the same as GetObject, otherwise it will open Outlook.
Set oOlAp = CreateObject("Outlook.Application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'No point searching the whole Inbox - just since yesterday.
Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & Format(Date - 1, "DDDDD HH:NN") & "'")
'If you have more than a single attachment they'll all overwrite each other.
'x will update the filename.
x = 1
For Each oOlItm In oOlResults
If oOlItm.attachments.Count > 0 Then
For Each oOlAtch In oOlItm.attachments
If GetExt(oOlAtch.FileName) = "xlsx" Then
oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & "-" & x & ".xlsx"
End If
x = x + 1
Next oOlAtch
End If
Next oOlItm
End Sub
'----------------------------------------------------------------------
' GetExt
'
' Returns the extension of a file.
'----------------------------------------------------------------------
Public Function GetExt(FileName As String) As String
Dim mFSO As Object
Set mFSO = CreateObject("Scripting.FileSystemObject")
GetExt = mFSO.GetExtensionName(FileName)
End Function
Another way of doing it is from within Outlook:
Create a new folder in your Outlook Inbox and set a rule to move the email to this folder when it arrives. You can then write code to watch this folder and save the file as soon as it arrives.
Place this code within the ThisOutlookSession module in Outlook.
Dim WithEvents TargetFolderItems As Items
Const FILE_PATH As String = "C:\TEMP\TestExcel\"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.Folders.Item("Mailbox - Darren Bartrup-Cook") _
.Folders.Item("Inbox") _
.Folders.Item("My Email For Processing").Items
End Sub
Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
'when a new item is added to our "watched folder" we can process it
Dim olAtt As Attachment
Dim i As Integer
Dim sTmpFileName As String
Dim objFSO As Object
Dim sExt As String
If Item.Attachments.Count > 0 Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
sExt = objFSO.GetExtensionName(olAtt.FileName)
If sExt = "xlsx" Then
sTmpFileName = "Daily Tracker " & Format(Now, "dd-mm-yyyy") & ".xlsx"
End If
Item.UnRead = False
olAtt.SaveAsFile FILE_PATH & sTmpFileName
DoEvents
Next
End If
Set olAtt = Nothing
MsgPopup "A new attachment has been saved.", vbOKOnly, "New Daily Tracker"
End Sub
Private Sub Application_Quit()
Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing
End Sub
Create a new module in Outlook and put this code in there. This will create a messagebox that won't stop whatever you're doing.
Public Function MsgPopup(Optional Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, _
Optional SecondsToWait As Long = 0) As VbMsgBoxResult
' Replicates the VBA MsgBox() function, with an added parameter
' to automatically dismiss the message box after n seconds
' If dismissed automatically, this will return -1: NOT ‘cancel’ or the default button choice.
' Nigel Heffernan, 2006. This code is in the public domain.
' Uses late-binding: bad for performance and stability, useful for code portability
' The correct declaration is: Dim objWshell As IWshRuntimeLibrary.WshShell
Dim objWshell As Object
Set objWshell = CreateObject("WScript.Shell")
MsgPopup = objWshell.Popup(Prompt, SecondsToWait, Title, Buttons)
Set objWshell = Nothing
End Function