I have working code below to extract attachments from my own Outlook email account, however I need to do it for a different account that is setup as a default reply email box for an automated process.
I'm not entirely sure how to tell the code below to check for that mailbox instead of my own. I've tried different variations of setting the Inbox variable, but none of them have worked thus far. This is done within Access 2013.
Private Sub GetAttachments()
Dim ns As Namespace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Atmt.Type = 1 And InStr(Atmt, "xlsx") > 0 Then
FileName = "C:\attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt
Next Item
End Sub
Try this:
Set Inbox = ns.Folders("MailboxName").Folders("Inbox")
Use Namespace.GetSharedDefaultFolder
Set recip = ns.CreateRecipient("other mailbox owner")
recip.Resolve
Set Inbox = ns.GetSharedDefaultFolder(recip, olFolderInbox)
Related
I am trying to move over 20,000 emails, based on email address, into desired folders.
The code I found freezes Outlook. The code does work before the freeze.
Using first code from the answer to this post
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
Also is it possible to filter not a specific email address e.g. dave#test.com but *#test.com?
I think at least your first problem might be the line 'Set Inbox = olNs.GetDefaultFolder(olFolderInbox)'
I have the similar line 'Set Items = objNS.GetDefaultFolder(olFolderInbox).Items' in my start-up routine Private Sub Application_Startup() . This worked fine ever since we switched to 365, but then circa February 2021 it started to crash on start-up. I got here by searching on this problem. Presumably they have changed something about the object model.
I also suppose it could be where olNs is set in the first place ' Set objNS = olApp.GetNamespace("MAPI"), if you mail doesn't use MAPI?
I've chucked the problem at out IT support, and I'll let you know if they come back with anything other than a mildly panicked 'what the hell you doing using VBA?'
The delay is caused by running a time-consuming task/code in Outlook. So, you need to optimize what and how is run in Outlook.
The problem is in the source code. I've noticed that you are iterating over all items in the folder:
// Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
That is completely a bad idea!
Instead, you need to use the Find/FindNext or Restrict methods to process all items that correspond to the specified search criteria. The Find method returns a single and first entry from the list of items. To get the second (if any) you need to use the FindNext method in the loop.
Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Also you may consider using the AdvancedSearch method of the Application class. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
See Advanced search in Outlook programmatically: C#, VB.NET for more information.
If processing every item there is no need for a Find. Find replaces the For loop item. It is more likely to run to completion when there are fewer items.
The simplest change is to remove the Find. This should fix any array out of bounds errors. Still it is inefficient.
// Email_One
Case "Email_One#email.com"
'// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder One")
'// Mark As Read
Item.UnRead = False
'// Move Mail Item to sub Folder
Item.Move SubFolder
One way to limit processing to the applicable items.
Option Explicit
Public Sub Move_Items_Restrict()
'// Declare your Variables
Dim myInbox As Folder
Dim subFolder As Folder
Dim myItem As Object
Dim myItems As Items
Dim resItems As Items
Dim strfilter As String
Dim i As Long
' Not while developing
'On Error GoTo MsgErr
' Set Inbox Reference
Set myInbox = Session.GetDefaultFolder(olFolderInbox)
'// Email_One
Set myItems = myInbox.Items
strfilter = "[SenderEmailAddress] = 'Email_One#email.com'"
Debug.Print strfilter
' some of these work, fromemail does
' https://learn.microsoft.com/en-us/previous-versions/office/developer/exchange-server-2007/aa579702(v=exchg.80)
'strfilter = "#SQL=urn:schemas:httpmail:fromemail LIKE '%#test.com'"
'Debug.Print strfilter
Set resItems = myItems.Restrict(strfilter)
Debug.Print resItems.count
If resItems.count > 0 Then
'// Set SubFolder of Inbox
Set subFolder = myInbox.folders("Folder One")
For i = resItems.count To 1 Step -1
Set myItem = resItems(i)
With myItem
'// Mark As Read
.UnRead = False
'// Move Mail Item to sub Folder
.Move subFolder
End With
' If there is a memory error,
' release item when no longer necessary,
'Set myItem = Nothing
Next
End If
'// Email_Two
Set myItems = myInbox.Items
strfilter = "[SenderEmailAddress] = 'Email_Two#email.com'"
Debug.Print strfilter
Set resItems = myItems.Restrict(strfilter)
Debug.Print resItems.count
If resItems.count > 0 Then
'// Set SubFolder of Inbox
Set subFolder = myInbox.folders("Folder Two")
For i = resItems.count To 1 Step -1
Set myItem = resItems(i)
With myItem
' // Mark As Read
.UnRead = False
' // Move Mail Item to sub Folder
.Move subFolder
End With
' If there is a memory error,
' release item when no longer necessary,
'Set myItem = Nothing
Next
End If
MsgErr_Exit:
Exit Sub
'// Error information for users to advise the developer
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & err.Number _
& vbCrLf & "Error Description: " & err.description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
Here is my requirement.
I have multiple accounts in my OUTLOOK configured.
1) 1#email.com (only one mailbox)
2) 2#email.com (Multiple mailbox's are there. ex: Unix box, Windows Box, Mac box)
Here my 2nd email account has its own mailbox and linked to multiple mailbox's like UNIX, Windows etc. Each Mailbox has its own inbox and sub folders.
Now i need to select a folder in Unix box (inbox) and run the code to do something in side the folder.
Here's what i have
For Each oAccount In Application.Session.Accounts
If oaccount ="1#email.com" then
Set folder = ns.GetDefaultFolder(olFolderInbox) ' here it selects the inbox folder of account.
For each item in folder.items
Code goes here
next
end if
next
This works fine for single mailbox account, but when i do this for multiple mailbox account , it doesn't work.
any help would be appreciated.
You can use the DeliveryStore property of the Account to get its inbox. For example:
Dim ns As NameSpace
Set ns = Application.Session
Dim acc As Account
Dim f As Folder
For Each acc In ns.Accounts
... Preconditions here ...
Set f = acc.DeliveryStore.GetDefaultFolder(olFolderInbox)
... Now, do some looping ...
Next
Expanding on DanL's suggestion to loop through ns.Folders as I cannot tell whether you understood it.
Option Explicit
Sub accTopFolder()
Dim oAccount As Account
Dim ns As Namespace
Dim fldr As folder
Dim item As Object
Dim inbx As folder
Set ns = GetNamespace("MAPI")
For Each oAccount In Session.Accounts
Debug.Print vbCr & "oAccount: " & oAccount
'
For Each fldr In ns.Folders
' Shows all the names so you can replace "test"
Debug.Print " top folder: " & fldr.name
If fldr = "test" Then
Set inbx = fldr.Folders("Inbox")
'inbx.Display
For Each item In inbx.Items
Debug.Print " item .Subject: " & item.subject
Next
Exit For
End If
Next
Next
Set inbx = Nothing
Set ns = Nothing
End Sub
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'm wondering if anyone managed to build a code to extract attachements within Outlook contacts? I have a lot of contacts in my outlook 2010 with several attachements and would like to create a copy for backup. Also, if an automated way exist, is it possible to link the downloaded attachement to the contacts?
update
I have used several pieces of code to do what i want but getting a "User-defined type not defined". Anyone know hoe to avoid that error?
Option Explicit
Sub GetAttachments()
Dim ns As Outlook.NameSpace
Dim contactFolder As Outlook.MAPIFolder
Dim myItem As Outlook.Item
Dim ContactItem As Object
Dim Attmt As Outlook.Attachments
Dim FileName As String
Dim i As Integer
Set ns = Application.GetNamespace("MAPI")
Set contactFolder = ns.GetDefaultFolder(olFolderContacts)
Set myItem = contactFolder.Items
Set Attmt = myItem.Attachments
i = 0
' Check each contacts for attachments
For Each ContactItem In contactFolder.Items
' Save any attachments found
For Each Attmt In ContactItem.Attachments
' This path must exist! Change folder name as necessary.
FileName = "C:\Temp\" & Attmt.FileName
Attmt.SaveAsFile FileName
i = i + 1
Next Attmt
Next ContactItem
End Sub
Use ContactItem.Attachments collection. To save an attachment, call Attachment.SaveAsFile.
You can develop a VBA macro or add-in to get the job done. Be aware, VBA macros are not designed for distributing the solution on multiple PCs. See Getting Started with VBA in Outlook 2010 for more information about VBA macros in Outlook.
If you need to automate Outlook from another applications, see How to automate Outlook by using Visual Basic.
As Dmitry suggested, you can use the SaveAsFile method of the Attachment class to save the attached file on the disk.
Sub SaveAttachment()
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.ContactItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "ContactItem" Then
Set myItem = myInspector.CurrentItem
Set myAttachments = myItem.Attachments
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the first attachment in the current item to the Documents folder? If a file with the same name already exists in the destination folder, it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
myAttachments.Item(1).SaveAsFile Environ("HOMEPATH") & "\My Documents\" & _
myAttachments.Item(1).DisplayName
End If
Else
MsgBox "The item is of the wrong type."
End If
End If
End Sub
To attach a file anew you can use the Add method of the Attachments class which creates a new attachment in the Attachments collection.
Sub AddAttachment()
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Set myItem = Application.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
myAttachments.Add "C:\Test.doc", _
olByValue, 1, "Test"
myItem.Display
End Sub
I have several mailboxes which I can see in my Outlook profile. One of the mailboxes, let's call it "Mailbox - HUR" receives messages constantly. presently one of my team goes into the inbox of this mailbox every day and moves (drag and drop) the messages into a subfolder of the inbox called Archive (we're an imaginative lot!) if the messages are greater than 24 hours old.
Is there any way that a macro can be set up to do this task? I know my simple way around VBA but have never used it with Outlook and can't figure out the namespace details to point me to the correct mailbox instead of my mailbox.
Unfortunately I do not have access to Exchange server, only using outlook client.
Any help anyone could give would be great.
You might like to try:
Sub MoveOldEmail()
Dim oItem As MailItem
Dim objMoveFolder As MAPIFolder
Dim objInboxFolder As MAPIFolder
Dim i As Integer
Set objMoveFolder = GetFolder("Personal Folders\Inbox\Archive")
Set objInboxFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For i = objInboxFolder.Items.Count - 1 To 0 Step -1
With objInboxFolder.Items(i)
''Error 438 is returned when .receivedtime is not supported
On Error Resume Next
If .ReceivedTime < DateAdd("h", -24, Now) Then
If Err.Number = 0 Then
.Move objMoveFolder
Else
Err.Clear
End If
End If
End With
Next
Set objMoveFolder = Nothing
Set objInboxFolder = Nothing
End Sub
Public Function GetFolder(strFolderPath As String) As MAPIFolder
'' strFolderPath needs to be something like
'' "Public Folders\All Public Folders\Company\Sales" or
'' "Personal Folders\Inbox\My Folder"
Dim objNS As NameSpace
Dim colFolders As Folders
Dim objFolder As MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objNS = GetNamespace("MAPI")
On Error Resume Next
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
End If
Next
End If
On Error GoTo TrapError
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Exit_Proc:
Exit Function
TrapError:
MsgBox Err.Number & " " & Err.Description
End Function
You should setup a mailbox rule. Tools | Rules Wizard
If you are using Exchange server have an Outlook rule to move the emails to the specific folder, then use the Mailbox Manager in Exchange to delete messages from that folder after a specific period of time. See this article for more information.
Fionnuala you rock!
I've been looking for a solution to a similar issue for months. With my corporate restrictions, I wasn't able to use the UDF (worked just fine on my personal); Within the sub MoveOldEmail, I instead used:
Set objMoveFolder = GetNamespace("MAPI").PickFolder
Cool thing is that this seems to let me move between email accounts that I have associated with my Outlook (until corp figures out at least).