Create Outlook E-mail with VBA from Excel

BrittKnee

Board Regular
Joined
Dec 4, 2017
Messages
69
Hi All. I am working on a macro that will create separate e-mails to send to different users. I'm not able to get outlook to actually create the new item(in bold below). I've looked around it seems the code should work. Any help is appreciated.

Code:
    'Start Outlook
    'Set outApp = CreateObject("Outlook.Application")
    cmd = """" & Application.Path & "\OUTLOOK.EXE"""
    Shell cmd, vbHide
    t = Timer + 10  ' timeout = 10 seconds max
    While outApp Is Nothing And Timer < t
      Set outApp = GetObject(, "Outlook.Application")
    Wend
    
    'If Outlook start failed raise an error and exit
    If outApp Is Nothing Then
        MsgBox "Microsoft Outlook session is not created, email will not be sent.", vbCritical, "OUTLOOK ERROR"
        GoTo exitProcedure
    End If
    
    'Create mail
    Set outMail = outApp.CreateItem(0)
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

BrittKnee

Board Regular
Joined
Dec 4, 2017
Messages
69
Unfortunately, the same issue exists to where the code is opening outlook and running with no errors, but it doesn't actually create an e-mail. Below is the full code:

Code:
Public sh_emailSettings As Worksheet
Sub sendMailOneByOne()

    Call sendMail("Sheet1")
    Call sendMail("Sheet2")

End Sub

'Sub sendMailAllAtOnce()

    'Dim mailToRng As Range, cell As Range
    
    'Set mailToRng = ThisWorkbook.Sheets("Email Settings").Range("tbl_emailSettings[Mail To]")

    'For Each cell In mailToRng
        'Call sendMail(cell.Value)
    'Next cell

'End Sub

Sub sendMail(mailTo As String)

    Dim emailRow As Long
    Dim cell As Range
    Dim OutApp As Object, OutMail As Object
    Dim cmd As String, t As Single
    Dim strTo As String, strCc As String, strSub As String, strBody As String, strType As String, strAtt As String, attFilename As String, sendToFilename As String

    'On Error GoTo errorHandler

    'Store Email Settings Tab in a variable
    Set sh_emailSettings = ThisWorkbook.Sheets("Email Settings")

    'Store fileName in a variable
    sendToFilename = ThisWorkbook.Path & "\" & ThisWorkbook.Name

    'Find mailTo row in tbl_email_settings table
    For Each cell In sh_emailSettings.Range("tbl_emailSettings[Mail To]")
        If cell.Value2 <> "" Then
            If cell = mailTo Then
                emailRow = cell.Row
                Exit For
            End If
        End If
    Next cell

    'If no relevant row found with called mailTo then exit
    If emailRow = 0 Then
        MsgBox "Recipent " & mailTo & " not found. Please check.", vbCritical, "MISSING RECIPIENT"
        GoTo exitProcedure
    End If

    'Start Outlook
    'Set outApp = CreateObject("Outlook.Application")
    cmd = """" & Application.Path & "\OUTLOOK.EXE"""
    Shell cmd, vbHide
    t = Timer + 10  ' timeout = 10 seconds max
    While OutApp Is Nothing And Timer < t
    Set OutApp = GetObject(, "Outlook.Application")
    Wend
    
    'If Outlook start failed raise an error and exit
    If OutApp Is Nothing Then
        MsgBox "Microsoft Outlook session is not created, email will not be sent.", vbCritical, "OUTLOOK ERROR"
        GoTo exitProcedure
    End If
    
    'Create mail
    Set OutMail = OutApp.CreateItem(0)
    
    'Store email details in variables (receipient, copy, subject, email body etc)
    strTo = Trim(cell.Offset(0, 1))
    strCc = cell.Offset(0, 2)
    strSub = cell.Offset(0, 3)
    strAtt = cell.Offset(0, 4)
    strBody = cell.Offset(0, 5)
    strType = cell.Offset(0, 6)
        
    'create_attachment (str_att), Attacgment column in tbl_emailSettings
    attFilename = generateAttachment(strAtt)
    
    'If there was an error during attachment generation exit
    If attFilename = "" Then GoTo exitProcedure
    
    'create email
    With OutMail
        .To = strTo
        .CC = strCc
        .Subject = strSub
        .Body = strBody
        .Attachments.Add attFilename
        If strType = "Send" Then
            .send
        Else
            .Display
        End If
    End With
    
    'If not the whole file sent delete the temporary file
    If Dir(attFilename) <> "" And attFilename <> sendToFilename Then
        Kill attFilename
    End If

exitProcedure:
    Set OutMail = Nothing
    Set OutApp = Nothing
    Exit Sub
    
errorHandler:
    MsgBox (Err.Number & vbCrLf & Err.Description & vbCrLf & "Something went wrong during sendMail procedure.")
    On Error GoTo 0
    Resume exitProcedure
    
