XL 2016 Envoi courriel copier/coller avec mise en forme (corps couuriel)

[MONTREAL2020]

Bonjour,

J'ai trouvé ce code pour envoyer un courriel copier/coller une plage sur le corps du courriel, ca fonctionne pas mal sauf que ma plage perd sa mise en forme ( couleur)

y -t-il moyen d'arranger ça.

Par la même occasion si je veux ajouter une pièce jointe qu'est ce qui pourrait-être rajouté.

Merci par avance

Sub Courriel_Commande_By_Outlook_1()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim body As Object

Set rng = Nothing
On Error Resume Next
'Uniquement Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want

Set rng = Sheets("commande").Range("F9:T55").SpecialCells(xlCellTypeVisible)
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 Application
.EnableEvents = False
.ScreenUpdating = False
End With

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

On Error Resume Next
With OutMail
.To = "montreal2020@gmail.com"
.CC = "montreal2020@gmail.com"
.BCC = "rmontreal2020@gmail.com"
.Subject = "Commande de la semaine" & " " & Format(Now + 1, "dd-mm-yyyy ")
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "\" & Format(Now + 1, "dd-mm-yy h-mm-ss") & ".htm"

'Copie la plage et crée une nouvelle table à coller
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
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

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
"align=left xublishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

 

[fanch55]

Bonsoir,
Si vous voulez joindre un code, utilisez l'outil avec indentation fourni, il sera plus facilement lisible et copiable.

Sinon, après test, la plage copiée conserve bien ses couleurs .

Pour annexer un fichier, le code ci-dessous annexe le fichier créé pour le transfert ( c'est un exemple ) :

Sub Courriel_Commande_By_Outlook_1()
Dim TempFile As String

    Dim Rng As Range: Set Rng = Nothing
    On Error Resume Next
        'Only the visible cells in the selection
        Set Rng = Selection.SpecialCells(xlCellTypeVisible)
        'You can also use a fixed range if you want
        Set Rng = Sheets("commande").Range("F9:T55").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
   
    If Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & vbLf & _
                "please correct and try again.", vbCritical + vbOKOnly
        Exit Sub
    End If
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
   
    On Error Resume Next
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "montreal2020@gmail.com"
        .CC = "montreal2020@gmail.com"
        .BCC = "rmontreal2020@gmail.com"
        .Subject = "Commande de la semaine" & " " & Format(Now + 1, "dd-mm-yyyy ")
         TempFile = Environ$("temp") & "\" & Format(Now + 1, "dd-mm-yy h-mm-ss") & ".htm"
        .HTMLBody = RangetoHTML(Rng, TempFile)
       '---------------------------------------------------------- '
        .Attachments.Add TempFile
       '---------------------------------------------------------- '
        .display 'or use .Display
        Kill TempFile
    End With
    On Error GoTo 0

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

End Sub

Function RangetoHTML(Rng As Range, TempFile As String)
' Working in Office 2000-2016
Dim Fso As Object
Dim Ts As Object
Dim TempWB As Workbook

    'Copie la plage et crée une nouvelle table à coller
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        '.Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next ' destroy All Objects
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    Set Fso = CreateObject("Scripting.FileSystemObject")
        Set Ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
            RangetoHTML = Ts.readall
            Ts.Close
        Set Ts = Nothing
    Set Fso = Nothing
    RangetoHTML = Replace(RangetoHTML, _
                "align=center x:publishsource=", _
                "align=left x:publishsource=")
   
    'Close TempWB
    TempWB.Close savechanges:=False
     
Set TempWB = Nothing
'Delete the htm file we used in this function
'Kill TempFile

End Function

 

[MONTREAL2020]

Bonjour franch55,

Merci pour le code, je viens de le tester, ça résout une partie de ma problématique, mais peut-être que je m'étais mal exprimé. Au fait, je veux en plus d'un copier coller de la plage , mais aussi une copie jointe après création d'un classeur Excel contenant le même tableau avec un nom du classeur correspondant à un cellule du classeur original.

Merci infiniment