I have found the following VBA, which I'm using in excel VBA, which will return each Outlook account item and its account number.
Sub Which_Account_Number()
Dim OutApp As Outlook.Application
Dim I As Long
Set OutApp = CreateObject("Outlook.Application")
For I = 1 To OutApp.Session.Accounts.Count
MsgBox OutApp.Session.Accounts.Item(I) & " : This is account number " & I
Next I
End Sub
I want to select the account number that is associated to a specific from email address, instead of returning them all one after another.
You just need to set it directly
Sub Which_Account_Number()
Dim OutApp As Outlook.Application
Dim DesiredAccount As Outlook.Account
Set OutApp = CreateObject("Outlook.Application")
Set DesiredAccount = OutApp.Session.Accounts.Item("desiredemail#domain.com")
MsgBox DesiredAccount.DisplayName
Set DesiredAccount = Nothing
Set OutApp = Nothing
End Sub
Probably this and this may be helpful as well later on.
Related
This question already has an answer here:
Select inboxes in different outlook accounts
(1 answer)
Closed 8 days ago.
I am trying to access a specific mail account in Outlook and going through the Sent Mail to get certain data from the mailbox.
I get a Run-time error ´438´ - Object doesn't support this property or method, when I reach
Set olSent = Account.GetDefaultFolder(olFolderSentMail)
I have used MsgBox Account.DisplayName and it showed me the correct account. I have swapped olFolderSentMail to 5. Always the same error.
Any idea what the issue could be?
Sub CopyEmailBodyToExcel()
Dim OutlookApp As Object
Dim MItem As Object
Dim xlSheet As Object
Dim RowCounter As Integer
Dim olNs As Object
Dim olSent As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set olNs = OutlookApp.GetNamespace("MAPI")
For Each Account In olNs.Accounts
If Account.SMTPAddress = testmymail#company.com Then
MsgBox Account.DisplayName
'Set olSent = Account.Folders("Sent Items")
Set olSent = Account.GetDefaultFolder(olFolderSentMail)
Exit For
End If
Next Account
Set xlSheet = Worksheets("Sheet3")
RowCounter = 1
For Each MItem In olSent
If MItem.Subject = "Payload Notification" Then
xlSheet.Cells(RowCounter, 1).Value = MItem.Body
RowCounter = RowCounter + 1
End If
Next MItem
xlApp.Visible = True
End Sub
In Microsoft Visual Basic, I had to go in Tools > References and add the Microsoft Outlook 16 Library.
I then changed to the following:
Dim olNs As Outlook.Namespace
Dim olSent As Outlook.MAPIFolder
Then I could follow the question the niton referenced to and changed the For Each Loop
For Each Account In olNs.Accounts
If Account.SMTPAddress = testmymail#company.com Then
Set olSent = Account.DeliveryStore.GetDefaultFolder(olFolderSentMail)
Exit For
End If
Next Account
Now it seems to work as promised.
I have a macro in Outlook named "DeleteMail", when I try to run it from excel somehow I get an error "438".
I think I'm missing something on before the last line.
Function OpenOL(Optional ProfileName) As Object
Dim objOL As Object
'On Error Resume Next
Set objOL = GetObject(, "Outlook.Application")
If objOL Is Nothing Then
Set objOL = CreateObject("Outlook.Application")
objOL.Session.Logon ProfileName, , False, True
End If
Set OpenOL = objOL
Call OpenOL.DeleteMail '***Error Here****
Set objOL = Nothing
End Function
Any help is appreciated.
Nick.
Apparently I was overthinking it.
I just had to put the first macro "DeleteMail" in Excel and run it from there instead of keeping it in Outlook and trying to run it from Excel.
Here was the macro, hope it helps someone.
Public Sub DeleteMail() ' Deletes Mail from a Folder on same level as Default Folders
Dim outApp As Outlook.Application
Dim delFolder As Outlook.MAPIFolder
Dim item As Object
Dim entryID As String
Set outApp = CreateObject("outlook.application")
'Set delFolder = outApp.GetNamespace("MAPI").GetDefaultFolder(olFolderJunk)' deletes Junk Mails
Set delFolder = outApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("Meeting")
For i = delFolder.Items.Count To 1 Step -1
delFolder.Items(i).Delete
Next
Set item = Nothing
Set delFolder = Nothing
Set outApp = Nothing
End Sub
I have open attachments file using following code
Sub Test()
Dim path As String
Dim msgFile As String
path = Application.ActiveWorkbook.path + "\"
file = path & "\*.msg"
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.mailitem
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate(file)
On Error Resume Next
With OutMail
.To = Application.User
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
But
Email attachments file was not open.
How to Open Email Attachments File in Macro?
The Application class from the Excel object model doesn't provide the User property. Instead, you could use the UserName property which returns the name of the current user.
MsgBox "Current user is " & Application.UserName
The MailItem.To property returns or sets a semicolon-delimited string list of display names for the To recipients for the Outlook item. But I would suggest using the Recipients collection which should be used to modify the To property.
My company is transferring from Outlook 16 to Outlook 365, and the Excel VBA script below now needs to refer to a mailbox in Outlook 365.
It errors on the line
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
with the error
The attempted operation failed. An object could not be found.
Is it possible the mailbox needs to be added in a different way? Or is there a different way to do this function in Outlook 365?
I am not seeing much on a different way to do this with Outlook 365.
Sub Import_Email_Preferences()
Const strMail As String = "borrowerservicesshiftbid#glhec.org"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim strEmailAddress As String
Dim strSenderName As String
Dim strSubject As String
Dim intRow As Integer
Dim i As Long
Dim tbl As ListObject
Dim ltblRow As Long
Set tbl = ThisWorkbook.Worksheets("Preferences").ListObjects(1)
ltblRow = tbl.DataBodyRange.Rows.Count
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
'Getting Error Here
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
For i = oMapi.Items.Count To 1 Step -1
Set oMail = oMapi.Items(i)
If TypeOf oMail Is Outlook.MailItem Then
MsgBox = "Blue"
End If
Next i
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set oHTML = Nothing
Set oElColl = Nothing
End Sub
Please try to reference the inbox by GetDefaultFolder:
On Error Resume Next
If oApp Is Nothing Then
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then
Set oApp = New Outlook.Application
End If
End If
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
If the default folder ist not accessible, be aware that folder names are language dependent, e. g. Namespace.Folders("Posteingang") in German.
The trouble with Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox") is you are stringing references together. This is fine if it works but you do not know what has failed if it does not.
Set oMapi = oApp.GetNamespace("MAPI") will fail if oApp is not an object.
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail) will fail if oApp.GetNamespace("MAPI") is not an object.
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox") will fail if oApp.GetNamespace("MAPI").Folders(strMail) is not an object.
I suggest trying the subroutine below to identify which step is failing. This subroutine does everything in single steps. It also tries different ways of achieving the same effect. If one Set fails, comment it out and see if the next one works.
I have suggested some possible causes of failures but I am sure there are other possibilities. Once you know the step that fails, come back if you need further help.
You may wish to try Asger suggestion of GetDefaultFolder as well. It does not work on my system because the default Inbox in not used. I have to name the store containing the Inbox I wish to access.
Sub TestGetInbox()
Dim olApp As Outlook.Application
Dim olInbox1 As Outlook.MAPIFolder
Dim olInbox2 As Outlook.Folder
Dim olInbox3 As Outlook.MAPIFolder
Dim olInbox4 As Outlook.Folder
Dim olNs As Outlook.Namespace
Dim olSession As Outlook.Namespace
Dim olStore1 As Outlook.Folder
Dim olStore2 As Outlook.Folder
' If execution stops her, you have a problem accessing Outlook
Set olApp = CreateObject("Outlook.Application")
' If execution stops here, you have a problem accessing Outlook's namespace
' using this method. Comment out statements down to "Set olSession = olApp.Session"
Set olNs = olApp.GetNamespace("MAPI")
' If execution stops here, look at your folder pane. Is "borrowerservicesshiftbid#glhec.org"
' the name of a store? Case does not seem to matter but a single letter change in the name
' does.
Set olStore1 = olNs.Folders("borrowerservicesshiftbid#glhec.org")
Debug.Print olStore1.Name
Set olInbox1 = olStore1.Folders("Inbox")
Debug.Print olInbox1.Name
Set olInbox2 = olStore1.Folders("Inbox")
Debug.Print olInbox1.Name
' If execution stops her, you have a problem accessing Outlook's namespace
' This is a different methods of accessing Outlook's namespace. The documentation
' says the two method are identical but I once had the olApp.Namespace("MAPI")
' fail so I now always use the olApp.Session method which has never failed for me.
Set olSession = olApp.Session
Set olStore2 = olSession.Folders("borrowerservicesshiftbid#glhec.org")
Debug.Print olStore2.Name
Set olInbox3 = olStore1.Folders("Inbox")
Debug.Print olInbox1.Name
Set olInbox4 = olStore1.Folders("Inbox")
Debug.Print olInbox1.Name
Set olInbox1 = Nothing
Set olInbox2 = Nothing
Set olStore1 = Nothing
Set olNs = Nothing
Set olInbox3 = Nothing
Set olInbox4 = Nothing
Set olStore2 = Nothing
Set olSession = Nothing
Set olApp = Nothing
End Sub
I would like to paste a range of formatted Excel cells into an Outlook message.
The following code (that I lifted from various sources), runs without error and sends an empty message.
Sub SendMessage(SubjectText As String, Importance As OlImportance)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim iAddr As Integer, Col As Integer, SendLink As Boolean
'Dim Doc As Word.Document, wdRn As Word.Range
Dim Doc As Object, wdRn As Object
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set Doc = objOutlookMsg.GetInspector.WordEditor
'Set Doc = objOutlookMsg.ActiveInspector.WordEditor
Set wdRn = Doc.Range
wdRn.Paste
Set objOutlookRecip = objOutlookMsg.Recipients.Add("MyAddress#MyDomain.com")
objOutlookRecip.Type = 1
objOutlookMsg.Subject = SubjectText
objOutlookMsg.Importance = Importance
With objOutlookMsg
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
' Set the Subject, Body, and Importance of the message.
'.Subject = "Coverage Requests"
'objDrafts.GetFromClipboard
Next
.Send
End With
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub
I think you need to call .Save on your Mail Item (objOutlookMsg) after you've made all the changes.
Put .Display before .Send,
Simple but Quick fix, your problem is the email is not refreshing with the pasted contents before it sends, forcing it to Display first gives it time...
Also make sure you have another macro which runs before this to Copy the Range into your clipboard...
There is a button in excel to do this, "Send to mail recipent" its not normally on the ribbon.
You can also use the simple mapi built into office using the MailEnvelope in VBA
.. a good article on what you are trying to do http://www.rondebruin.nl/mail/folder3/mail4.htm