Hello

Newbie here, need some help with this Managed to get this sending out using Excel with SMTP; and it loops through the dates just fine. However when sending out one e-mail at a time, the first one sent has the signature (not attached, but displayed where it should), second e-mail sent, will do the same, BUT also add the signature as an attachment. Third e-mail sent will do the same but add the signature as an attachment TWICE, and it will repeat the the cycle adding more and more signature images as attachments

TLDR goes like this 1 e-mail sent = 0 attachment 2 e-mail sent = 1 attachment 3 e-mail sent = 2 attachment Basically don't want any attached files, just a signature

Hope this makes sense :)

Sub SendMail()
    Set MyEmail = CreateObject("CDO.Message")
    Path = "C:\Users\Users1\Desktop\Signature\"


    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Sheet1")
    Set sh2 = ThisWorkbook.Sheets("Sheet2")

    Dim nDateTime As Date, oDateTime As Date
    nDateTime = Now
    oDateTime = nDateTime - 3

    Dim last_row As Integer
    last_row = Application.CountA(sh.Range("A:A"))
    For i = 2 To last_row
    Set emailConfig = MyEmail.Configuration

With MyEmail
    emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing")
= redacted
    emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver")
= redacted
    emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= redacted
    emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")
= redacted
    emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl")
= redacted
    emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername")
= redacted
    emailConfig.Fields.Update
    MyEmail.Configuration.Fields.Update

End With

mail_body_message = sh2.Range("D2")
serial_number = sh.Range("A" & i).Value
mail_body_message = Replace(mail_body_message, "replace_serial_here", serial_number)
Attachment = Path   Filename
signaturelogo = "userSignature.png"

With MyEmail

Attachment = Path   Filename
signaturelogo = "userSignature.png"
Path = "C:\Users\Users1\Desktop\Signature\"
.Subject = "Hello there (HTTPS) Serial: " & serial_number
.From = "redacted"
.To = sh.Range("B" & i).Value
.HTMLBody = mail_body_message
.Attachments.Add Path & signaturelogo, 0

End With
    If sh.Range("C" & i).Value <= oDateTime Then

MyEmail.Send

End If

Next i

End Sub

CodePudding user response：

Because you are re-using the same object just attach the logo once at the start.

Option Explicit

Sub SendMyMail()
    
    Const LOGO = "C:\Users\Users1\Desktop\Signature\userSignature.png"
    Const DAYS = 3
    Const SCHEMA = "http://schemas.microsoft.com/cdo/configuration/"
    
    ' configure email
    Dim MyEmail As Object
    Set MyEmail = CreateObject("CDO.Message")
    With MyEmail
        With .Configuration.Fields
            .Item(SCHEMA & "sendusing") = 2
            .Item(SCHEMA & "smtpserver") = "smtp.#.com"
            .Item(SCHEMA & "smtpserverport") = 465
            .Item(SCHEMA & "smtpauthenticate") = 1
            .Item(SCHEMA & "sendusername") = "#@#"
            .Item(SCHEMA & "sendpassword") = "#"
            .Item(SCHEMA & "smtpusessl") = 1
            .Update
        End With
        ' add logo
        .AddAttachment LOGO
    End With
    
    Dim sh As Worksheet, sh2 As Worksheet
    Dim serialno As String, n As Long, i As Long, last_row As Long
    Set sh = ThisWorkbook.Sheets("Sheet1")
    Set sh2 = ThisWorkbook.Sheets("Sheet2")
    
    With sh
        last_row = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    For i = 2 To last_row
        If sh.Range("C" & i).Value <= Now - DAYS Then
            serialno = sh.Range("A" & i).Value
            With MyEmail
                .Subject = "Hello there (HTTPS) Serial: " & serialno
                .From = "redacted"
                .To = sh.Range("B" & i).Value
                .HTMLBody = Replace(sh2.Range("D2"), "replace_serial_here", serialno)
                
                ' send
                On Error Resume Next
                .Send
                If Err.Number = 0 Then
                    n = n   1
                Else
                    MsgBox Err.Description, vbExclamation, "Error Row " & i
                End If
                On Error GoTo 0
                
            End With
        Else
            'Debug.Print "Skipped row " & i & " = " & sh.Range("C" & i)
        End If
    Next
    
    MsgBox n & " emails sent", vbInformation

End Sub

CodePudding user response：

Ended up removing .Attachments.Add Path & signaturelogo, 0

For .HTMLBody = mail_body_message Changed to below, (the fix) .HTMLBody = mail_body_message & " "