Copie Tableau dans mail

Version imprimable

Bonjour le forum,
J'arrive à envoyer des mails automatiques à partir de mon application, mais il me reste à coller un tableau à partir d'une feuille dans mon mail.
le code que j'utilise marche très bien, je le mets à votre disposition, mais il manque l'insersion d'un tableau .

Code:

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
Sub envoi_mail()
 
Dim mMessage As Object
Dim mConfig As Object
Dim mChps
Dim rng As Range
 
NoteAudit = CStr(NoteAudit)
Set mConfig = CreateObject("CDO.Configuration")
 
Set rng = Range("Data_TDL_tamp[[Type_Audit]:[Completed]]")
 
mConfig.Load -1
Set mChps = mConfig.Fields
With mChps
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mailhub.utc.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
 
Set mMessage = CreateObject("CDO.Message")
With mMessage
Set .Configuration = mConfig
.From = "blbla@blabla.com"
.To = "taha@blabla.com"
 
.Subject = "Audit 5s de la zone: " + Login.ComboBox_Zone.Value + "\" + Login.ListBox_sousZone.Value
'.HTMLBody =
'For i = 0 To k - 1
'txt = txt & vbCrLf & UserForm1.ListBox1.List(ListBox1.ListCount - i - 1, 1) & " (Réf. " & UserForm1.ListBox1.List(ListBox1.ListCount - i - 1, 3) & " : " & UserForm1.ListBox1.List(ListBox1.ListCount - i - 1, 4) & ")"
'Next i
.TextBody = "Bonjour, " & vbCrLf & vbCrLf & "La zone  : " + Login.ComboBox_Zone.Value + "    " + Login.ListBox_sousZone.Value + " " + " été audité par :  " + Login.Label4.Caption & vbCrLf & vbCrLf & "La note de l'audit est:  " + NoteAudit & vbCrLf & vbCrLf & "Cordialement,"
 
.Send
End With
Set mMessage = Nothing
 
Set mConfig = Nothing
Set mChps = Nothing
 
 
 
End Sub

Merci d'avance

11/02/2020, 10h59
Menhir

Ceci pourrait peut-être t'aider : https://excel.developpez.com/faq/?pa...geCellulesMail

Citation:

Envoyé par Menhir

Ceci pourrait peut-être t'aider : https://excel.developpez.com/faq/?pa...geCellulesMail

Merci pour ta reponse j'ai résolu mon probleme avec cette fonction que j'appelle dans l'envoi de mail

Code:

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
Function rangetoHTML(ByVal rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
 
        .Cells(1).PasteSpecial Paste:=12
        .Cells(1).PasteSpecial Paste:=-4122
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            .Columns.AutoFit
            .Rows.AutoFit
        On Error GoTo 0
    End With
 
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    rangetoHTML = ts.ReadAll
    ts.Close
    rangetoHTML = Replace(rangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    TempWB.Close savechanges:=False
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
 
End Function