No longer able to send e-mails with VBA and google smtp - excel

I need to periodically send e-mails and I used the following code for years:
Function SSLSendMail(sTO As String, sFROM As String, sSubject As String, sText As String, sServer As String, _
sUser As String, sPassword As String, Optional sAttach As String, Optional sCC As String, Optional sBCC As String) As Boolean
Dim ObjSendMail As Object
Set ObjSendMail = CreateObject("CDO.Message")
Dim iConf As Object
Set iConf = CreateObject("CDO.Configuration")
With iConf.Fields 'Flds
.Item(cdoSendUsingMethod) = cdoSendUsingPort ' 2
.Item(cdoSMTPAuthenticate) = cdoBasic ' 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True ' If use SSL set to True, if not, set to False
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item(cdoSendUserName) = sUser
.Item(cdoSendPassword) = sPassword
.Item(cdoSMTPServer) = sServer
.Item(cdoSMTPConnectionTimeout) = 10
.Update
End With
Set ObjSendMail.Configuration = iConf
With ObjSendMail
.To = sTO
.Subject = sSubject
.from = sFROM
.TextBody = sText
If sAttach > "" Then
.AddAttachment sAttach
End If
If sCC > "" Then
.cc = sCC
End If
If sBCC > "" Then
.BCC = sBCC
End If
On Local Error GoTo invalidTo
.Send
On Local Error GoTo 0
End With
Set ObjSendMail = Nothing
Set iConf = Nothing
SSLSendMail = True
Exit Function
invalidTo:
Debug.Print "Error on " & sTO & ": " & Err.description
Err.Clear
SSLSendMail = False
End Function
In the last days, I get error 0x80040217 and the mail is not sent. After some investigation, I found that Google changed the authentication method from Basic to OAuth2 or, at least, that is what I have to change in my Thunderbird client in order to be able to send mails.
I have seen an answer to a similar question suggesting to use Outlook object, but that is not applicable for a series of reasons: I don't have any outlook user configured (and I don't want to!), the "sender" seems not dynamically specified, etc.
I guess I have to change .Item(cdoSMTPAuthenticate) = cdoBasic to something else, but I cannot find anything related to OAuth2.

After days and days of unsuccessfully testing changes in that code, I finally realized the problem was in the SMTP server only. I had to access my Google configuration page, ask for a second level security for the specific machine on which the Excel VBA is running and I got an encrypted password, based on my regular password, I guess. Using that password, the above code works fine, as before. Thanks Google for making our life more difficult!

Related

Send a email via Excel

I have a project that i want to ditribute.
I would like it to autosend me a mail on error.
I tried here with CDO library, but i am not sure it is the best to use.
I have :
Private Sub MyErrorHandler()
'Here i save the file to send it next
Dim path As String: path = Environ("AppData") + "\Local"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs path & "AI_ErroringFile.xls"
Application.DisplayAlerts = True
'Here i create my email
Dim Cdo_Message As New CDO.Message
Set Cdo_Message.Configuration = GetSMTPGmailServerConfig()
With Cdo_Message
.To = "myadress#yahoo.fr"
.From = Environ("username") + "#ErrorHandler.com"
.Subject = "Test"
.TextBody = "Hello"
.send
End With
Set Cdo_Message = Nothing
End Sub
and my gmail config function :
Function GetSMTPGmailServerConfig() As Object
Dim Cdo_Config As New CDO.Configuration
Dim Cdo_Fields As Object
Set Cdo_Fields = Cdo_Config.Fields
With Cdo_Fields
.item(cdoSendUsingMethod) = cdoSendUsingPort
.item(cdoSMTPServer) = "smtp.gmail.com"
.item(cdoSMTPServerPort) = 465
.item(cdoSendUserName) = "AIErrorHandler#gmail.com"
.item(cdoSendPassword) = "mypassword"
.item(cdoSMTPAuthenticate) = cdoBasic
.item(cdoSMTPUseSSL) = True
.Update
End With
But on the .send instruction i have this error :
sendusing configuration value is invalid
I have try the 3 possibles sendusing configurations without success.
I am looking for a way to fix this or to send an email with vba without using outlook

