How to send these created outlook emails?

[cutemeatball]

So I have this existing Macro from 2012? This basically separates all the individual sheets from this one workbook and creates an outlook email with the correspondent sheet attached. Problem is it displays all the outlook emails ,but does not send it all automatically. Can anyone help me with this? the line that has If lngSend = vbYes Then OutMail.Display Else OutMail.Save is probably what needs to be looked at if im trying to guess here. I tried replacing Display with Send but nothing happened. Macro just kept running and no emails were sent.

Option Explicit

Sub RenameToLocations()
Dim wks As Worksheet
Dim wksAddr As Worksheet
Dim rng As Range
Dim strCode As String
Dim strState As String

Set wksAddr = Worksheets("Addresses")

For Each rng In wksAddr.Range("A3:A" & wksAddr.Range("A" & Rows.Count).End(xlUp).Row)
    strCode = rng
    strState = rng.Offset(0, 1)
    For Each wks In Worksheets
        If LCase(wks.Name) = LCase(strCode) Then
            wks.Name = strState
            Exit For
        Else: End If
    Next wks
Next rng
End Sub

Sub SendSheets()
'
' Macro2 Macro
' Macro recorded 6/19/2009 by Jennie Warren

On Error GoTo Problem

Dim i As Integer
Dim strName As String
Dim wkbNew As Workbook
Dim wksSheet As Worksheet
Dim rngAddress As Range
Dim strSendTo As String
Dim intCount As Integer
Dim strFileName As String
Dim strBody As String


RenameToLocations

Set rngAddress = Worksheets("Addresses").Range("C3")
strBody = Worksheets("Addresses").Range("EmailSubject").Value
strBody = strBody & Worksheets("Addresses").Range("H2").Value  'Added 12/4/2012

intCount = 0

    For i = 1 To Worksheets.Count
        strName = Sheets(i).Name
        Set wksSheet = Sheets(i)
        If Not strName = "Summary" And Not strName = "Data_Sales" And Not strName = "Data_OpenOrders" And Not strName = "Data_CustInsCodes" And Not strName = "Addresses" And Not strName = "Summary By Loc" And Not strName = "Forecast By Reg Subtotaled" And Not strName = "MTD_Sales qry 975" And Not strName = "QTD_Sales qry 9951" And Not strName = "Data_Sales" And Not strName = "Data_OpenOrders" And Not strName = "Data_CustInsCodes" And Not strName = "Addresses" And Not strName = "Summary By Loc" And Not strName = "Forecast By Reg Subtotaled" And Not strName = "MTD_Sales qry 975" And Not strName = "LastYTDSales qry 9998" And Not strName = "Data_Sales" And Not strName = "Data_OpenOrders" And Not strName = "Data_CustInsCodes" And Not strName = "Addresses" And Not strName = "Summary By Loc" And Not strName = "Forecast By Reg Subtotaled" And Not strName = "MTD_Sales qry 975" And Not strName = "Forecast" And Not strName = "Misc" Then
            intCount = intCount + 1
            Set wkbNew = Workbooks.Add
            wksSheet.Copy before:=wkbNew.Sheets(1)
            With wkbNew.ActiveSheet.Cells
                .Copy
                .PasteSpecial Paste:=xlPasteValues
            End With
          
            For Each wksSheet In wkbNew.Worksheets
                If Not wksSheet.Name = strName Then
                    Application.DisplayAlerts = False
                    wksSheet.Delete
                    Application.DisplayAlerts = True
                End If
            Next wksSheet
          
            wkbNew.SaveAs ThisWorkbook.Path & "\" & strName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
          
            If Len(Trim(rngAddress.Value)) > 0 Then
                strSendTo = rngAddress.Value
                If Len(Trim(rngAddress.Offset(0, 1).Value)) > 0 Then
                    strSendTo = strSendTo & ";" & rngAddress.Offset(0, 1)
                Else: End If
              
                If Len(Trim(rngAddress.Offset(0, 2).Value)) > 0 Then
                    strSendTo = strSendTo & ";" & rngAddress.Offset(0, 2)
                Else: End If
              
                Set rngAddress = rngAddress.Offset(1, 0)
            Else
                strSendTo = InputBox("Mail " & strName & " to:", "Enter E-mail Address")
            End If
          
            strFileName = wkbNew.FullName
            'SendNotesMsg strSendTo, , strName, strBody, strFileName
            SendOutlookMsg strSendTo, , strName, strBody, strFileName '# Uses function for Outlook messages
          
          wkbNew.Close
        
          Kill strFileName
        End If
    Next i