End Sub

Function generateAttachment(attachmentStr As String) As String
    
    Dim fileName As String
    Dim sh_array() As String
    Dim wbTemp As Workbook
    Dim sh As Worksheet
    Dim i As Long
    
    'On Error GoTo errorHandler
    
    'Turn off events
    Application.EnableEvents = False
    'Set calculation to manual
    Application.Calculation = xlCalculationManual
    'Turn off screen updating
    Application.ScreenUpdating = False

    Select Case attachmentStr
        
        'Whole file will be sent, in this case file's name remain the same
        Case "full"
            'NOTE: other possible solution is to Save As the workbook as a new file
            'Attached file name will be the same
            'fileName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
            
            'Function return value is the filename
            generateAttachment = fileName
        
        'Listed sheets will be sent
        Case Else
        
        'Store listed sheet names in an array (Attachment column in tbl_emailSettings)
    sh_array = Split(attachmentStr, ",")
    'Define name to the new the where the sheets will be copied, this will be the attachment name in the mail
    If UBound(sh_array) = 1 Then
    fileName = Application.ActiveWorkbook.Path & "\" & CStr(sh_array(1)) & ".xlsx"
    'Else
    'fileName = ThisWorkbook.Path & "\" & CStr(sh_array(1)) & ".xlsx"
    End If
            'Store listed sheet names in an array (Attachment column in tbl_emailSettings)
            'sh_array = Split(attachmentStr, ",")
        
            'Define name to  the new the where the sheets will be copied, this will be the attachment name in the mail
            'fileName = ThisWorkbook.Path & "\" & sh.Name & ".xlsx"
        
            'Add a new workbook
            Set wbTemp = Workbooks.Add(1)
        
            'Turn off alerts
            Application.DisplayAlerts = False
        
            'Copy sheets given on Email Settings sheet (Attachment column)
            'NOTE: if the workbook is protected and/or sheet(s) is hidden handle that before copying
            For i = UBound(sh_array) To LBound(sh_array) Step -1
                ThisWorkbook.Sheets(sh_array(i)).Copy after:=wbTemp.Sheets(1)
            Next i
        
            'Paste special values - only optional, if you 100% sure that no formula error will occur you can delete this part
            'NOTE: also worth to consider to delete names, break links and connections
            'For Each sh In wbTemp.Sheets

        
            'Delete first sheet
            wbTemp.Sheets(1).Delete
        
            'Save the new workbook
            wbTemp.SaveAs
            wbTemp.Close
       
            'Function return value is the fileName
            generateAttachment = fileName
    End Select

exitFunction:
    'Turn back on things
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Function

errorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & "Something went wrong. Check Attachment Settings."
    'In case of an error function return "empty" string
    generateAttachment = ""
    On Error GoTo 0
    Resume exitFunction

End Function
 

BrittKnee

Board Regular
Joined
Dec 4, 2017
Messages
69
What this code should do is open outlook and generate draft that attach specific worksheets to different e-mails. I have it set up so that the code references a table (e-mail settings) and uses that to attach, enter subject, enter to/cc, and attach the item. The whole macro runs with no errors, but the e-mails are never generated.
 

KenU

New Member
Joined
Jan 5, 2022
Messages
45
Office Version
  1. 365
Platform
  1. Windows
The following lines are most likely the problem:

VBA Code:
    'Store email details in variables (receipient, copy, subject, email body etc)
    strTo = Trim(cell.Offset(0, 1))
    strCc = cell.Offset(0, 2)
    strSub = cell.Offset(0, 3)
    strAtt = cell.Offset(0, 4)
    strBody = cell.Offset(0, 5)
    strType = cell.Offset(0, 6)

The loop that controls *cell* has already completed in this block:

VBA Code:
    'Find mailTo row in tbl_email_settings table
    For Each cell In sh_emailSettings.Range("tbl_emailSettings[Mail To]")
        If cell.Value2 <> "" Then
            If cell = mailTo Then
                emailRow = cell.Row
                Exit For
            End If
        End If
    Next cell

When your routine is trying to create a message, it no longer has an address.

Hope that helps.

Regards,
Ken
 

BrittKnee

Board Regular
Joined
Dec 4, 2017
Messages
69
I've entered a break right after the the CreateItem command and it still doesn't seem to want to create the e-mail. I'm at a loss.
 

KenU

New Member
Joined
Jan 5, 2022
Messages
45
Office Version
  1. 365
Platform
  1. Windows
When you are testing, are you calling your sendMail procedure from this routine?

VBA Code:
Sub sendMailOneByOne()

    Call sendMail("Sheet1")
    Call sendMail("Sheet2")

End Sub

If that is the case, you are passing the strings "Sheet1" and "Sheet2" as the "mailTo" parameter.
 

Forum statistics

Threads
1,181,228
Messages
5,928,770
Members
436,628
Latest member
Krakenfan69

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top