VBA Send Outlook Email from MS Access (avoid user prompt to allow) 1

[03Explorer]

[Bold]I know the title sounds very suspicious and the feature is valid for protection, but I need to bypass it for my internal app so the system can send team members emails with generated attachments.[/bold]

I am using Office 365, I am building an app in Access that processes data, then attaches an Excel file to an email. All is working except for the send email. It prompts the user with "A program is trying to send an email message on your behalf. If this is unexpected, click Deny and verify your antivirus software is up-to-date." ... prompt waiting for [BOLD]Allow/Deny button[/bold] to continue processing.

Sub SendEmail(DirLocation)

    Dim appOutLook As Outlook.Application   '- Outlook Application
    Dim MailOutLook As Outlook.MailItem '- Outlook Mail
    Dim objFSO As Object        '- File System Object
    Dim objFolder As Object     '- Folder
    Dim objFile As Object       '- File
    Dim strFldr As String          '- Folder Name
    Dim strNme As String           '- Original File Name
    Dim strPth As String           '- Original File Path
    Dim strDpth As String          '- Destination File Path

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(strFldr)
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.createitem(olMailItem)
    Set db = CurrentDb
    Set objFolder = objFSO.GetFolder(strFldr)
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.createitem(olMailItem)
    Set db = CurrentDb
    strFldr = DirLocation
    strNme = objFile.Name  '--file name

        If strNme <> "" Then
            Set MailOutLook = appOutLook.createitem(olMailItem)  '-- Intiate Outlook to create a new email message
            With MailOutLook                            '-- Define and populate Email message
                .Display
                .BodyFormat = olFormatRichText
                .To = "RobertWagner@SullivanCotter.com" '-- Testing purposes
                .Subject = "Subject text here"
                .HTMLBody = "Body text here"
                .Attachments.Add strPth & strNme   '-- Attachment #1 (File)
                '- I want to understand options for .SendUsingAccount for speicific vs a Number(3)
                .SendUsingAccount = appOutLook.Session.Accounts.Item(3)  '- third associated email address
                .Send
            End With
        Else
            MsgBox "No file matching " & strPth & strNme & " found." & vbCrLf & _
                    "Processing terminated."
            Exit Sub    'This line only required if more code past End If
        End If
End Sub

 

[Andrzejek]

You have some information (and solution) about it here


---- Andy

There is a great need for a sarcasm font.

 

[03Explorer]

Thanks Andy,

I am looking for a method that doesn't need an installed add-on or SendKey action. I seem to believe there is an administrative way around this (also avoiding going into Outlook and turning off Trust Center/Programmatic Access warning.

=\

 

[Andrzejek]

Have you considered by-passing Outlook all together and send e-mails straight to Exchange server?
This way you have full control of what's going on.

I have code to do it, if you want...

Have a reference to:
Microsoft CDO for Windows 2000 Library

Dim objMessage As CDO.Message

Public Sub SendAMessage(strFrom As String, strTo As String, _
    strCC As String, strSubject As String, strTextBody As String, _
    Optional strBcc As String, Optional strAttachDoc As String, _
    Optional blnHighPriority As Boolean = False)

Set objMessage = New CDO.Message

