mail via Outlook does not send (1 Viewer)

Public Function EmailPDFOutlook(MsgTo As String, _
                                MsgCC As String, _
                                MsgBCC As String, _
                                MsgSubject As String, _
                                MsgBody As String, _
                                ReportPath As String)

Dim olApp As Outlook.Application
Dim olMailItem As Outlook.MailItem

   On Error GoTo EmailPDFOutlook_Error
' If Outlook is closed, open Outlook
If olApp Is Nothing Then
    Set olApp = New Outlook.Application
End If

' Create a new email object
Set olMailItem = olApp.CreateItem(0)
' Add the To/Subject/Body/Attachments to the message then display the message
With olMailItem
.To = MsgTo
.CC = MsgCC
.BCC = MsgBCC
.Subject = MsgSubject
.Body = MsgBody
.Attachments.Add ReportPath
.Display
'.Send
End With

'DoEvents to keep outlook open so mail gets sent?
DoEvents

Set olMailItem = Nothing
Set olApp = Nothing

MsgBox "Email Sent", vbInformation, "Confirm Email"

   On Error GoTo 0
   Exit Function

EmailPDFOutlook_Error:

    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure EmailPDFOutlook of Module nsEmailPDF"

End Function

' Should we display the message before sending?
            If blnDisplayMsg Then
                .Display
            Else
                .Save
                .Send
            End If

Set olApp = CreateObject("Outlook.Application")

    ' See if Outlook is open, otherwise open it
    If fIsOutlookRunning = False Then
        Call OpenOutlook
        Pause (5)
    End If
    
    
    ' Create the Outlook session.
    Set objOutlook = GetObject(, "Outlook.Application")

Public Sub OpenOutlook()

    'Depending on your version of Access, Access.hWndAccessApp could also be Application.hWnd
    If ShellExecute(Access.hWndAccessApp, vbNullString, "Outlook", vbNullString, "C:\", 1) < 33 Then
        MsgBox "Outlook not found."
    End If
End Sub

Option Compare Database
Option Explicit
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long

Public Function fIsOutlookRunning() As Boolean
Dim W As Object
Dim processes As Object
Dim process As Object

fIsOutlookRunning = False

Set W = GetObject("winmgmts:")
Set processes = W.execquery("SELECT * FROM win32_process")

For Each process In processes
    If process.Name = "OUTLOOK.EXE" Then
        
        fIsOutlookRunning = True
        Exit For
        
    End If
Next

Set W = Nothing
Set processes = Nothing
Set process = Nothing

End Function

Public Function Pause(NumberOfSeconds As Variant)
On Error GoTo Err_Pause

    Dim PauseTime As Variant, start As Variant

    PauseTime = NumberOfSeconds
    start = Timer
    Do While Timer < start + PauseTime
    DoEvents
    Loop

Exit_Pause:
    Exit Function

Err_Pause:
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "Pause()"
    Resume Exit_Pause

End Function