Outlook Security Warning bypass when sending emails from VBA code (1 Viewer)

Hello1

Registered User.
Local time
Today, 14:41
Joined
May 17, 2015
Messages
271
Im sending about 50+ emails through Access VBA with Outlook but for every email this warning pops up and I have to click on allow.
Anyone else had this problem and whats the best way to avoid it?
I did research a bit but didnt find any optimal solution.
Interesting is that on the first PC it didnt show this warning but I think it was MS Office 2007 and this one is 2010.

Thanks
 

theDBguy

I’m here to help
Staff member
Local time
Today, 05:41
Joined
Oct 29, 2018
Messages
21,358
Hi. Other good candidates for third-party apps are Click Yes and Outlook Redemption.
 

pbaldy

Wino Moderator
Staff member
Local time
Today, 05:41
Joined
Aug 30, 2003
Messages
36,118
Another thought, there was an Outlook security update that affected this type of thing. I think I had success making sure (on the user's computer) in Outlook File/Options/Trust Center/Trust Center Settings/Programmatic Access that the antivirus status was Valid. If it isn't, Outlook will throw this type of warning.
 

Hello1

Registered User.
Local time
Today, 14:41
Joined
May 17, 2015
Messages
271
Thanks pbaldy, it does state that the antivirus status isnt valid, so it might be the case. Unfortunately im not in the position to test it now but I assume thats the problem.
However, I had another problem next to this one.
Today a worker sent the emails as usually and that warning poped up, I clicked on allow for each email but then in the sent items all emails were sent double and I couldnt find the reason.
Whenever the allow was clicked (email was sent) through code I write the exact time in the table and according to that time and can say that it was written every time I clicked on allow but what I cant explain is why did Outlook or access code sent every email 2 times (I can see it in the sent items).
Before it worked just fine on the other PC, after every successful .Send code writes the time in the table and that prevents the emails from being sent again.
Im suspecting that security message or the Outlook isnt activated pop up message at the start.
Any other ideas?
 

pbaldy

Wino Moderator
Staff member
Local time
Today, 05:41
Joined
Aug 30, 2003
Messages
36,118
That's a new one on me. It might help to see the code.
 

Hello1

Registered User.
Local time
Today, 14:41
Joined
May 17, 2015
Messages
271
Here is the code, I translated the commented parts and some msgbox-es.
Hopefully you can understand it :D
And the code needs improvement, Im still a newbie at this.

Code:
Private Sub cmdEmail_Click()    '20190410
    Dim FileName As String
    Dim emailText As String
    Dim SaDatumom As String
    Dim MyRs2 As Recordset
    Dim varReturn As Variant
    Dim OutlookCDO As String        'Saving the answer of the user, which method is he going to use, Outlook or CDO 20190531
    'Variables for CDO
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
    Dim Pw As String
    Dim objImage As Object
    'Variables for Outlook, LateBinding. 20190531
    Dim outMail As Object
    Dim myInspector As Object
    Dim OutApp  As Object
    Dim SendTo As String
    Dim MailSubject As String
    Dim PrikazatiEmail As Boolean   'Saving the answer of the user if he wants to preview the email before sending (manual sending)
    Dim oAccount As String          'Email account for sending the mails
    
    On Error GoTo Err_cmdEmail_Click
    varReturn = SysCmd(acSysCmdSetStatus, "Sending Emails!")
    DoCmd.Hourglass True
    
    ''''''''''''''   20190531   '''''''''''''
    Set MyDb = CurrentDb
    Set MyRs = MyDb.OpenRecordset("SELECT * FROM Korisnik")	'table where Im storing the email address for sending mails
    oAccount = MyRs!EmailAdr
    If IsNull(oAccount) Then
        MsgBox "Cant send Emails, your email address is missing!", vbCritical, "Title 1.0"
    End If
    If Not IsEmailAddress(oAccount) Then	'Checking if email address is valid with a function
        DoCmd.Hourglass False
        varReturn = SysCmd(acSysCmdSetStatus, " ")
        MsgBox "Email address is not valid, you cant send the emails!", vbCritical, "Title 1.0"
        Exit Sub
    End If
	'Now here Im checking if the sending method for email (CDO or Outlook) is set already in the table, if not then ask the user which one to use
	'For now its O in the table, so Outlook as default without asking the user anything
    Select Case MyRs!EmailVrs
        Case "O"
            OutlookCDO = "O"
        Case "A"
            OutlookCDO = "A"
        Case Else
Again1:
			'You can ignore this part its the inputbox but we are skipping it because Outlook is already set as default (I wont bother translating the msgbox)
            OutlookCDO = InputBox("Unesite kako želite da pošaljete E-mailove." & Chr(13) & "Ako želite poslati putem Outlook-a (brža opcija) unesite slovo ""O"", a za slanje putem aplikacije unesite ""A"" (bez navodnika)" & Chr(13) & "Ako zelite odustati kliknite na Cancel", "Title 1.0")
                Select Case OutlookCDO
                    Case "O", "A"
                    Case ""
                        DoCmd.Hourglass False
                        varReturn = SysCmd(acSysCmdSetStatus, " ")
                        Exit Sub
                    Case Else
                        MsgBox "Možete unijeti samo jednu od dvije ponuđene opcije!", vbCritical, "Title 1.0"
                        GoTo Again1
                End Select
        End Select
    If OutlookCDO = "A" Then   ' This is for CDO so ignore it aslo
    '''''''''''     Kraj    '''''''''''''
        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/smtpusessl") = True
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "anemailaddress@email.com"
            Pw = InputBox("Unesite pasvord za anemailaddress@email.com" & Chr(13) & "Ako zelite odustati kliknite na Cancel", "Title 1.0")
            If Pw = "" Then
                DoCmd.Hourglass False
                varReturn = SysCmd(acSysCmdSetStatus, " ")
                Exit Sub
            End If
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pw
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
    
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
            .Update
        End With
    End If
    
Again0:
	'Now here Im asking the user to enter the date so I can filter which PDF files (emails) are going to be sent
    SaDatumom = InputBox("Enter the date of reading (last day of the month) like 'dd.mm.gggg' npr. 31.03.2019 if you are sending emails for mart!" & Chr(13) & "If you want to stop, click Cancel", "Title 1.0")
    If SaDatumom = "" Then      '20190531
        DoCmd.Hourglass False
        varReturn = SysCmd(acSysCmdSetStatus, " ")
        Exit Sub
    ElseIf Not IsDate(SaDatumom) Or Len(SaDatumom) <> 10 Then
        DoCmd.Hourglass False
        varReturn = SysCmd(acSysCmdSetStatus, " ")
        MsgBox "Your input is not a date", vbCritical, "Title 1.0"
        Exit Sub
        GoTo Again0:
    End If
    'Here Im writing a SQL code to see who of the customers needs to receive the email 20190419
    SQL = "SELECT Potrosac.IdPotrosaca, RacUpl.IdRacUpl, First(IIf(IsNull([NazFirme]),[ImeNaziv],[NazFirme] & ' ' & [ImeNaziv])) AS Potr, First(Potrosac.Email) AS FirstOfEmail, First(Mid([RacUpl.DatumDo],4,2) & '/' & Right([RacUpl.DatumDo],4)) AS TekuciMje"
    SQL = SQL & " FROM Potrosac INNER JOIN RacUpl ON Potrosac.IdPotrosaca = RacUpl.IdPotrosaca"
    SQL = SQL & " WHERE RacUpl.DatumDo = cvdate('" & SaDatumom & "') AND Potrosac.ElektronskiRac = True AND RacUpl.DatumVriEma Is Null AND RacUpl.Vazeci = True"    
	'Give me only the customers Potrosac.ElektronskiRac = True (means the customer is selected for receiving the emails), RacUpl.DatumVriEma Is Null (this field is empty, once we send the email we write the current date and time in it) and RacUpl.Vazeci = True" (is a valid PDF file)
    SQL = SQL & " GROUP BY Potrosac.IdPotrosaca, RacUpl.IdRacUpl"
    SQL = SQL & " ORDER BY Potrosac.IdPotrosaca;"
    Set MyRs = MyDb.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges)     'This Rs I use to send the email
    Set MyRs1 = MyDb.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges)    'This Rs1 I use to check if all the Email addresses of the customers are valid and if all of the PDF files are existing
    If Not MyRs1.EOF Then
        MyRs1.MoveFirst
            While Not MyRs1.EOF
                FileName = Format(MyRs1!IdPotrosaca, "000000") & "_" & Left(MyRs1!TekuciMje, 2) & "_" & Right(MyRs1!TekuciMje, 2)
                FilePath = "D:\PDFs\" & Right(MyRs1!TekuciMje, 4) & "god\" & FileName & ".pdf"
                If Not FileExists(FilePath) Then
                    DoCmd.Hourglass False
                    varReturn = SysCmd(acSysCmdSetStatus, " ")
                    MsgBox "Cant send the emails because a PDF file for the customer " & MyRs1!Potr & ", ID Potrošača: '" & MyRs1!IdPotrosaca & "' is missing!", vbCritical, "Title 1.0"
                    Exit Sub
                End If
                If IsNull(MyRs!FirstOfEmail) Then     '20190513
                    DoCmd.Hourglass False
                    varReturn = SysCmd(acSysCmdSetStatus, " ")
                    MsgBox "Cant send the email because the email address for the customer: " & MyRs1!Potr & ", ID Potrošača: '" & MyRs1!IdPotrosaca & "' is not valid", vbCritical, "Title 1.0"
                    Exit Sub
                End If
            MyRs1.MoveNext
            Wend
    Else
        DoCmd.Hourglass False
        varReturn = SysCmd(acSysCmdSetStatus, " ")
        MsgBox "There is nothing to send", vbInformation, "Title 1.0"
        Exit Sub
    End If
            
    If OutlookCDO = "O" Then   'Starting Outlook and checking if the user wants to see the email before sending 20190531
        Set OutApp = OutlookApp()
        If MsgBox("Do you want to preview the emails before sending?", vbYesNo, "Title 1.0") = vbYes Then
            PrikazatiEmail = True
        Else
            PrikazatiEmail = False
        End If
    End If
    If Not MyRs.EOF Then    'Starting to send the emails
        MyRs.MoveFirst
            While Not MyRs.EOF
                Set iMsg = CreateObject("CDO.Message")
                FileName = Format(MyRs!IdPotrosaca, "000000") & "_" & Left(MyRs!TekuciMje, 2) & "_" & Right(MyRs!TekuciMje, 2)
                FilePath = "D:\PDFs\" & Right(MyRs!TekuciMje, 4) & "god\" & FileName & ".pdf"
                emailText = emailText & _
                    "<style>.my_text {font-family: Calibri;}" & _
                    ".my_sign {font-family: Calibri;}</style>" & _
                    "<div class=""my_text""><p style= 'margin:0;'>Poštovani,</p>" & _
                    "<p class=""my_text"">Here is the PDF name " & MyRs!TekuciMje & ".<br> " & _
                    "<br>" & _
                    "Ukoliko trebate bilo kakve dodatne informacije, kontaktirati nas možete na:<br>" & _
                    "Tel/fax: +000 000 000;<br>" & _
                    "Company name<br>" & _
                    "-----------------------------------------------------------------<br>" & _
                    "Ova poruka je automatski generisana, te Vas molimo da ne odgovarate na nju.</p></div>"
                If OutlookCDO = "A" Then	'Its CDO, so skipping (ignore it)
                    With iMsg
                        Set .Configuration = iConf
                        .To = MyRs!FirstOfEmail
                        .CC = ""
                        .BCC = ""
                        .From = """The Hello"" <emailaddress@email.com>"
                        .Subject = "Some firm name, račun za " & MyRs!TekuciMje & ""
                        .HTMLBody = emailText & GetTextFileContents("D:\XXX\potpis.html") & "<html><br><div align=""center""><img src=""cid:XXXX.gif""></div></html>"
                        '20190419 logo za email
                        Set objImage = iMsg.AddRelatedBodyPart("D:\XXX\XXXX.gif", "XXXX.gif", cdoRefTypeId)
                            objImage.Fields.Item("urn:schemas:mailheader:Content-ID") = "<XXXX.gif>"
                            objImage.Fields.Update
                        .HTMLBodyPart.Charset = "utf-8"
                        .AddRelatedBodyPart "D:\XXX\XXXX.gif", "XXXX.gif", cdoRefTypeId
                        .AddAttachment FilePath
                        .Send
                    End With
                    Set iMsg = Nothing
                Else
                    'Sending the emails finaly
                    Set outMail = OutApp.CreateItem(0)
                        With outMail
                            SendTo = MyRs!FirstOfEmail
                            MailSubject = "Firm name, račun za " & MyRs!TekuciMje & ""
                            .To = SendTo
                            .Subject = MailSubject
                            'Set myInspector = .GetInspector
                            .Display
                            .HTMLBody = emailText & outMail.HTMLBody & GetTextFileContents("D:\XXX\XXXX.html") & "<div align=""center""><p><img src=""D:\XXX\XXXX.gif"" align=""middle""></p></div>"	'Besides the text Im inserting a signature
                            .Attachments.Add FilePath
                            Set .SendUsingAccount = OutApp.Session.Accounts.Item(oAccount)
                            If Not PrikazatiEmail Then
                                .Send
                            Else
                                .Display
                                If MsgBox("Did you send the Email successfuly?", vbYesNo) = vbNo Then
                                    DoCmd.Hourglass False
                                    varReturn = SysCmd(acSysCmdSetStatus, " ")
                                    MsgBox "Check the customer and the PDF file!", vbCritical, "Title 1.0"
                                    Exit Sub
                                End If
                            End If
                        End With
                End If
                Set MyRs2 = MyDb.OpenRecordset("SELECT * FROM RacUpl WHERE IdRacUpl = " & MyRs!IdRacUpl & "")	'Writing the current date and time in the filed to know that the email has been sent
                    With MyRs2
                        .Edit
                            !DatumVriEma = (Now)
                        .Update
                    End With
                    emailText = ""
            MyRs.MoveNext
            Wend
        DoCmd.Hourglass False
        varReturn = SysCmd(acSysCmdSetStatus, " ")
        MsgBox "Emails sent successfuly.", vbInformation, "Title 1.0"
    End If
Exit_cmdEmail_Click:
    Exit Sub
    
Err_cmdEmail_Click:
    DoCmd.Hourglass False
    varReturn = SysCmd(acSysCmdSetStatus, " ")
    Select Case Err.Number
        Case -2147220973  'Could be because of Internet Connection
            MsgBox " Provjerite da li imate internet vezu !!  -- " & Err.Description, vbCritical, "Title 1.0"
        Case -2147220975  'Incorrect credentials User ID or password
            MsgBox "Pogrešan pasvord !!  -- " & Err.Description, vbCritical, "Title 1.0"
        Case -2147220977  'That is, there’s an incorrect email address into the recipients line.    20190513
            MsgBox "Email-ove nije moguće poslati jer za potrošača: " & MyRs1!Potr & ", ID Potrošača: '" & MyRs1!IdPotrosaca & "' je neispravna e-mail adresa ili nije unešena. Unesite ispravnu e-mail adresu na formi Potrošači pa pokrenite ponovno ovu akciju", vbCritical, "Title 1.0"
        Case Else   'Rest other errors
            MsgBox "Greška pri slanju email-a !!  -- " & Err.Description, vbCritical, "Title 1.0"
    End Select
    Set iConf = Nothing
    Set Flds = Nothing
    Resume Exit_cmdEmail_Click
End Sub

Here in pastebin, maybe easier to read VBA Code
 
Last edited:

pbaldy

Wino Moderator
Staff member
Local time
Today, 05:41
Joined
Aug 30, 2003
Messages
36,118
The only thing that jumps out to me is that you display the email and then later either send/display it again. I'd take out the first .Display so that it's only done once.

Code:
                            [COLOR="Red"].Display[/COLOR]
                            ...
                            Set .SendUsingAccount = OutApp.Session.Accounts.Item(oAccount)
                            If Not PrikazatiEmail Then
                                .Send
                            Else
                                .Display
...
 

Hello1

Registered User.
Local time
Today, 14:41
Joined
May 17, 2015
Messages
271
If I dont put the .Display before, the logo doesnt want to show up.
I tried inserting the .gif in the .html file but same, it doesnt want to show up on the email, it does show up when I open the .hmtl file.
 
Last edited:

Hello1

Registered User.
Local time
Today, 14:41
Joined
May 17, 2015
Messages
271
Seems like I forgot to answer what fixed the problem for me.
Actually the antivirus was outdated and outlook stated that its not valid or similar, cant really remember now. However, updating the antivirus fixed it.

But now I have the same problem but on a Windows server 2008 r2 which doesnt support some Action center things to read the antivirus as I found out and that makes Outlook also unable to see the antivirus on the system.

Only solution without some 3rd party apps and similar I found to be disabling the settings for that warning message in Outlook and it works if I do it but I dont want to have that.

I saw that also changing some things in the registry also can suppress that warning, so I was thinking is there a way to write some VBA code which will change the registry before sending emails and after the emails are successfully sent to change it back?
 

theDBguy

I’m here to help
Staff member
Local time
Today, 05:41
Joined
Oct 29, 2018
Messages
21,358
Seems like I forgot to answer what fixed the problem for me.
Actually the antivirus was outdated and outlook stated that its not valid or similar, cant really remember now. However, updating the antivirus fixed it.

But now I have the same problem but on a Windows server 2008 r2 which doesnt support some Action center things to read the antivirus as I found out and that makes Outlook also unable to see the antivirus on the system.

Only solution without some 3rd party apps and similar I found to be disabling the settings for that warning message in Outlook and it works if I do it but I dont want to have that.

I saw that also changing some things in the registry also can suppress that warning, so I was thinking is there a way to write some VBA code which will change the registry before sending emails and after the emails are successfully sent to change it back?
Hi. Glad to hear you were able to manage. Yes, you can use VBA to write to the registry. Just make sure you do it very carefully to avoid any disasters.
 
Last edited:

Hello1

Registered User.
Local time
Today, 14:41
Joined
May 17, 2015
Messages
271
Hey guys,
Im trying to change the registry with VBA but it doesnt want to. The code works without errors, however it doesnt write a value to the registry key.
Here is the code:

Code:
Dim myRegKey As String

myRegKey = "SOFTWARE\WOW6432Node\Microsoft\Office\12.0\Outlook\Security"
RegKeySave (myRegKey)

Sub RegKeySave(i_RegKey As String)
Dim myWS As Object
Const HKLM = &H80000002

  'access Windows scripting
  Set myWS = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
  'write registry key
  myWS.SetDWORDValue HKLM, i_RegKey, "ObjectModelGuard", 2
End Sub

Edit:
So seems I need to have the admin rights. When I run access as administrator and then open my access .accdb and run the code the value changes. Any way to run that piece of code as administrator or something?
 
Last edited:

Users who are viewing this thread

Top Bottom