Issue with Mass-Email Excel macro

[MikeSta4ord]

Hello,

I'm having trouble getting my macro to effectively send a mass email which is based on a message template set up in excel. The code I am attempting is:

Sub SendEmail(what_address As String, subject_line As String, mail_body As String)

Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)
    
    olMail.To = what_address
    olMail.Subject = subject_line
    olMail.Body = mail_body
    olMail.Send
     
End Sub
Sub SendMassEmail()
     
    Row_number = 2
     
    Do While Sheet10.Range("C" & Row_number) <> ""
        DoEvents
        Dim mail_body_message As String
        Dim full_name As String
        Dim project_name As String
        Dim offer_number As String
        Dim IPS_contact As String
        Dim Customer_Email_Address As String
        Dim Days_Expired As Integer
        
Dim Follow_up_column As Range
     Dim i As Long
    
        
        Customer_Email_Address = Sheet10.Range("A" & Row_number)
        IPS_contact = Sheet10.Range("C" & Row_number)
        mail_body_message = Sheet10.Range("I2")
        Days_Expired = Sheet10.Range("H" & Row_number)
        full_name = Sheet10.Range("G" & Row_number)
        project_name = Sheet10.Range("E" & Row_number)
        offer_number = Sheet10.Range("F" & Row_number)
        mail_body_message = Replace(mail_body_message, "Days_Expired", Days_Expired)
        mail_body_message = Replace(mail_body_message, "IPS_Contact", IPS_contact)
        mail_body_message = Replace(mail_body_message, "Customer_Email_Address", Customer_Email_Address)
        mail_body_message = Replace(mail_body_message, "Offer_number", offer_number)
        mail_body_message = Replace(mail_body_message, "Customer_name", full_name)
        mail_body_message = Replace(mail_body_message, "Project_name", project_name)
    
        
        
        Call SendEmail(Sheet10.Range("D" & Row_number), "Reminder to send followup email", mail_body_message)
        Row_number = Row_number + 1
          
     Loop
   
     
    Set Follow_up_column = Sheet3.Range("R2:R10000")
     
    For i = 2 To 10000
        If Follow_up_column.Cells(i).Value = "Yes" Then
            Follow_up_column.Cells(i).Value = "Reminder Sent"
            MsgBox "Reminders Sent!"
        End If
    Next i
    
   
End Sub

It's not giving me a particular error but nothing is happening after I execute the macro. So I suppose I am missing something within the code for it to execute correctly. It is also supposed to be deleting the data in the email tab when it sends out the email, and changing yes in the proposal log to "Reminder sent". It worked fine a couple weeks ago but has gone inactive since I updated the macro to include more rows. I've had others test the code on office 2007 and 2010 and it works as it's suppose to so there might be with an issue with my office 2016.

I will attach a sample file to show you the excel file I am working with. You have to input an email address to test the macro on yourself. Please let me know if you need anything else from me.

Thank-You very much for the help
Mike

[Jan Karel Pieterse]

This worked for me:

Dim molApp As Outlook.Application
Sub SendEmail(what_address As String, subject_line As String, mail_body As String)
    Dim olMail As Outlook.MailItem
    If molApp Is Nothing Then
        Set molApp = New Outlook.Application
    End If
    Set olMail = molApp.CreateItem(olMailItem)
    olMail.To = what_address
    olMail.Subject = subject_line
    olMail.Body = mail_body
    olMail.Send
    Set olMail = Nothing
End Sub

Note that I removed the createobject, that is only needed when you use late binding.

[MikeSta4ord]

I've identified the issue, like you suggested the macro works fine. The issue was with the outlook outbound server I was connected to, after updating the server number I was able to send the email.

Thank-you