Send Email without Outlook (1 Viewer)

[Moore71]

Hi,
I am here again with a bit of challenge to tackle.
I want to send email from ms Access without Outlook, so I copied the following code from this forum, but my problem is how do I implement it on my application. Where do I place the code and how do I call it from my application?
I used "Call SendEmail" on a button, it is raising error. I also used "ModuleName.SendEmail", it is also raising error.
Here's the code:
Private Const URL_CDOCONFIG As String = "http://schemas.microsoft.com/cdo/configuration/"


Public Function SendEmail(ByVal sTo As String, ByVal sFrom As String, _
Optional ByVal sCC As String = "", Optional ByVal sBCC As String = "johnmc71@hotmail.com", _
Optional ByVal sSubject As String = "Just a Test", Optional ByVal sBody As String = "My Testing email body", _
Optional ByVal sServer As String = "smtp.gmail.com", Optional ByVal iPort As Integer = 587, _
Optional ByVal sUsername As String = "myEmail@gmail.com", Optional ByVal sPassword As String = "myPassword", _
Optional ByVal iSendUsing As Integer = 2, Optional ByVal bAuthenticate As Boolean = True, _
Optional ByVal bUseSSL As Boolean = True, Optional ByVal iTimeout As Integer = 60) As Boolean

On Error Resume Next
Err.Clear
Dim cdoConfig As Object
Dim cdomsg As Object

Set cdoConfig = CreateObject("CDO.Configuration")
Set cdomsg = CreateObject("CDO.Message")

'Dim cdomsg As CDO.Message
'Set cdomsg = CreateObject("CDO.message")
If Err Then
Debug.Print Err.Description
SendEmail = False 'Message not sent
Else
With cdomsg
With .Configuration.Fields
.Item(URL_CDOCONFIG & "sendusing") = iSendUsing
.Item(URL_CDOCONFIG & "smtpserver") = sServer
.Item(URL_CDOCONFIG & "smptserverport") = iPort
.Item(URL_CDOCONFIG & "smtpauthenticate") = IIf(bAuthenticate, 1, 0)
.Item(URL_CDOCONFIG & "smtpusessl") = bUseSSL
.Item(URL_CDOCONFIG & "smtpconnectiontimeout") = iTimeout
.Item(URL_CDOCONFIG & "sendusername") = sUsername
.Item(URL_CDOCONFIG & "sendpassword") = sPassword
.Update
End With
.To = sTo
.From = sFrom
.CC = sCC
.BCC = sBCC
.Subject = sSubject
.TextBody = sBody
If Err Then
Debug.Print Err.Description
SendEmail = False 'Message not sent
Else
DoCmd.Hourglass True
.Send
DoCmd.Hourglass False
If Err Then
Debug.Print Err.Description
SendEmail = False 'Message not sent
Else
SendEmail = True 'Message sent
End If
End If
End With
Set cdomsg = Nothing
End If
End Function

Thanks for quick reply,
Moore71

 

[pbaldy]

You'd copy all that into a standard module, named anything but SendEmail (the module can't have the same name as function). Then you'd call it, passing at least the 2 required arguments:

SendEmail "paul@xyz.com", "bill@123.com"

Of course, you have to put all your server and credential info in it.

 

[Moore71]

Yes,I did all that stuff, but I still get error.
So my puzzle is do I have to create a form with the field names as the variable in the modules?

 

[pbaldy]

I wonder what the error message is.

It would be common to use a form for user input, but not necessary.

 

[isladogs]

See if this function will do what you need.
Place it in a standard module

Public Function SendEmailUsingOutlook(strSendTo As String, strCopyTo As String, strSubject As String, strMessage As String, strAttachment As String)

On Error GoTo ErrHandler

'Uses late binding to send email without displaying Outlook

Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim StartOutlookFlag As Boolean

StartOutlookFlag = False

' Create the Outlook session.
If IsAppRunning("Outlook.Application") = True Then
    'Use existing instance of Outlook
    Set objOutlook = CreateObject("Outlook.Application")
Else
   'Could not get instance of Outlook, so create a new one
        Path = GetAppExePath("outlook.exe")    'determine outlook's installation path
        Shell (Path), vbMinimizedFocus   'start outlook
        Do While Not IsAppRunning("Outlook.Application")
            DoEvents
        Loop
        Set objOutlook = GetObject(, "Outlook.Application") 'Bind to new instance of Outlook
        StartOutlookFlag = True 'needed so Outlook can be closed later
End If

' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)

' Add the To/Subject/Body/Attachments to the message then send the message
With objOutlookMsg
    .To = strSendTo
    .CC = strCopyTo
    .Subject = strSubject
    .Body = strMessage
    If Nz(strAttachment, "") <> "" Then
        .Attachments.Add strAttachment
    End If
   ' .Display 'do not display message
    .Save
    .Send
End With

Set objOutlook = Nothing
Set objOutlookMsg = Nothing

'close Outlook if it was opened for this function - time may need modifiying
DoEvents
DoEvents
Wait 5 'allow time to send message
If StartOutlookFlag = True Then CloseOutlook

ErrHandlerExit:
   Exit Function

