I'm trying to save attachments from multiple subfolders.
My code is not iterating through subfolders, it's only saving one attachment.
Private WithEvents Items As Outlook.Items
Private Count As Integer
Private Sub Application_Startup()
Dim objApp As Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim path_location As String
' Get the items in the Inbox folder
Set objApp = Outlook.Application
Set objNameSpace = objApp.GetNamespace("MAPI")
Set Items = objNameSpace.Folders("Archives_May_2016").Folders("Inbox").Folders("subfolder1").Items
path_location = "C: \emails" & "\Attachments\"
For Each Item In Items
Items.Item(1).Attachments.Count
' Initialize count
strFile = Items.Item(1).Attachments.Item(1).FileName
strFile = path_location & strFile
Items.Item(1).Attachments.Item(1).SaveAsFile strFile
Count = Count + 1
Next
End Sub
You are always accessing the same file since you are setting Items before the for loop, but inside it you are doing:
Items.Item(1).Attachments.Count
Try changing the for loop to:
For Each Item In Items
atts = Item.Attachments.Count
For i = 1 to atts
strFile = Item.Attachments.Item(i).FileName
strFile = path_location & strFile
Item.Attachments.Item(i).SaveAsFile strFile
Next
Next
Related
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 wanted to save an attached excel file in outlook to a ftp space with VBA.
I have mapped ftp folder in Windows 10 and I can reach it.
But macro cannot save attachment in that folder. The code is
Public Sub CheckEmail_BlueRecruit()
Dim outlookApp As Outlook.Application
Dim outlookNamespace As Outlook.NameSpace
Dim outlookFolder As Outlook.MAPIFolder
Dim filterKeywords As String
Dim filter As String
Set outlookApp = New Outlook.Application
Set outlookNamespace = Outlook.GetNamespace("MAPI")
Set outlookFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
filterKeywords = "I: Reservations"
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & filterKeywords & " %'"
LoopFolders outlookFolder, filter
End Sub
Private Sub LoopFolders(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)
Dim outlookSubFolder As Outlook.MAPIFolder
Dim outlookMail As Outlook.MailItem
ProcessFolder outlookFolder, filter
If outlookFolder.Folders.Count > 0 Then
For Each outlookSubFolder In outlookFolder.Folders
LoopFolders outlookSubFolder, filter
Next
End If
End Sub
Private Sub ProcessFolder(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)
Dim outlookItems As Outlook.Items
Dim outlookMail As Outlook.MailItem
Set outlookItems = outlookFolder.Items.Restrict(filter)
If Not outlookItems Is Nothing Then
For Each outlookMail In outlookItems
If outlookMail.Attachments.Count <> 0 Then
For i = outlookMail.Attachments.Count To 1 Step -1
'Debug.Print outlookMail.Subject
strFile = outlookMail.Attachments.Item(i).FileName
Debug.Print strFile
strFolderpath = "ftp://myserverexample.it/public_html/check/import/drive/"
outlookMail.Attachments.Item(i).SaveAsFile strFolderpath & strFile
Next i
End If
Next outlookMail
End If
End Sub
Manually I can navigate the FTP folder as a normal Window folder, but macro cannot save in that position, Why?
Thx a lot
The Attachment.SaveAsFile method takes a string as a parameter which stands for the location at which to save the attachment. The string should be represented by a local file path. After saving the file on the hard drive locally you can upload it to any ftp server programmatically.
I would like to save an attached file in a mapi folder (Enterptise connect) when the mail arrives according to the subject's title.
The vba code I use allows me to move the messages to the destination folder.
Do you have any idea how to copy an attachment to a folder in a storage space like Enterprise connect?
Option Explicit Sub PseudoArchive() Dim objNamespace As Outlook.NameSpace Dim sourceFolder As Outlook.MAPIFolder Dim destinationFolder As Outlook.MAPIFolder Dim Items As Outlook.Items Dim Item As Object Dim Msg As String Dim i As Long
Set objNamespace = GetNamespace("MAPI")
Set sourceFolder = objNamespace.Folders("test1_1#Outlook.com").Folders("MyFodes")
Set destinationFolder = objNamespace.Folders("Interprise Connect").Folders("Test2").Folders("Save_Attachments")
Set Items = sourceFolder.Items
'Move emails in sourceFolder to destinationFolder
Msg = Items.Count & " Items in " & sourceFolder.Name & ", Move?"
If MsgBox(Msg, vbYesNo) = vbYes Then
For i = Items.Count To 1 Step -1
Set Item = Items.Item(i)
DoEvents
Item.Move destinationFolder
Next
End If
End Sub
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
I am not familiar with vba enough to modify this for my needs.
I need to download the attachments from a specific folder.
I found this example, but I am not sure how to get the folder where these emails are sent to.
I have a rule that when these emails come in, it places them into a different folder.
This where I want to run the macro so it only strips the attachments from these emails and places them on the local computer folder.
What parts do I need to change to get this to work for my needs?
Public Sub SaveAttachments(Item As Outlook.MailItem)
If Item.Attachments.Count > 0 Then
Dim objAttachments As Outlook.Attachments
Dim lngCount As Long
Dim strFile As String
Dim sFileType As String
Dim i As Long
Set objAttachments = Item.Attachments
lngCount = objAttachments.Count
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Get the path to your My Documents folder
strfolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
strfolderpath = strfolderpath & "\Attachments\"
' Combine with the path to the folder.
strFile = strfolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
End Sub
To open a folder on the same level as your Inbox, open Inbox, then go one level up to its parent, then retrieve your folder by name:
set MyFolder = Application.Session.GetDefaultFolder(olFolderInbox).Parent.Folders.Item("My Folder Name")
Code goes under ThisOutlookSession Update folder Name "Temp"
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNameSpace As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Set olNameSpace = Application.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("TEMP")
Set Items = olFolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
SaveAttachments Item
End If
End Sub
'// http://www.slipstick.com/developer/save-attachments-to-the-hard-drive/
Public Sub SaveAttachments(Item As Outlook.MailItem)
If Item.Attachments.Count > 0 Then
Dim objAttachments As Outlook.Attachments
Dim lngCount As Long
Dim strFile As String
Dim sFileType As String
Dim i As Long
Set objAttachments = Item.Attachments
lngCount = objAttachments.Count
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
strFolderpath = strFolderpath & "\Attachments\"
' Combine with the path to the folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
End Sub