Using CDO.sys dll for sending messages in VBA freezes Excel

I'm facing with a strange problem using CDO.sys for sending email messages from a VBA-enabled Excel application.
I've used the following code, found at https://www.rondebruin.nl/win/s1/cdo.htm :
Sub SendMailCDO(FSubject As String, FBody As String, FFrom As String, FTo As String, FCc As String)
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "myServerIPAddress"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "mydestination"
.CC = ""
.BCC = ""
.From = FFrom
.Subject = FSubject
.TextBody = ""
.HTMLBody = FBody
.Send
End With
MsgBox ("Email sent to " & FTo)
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Sub
Now, the code works fine and the emails are sent. However, after the first email is sent, immediately Excel becomes unresponsive on many different commands. For example, normal operations like changing the font dimensions in cells or applying a conditional formatting are not active anymore. In addition, Excel appear slow executing everything.
The only solution to fix this condition is to close Excel and open it again.
Any suggestion to fix the problem?
Thanks in advance,
Emilio
Absolutely unexpected, but removing the Msgbox call "Email sent to" solved the problem!
this happened to me too. If you have the same problem I gotta say that removing Msgbox call will not necesarily fix it. However the previous answer made me realize that anything within my code could be causing the issue.
So... I tried commenting every single line and in my case removing a call to the Application.StatusBar worked like a charm. Can't put on a nice status but at least Excel is not freezing after sending the email anymore.
Hope it helps ;)

MailItem.Send in VBA not functioning since Office 365 upgrade