ErrHandler:
   If Err.Number <> 287 Then 'And err.Number <> 429 Then
        MsgBox "Error " & Err.Number & " in SendEMailUsingOutlook routine: " & Err.Description
   End If
   Resume ErrHandlerExit

End Function

It references the following functions - some from DevHut.com
The declarations have been updated for 32-bit or 64-bit Access

Option Compare Database   ' Use database order for string comparisons.
Option Explicit           ' Require variables to be declared before being used.

'###############################################
'Add PtrSafe - required for 64-bit Office (VBA7)
#If VBA7 Then
    Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
        "GetOpenFileNameA" (pOpenfilename As OpenFilename) As Boolean
    Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
        "GetSaveFileNameA" (pOpenfilename As OpenFilename) As Boolean
#ElseIf Win64 Then 'need datatype LongPtr
    Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
        "GetOpenFileNameA" (pOpenfilename As OpenFilename) As Boolean
    Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
        "GetSaveFileNameA" (pOpenfilename As OpenFilename) As Boolean
#Else '32-bit Office
    Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
        "GetOpenFileNameA" (pOpenfilename As OpenFilename) As Boolean
    Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
        "GetSaveFileNameA" (pOpenfilename As OpenFilename) As Boolean
#End If
'###############################################

Type MSA_OPENFILENAME
    ' Filter string used for the Open dialog filters.
    ' Use MSA_CreateFilterString() to create this.
    ' Default = All Files, *.*
    strFilter As String
    ' Initial Filter to display.
    ' Default = 1.
    lngFilterIndex As Long
    ' Initial directory for the dialog to open in.
    ' Default = Current working directory.
    strInitialDir As String
    ' Initial file name to populate the dialog with.
    ' Default = "".
    strInitialFile As String
    strDialogTitle As String
    ' Default extension to append to file if user didn't specify one.
    ' Default = System Values (Open File, Save File).
    strDefaultExtension As String
    ' Flags (see constant list) to be used.
    ' Default = no flags.
    lngFlags As Long
    ' Full path of file picked.  When the File Open dialog box is
    ' presented, if the user picks a nonexistent file,
    ' only the text in the "File Name" box is returned.
    strFullPathReturned As String
    ' File name of file picked.
    strFileNameReturned As String
    ' Offset in full path (strFullPathReturned) where the file name
    ' (strFileNameReturned) begins.
    intFileOffset As Integer
    ' Offset in full path (strFullPathReturned) where the file extension begins.
    intFileExtension As Integer
End Type

Const ALLFILES = "All Files"

Type OpenFilename
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    nMaxCustrFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustrData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type

Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10

Const msoFileDialogFilePicker = 3       'File picker dialog box.
Const msoFileDialogFolderPicker = 4     'Folder picker dialog box.
Const msoFileDialogOpen = 1             'Open dialog box.
Const msoFileDialogSaveAs = 2           'Save As dialog box.

'---------------------------------------------------------------------------------------
' Procedure : IsAppRunning
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine is an App is running or not
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sApp      : GetObject Application to verify if it is running or not
'
' Usage:
' ~~~~~~
' IsAppRunning("Outlook.Application")
' IsAppRunning("Excel.Application")
' IsAppRunning("Word.Application")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Oct-31                 Initial Release
'---------------------------------------------------------------------------------------
Function IsAppRunning(sApp As String) As Boolean
    On Error GoTo Error_Handler
    
    Dim oApp As Object
 
    Set oApp = GetObject(, sApp)
    IsAppRunning = True
 
Error_Handler_Exit:
    On Error Resume Next
    Set oApp = Nothing
    Exit Function
 
Error_Handler:
    Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : GetAppExePath
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine the path for a given exe installed on the local computer
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sEXEName  : Name of the exe to locate
'
' Usage:
' ~~~~~~
' Call GetAppExePath("msaccess.exe")
' GetAppExePath("firefox.exe")
' GetAppExePath("outlook.exe")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Oct-31                 Initial Release
'---------------------------------------------------------------------------------------
Function GetAppExePath(ByVal sExeName As String) As String
    On Error GoTo Error_Handler
    Dim WshShell        As Object
 
    Set WshShell = CreateObject("Wscript.Shell")
    GetAppExePath = WshShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & sExeName & "\")
 
Error_Handler_Exit:
    On Error Resume Next
    Set WshShell = Nothing
    Exit Function
 
Error_Handler:
    If Err.Number = -2147024894 Then
        'Cannot locate requested exe????
    Else
        MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: " & sExeName & "/GetAppExePath" & vbCrLf & _
               "Error Description: " & Err.Description, _
               vbCritical, "An Error has Occured!"
    End If
    Resume Error_Handler_Exit
End Function

Sub Wait(N As Integer)  'creates a delay while other programs execute

    For zCount = 1 To N
        Sleep 1000              'sleep function from api library file
    Next zCount
    DoEvents 
End Sub

 

[pbaldy]

I'll get out of the way.

 

[isladogs]

Sorry Paul - didn't mean to tread on your toes...

 

[Moore71]

Well thank you all for your contributions. I will try these out now and get back to you, soon
thank you all