Handtekening wordt niet opgenomen in VBA code

[BertDP]

Hallo,

Ik heb een Excel document dat ik via vba wil versturen in Outlook. Ik vond via het forum de onderstaande code. Dit werkt perfect.

Alleen wordt de handtekening van de verzender niet automatisch opgenomen in de mail. Dit gebeurt wel als ik de 2 codes in het rood delete. Maar dan heb ik geen tekst meer in de body van de e-mail. Met .body kan ik tekst opnemen in een e-mail maar ook dan wordt de handtekening niet opgenomen. Ik denk dus dat ik .HTMLbody moet gebruiken.

Enig idee wat ik hier verkeerd doe? Waarschijnlijk is het een detail maar ik vind het niet.

Alvast bedankt!

---------

Private Sub CommandButton1_Click()

If Range("D10") = "" Or Range("m10") = "" Or Range("D12") = "" Or Range("M36") = "" Or Range("m21") = "" Or Range("c18") = "" Or Range("e31") = "" Or Range("e34") = "" Or Range("e36") = "" Or Range("e38") = "" Or Range("c43") = "" Or Range("c52") = "" Then
MsgBox "Vergeet niet om alle verplichte velden in te vullen aub. Bedankt!" & vbNewLine & "Veuillez remplir tous les champs obligatoires svp. Merci!" & vbNewLine & "Please, do not forget to fill in all the required fields. Thank you!"
Else

     Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    



Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
   Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String


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

    Set Sourcewb = ActiveWorkbook

    
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    
    With Destwb
        If Val(Application.Version) < 12 Then
           
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.Name & " " & ThisWorkbook.Sheets("Data").Range("AB5").Value & " " & Format(Now, "d-mm-yyyy h-mm")

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

[COLOR="#FF0000"]With ThisWorkbook.Sheets("Hiring Request Form")
       strbody = "<font size=""2"" face=""Calibri"" color=""Black"">" & _
"<span style='font-size:10pt;font-family:Calibri;color:Red'><b>" & Sheets("Hiring Request Form").Range("B10").Value & "</span></b>" & "<br>" & _
"<span style='font-size:10pt;font-family:Calibri;color:Black'><b>" & Sheets("Hiring Request Form").Range("B10").Value & "</span></b>" & "<br>" & _
"<br><br><br>"[/COLOR]



    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = ThisWorkbook.Sheets("Data").Range("W2").Value
            .CC = ThisWorkbook.Sheets("Data").Range("X2").Value
            .BCC = ""
            .Subject = ThisWorkbook.Sheets("Data").Range("AA2").Value
                      .Attachments.Add Destwb.FullName
            [COLOR="#FF0000"][/COLOR][COLOR="#FF0000"] .htmlbody = strbody & "<br>" & .htmlbody[/COLOR]
            
            .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

   
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

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

 

[wildboy]

Hoi,
Kijk even op de site van Ron de Bruin

hier link naar het onderwerp, waar volgens mij de oplossing voor je probleem staat
kan het helaas zelf niet testen op dit moment.

http://rondebruin.nl/win/s1/outlook/signature.htm

 

[BertDP]

Dag Eric,

Bedankt voor de tip.

Ik heb de link bekeken (veel interessante info gevonden trouwens) maar ik gebruik dezelfde code (strbody, etc.). Misschien maak ik het te complex.

 

[edmoor]

Het is een heel geniepige maar Ron heeft het wel goed beschreven. Je mist de .Display direct onder With Outmail. Die .Display moet er dus 2x in staan, anders wordt de handtekening er niet in gezet. De tweede .Display mag je ook vervangen door .Send om direct de mail te versturen.

With OutMail
    [COLOR="#FF0000"].Display[/COLOR]
    .To = ThisWorkbook.Sheets("Data").Range("W2").Value
    .CC = ThisWorkbook.Sheets("Data").Range("X2").Value
    .BCC = ""
    .Subject = ThisWorkbook.Sheets("Data").Range("AA2").Value
    .Attachments.Add Destwb.FullName
    .HTMLBody = strbody & "<br>" & .HTMLBody            
    [COLOR="#FF0000"].Display 'Of .Send[/COLOR]
End With

 

[BertDP]

Je hebt gelijk Ed. De .display ontbrak. Bedankt om er mij op te wijzen.

Nu werkt het perfect!