End_Now:

    Set wksSheet = Nothing
    Set wkbNew = Nothing
    Exit Sub
  
Problem:
    MsgBox "An unexpected error occurred.  Please contact your file administrator." & vbCrLf _
        & "Error #: " & Err.Number & " Error Desc.: " & Err.Description & vbCrLf _
        & "This procedure will now be terminated."
    GoTo End_Now
      
End Sub



Function SendNotesMsg( _
ByVal sSendTo As Variant, _
Optional ByVal sCC As Variant, _
Optional ByVal sSubject As String, _
Optional ByVal sBodyText As String, _
Optional ByVal sAttachment As Variant _
) As Long
'*******************************************************************************
'Purpose: Send a Notes mail message

'Arguments: sSendTo (Required)- a string of the Name of a single recipient
' or an array of strings for multiple recipients
'If needs to use Multiple recipients, then
'sSendTo to must be passed in as an array
' sCC (Optional)- same rules as the sSendTo parameter, except the names
' will be used in the CC field
' sSubject (Optional)-the string to be used for the Subject line
' sBodyText (Optional)-the string to be used for the Body of the message
' sAttachment (Optional)-the string or an array of strings containing the
' path and file name of
' file(s) to be attached
'Sample Syntax SendNotesMsg "Blake Hartman", "This is the subject", "The body","C:\data\mydoc.doc"
'**********************************************************************************
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim i As Long
Dim v As Variant
Dim ntsServer As String
Dim ntsMailFile As String
'use the below constant lines instead of the above 2 lines
'only if hard coding in the server and mailfile name
'Use empty string for ntsServer if it is a local database
'Const ntsserver = "notes46/pchelps46"
'Const ntsmailFile = "mail\bhartman.nsf"
'On Error GoTo err_SendNotesMsg
'Set oSess = CreateObject("Notes.NotesSession")
'don't use the next 2 if using the constants
'gets server name
'ntsServer = oSess.GetEnvironmentString("MailServer", True)
'get the mailfile name of current user from the Notes.ini
'ntsMailFile = oSess.GetEnvironmentString("MailFile", True)
'Set oDB = oSess.GetDatabase(ntsServer, ntsMailFile)
Set oDB = oSess.GetDatabase("", "")

Set oDoc = oDB.CreateDocument
Set oItem = oDoc.CreateRichTextItem("BODY")

oDoc.Form = "Memo"

If Not IsMissing(sSubject) Then
If sSubject <> "" Then oDoc.Subject = sSubject
End If

If Not IsMissing(sSubject) Then
If sBodyText <> "" Then oDoc.Body = sBodyText
End If

oDoc.from = oSess.CommonUserName
oDoc.PostedDate = Date

If IsMissing(sAttachment) Then
' Nothing to do
ElseIf IsArray(sAttachment) Then
    For i = LBound(sAttachment) To UBound(sAttachment)
        If sAttachment(i) <> "" Then Call oItem.EmbedObject(1454, "", sAttachment(i))
    Next
Else
    If sAttachment <> "" Then Call oItem.EmbedObject(1454, "", sAttachment)
End If

If IsMissing(sCC) Then
' nothing to do
Else
oDoc.CopyTo = sCC
End If
'split sSendto into an array for multiple recipients
Dim sEmailArray() As String

sEmailArray = SplitEx(sSendTo, True, ";")
oDoc.SendTo = sEmailArray
oDoc.SaveMessageOnSend = True  'Added 12/4/2012 to save email in sent items folder
'send the message
Call oDoc.Send(False)
SendNotesMsg = 0
'MsgBox "Your message was sent", vbInformation
exit_SendNotesMsg:
On Error Resume Next
Set oSess = Nothing
Set oDB = Nothing
Set oDoc = Nothing
Set oItem = Nothing

