Discussion :

[chrisssou]

Bonjour à tous,

J'ai une macro qui envoi un mail automatiquement via un fichier excel.
Dans le corps du mail je veux insérer un texte mais également un tableau issu de mon fichier excel.
Le problème est que lorsque le mail se crée il affiche bien le tableau dans le corps du message mais pas le texte. J'ai essayé séparément et il m'affiche bien le texte tout seul et le tableau tout seul mais pas les deux ne même temps.
J'ai beau chercher je ne vois pas comment résoudre le problème.

Merci d'avance de votre aide.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
 
Code:
Sub envoi_mail()
 
Dim appOutlook As Outlook.Application
Dim mailOutlook As Outlook.MailItem
Dim emlBody1 As String, emlBody2 As String, sendTo As String
Dim wkbook As String
Dim rng As Range
Dim lastfilline As String
 
 
lastfilline = Range("J65536").End(xlUp).Row
 
For i = 1 To lastfilline
 
    If Cells(i, 1).Value = "COMMENT" Then
 
        cpty = Cells(i + 1, 10).Value
        contact = Sheets("contact mail").Range("A1:B30")
 
        Set appOutlook = New Outlook.Application
        Set mailOutlook = appOutlook.CreateItem(1)
 
 
        On Error Resume Next
        sendTo = WorksheetFunction.VLookup(cpty, contact, 2, False)
 
        emlBody1 = "Hi," & "<br><br>" & _
                  "Please confirm /infirm booking details bellow" & "<br><br>" & "Thanks" & vbCrLf & vbCrLf
 
        emlBody2 = "Thanks" & "<br><br>"
 
        Set rng = Nothing
        On Error Resume Next
        Set rng = Sheets("ecart " & D & " " & M & " " & Y).Range(Cells(i, 1), Cells(i, 13).End(xlDown))
        On Error GoTo 0
 
        If rng Is Nothing Then
            MsgBox "The selection is not a range or the sheet is protected" & _
                    vbNewLine & "please correct and try again.", vbOKOnly
            Exit Sub
        End If
 
        With mailOutlook
            '.To = sendTo
            .HTMLBody = emlBody1 & RangetoHTML(rng) & emlBody2
            .Subject = cpty & " Collat Break "
            .Display
        End With
 
    End If
 
Next i
 
Set appOutlook = Nothing
Set mailOutlook = Nothing
 
 
End Sub

[QuestVba]

Bonjour

J'ai eu un problème similaire car le mail ne voulait pas du corps du message avec la signature (c'était l'un ou l'autre).

Du coup, j'ai fait ma partie avec signature et seulement après mon corps du texte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Sub Envoi_Mail_Signature()
 
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim olFormatHTML As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
 
    strbody = "Coucou, voici un essai de mail avec signature"
 
    SigString = Environ("appdata") & "\Microsoft\Signatures\Sans titre.htm"
 
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
 
    On Error Resume Next
    With OutMail
        .To = "...@..."
        .CC = ""
        .BCC = ""
        .Subject = "Mail avec signature et corps de texte"
        .BodyFormat = olFormatHTML
        .HTMLBody = Signature
        .Display
    End With
    On Error GoTo 0
 
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.MoveUp Unit:=wdLine, Count:=2
 
'Mise en forme du texte (#signature)
    With Selection.Font
        .Name = "Arial"
        .Size = 10
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .Strikethrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Spacing = 0
        .Scaling = 100
        .Position = 0
        .Kerning = 0
        .Animation = wdAnimationNone
    End With

'Insertion du corps du texte
    Selection.Font.Bold = wdToggle
    Selection.TypeText Text:=strbody 
End Sub

Function GetBoiler(ByVal sFile As String) As String
    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

Un bidouillage...

[chrisssou]

Merci de ta reponse QuestVba, j'ai essayer ta methode mais ca ne marche toujours pas...

[QuestVba]

Bonjour,

Voici un autre qui fonctionne suffisamment pour moi. à toi de voir

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Sub Envoi_Mail_Signature()
 
Dim strHTML As String
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim olFormatHTML As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
 
    SigString = Environ("appdata") & "\Microsoft\Signatures\Sans titre.htm"
 
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
 
    On Error Resume Next
 
strHTML = ""
strHTML = strHTML & "<HEAD>"
strHTML = strHTML & "<BODY>"
strHTML = strHTML & "Bonjour , <BR>Vous trouverez ci joint le tableau demandé<BR><BR>"
strHTML = strHTML & "<TABLE BORDER>"
 
For i = 1 To 5 'nombre de lignes (exemple plage A1:B5)
 
    strHTML = strHTML & "<TR halign='middle'nowrap>"
    For j = 1 To 2 'nombre de colonnes
    strHTML = strHTML & "<TD bgcolor='yellow'align='center'><FONT COLOR='blue'SIZE=3>" _
            & Cells(i, j) & "</FONT></TD>"
    Next j
    strHTML = strHTML & "</TR>"
 
Next i
 
strHTML = strHTML & "</TABLE>"
 
strHTML = strHTML & "<BR><BR>Cordialement<BR>" & Application.UserName
strHTML = strHTML & "</BODY>"
strHTML = strHTML & ""
 
    With OutMail
        .To = "...@..."
        .CC = ""
        .BCC = ""
        .Subject = "Mail avec signature et corps de texte"
        .BodyFormat = olFormatHTML
        .HTMLBody = strHTML
        .Display
    End With
    On Error GoTo 0
 
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Function GetBoiler(ByVal sFile As String) As String
    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