With objMessage
    .From = strFrom
    .To = strTo
    If Len(Trim$(strCC)) > 0 Then
        .CC = strCC
    End If
    If Len(strBcc) > 0 Then
        .BCC = strBcc
    End If[green]
    ''' On behalf of
    '.Sender = "vvv@domain.com"[/green]
    
    If blnHighPriority Then
       With .Fields[green]
           ' for Outlook:[/green]
           .Item(cdoImportance) = cdoHigh
           .Item(cdoPriority) = cdoPriorityUrgent
    [green]
           ' for Outlook Express:
           '.Item("urn:schemas:mailheader:X-Priority") = 1[/green]
    
           .Update
       End With
    End If
    
    .Subject = strSubject
    
    If InStr(UCase(strTextBody), "<HTML>") Or InStr(UCase(strTextBody), "</HTML>") Then
        .HTMLBody = strTextBody
    Else
        .TextBody = strTextBody
    End If

    If Len(strAttachDoc) > 0 Then
        .AddAttachment strAttachDoc
    End If
    
    With .Configuration.Fields
        .Item(CDO.cdoSMTPServer) = "NTSMTP.COM.ABC.XYZ"
        .Item(CDO.cdoSMTPServerPort) = 25
        .Item(CDO.cdoSendUsingMethod) = CDO.cdoSendUsingPort
        .Item(cdoSMTPConnectionTimeout) = 10
        .Update
    End With
    .Send
End With

Set objMessage = Nothing

End Sub

---- Andy

There is a great need for a sarcasm font.

 

[03Explorer]

Ohh, Thanks Andy!

Would you know if there is something the Exchange server administrator will need to adjust? (for your suggestion)

Rob

 

[Andrzejek]

Yes.
When I was implementing this logic, I could send several e-mails pretty quick. Mail server assumed this was SPAM and locked me out. Admin had to allow my application to sent multiple e-mails and not stop it. I was just too efficient, I guess...


---- Andy

There is a great need for a sarcasm font.

 

[03Explorer]

Thanks again Andy for sharing the CDO concept.

I updated your code and get the response "The transport failed to connect to the server". Thinking need to keep searching for another option that is self contained vs buy a plugin (

https://www.add-in-express.com/crea...y-warnings-sending-email-messages-in-access/)

=\

 

[DjangMan]

I have the add-in-express toolset. It allows you to create some nicely integrated stuff. You might consider Redemption. It looks pretty robust:

http://www.dimastr.com/redemption/home.htm

 

[03Explorer]

Thanks, DjangMan... I am looking into your suggestion. The first glimpse looks good!

 

[Andrzejek]

I hope you updated this (red) part of code:
[tt].Item(CDO.cdoSMTPServer) = [red]"NTSMTP.COM.ABC.XYZ"[/red][/tt]
with your server info...


---- Andy

There is a great need for a sarcasm font.

 

[03Explorer]

Yes Andy, I am doing some digging to find out what our Exchange or SMTP server Name is... Trying to fly under radar vs ask and get the red tape. =)

 

[03Explorer]

Do you know if there is a trick when using Office365 as mail routing? Authentication?

 

[Andrzejek]

We moved to Office365 (I believe) and I did not have to do anything.
My code still works just fine....

SMTP server Name try this.


---- Andy

There is a great need for a sarcasm font.

 

[03Explorer]

Andy, When looking at Outlook, this is all I see in the area of changing email address...

 

[Andrzejek]

Did you Google "find your smtp server name"?
There are a lot of hints of how to find it...


---- Andy

There is a great need for a sarcasm font.

 

[03Explorer]

Andy, I am back on topic for a bit today... I broke down and talked with IT support. They gave me the SMTP Server information without any hitches! Sounds too good to be true, but I hope to update with positive feedback soon!

Rob

 

[Andrzejek]

That's beyond my knowledge :-(
I had this code from somewhere, put my 'stuff' in there and it worked great. So I've never questioned what's what. It just worked. And I shared this code with some people here on TT and (eventually) it worked form them, too.

So, give it a try, modify if needed. Good luck.
Share your experience here, especially when it starts to work for you, too


---- Andy

There is a great need for a sarcasm font.

 

[03Explorer]

Andy, I notice other postings online for CDO, code commonly passes an ID and PASSWORD. I'm asking because I didn't see it in your code which implies your version is not using any authentication. This aligns with my discussion with IT that no need to authenticate when within the Local Network.

Thanks for your honesty and sharing! I will do my best to keep the thread updated with my findings. =)

Rob

 

[03Explorer]

Ahhh, Andy! I found the source of my dillema.

 Public Sub SendAMessage(strFrom As String, _
                        strTo As String, _
                        strCC As String, _
                        strSubject As String, _
                        strTextBody As String, _
                        Optional strBcc As String, _
                        Optional strAttachDoc As String, _
                        Optional blnHighPriority As Boolean = False)

    Set objMessage = New CDO.Message
    
    With objMessage
        .From = strFrom
        .To = strTo
        If Len(Trim$(strCC)) > 0 Then
            .CC = strCC
        End If
        If Len(strBcc) > 0 Then
            .BCC = strBcc
        End If
        ''' On behalf of
        '.Sender = "vvv@domain.com"
        
        If blnHighPriority Then
           With .Fields
               ' for Outlook:
               .Item(cdoImportance) = cdoHigh
               .Item(cdoPriority) = cdoPriorityUrgent
        
               ' for Outlook Express:
               '.Item("urn:schemas:mailheader:X-Priority") = 1
        
               .Update
           End With
        End If
        
        .Subject = strSubject
        
        If InStr(UCase(strTextBody), "<HTML>") Or InStr(UCase(strTextBody), "</HTML>") Then
            .HTMLBody = strTextBody
        Else
            .TextBody = strTextBody
        End If
    
        If Len(strAttachDoc) > 0 Then
            .AddAttachment strAttachDoc
        End If
        
        With .Configuration.Fields
            .Item(CDO.cdoSMTPServer) = "SMTP.SOMETHINGoutlook.com"  '- Use TLS
            .Item(CDO.cdoSMTPServerPort) = 25      '- 587, 25  or 465
            .Item(CDO.cdoSendUsingMethod) = CDO.cdoSendUsingPort
            .Item(cdoSMTPConnectionTimeout) = 10
            .Item(cdoSMTPUseSSL) = True
            
            .Update
        End With
        .Send
    End With

    Set objMessage = Nothing

End Sub

Solution to the problem? Spend a few days with IT staff to figure out what layer of network protection is blocking as well as rules for the SMTP server. For me it was a two-fold issue: SMTP server needed to allow bounce off and McAfee Firewall had blocking rules as a double up of network protection.

Today it officially works (as I provided the code above)
*Note to others... no authentication is needed and populate your OWN SMTP server address.

Rob

 

[Andrzejek]

Alright Rob!!!

Good for you - keep digging and bothering IT personnel until you get what you want.




---- Andy

There is a great need for a sarcasm font.