VBA, Insert outlook signature in vba code

Question

I have a vba code which sends automatically emails when a due date is approaching at least 7 seven days from the current date.

The problem is they when the email is sent without my outlook signature.

The code is:

Sub email()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

Sheets(1).Select
lRow = Cells(Rows.Count, 4).End(xlUp).Row

For i = 2 To lRow
toDate = Cells(i, 3)
 If toDate - Date <= 7 Then
     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)

        toList = Cells(i, 4)    'gets the recipient from col D
        eSubject = "Doukementacion per  " & Cells(i, 2) & " Targa " & Cells(i, 5)
        eBody = "Pershendetje Adjona" & vbCrLf & vbCrLf & "Perfundo dokumentacionin e nevojshem per " & Cells(i, 2) & " me targa " & Cells(i, 5)

        On Error Resume Next
        With OutMail
        .To = toList
        .CC = ""
        .BCC = ""
        .Subject = eSubject
        .Body = eBody
        .bodyformat = 1
        '.Display   ' ********* Creates draft emails. Comment this out when you are ready
        .Send     '********** UN-comment this when you  are ready to go live
        End With
  On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
 Cells(i, 11) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i

ActiveWorkbook.Save

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

Answer 1

Sub CreateManagingTeamPresentationWithImages() Dim pptApp As Object Dim pptPres As Object Dim slideIndex As Integer Dim slide As Object Dim titleText As String Dim bodyText As String

' Create a new PowerPoint application
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add

' Define slide content and image URLs
Dim slidesContent As Variant
slidesContent = Array( _
    Array("Creating and Managing a Team", "Effective team management is crucial for achieving organizational goals. This presentation will guide you through the key steps in building and leading a successful team.", "https://example.com/team-management.jpg"), _
    Array("1. Identifying Team Needs", "Assess the project's goals and requirements to determine the skills and expertise needed. Analyze existing resources and identify gaps that need to be filled by new team members.", "https://example.com/identify-needs.jpg"), _
    Array("2. Recruiting the Right Talent", "Develop a clear job description and recruit team members who possess the required skills and align with the team's goals. Utilize various recruitment channels and conduct thorough interviews to ensure a good fit.", "https://example.com/recruit-talent.jpg"), _
    Array("3. Building Team Cohesion", "Foster a collaborative environment by encouraging open communication, trust, and mutual respect among team members. Organize team-building activities to strengthen relationships and improve teamwork.", "https://example.com/team-cohesion.jpg"), _
    Array("4. Setting Clear Goals and Expectations", "Define clear, achievable goals for the team and establish expectations for performance. Ensure that each team member understands their role and responsibilities in achieving these goals.", "https://example.com/clear-goals.jpg"), _
    Array("5. Providing Ongoing Support and Training", "Offer continuous support and opportunities for professional development. Provide feedback, recognize achievements, and address any issues promptly to keep the team motivated and skilled.", "https://example.com/support-training.jpg"), _
    Array("6. Monitoring Progress and Making Adjustments", "Regularly review the team's progress towards goals. Use performance metrics to evaluate effectiveness and make necessary adjustments to strategies or team structure to improve results.", "https://example.com/monitor-progress.jpg") _
)

' Create slides based on the content
For slideIndex = LBound(slidesContent) To UBound(slidesContent)
    Set slide = pptPres.Slides.Add(slideIndex + 1, 1) ' 1 stands for ppLayoutTitle
    slide.Shapes.Title.TextFrame.TextRange.Text = slidesContent(slideIndex)(0)
    slide.Shapes.Placeholders(2).TextFrame.TextRange.Text = slidesContent(slideIndex)(1)
    
    ' Add image to slide
    With slide.Shapes.AddPicture(FileName:=slidesContent(slideIndex)(2), LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=100, Top:=100, Width:=400, Height:=300)
        .LockAspectRatio = msoTrue
    End With
Next slideIndex

' Cleanup
Set slide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing

End Sub

Answer 2

If you don't have picture in your signature and can use .body , then you can just use this simplest tool in my opinion.

Sub Mail_Workbook_1()
    Dim OutApp As Object
    Dim Outmail As Object

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

    On Error Resume Next

    With OutMail
         .Display
    End With

         Signature = OutMail.body

    With OutMail

        .Subject = "This is the Subject line"
        .Body = strbody & Signature
        .Send    'or use .Display

    End with

    On Error GoTo 0

       Set Outmail = Nothing
       Set OutApp = Nothing

End Sub

Have a great day

Answer 3

What I found helpful was to make it a HTMLBody. so this part:

With OutMail
    .To = toList
    .CC = ""
    .BCC = ""
    .Subject = eSubject
    .Body = eBody
    .bodyformat = 1
    '.Display   ' ********* Creates draft emails. Comment this out when you are ready
    .Send     '********** UN-comment this when you  are ready to go live
End With

would look like

With OutMail
    .Display 'ads the signature
    .To = toList
    .Subject = eSubject
    .HTMLBody = eBody & .HTMLBody
    '.Display   ' ********* Creates draft emails. Comment this out when you are ready
    .Send     '********** UN-comment this when you  are ready to go live
    End With

You might need to toggle events, not sure since I haven't tested with events disabled