We send out a lot of spreadsheets around the organisation, in order to automate this as much as possible we wrote some code to send this automatically and allow us to still put body text in.
This particular Script picks information up from our Finance System (SAP) dumps it into Excel and emails it to the user, it loops through a number times downloading and emailing different data each time.
This works fine on our old windows 7 (Office 2010) machines but some of us have been given new Windows 10 (Office 365) machines to pilot.
The code runs without any error messages but when it gets to .Send it jumps straight to End Sub and does not send the email.
I have tried EmailItem.Display and you can see the email being populated and then just stays visible on the desktop as it loops through the rest of the emails.
Any ideas on how to get round this? I could use the application.send function but I like to have the ability to add custom text into the email body.
Thanks :)
Sub EmailData()
Dim OL As Object
Dim EmailItem As Object
Dim y As Long
Dim TempChar As String
Dim Bodytext As String
Dim Flds As Variant
Dim EmailText As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Email Download to nursery
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.Createitem(OLMailItem)
'Check File Name is correct
Filename = Range("A1") & ".xls"
For y = 1 To Len(Filename)
TempChar = Mid(Filename, y, 1)
Select Case TempChar
Case Is = "/", "\", "*", "?", """", "<", ">", "|"
Case Else
SaveName = SaveName & TempChar
End Select
Next y
ActiveSheet.Cells.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
With ActiveWindow
.DisplayGridlines = False
.DisplayZeros = False
End With
Range("A1:S38").Select
Selection.Locked = True
Selection.FormulaHidden = False
Set EmailText = ActiveSheet.Range("AB1:AB5").SpecialCells(xlCellTypeVisible)
ActiveSheet.Protect ("keepsafe")
ActiveWorkbook.SaveAs Networkpath & "\" & SaveName, , "", , True
ActiveWorkbook.ChangeFileAccess xlReadOnly
EmailItem.display
'On Error Resume Next
With EmailItem
.To = "Daston#blahblah.uk"
'.To = Range("AA1")
.CC = ""
.BCC = ""
.Subject = Filename
.HTMLBody = RangetoHTML(EmailText)
.Attachments.Add ActiveWorkbook.FullName
.send
End With
Application.Wait (Now + TimeValue("0:00:02"))
Kill Networkpath & "\" & SaveName
ActiveWorkbook.Close False
Set OL = Nothing
Set EmailItem = Nothing
End Sub
This describes how, in certain situations, you may "make the object model fully functional".
NameSpace.Logon Method (Outlook)
"first, instantiate the Outlook Application object, then reference a default folder such as the Inbox. This has the side effect of initializing MAPI to use the default profile and to make the object model fully functional."
Sub InitializeMAPI ()
' Start Outlook.
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
' Get a session object.
Dim olNs As Outlook.NameSpace
Set olNs = olApp.GetNamespace("MAPI")
' Create an instance of the Inbox folder.
' If Outlook is not already running, this has the side
' effect of initializing MAPI.
Dim mailFolder As Outlook.Folder
Set mailFolder = olNs.GetDefaultFolder(olFolderInbox)
' Continue to use the object model to automate Outlook.
End Sub
For security purposes, the HTMLBody, HTMLEditor, Body and WordEditor properties all are subject to address-information security prompts because the body of a message often contains the sender's or other people's e-mail addresses.
HKCU\Software\Policies\Microsoft\office\16.0\outlook\security\
promptoomaddressbookaccess
promptoomaddressinformationaccess
https://support.microsoft.com/en-za/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
The most probable cause is Outlook Security.
You can find the security configurations in HKCU\Software\Policies\Microsoft\office\16.0\outlook\security
(change 16.0 to your office version)
Change promptoomsend to 2 (or ask your system administrator), restart Outlook and try again.
More info https://support.microsoft.com/en-za/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo

Excel to email with replace text in Premade Email Template

I'm using the below code to auto-generate an email.
Public Function GenerateEmail(sendToText As String, _
sendCCText As String, sendBCCText As String, _
subjectText As String, fileName As String)
Application.ScreenUpdating = False
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate(fileName)
With OutMail
.sendTo = sendToText
.CC = sendCCText
.BCC = sendBCCText
.Subject = subjectText
.HTMLbody = WorksheetFunction.Substitute(OutMail.HTMLbody, "%TESTNUM%", "98541")
.Attachments.Add (Application.ActiveWorkbook.FullName)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Function
My end goal is to add data into the email and attach the active document into it as well. Everything here is working as intended, except the .HTLMbody section. It's giving me an error
"Unable to get the Substitute property of the WorksheetFunction
class."
Am I missing a reference to a library? Should I be using something different?
The email is saved as .oft format, so I have a line in the email that has %TESTNUM% that I'm looking to replace with 98541 (or any other string I need to pass into the function)
I have HTML email working in Excel using very similar code. The difference is that I build a temporary string with the text and you could do your substitute code on the string.
Then you can simply use:
.HTMLbody = temp_string
It might not be as elegant but it will help you work out where the problem is.

vba - sending email from a different user

My client wants to distribute excel/vba to his clients and the vba will automatically send emails.
Maybe the sender should be some other account, not the outlook account of the person using the vba, because some private stuff might be in the email. Is it really possible?
Another thing is the infamous pop-up warning when automating such tasks. I heard Application.SendKeys doesn't always work when computer's locked.
How is CDO for this task?
On your initial question you can use MailItem.SentOnBehalfOfName with Outlook
On the Security warning the standard two solutions for Outlook are:
1) Use Clickyes
2) Install Outlook Redemption
You don't have to use Outlook to send emails. As you ask, CDO works without using Outlook.
Here's some code to get you started.
Public Sub SendEmail(Subject As String, Body As String, ToPerson as String)
Dim iCfg As Object
Dim iMsg As Object
Set iCfg = CreateObject("CDO.Configuration")
Set iMsg = CreateObject("CDO.Message")
With iCfg.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "email-account"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/sendemailaddress") = "account#domain.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
.Configuration = iCfg
.Subject = Subject
.TextBody = Body
.To = ToPerson
.Send
End With
Set iMsg = Nothing
Set iCfg = Nothing
End Sub

Resources