Exit Function

err_SendNotesMsg:

SendNotesMsg = Err.Number
If Err.Number = 7225 Then
    MsgBox "Couldn't create attachment. make sure it is a valid path and Filename!", vbCritical
Else
    MsgBox "[" & Err.Number & "]: " & Err.Description
End If
MsgBox "Message was NOT sent!", vbCritical
Resume exit_SendNotesMsg
Resume
End Function


[FONT=georgia]Function SendOutlookMsg( _
ByVal sSendTo As Variant, _
Optional ByVal sCC As Variant, _
Optional ByVal sSubject As String, _
Optional ByVal sBodyText As String, _
Optional ByVal sAttachment As Variant, _
Optional ByVal lngSend As Long = vbYes _
) As Long
'################################################################
'# Added 8/20/2015 by Marshall Heikkila at theITSupportCenter   #
'################################################################
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

  
    On Error Resume Next

    With OutMail
        .To = sSendTo
        .CC = sCC
        .BCC = ""
        .Subject = sSubject
        .Body = sBodyText
        .Attachments.Add sAttachment
        .Send
    End With
  
  
    If lngSend = vbYes Then OutMail.Display Else OutMail.Save
  
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Function[/FONT]


Function SplitEx(ByVal InString As String, IgnoreDoubleDelmiters As Boolean, _
        ParamArray Delims() As Variant) As String()
    Dim Arr() As String
    Dim Ndx As Long
    Dim N As Long
  
    If Len(InString) = 0 Then
        SplitEx = Arr
        Exit Function
    End If
    If IgnoreDoubleDelmiters = True Then
        For Ndx = LBound(Delims) To UBound(Delims)
            N = InStr(1, InString, Delims(Ndx) & Delims(Ndx), vbTextCompare)
            Do Until N = 0
                InString = Replace(InString, Delims(Ndx) & Delims(Ndx), Delims(Ndx))
                N = InStr(1, InString, Delims(Ndx) & Delims(Ndx), vbTextCompare)
            Loop
        Next Ndx
    End If
  
  
    ReDim Arr(1 To Len(InString))
    For Ndx = LBound(Delims) To UBound(Delims)
        InString = Replace(InString, Delims(Ndx), Chr(1))
    Next Ndx
    Arr = Split(InString, Chr(1))
    SplitEx = Arr
End Function

 

[6StringJazzer]

First, called Send should send the email at that point in the code, end of story. I do not know why that is not happening. How did you determine that the email is not being sent?

Second, the intent of the function is to either display the email and allow the user to send it, or simply save it. This is controlled by the flag lngSend. However, it appears that you want to change that intent and always send it. Therefore I would delete the line

    If lngSend = vbYes Then OutMail.Display Else OutMail.Save

and remove lngSend as an argument to the function. I don't think that is causing your problem but I don't know what happens if you try to Display or Save an email that has already been sent.

 

[cutemeatball]

First, called Send should send the email at that point in the code, end of story. I do not know why that is not happening. How did you determine that the email is not being sent?

Second, the intent of the function is to either display the email and allow the user to send it, or simply save it. This is controlled by the flag lngSend. However, it appears that you want to change that intent and always send it. Therefore I would delete the line

    If lngSend = vbYes Then OutMail.Display Else OutMail.Save

and remove lngSend as an argument to the function. I don't think that is causing your problem but I don't know what happens if you try to Display or Save an email that has already been sent.

I just ran the macro and it just displays all the emails that was made in outlook.

I'll try deleting and let you know.

 

[cutemeatball]

First, called Send should send the email at that point in the code, end of story. I do not know why that is not happening. How did you determine that the email is not being sent?

Second, the intent of the function is to either display the email and allow the user to send it, or simply save it. This is controlled by the flag lngSend. However, it appears that you want to change that intent and always send it. Therefore I would delete the line

    If lngSend = vbYes Then OutMail.Display Else OutMail.Save

and remove lngSend as an argument to the function. I don't think that is causing your problem but I don't know what happens if you try to Display or Save an email that has already been sent.

This seemed to work:
I deleted the line and replaced the send with
.Display
SendKeys "^{ENTER}


Thanks for your tips!