Option Explicit
Sub test4()
Dim OutLK As Object, email As Object, wdDoc As Object, rng As Object, plage(1 To 10) As Range, texte$(1 To 20)
Dim Envoyeur$, Destinataire, sujet$
With Sheets(1)
Envoyeur = "toto@trucmachin.farigoulette" 'envoyeur
Destinataire = [B2] 'Destinataire le destinataire peut etre plusieurs séparé par une virgule
sujet = "blablablabla"
texte(1) = [B4] ' les salamalec et tout le toutim
texte(2) = [B6] & Format(Date, " dddd dd mmmm yyyy") 'le titre au dessu du tableau
Set plage(1) = .Range("C8:N15") 'le tableau à envoyer
texte(3) = [B19] ' les byebye courbette et compagnie
End With
'instante de outlook et du mail item
Set OutLK = CreateObject("outlook.application")
Set email = OutLK.CreateItem(0)
With email
'....... remplissage sujet, objet, et adresse
.To = [B2]
.CC = Envoyeur
.Subject = sujet
.BodyFormat = 3 '2=html -- 3=olFormatRichText
'....... corps du mail
.Display
Set wdDoc = email.GetInspector.WordEditor 'le document word du mail
'-------------------------------------------------------------------------
'ajout du salamalec
Set rng = wdDoc.Range(0, 0) 'on determine le range (pour l'instant c'est vide )
' Insertion avant la copie du tableau
rng.InsertAfter texte(1) & vbNewLine & vbNewLine ' on insert le salamalec
'-------------------------------------------------------------------------
'ajout du titre tableau
rng.InsertAfter texte(2) & vbNewLine & vbNewLine 'on insert le text audessu du tableau
'-------------------------------------------------------------------------
'ajout du tableau 1
Set rng = rng.Paragraphs.Add().Range 'on ajoute un nouveau paragraphe
'
plage(1).Copy ' Copie du tableau 1
'
' collage au choix en image ou tableau ou texte ou par (defaut tableau)
'rng.Paste 'en tableau par defaut
'rng.PasteSpecial , DataType:=1 'en tableau
'rng.PasteSpecial , DataType:=2 'en texte "
rng.PasteSpecial , DataType:=4 'en metafichier "format image WMF"
'rng.Move 1, 1
'tableau 1 Ok
Set rng = rng.Paragraphs.Add().Range 'on ajoute un nouveau paragraphe
rng.InsertAfter vbNewLine & texte(3) 'et on insert les bybye et tou le toutim
'.Send 'débloquer pour envoyer automatiquement
End With
'destruction des objets
Set OutLK = Nothing: Set email = Nothing: Set wdDoc = Nothing
End Sub