Can't merge my mail macro and signature macro

**JohannesEngelbert** · 02-14-2010, 10:04 AM

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

**JohannesEngelbert** · 02-14-2010, 01:54 PM

I have now changed it to the code below, but it isn't running perfect. When I run the macro, he opens one new e-mail with the correct text and signature, but with no adress, no subject and no returns in it. The rest of the mails he opens are correct, but do not have the signature in it.

rivate 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

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 probeer()

    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 = Cells(7, 20) & Cells(R, 3) & "," & vbCrLf & vbCrLf
    strbody = strbody & Cells(8, 20) & vbCrLf & vbCrLf
    strbody = strbody & Cells(9, 20) & vbCrLf & vbCrLf
    strbody = strbody & Cells(11, 20) & Cells(R, 10) & "." & vbCrLf & vbCrLf
    strbody = strbody & Cells(13, 20) & vbCrLf & vbCrLf
    strbody = strbody & Cells(15, 20) & vbCrLf
    strbody = strbody & Cells(16, 20) & vbCrLf & vbCrLf
        Else
    '   Message subject
        Subj = Cells(18, 22)

        '       Compose the message
    strbody = Cells(20, 20) & Cells(R, 3) & "," & vbCrLf & vbCrLf
    strbody = strbody & Cells(21, 20) & vbCrLf & vbCrLf
    strbody = strbody & Cells(22, 20) & vbCrLf & vbCrLf
    strbody = strbody & Cells(24, 20) & Cells(R, 10) & "." & vbCrLf & vbCrLf
    strbody = strbody & Cells(26, 20) & vbCrLf & vbCrLf
    strbody = strbody & Cells(28, 20) & vbCrLf
    strbody = strbody & 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
        .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