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
Related
How do I select all Mails in the Deleted Items folder of a shared account (not my personal account) and then move them to a different folder not called "Deleted Items". For now, let's call the destination folder "Old Emails".
Here is what I have written so far:
'Macro for pseudo-archiving
Sub PseudoArchive()
On Error Resume Next
Dim objNamespace As Outlook.NameSpace
Dim sourceFolder As Outlook.MAPIFolder
Dim Messages As Selection
Dim Msg As MailItem
Set objNamespace = GetNamespace("MAPI")
Set sourceFolder = objNamespace.Folders("sharedemail#website.com")
Set sourceFolder = objFolder.Folders("Deleted Items")
'Define path to the target folder
Set destinationFolder = ns.Folders("sharedemail#website.com").Folders("Old Emails")
'Move emails in sourceFolder to destinationFolder
For Each Msg In sourceFolder
Msg.Move destinationFolder
Next
Set objNamespace = Nothing
Set sourceFolder = Nothing
Set Messages = Nothing
Set Msg = Nothing
End Sub
I am stuck on how to get the macro to select all items in the sourceFolder so it can then move them to the destinationFolder. I prefer not to manually select the emails in the folder before running the macro.
If anyone can provide assistance, that would be appreciated. Thanks!
You almost got it, try the following
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("sharedemail#website.com").Folders("Deleted Items")
Set destinationFolder = objNamespace.Folders("sharedemail#website.com").Folders("Inbox").Folders("Old Emails")
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
Here is a code snippet that should help.
Dim olApp As Outlook.Application
Dim olFol As Outlook.Folder, olDestFol As Outlook.Folder
Dim olItem As Object
Dim i as Long, j as Long
Set olApp = New Outlook.Application olApp.GetNamespace("MAPI").Folders("mailboxnamehere").Folders("Deleted Items")
Set olDestFol = olApp.GetNamespace("MAPI").Folders("mailboxnamehere").Folders("Inbox").Folders("Deleted Items") ' Destination Folder
Do Until olFol.Items.Count = 0
olFol.Items(1).Move olDestFolder
Loop
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 writing a program to track the current status of projects.
The users would like to save relevant documents to the current project. I can do this for files that are residing in a folder with FileSaveDialog. However, many times the file is an e-mail message or an attachment to a message. I would like to grab this directly from Outlook and either save the message as an MSG or save the attachment.
I have code like below to reference Outlook messages from VB.NET but I can't figure out how to reference an entire message to save as msg or attachment filename.
Dim objOutlook As Outlook._Application
objOutlook = New Outlook.Application()
Dim objSelection As Outlook.Selection = objOutlook.ActiveExplorer.Selection
Dim iCount As Int16 = objSelection.Count
For i = iCount To 1 Step -1
Console.WriteLine(objSelection.Item(i).Subject)
Console.WriteLine(objSelection.Item(i).Attachments)
Next
Use the Outlook Object Library for this.
An example on how to download an attachment from an unread mail:
Private Sub ThisAddIn_NewMail() Handles Application.NewMail
Dim inBox As Outlook.MAPIFolder = Me.Application.ActiveExplorer() _
.Session.GetDefaultFolder(Outlook. _
OlDefaultFolders.olFolderInbox)
Dim inBoxItems As Outlook.Items = inBox.Items
Dim newEmail As Outlook.MailItem
inBoxItems = inBoxItems.Restrict("[Unread] = true")
Try
For Each collectionItem As Object In inBoxItems
newEmail = TryCast(collectionItem, Outlook.MailItem)
If newEmail IsNot Nothing Then
If newEmail.Attachments.Count > 0 Then
For i As Integer = 1 To newEmail.Attachments.Count
Dim saveAttachment As Outlook.Attachment = _
newEmail.Attachments(i)
newEmail.Attachments(i).SaveAsFile _
("C:\TestFileSave\" & (newEmail _
.Attachments(i).FileName))
Next i
End If
End If
Next collectionItem
Catch ex As Exception
If Left(ex.Message, 11) = "Cannot save" Then
MsgBox("Create Folder C:\TestFileSave")
End If
End Try
End Sub
Good luck!
Source: msdn
Having the same problem as you on saving an e-mail message I ended up with the following solution:
Sub SaveEmail()
'Save e-mail from Outlook
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objSelection As Outlook.Selection
Dim strFile As String
'Instantiate an Outlook Application object.
objOL = CreateObject("Outlook.Application")
'Get the collection of selected objects.
objSelection = objOL.ActiveExplorer.Selection
'Set the target folder
Dim FilePath1 as String
FilePath1 = "C:\tmp\"
'Save each selected e-mail to disk
For Each objMsg In objSelection
'Save attachment before deleting from item.
'Get the file name using "objMsg.Subject" and remove special characters.
strFile = Regex.Replace(objMsg.Subject, "[^a-zA-Z0-9_ -]", "-",_
RegexOptions.Compiled)
'Combine with the path to the Temp folder.
strFile = FilePath1 & strFile & ".msg"
'Save the attachment as a file.
objMsg.SaveAs(strFile, Outlook.OlSaveAsType.olMSG)
Next
End Sub
For a bit of input on the regex.replace function please see the following links:
https://www.regular-expressions.info/charclass.html
https://learn.microsoft.com/en-us/dotnet/api/system.text.regularexpressions.regex.replace?view=netframework-4.7.2#System_Text_RegularExpressions_Regex_Replace_System_String_System_String_System_String_
I try to write some VBA to save the attachment files from some email to a folder
But I get the error
Run Time Error '424'
Object Required
This is the code I am trying to use
Sub test_extraer()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
If (Msg.SenderName = "sender#email.com") And _
(Msg.Subject = "subject of the email") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
Const attPath As String = "C:\temp\"
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
End If
End Sub
The error is triggered when the script enter to this if
If (Msg.SenderName = "sender#email.com") And _
(Msg.Subject = "subject of the email") And _
(Msg.Attachments.Count >= 1) Then
Any advice
Thanks in advance
Ok... where to start.
You definitely have some basic issues you need to work out here. You have a couple of variables that are not declared. The first of which is the cause of your title. msg in context is most likely supposed to be an Outlook.MailItem. Just declaring that variable is not the sole source of your problems. Next you have item which much like msg in context should be an Outlook.MailItem. You are missing a loop that would navigate through all the items in the Inbox as well.
So you are just trying to navigate the Inbox looking for a particular item correct? Just adding the loop would create another issue. Some of the items in the inbox are not mail items. To address this we navigate every object in the inbox and examine every mailitem we come across. If that matches the criteria of sender,subject and number of items we proceed to .SaveAsFile to the destination directory.
Sub Test_ExtraER()
Const strAttachmentPath As String = "C:\temp\"
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objItem As Object
Dim strFileName As String
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
For Each objItem In objFolder.Items
If TypeName(objItem) = "MailItem" Then
If (objItem.Attachments.Count >= 1) And (objItem.Subject = "Some Subject") And (objItem.SenderName = "sender#email.com") Then
With objItem.Attachments.Item(1)
strFileName = strAttachmentPath & .DisplayName
Debug.Print strFileName
.SaveAsFile strFileName
End With
End If
End If
Next
End Sub
This is mostly preference but, as you can see, I made some other coding changes. I renamed some of the other variables to be a little more descriptive of the object it was. Also moved all the Dims and Const together for better readability.
One last thing. It would seem you are navigating you entire inbox looking for a small subset of mails. You could create a rule that would process these mails as they come into your mailbox. An example of this would be: Save Outlook attachment to disk
Sub test_extraer()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim MailItems As Outlook.MAPIFolder 'Add this one
Dim Msg As Outlook.MailItem 'Add this one
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set MailItems = objNS.GetDefaultFolder(olFolderInbox)
For Each Msg In MailItems.Items 'loop thru the inbox folder to match the exact sender name and subject
If (Msg.SenderName = "Sender Name Here") And _
(Msg.Subject = "Subject Here") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
Const attPath As String = "C:\temp\"
Set myAttachments = Msg.Attachments
Att = myAttachments.Item(1).DisplayName
myAttachments.Item(1).SaveAsFile attPath & Att
End If
Next
End Sub
So, the goal is that when I receive an email from a customer, containing the desired attachment, save the attachment to a location of my choosing.
This is my new code, it compiles but doesn't output the file?
Thanks in advance.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Application_NewMail()
Dim oInbox As MAPIFolder
Dim oItem As MailItem
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oItem = oInbox.Items.GetLast
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = oItem
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "Name Of Person") And _
(Msg.Subject = "Subject to Find") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
' mark as read
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
When you open the VBA window, you will see the object called "ThisOutlookSession", which is where you place the code.
This event is triggered automatically upon reception of a new email received:
Private Sub Application_NewMail()
Dim oInbox As MAPIFolder
Dim oItem As MailItem
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oItem = oInbox.Items.GetLast
//MsgBox oItem.To
//Etcetera
End Sub
About your edit, I didn't really investigate why it didn't work, but you can use this, which I tested:
Dim atmt As Outlook.Attachment
Dim Att As String
Const attPath As String = "U:\"
For Each atmt In Msg.Attachments
Att = atmt.DisplayName
atmt.SaveAsFile attPath & Att
Next
Note that it may seem as if you didn't save the file, because you cannot use 'Date modified' in WinExplorer to show the latest saved attachment (I noticed just now). But you can look it up alphabetically.