XL 2013 Envoi mail avec choix

Private Sub CheckBox1_Click()
Dim i As Integer
ListBox1.MultiSelect = fmMultiSelectExtended
On Error Resume Next
For i = 0 To Me![ListBox1].ListCount + 1
Me![ListBox1].Selected(i) = True
Next
End Sub

Private Sub Envois_Click()
Dim i As Byte
Dim olApp, objMail
Dim olmail As MailItem
Dim Chaine As String, OpenFolder

    ChDrive "D"
    ChDir ThisWorkbook.Path & "\"
    OpenFolder = Application.GetOpenFilename("(*.*),*.*")

    For i = 0 To ListBox1.ListCount - 1
      If ListBox1.Selected(i) Then
            Chaine = Chaine & " " & ListBox1.List(i) & ";"
        End If
      Next i

    Set olApp = CreateObject("Outlook.Application")
    Set objMail = olApp.CreateItem(olMailItem)

    With objMail
    .To = Nouveau.Email.Value
    .CC = Trim(Chaine)
    .Subject = ""
    .Body = ""
    If OpenFolder <> False Then .Attachments.Add OpenFolder
    .Display
    End With
End Sub

Sub EnvoiMail()

    With Worksheets("Feuil1")
        If .Range("B3") < .Range("G6") Then
            Set olApp = CreateObject("outlook.application")
            Set olMail = olApp.CreateItem(olMailItem)
            With olMail
                .To = "xxx@yy.com"
               .CC = "zzz@yy.com"
                .Subject = "sujet"
                .Body = " message"
                .send
            End With
        End If
    End With
End Sub