I have the following code which I believe should work to save attachments from an Outlook subfolder to the specified path, before emptying the subfolder.
Sub Downloadattachments()
Dim applOutlook As Outlook.Application
Dim ns As Namespace
Dim inbox As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim SubFolder As MAPIFolder
Dim SubSubFolder As MAPIFolder
Dim VariableName As Name
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = inbox.Folders("Paul")
Set SubSubFolder = SubFolder.Folders("Soja")
i = 0
If SubSubFolder.Items.Count = 0 Then
MsgBox
Else: End If
If SubSubFolder.Items.Count > 0 Then
For Each item In SubSubFolder.Items
For Each atmt In item.attachments
FileName = "\\homefolder5\bases" & atmt.FileName
atmt.SaveAsFile FileName
i = i + 1
item.Delete
Next atmt
Next item
End If
End Sub
Unfortunately I don't get past the line Set ns = GetNamespace("MAPI") before encountering the run-time error stating "Automation error: Library not registered". To clarify, I have the Microsoft Outlook 14.0 Object Library activated, along with other basic libraries. I think this must be something different.
I apologize if this is a really simple thing that I am overlooking, but I would appreciate whatever guidance you could give me!
Where do you run the VBA macro?
Dim applOutlook As Outlook.Application
It looks like you didn't initialize the applOutlook object in the code. If you develop an Outlook VBA macro, you can use the Application property:
Set applOutlook = Application
Set ns = applOutlook.GetNamespace("MAPI")
In case if you automate Outlook you need to create a new instance of the Application class. See How to automate Outlook from another program for more information.
Related
I've had an Outlook 2016 VBA macro running for a year to check emails arriving in my inbox. Today, following installation of Windows 10 updates, I get a type mismatch error when this macro runs. The error line is the Set olNs = Application.GetNamespace("MAPI") line below:
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim olRecip As Recipient
Dim dt As String
Dim strFile_Path As String
dt = Format(CStr(Now), "yyyy_mmm_dd_hh_mm")
strFile_Path = "d:\temp\parking.log"
Open strFile_Path For Append As #1
Write #1, dt & " " & "Application_Startup() triggered"
Close #1
Set olNs = Application.GetNamespace("MAPI")
Set olRecip = olNs.CreateRecipient("me#gmail.com")
Set Inbox = olNs.Folders("me#gmail.com").Folders("Inbox")
Set Items = Inbox.Items
End Sub
Any idea how I can fix this?
First of all, you need to make sure the COM references are set correctly.
You may try to run the code without setting a local variable:
Private Sub Application_Startup()
MsgBox "Welcome, " & Application.GetNamespace("MAPI").CurrentUser
Application.ActiveExplorer.WindowState = olMaximized
End Sub
I just ran into this issue (COM add-ins were fine) and as stated, removing the explicit declaration seems to fix the issue (you can also Dim the Namespace as an Object instead of Outlook.Namespace).
As a quick reference for anyone else I used the following code to bypass the issue:
With Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = .GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = .GetDefaultFolder(olFolderJunk)
End With
I am having trouble getting my Outlook VBA code to recognize the subfolder in my Shared Tasks.
What I'm trying to do is create a macro that will automatically create a task in the department Shared Task folder. Tried Googling a variety of solutions to no avail. The code goes as follows:
Dim objApp As Outlook.Application
Dim defaultTasksFolder As Outlook.MAPIFolder
Dim subFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objMail As MailItem
Dim objItm As TaskItem
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objMail = Outlook.Application.ActiveExplorer.Selection.Item(1)
Dim objOwner As Outlook.Recipient
Set objOwner = objNS.CreateRecipient("name#email.com")
objOwner.Resolve
If objOwner.Resolved Then
Set defaultTasksFolder = objNS.GetSharedDefaultFolder(objOwner, olFolderTasks)
subFolder = defaultTasksFolder.Folders("TestFolder") **ERROR OCCURS HERE - OBJECT COULD NOT BE FOUND**
Set objItm = subFolder.Items.Add(olTaskItem)
With objItm
.Subject = "Name- " & objMail.Subject
.StartDate = objMail.ReceivedTime
.Body = objMail.Body
End With
objItm.Save
MsgBox ("Task Created for e-mail: " & vbCrLf & objMail.Subject)
End If
End Sub
It errors out on subFolder = defaultTasksFolder.Folders("TestFolder"), saying that the object could not be found. I double and tripled checked the folder name.
Any ideas what might be causing this error? Thank you!!
First of all, add the Logon method before accessing MAPI, it will log to the profile if Outlook has just been started. If it is already running it will not affect anything. Then try to add both mailboxes as delegate stores (see the Advanced tab of the Exchange account properties dialog). You should see both mailboxes.
Finally, I'd try to iterate over all folders before to make sure the folder exists. Also, I'd recommend checking the recipient's name.
Keep in mind that Outlook might cache only the default folders, but not their suborders.
Can you see and access the subfolder in Outlook?
I have some VBA code in Outlook which behaves perfectly for the main Mailbox - however the same code is struggling when I add a secondary mailbox - this is Outlook 2016.
It seems to be struggling with reading the sub folders - I can get it to read mail items in the Inbox, but not the sub folders.
Code :
Dim sharedemail As Outlook.Recipient
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myDestFolder Outlook.MAPIFolder
Dim strSubject As String
Dim i As Integer
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set sharedemail = myNameSpace.CreateRecipient("recip#domain.com")
Set myInbox = myNameSpace.GetSharedDefaultFolder(sharedemail, olFolderInbox)
For itemCount = myInbox.items.Count To 1 Step -1 'Iterates from the end backwards
Set item = myInbox.items(itemCount)
strSubject = UCase(item.Subject)
Select Case True
Case InStr(strSubject, UCase("Holiday Request")) > 0
'Set destination folder
Set myDestFolder = myInbox.Folders("HolidayRequests")
'move the email out of inbox
item.Move myDestFolder
End Select
Next
It stalls at the Set myDestFolder line as it can't seem to select that sub folder - as I say same code seems to work fine in main Inbox?
Thanks
Keep in mind that Outlook keeps shared default folders in the primary OST file, and it does not sync the subfolders.
You can either
Uncheck the "Download shared folders" checkbox
Use Extended MAPI (C++ or Delphi) - that would be fairly complex as you'd need to retrieve the autodiscover XML for that mailbox and construct the store entry id appropriately.
use Redemption (I am its author) - its version of RDOSession.GetSharedDefaultFolder returns an online version of the folder (RDOFolder) with all its subfolders.
How do I automatically send out multiple (currently visible) draft items with VBA?
Please help, thank you.
Edit: It's a tough case, none of the items are in the drafts folder yet. These are generated emails that are on your screen, waiting to be sent.
Edit2: nvm, it's not going to help anyway. My script creates approximately 500 emails, and displaying the first 100 causes out of memory error. I opted to auto send them without displaying (it breaks the layout this way, but it's my only option for now.)
It just so happens that I ran into the same issue before and have code handy. If you're not already in Outlook, you will need to add a reference in the VBA IDE, Tools ---> References... and check the box next to "Microsoft Outlook 14.0 Object Library".
Dim oFolder As Folder
Dim oNS As NameSpace
Dim olMail As MailItem
If (MsgBox("Are you sure you want to send ALL EMAILS IN YOUR DRAFTS FOLDER?", vbYesNo + vbCritical, "WARNING: THIS WILL SEND ALL DRAFTS")) = vbYes Then
Set oNS = Outlook.Application.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderDrafts)
For i = 1 To oFolder.Items.Count
oFolder.Items(1).Send
Next
End If
Set oNS = Nothing
Here's some code. Replace Your Name in myFolders("Mailbox - Your Name") with your actual name as it appears in the mailbox.
Public Sub EmailOutlookDraftsMessages()
Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
'Send all items in the "Drafts" folder that have a "To" address filled in.
'Setup Outlook
Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
'Set Draft Folder.
Set myDraftsFolder = myFolders("Mailbox - Your Name").Folders("Drafts")
'Loop through all Draft Items
For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
'Check for "To" address and only send if "To" is filled in.
If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then
'Send Item
myDraftsFolder.Items.Item(lDraftItem).Send
End If
Next lDraftItem
'Clean-up
Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing
End Sub
Source Code adapted from this Question's answer.
Outlook wont let me send multiple drafts at the same time. Is there an easy way to send multiple drafts at once in outlook? without having to open each one individually?
From what i've read, seen and tried; this is not possible from within outlook itself, and thus a programming solution would be required, probably some VB script
ok, i found a bit of VB that does it:
`Public Sub SendDrafts()
Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
'Send all items in the "Drafts" folder that have a "To" address filled
'in.
'Setup Outlook
Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
'Set Draft Folder. This will need modification based on where it's
'being run.
Set myDraftsFolder = myFolders("$MAILBOX").Folders("$DRAFTS")
'Loop through all Draft Items
For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
'Check for "To" address and only send if "To" is filled in.
If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then
'Send Item
myDraftsFolder.Items.Item(lDraftItem).Send
End If
Next lDraftItem
'Clean-up
Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing
End Sub
just replace $MAILBOX with your mailbox name and $DRAFTS with the name of your drafts folder.
This has been personnaly tested and seems to work fine.
Not very different from author's answer, but still:
Sub SendDrafts()
Dim ns As NameSpace
Dim drafts As MAPIFolder
Dim Item As MailItem
Set ns = Application.GetNamespace("MAPI")
Set drafts = ns.GetDefaultFolder(olFolderDrafts) ' 16
For Each Item In drafts.Items
'Item.Send
Next
End Sub
Please be careful as it really sends all emails in your default draft folder. After uncommenting the send line. Dim lines to allow for autocompletion when inside Outlook macro editor.
A useful version, which I just tested in Outlook 2000:
Drag the emails you wish to send to the Outbox. They won't be sent automatically, but using this version of the prior posting sends them:
Sub SendOutbox()
Dim ns As NameSpace
Dim outbox As MAPIFolder
Dim Item As MailItem
Set ns = Application.GetNamespace("MAPI")
Set outbox = ns.GetDefaultFolder(olFolderOutbox) ' 16
For Each Item In outbox.Items
Item.Send
Next
End Sub
That way, you can be selective.
Yes, you can write a macro or add-in to do that.