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

MONTREAL2020

XLDnaute Junior
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 x:publishsource=", _
"align=left x:publishsource=")

'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

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


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


Pour annexer un fichier, le code ci-dessous annexe le fichier créé pour le transfert ( c'est un exemple ) :
VB:
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

XLDnaute Junior
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 :)
 

Discussions similaires

Statistiques des forums

Discussions
302 236
Messages
2 001 687
Membres
215 256
dernier inscrit
Adso