Unable to send email using shared mailbox from Excel VBA
Question
I have about 35 files that I run daily, all of which send their own email to a different distribution list, depending on which report is being sent, and all from a shared email account which has been added to my Outlook. I have 2 files that, for some odd reason, will not send from the shared email account I need to use.
**Edit: To clarify, the code runs to completion, and I can see the email open and disappear quickly, as if the email DID send. But nothing sends and no email shows in that account's sent items.
I have added the Microsoft Outlook 16.0 Object Library in my references, and all files are essentially using the same code:
Public Sub sendEmail()
Dim OutLookApp As Object, oAccount As Outlook.Account
Dim OutLookMailItem As Object
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
For i = 1 To Outlook.Application.Session.Accounts.Count
Set oAccount = OutLookApp.Session.Accounts.Item(i)
If oAccount = "notmypersonalaccount@xxx.com" Then Exit For
Next
With OutLookMailItem
Set .SendUsingAccount = OutLookApp.Session.Accounts.Item(i)
.To = "user1; user2; user3; user4; user5; " _
& "user6; user7; user8; user9; user10; user11; " _
& "user12; user13; user14; user15; user16; " _
& "user17; user18; user19; user20; user21; user22"
.CC = "user23; user24; user25"
.BCC = ""
.Subject = "Queue Inquiry for " & Format(Now, "m/d/yyyy") & ":"
.Display
.HTMLBody = "<BODY style=font-size:11pt;font-family:Cambria>Good Morning, " & "<br>" & "<br>" & _
"Please follow the link below to view the Queue Inquiry Report for " & Format(Now, "m/d/yyyy") _
& ". Below are the queue listings applicable for each area. This report will show you the volume in each queue and is sorted by oldest referral date (to help manage SLAs/Production)." _
& "<br>" & "<br>" & "Fraud Queues" & "<br>" & "- JPF" & "<br>" & "- PFR" & "<br>" & "<br>" _
& "C/S Back Office" & "<br>" & "- LBX" & "<br>" & "- SCK" & "<br>" & "- WSN" & "<br>" & "- TCR" & "<br>" & "- FIC" & "<br>" & "<br>" _
& "Dispute Resolution" & "<br>" & "- CS1" & "<br>" & "- APP" & "<br>" & "- RDP" & "<br>" & "- RTV" & "<br>" & "<br>" _
& "Credit Bureau Disputes" & "<br>" & "- CBD" & "<br>" & "<br>" _
& "Credit Back Office" & "<br>" & "- LTQ" & "<br>" & "<br>" _
& "Collections" & "<br>" & "- MGR" & "<br>" & "<br>" _
& "Bankruptcy" & "<br>" & "- LD7" & "<br>" & "- MM4" & "<br>" & "<br>" _
& "<a href=""https://xxxx.xx.com/xxxx/xx-xxx-xxx-xxxxxxxx/xxxxxx/xxxxx/xxxxx/xxxxx xxxxx/"">xxxxx xxxxx</a></BODY>" & .HTMLBody
.Send
End With
End Sub
What I don't get is that this file was working yesterday, before I added 6 new people to the distro list, user17 through user22. If I comment out the .SendUsingAccount = OutLookApp.Session.Accounts.Item(i) I am able to send using my email account.
Any thoughts?
1 answers
solution1
0 2021-02-15 13:34:09
Some changes that may make the code more reliable.
Option Explicit
Public Sub sendEmail()
Dim OutLookApp As Object
Dim oAccount As Outlook.account
Dim OutLookMailItem As Object
Dim srchAccount As String
Dim i As Long
Dim foundFlag As Boolean
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
srchAccount = "notmypersonalaccount@xxx.com"
For i = 1 To Session.Accounts.Count
Set oAccount = Session.Accounts.Item(i)
Debug.Print oAccount
If oAccount = srchAccount Then
foundFlag = True
Exit For
End If
Next
If foundFlag = True Then
With OutLookMailItem
Set .SendUsingAccount = oAccount
' without a subsequent .Send you can see the mail
.Display
End With
Else
MsgBox srchAccount & " not found."
End If
End Sub
To remove Excel from possible causes.
Option Explicit
Public Sub sendEmail_NotFromExcel()
Dim oAccount As account
Dim OutLookMailItem As Object
Dim srchAccount As String
Dim i As Long
Dim foundFlag As Boolean
Set OutLookMailItem = CreateItem(olMailItem)
srchAccount = "notmypersonalaccount@xxx.com"
For i = 1 To Session.Accounts.count
Set oAccount = Session.Accounts.Item(i)
Debug.Print oAccount
If oAccount = srchAccount Then
foundFlag = True
Exit For
End If
Next
If foundFlag = True Then
With OutLookMailItem
Set .SendUsingAccount = oAccount
.Display
End With
Else
MsgBox srchAccount & " not found."
End If
End Sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.