Option Explicit
Private Sub LBListeContacts_Change()
Dim I As Integer, Nb As Integer
VérificationDonnées
With Me.LBListeContacts
For I = 0 To .ListCount - 1
If .Selected(I) = True Then Nb = Nb + 1
Next I
Me.LNombreContact.Caption = "Il y a " & .ListCount & " contact(s) dont " & Nb & " de sélectionné(s)"
End With
End Sub
Private Sub CBContact_Click()
With Sheets("Gestion des données")
.Range("B4") = "Mail personnalisé"
End With
Hide
Répertoire.Show ModeModal
End Sub
Private Sub LBListePièceJointe_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If Me.LBListePièceJointe.ListCount > 0 Then
Me.LBListePièceJointe.RemoveItem Me.LBListePièceJointe.ListIndex
End If
End Sub
Private Sub CBParcourir_Click()
Dim LesFichiers As Variant
Dim I As Integer
LesFichiers = Application.GetOpenFilename("Tout fichier(*.*),*.*", , "Sélection de(s) fichier(s)", "Ok", True)
If IsArray(LesFichiers) Then
For I = LBound(LesFichiers, 1) To UBound(LesFichiers, 1)
Me.LBListePièceJointe.AddItem Mid(LesFichiers(I), InStrRev(LesFichiers(I), "\", -1) + 1)
Me.LBListePièceJointe.List(Me.LBListePièceJointe.ListCount - 1, 1) = LesFichiers(I)
Next I
End If
End Sub
Private Sub TBObjet_Change()
Dim PremiereMajuscule As String
VérificationDonnées
PremiereMajuscule = TBObjet.Text
TBObjet.Text = UCase(Mid(PremiereMajuscule, 1, 1)) & Mid$(PremiereMajuscule, 2, Len(PremiereMajuscule))
End Sub
Private Sub TBMessage_Change()
Dim PremiereMajuscule As String
VérificationDonnées
PremiereMajuscule = TBMessage.Text
TBMessage.Text = UCase(Mid(PremiereMajuscule, 1, 1)) & Mid$(PremiereMajuscule, 2, Len(PremiereMajuscule))
End Sub
Private Sub CBEnvoiMailPersonnalisé_Click()
Dim I As Integer
Dim LesContacts As String
Dim OutApp As Object, OutMail As Object
If VérificationConnexionInternet = False Then
MsgBox "Vous n'êtes pas connecté à internet !", vbInformation, "Pas de connexion internet"
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Application.ActivateMicrosoftApp (xlMicrosoftMail)
With Me.LBListeContacts
For I = 0 To .ListCount - 1
If .Selected(I) = True Then LesContacts = LesContacts & ";" & Mid(.List(I), InStr(1, .List(I), ":") + 2)
Next I
End With
With OutMail
.To = Mid(LesContacts, 2)
.Subject = TBObjet.Value
.HTMLBody = "<pre><Font size=3 Face=" & """ Times New Roman """ & ">" & TBMessage.Text & "</pre>" & "<br>" & "<img src=" & ExecuteExcel4Macro("'" & CheminDossierDevisFacturation & "[Modèle.xlsm]Données'!R4C24") & ">" & "<br>" & "<br>" & "<br>" & "<img src=" & ExecuteExcel4Macro("'" & CheminDossierDevisFacturation & "[Modèle.xlsm]Données'!R5C24") & ">"
For I = 0 To Me.LBListePièceJointe.ListCount - 1
.Attachments.Add Me.LBListePièceJointe.List(I, 1)
Next I
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Private Sub CBRetour_Click()
Unload Me
Mail.Show ModeModal
End Sub
Private Sub CBQuitter_Click()
Quitter
End Sub
Private Sub UserForm_Activate()
Dim Tablo As Variant, Temp As Variant
Dim I As Integer, k As Integer, Indice As Integer
Dim Ok As Boolean
Dim J As Long
ReDim Tablo(0 To 1, 0 To 0)
With Sheets("Gestion des contacts")
For J = 4 To .Range("F" & Rows.Count).End(xlUp).Row
For I = 0 To UBound(Tablo, 2)
If Tablo(0, I) = .Range("E" & J) Then Exit For
Next I
If I > UBound(Tablo, 2) Then
ReDim Preserve Tablo(0 To 1, 0 To Indice)
Tablo(0, Indice) = .Range("F" & J) & " : " & .Range("E" & J)
Tablo(1, Indice) = J
Indice = Indice + 1
End If
Next J
End With
If Indice = 0 Then Exit Sub
Do
Ok = True
For I = 0 To UBound(Tablo, 2) - 1
For k = I + 1 To UBound(Tablo, 2)
If Tablo(0, I) > Tablo(0, k) Then
Temp = Tablo(0, I): Tablo(0, I) = Tablo(0, k): Tablo(0, k) = Temp
Temp = Tablo(1, I): Tablo(1, I) = Tablo(1, k): Tablo(1, k) = Temp
Ok = False
End If
Next k
Next I
Loop Until Ok = True
If Indice = 1 Then
Me.LBListeContacts.AddItem Tablo(0, 0)
Me.LBListeContacts.List(0, 1) = Tablo(1, 0)
Else
Me.LBListeContacts.List() = Application.Transpose(Tablo)
End If
Me.LNombreContact.Caption = "Il y a " & Me.LBListeContacts.ListCount & " contact(s) dont 0 de sélectionné(s)"
Me.ScrollTop = 0
Me.ScrollLeft = 0
End Sub
Private Sub UserForm_Initialize()
Dim Cel As Range
With Sheets("Gestion des données")
Set Cel = .Columns("C").Find(what:=Me.Name, LookIn:=xlValues, lookat:=xlWhole)
If Not Cel Is Nothing Then
Me.Caption = "Envoyer un e-mail personnalisé (Raccourci clavier : Ctrl+" & IIf(Asc(Cel.Offset(, -1)) < 90, "Shift+" & Cel.Offset(, -1), Cel.Offset(, -1)) & ")"
Else
Me.Caption = "Envoyer un e-mail personnalisé"
End If
.Range("B4").ClearContents
End With
SupprimerCroixFermeture Me
Me.CBEnvoiMailPersonnalisé.Enabled = False
With Me.LBListePièceJointe
.ColumnCount = 2
.ColumnWidths = "-1;0"
End With
TestScrollBars Me
End Sub
Sub VérificationDonnées()
Dim I As Integer
With Me.LBListeContacts
For I = 0 To .ListCount - 1
If .Selected(I) = True Then Exit For
Next I
Me.CBEnvoiMailPersonnalisé.Enabled = False
If I < .ListCount And Me.TBObjet <> "" And Me.TBMessage.Text <> "" Then
Me.CBEnvoiMailPersonnalisé.Enabled = True
End If
End With
End Sub
