Hi all,

I have a working mail macro and a signature macro, but when I want to merge them, it doesn't work. Below I'll paste both macro's, and my try to merge them. Does someone see what I do wrong? Thanks.

My e-mail macro
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

Sub SendEMail()

    Dim Email As String, Subj As String
    Dim Msg As String, URL As String
    Dim R As Integer, x As Double

    For R = 5 To 4 + Application.WorksheetFunction.CountIf(Range("E5", Cells(Rows.Count, 5).End(xlUp)), "*@*")
        '       Get the email address
        If Cells(R, 7) = Empty Then
    Email = Cells(R, 5)

    If LCase(Cells(R, 6).Value) = "nl" Then
        '       Message subject
        Subj = Cells(5, 22)

        '       Compose the message
            Msg = ""
        Msg = Msg & Cells(7, 20) & Cells(R, 3) & "," & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(8, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(9, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(11, 20) & Cells(R, 10) & "." & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(13, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(15, 20) & vbCrLf
        
        Msg = Msg & Cells(16, 20) & vbCrLf & vbCrLf
        Else
    '   Message subject
        Subj = Cells(18, 22)

        '       Compose the message
            Msg = ""
        Msg = Msg & Cells(20, 20) & Cells(R, 3) & "," & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(21, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(22, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(24, 20) & Cells(R, 10) & "." & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(26, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(28, 20) & vbCrLf
        
        Msg = Msg & Cells(29, 20) & vbCrLf & vbCrLf
        End If

        '       Replace spaces with %20 (hex)
        Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
        Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")

        '       Replace carriage returns with %0D%0A (hex)
        Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
        '       Create the URL
        URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg

        '       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus

        '       Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
        End If
    Next R
End Sub
My signature macro
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Sub Handtekening()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String

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

    strbody = "Hier komt de test"

    Sigstring = "C:\Users\Johannes Engelbert\AppData\Roaming\Microsoft\Handtekeningen\MySig.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next
    With OutMail
        .To = "Johannes@test.nl"
        .CC = ""
        .BCC = ""
        .Subject = "Test Onderwerp"
        .HTMLBody = strbody & "<br><br>" & Signature
        .Send
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
My try to merge them
Option Explicit

Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function


Sub TestEMail()

    Dim Email As String, Subj As String
    Dim Msg As String, URL As String
    Dim R As Integer, x As Double
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String

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

    For R = 5 To 4 + Application.WorksheetFunction.CountIf(Range("E5", Cells(Rows.Count, 5).End(xlUp)), "*@*")
        '       Get the email address
        If Cells(R, 7) = Empty Then
    Email = Cells(R, 5)

    If LCase(Cells(R, 6).Value) = "nl" Then
        '       Message subject
        Subj = Cells(5, 22)

    strbody = Msg = ""
        Msg = Msg & Cells(7, 20) & Cells(R, 3) & "," & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(8, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(9, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(11, 20) & Cells(R, 10) & "." & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(13, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(15, 20) & vbCrLf
        
        Msg = Msg & Cells(16, 20) & vbCrLf & vbCrLf
        Else
    '   Message subject
        Subj = Cells(18, 22)

        '       Compose the message
            Msg = ""
        Msg = Msg & Cells(20, 20) & Cells(R, 3) & "," & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(21, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(22, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(24, 20) & Cells(R, 10) & "." & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(26, 20) & vbCrLf & vbCrLf
        
        Msg = Msg & Cells(28, 20) & vbCrLf
        
        Msg = Msg & Cells(29, 20) & vbCrLf & vbCrLf
        End If

    SigString = "C:\Users\Rodney van Ekeren\AppData\Roaming\Microsoft\Handtekeningen\MySig.htm"
        
If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next
    With OutMail
        .To = "ikbenrodney@gmail.com"
        .CC = ""
        .BCC = ""
        .Subject = "Test Signature"
        .HTMLBody = strbody & "<br><br>" & Signature
        'You can add files also like this
        '.Attachments.Add ("C:\test.txt")
        .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing


'       Replace spaces with %20 (hex)
        Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
        Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")

        '       Replace carriage returns with %0D%0A (hex)
        Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
        '       Create the URL
        URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg

        '       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus

        '       Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
        End If
    Next R
End Sub