Option Explicit
Dim i&, derLn&, timedebut, compteur

Sub EnvoiOngletHTML2()
    
    timedebut = Now()
    Application.ScreenUpdating = False
    BarreProgression.Show vbModeless
    BarreProgression.Caption = "Veuillez patienter..."

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim ws     As Worksheet
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim Destinataire As String
    Dim Sujet  As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Tableau As Variant
    Dim i      As Integer, k As Integer, LastRow As Integer
    Dim aKey   As String
    Dim aValue As String
    Dim Dict   As Object
    Dim wsMail As Worksheet
    Dim Adresse As String
    Dim strBody As String
    Dim DestCopie As String
    Dim Intro  As String, TexteInit As String, TexteRouge As String, Salutation As String

    
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        
    End With
    
    
    Set wsMail = ThisWorkbook.Sheets("Mail")
    LastRow = wsMail.Cells(Rows.Count, 1).End(xlUp).Row
    
    Intro = wsMail.Range("H2")
    TexteInit = wsMail.Range("H3")
    TexteRouge = wsMail.Range("H4")
    Salutation = wsMail.Range("H5")
    
    Tableau = wsMail.Range("A2:B" & LastRow)
    
    Set Dict = CreateObject("scripting.dictionary")
    
    For i = 1 To UBound(Tableau)
    'BarreDeProgression (i / UBound(Tableau, 1))
        aKey = Tableau(i, 1)
        aValue = Tableau(i, 2)
        Dict.Add aKey, aValue
    Next i
    
    i = 0
    For Each ws In Worksheets
        
        i = i + 1
        BarreDeProgression (i / Worksheets.Count)
        
        If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" And ws.Name <> "Feuil2" Then
            
            Set Sourcewb = ActiveWorkbook
            
            ws.Copy
            Set Destwb = ActiveWorkbook
            
            FileExtStr = ".xlsx": FileFormatNum = 51
            
            TempFilePath = ThisWorkbook.Path
            TempFileName = ActiveSheet.Name
            
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
            
            With Destwb
                .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
                On Error Resume Next
                
                
                strBody = Intro & "<p>" & _
                          TexteInit & "<br>" & _
                          "<font color=red>" & TexteRouge & "</font color=red>" & "<br>" & Salutation
                          'TexteInit = Replace(TexteInit,",",",<br>")'
                
                
                Adresse = Sheets(1).Range("B5").Value
                Destinataire = Dict.Item(Adresse)
                DestCopie = Application.WorksheetFunction.VLookup(Destinataire, wsMail.Range("B2:C" & LastRow), 2, False)
                Sujet = Sheets(1).Range("C2")
                
                
                With OutMail
                    .To = Destinataire
                    .CC = DestCopie
                    .BCC = ""
                    .Subject = Sujet
                    .HTMLBody = strBody
                    .Attachments.Add Destwb.FullName
                    .display
                    .Send
                End With
                On Error GoTo 0
                .Close savechanges:=False
            End With
            
            Kill TempFileName & FileExtStr
        End If
        
    Next ws
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    Unload BarreProgression
Exit Sub
End Sub