XL 2016 Mailing Type à différents groupe de personnes

B

Bullrot

XLDnaute Junior
Bonjour à tous,

J'ai pu faire un code pour envoyer un mail reprenant des informations de concernant chaque personne dans la liste et lui informant qu'il appartient à tel ou tel groupe.

User: admin
Password: admin
deverrouilage sheet/book: fullcrum

VB: 
'Ok
Private Sub AddFile1_Click()
Dim Myfilepath As String
Dim MyfilepathExist As String
    Myfilepath = Application.GetOpenFilename()
    MyfilepathExist = Dir(Myfilepath)
            If MyfilepathExist = "" Then
                TextBox1.Text = ""
                Else
                TextBox1.Text = Myfilepath
            End If
End Sub
'ok
Private Sub AddFile2_Click()
Dim Myfilepath As String
Dim MyfilepathExist As String
    Myfilepath = Application.GetOpenFilename()
    MyfilepathExist = Dir(Myfilepath)
            If MyfilepathExist = "" Then
                TextBox2.Text = ""
                Else
                TextBox2.Text = Myfilepath
            End If
End Sub
'ok
Private Sub AddFile3_Click()
Dim Myfilepath As String
Dim MyfilepathExist As String
    Myfilepath = Application.GetOpenFilename()
    MyfilepathExist = Dir(Myfilepath)
            If MyfilepathExist = "" Then
                TextBox3.Text = ""
                Else
                TextBox3.Text = Myfilepath
            End If
End Sub

'Sub Mapping()
'Dim objNetwork, strLocalDrive, strRemoteShare
 'Set objNetwork = WScript.CreateObject("WScript.Network")
 'strLocalDrive = "T:"
 'strRemoteShare = "\\IPCOMMON.value\NAS\Films\"
 'objNetwork.MapNetworkDrive strLocalDrive, strRemoteShare, True
 'End Sub

Private Sub PreviewMail_Click()
    Dim ListeDest() 'variable dans tableau USERS
    Dim ListeService() 'variable dans tableau USERS
    Dim ListeDistribution() 'variable dans tableau USERS
    Dim ListeServiceExtra() 'variable dans tableau USERS
    Dim i As Long
    Dim Outlookapp As Object
    Dim MItem As MailItem
    Dim sListeDest As String
    Set Outlookapp = CreateObject("outlook.application")
    Set Outlookapp = New Outlook.Application
    
    On Error Resume Next
    
    ListeDest() = Range("USERS_CDN[CDN MAIL]") 'variable dans tableau USERS
    ListeService() = Range("USERS_CDN[SERVICE MAIL UNCLASS]") 'variable dans tableau USERS
    ListeServiceExtra() = Range("USERS_CDN[SERVICE MAIL UNCLASS EXTRA]") 'variable dans tableau USERS
    ListeDistribution() = Range("USERS_CDN[DISTRIBUTION LIST UNCLASS]") 'variable dans tableau USERS



For i = LBound(ListeDest(), 1) To UBound(ListeDest(), 1)
        If ListeDest(i, 1) = "" Then
           GoTo nextI
        End If
        
Set MItem = Outlookapp.CreateItem(olMailItem) 'create new mail

        With MItem
            .SentOnBehalfOfName = TextBoxFrom.Text
            .To = ListeDest(i, 1)
            If FR.Value Then .Subject = .Subject & Worksheets("Mail").Range("B4") & "/"
            If NL.Value Then .Subject = .Subject & Worksheets("Mail").Range("B8") & "/"
            If EN.Value Then .Subject = .Subject & Worksheets("Mail").Range("B12")
                
                'BODY
                If FR.Value Then
                .Body = TEST
                    .Body = .Body & Worksheets("Mail").Range("B5") & Chr(10) & Chr(13) & "Vous avez été ajouté à la boite de service suivante: " & ListeService(i, 1) & Chr(10) & Chr(13) & "Vous avez été ajouté à la boite de service supplémentaire suivante: " & ListeServiceExtra(i, 1) & Chr(10) & Chr(13) & "Vous appartenez à la liste de distribution suivante: " & ListeDistribution(i, 1) & Chr(10) & Chr(13)
                    'COMMON
                    If COMMON_BOX.Value Then
                    .Body = .Body & "L'addresse du NAS (COMMON) est: \\" & IPCOMMON.Value & "\COMMON\" & Chr(10) & Chr(13)
                    End If
                    
                    'Signature
                    If FR.Value Then
                    .Body = .Body & "CIS TEAM" & Chr(10) & Chr(13) & "------------------------------------------------------------------------------------------------------------------------------"
                    End If
                End If
                'BODY
                If NL.Value Then
                    .Body = .Body & Worksheets("Mail").Range("B9") & Chr(10) & Chr(13) & "U bent toegevoegd aan de volgende servicebox: " & ListeService(i, 1) & Chr(10) & Chr(13) & "U bent toegevoegd aan de volgende aanvullende servicebox: " & ListeServiceExtra(i, 1) & Chr(10) & Chr(13) & "U behoort tot de volgende distributielijst: " & ListeDistribution(i, 1) & Chr(10) & Chr(13)
                    'COMMON
                    If COMMON_BOX.Value Then
                    .Body = .Body & "Het adres van de NAS (COMMON) is: \\" & IPCOMMON.Value & "\COMMON\" & Chr(10) & Chr(13)
                    End If
                    'Signature
                    If NL.Value Then
                    .Body = .Body & "CIS TEAM" & Chr(10) & Chr(13) & "------------------------------------------------------------------------------------------------------------------------------"
                    End If
                End If
                    'BODY
                    If EN.Value Then
                        .Body = .Body & Worksheets("Mail").Range("B13") & Chr(10) & Chr(13) & "You have been added to the following service box: " & ListeService(i, 1) & Chr(10) & Chr(13) & "You have been added to the following additional service box: " & ListeServiceExtra(i, 1) & Chr(10) & Chr(13) & "You belong to the following distribution list: " & ListeDistribution(i, 1) & Chr(10) & Chr(13)
                        'COMMON
                        If COMMON_BOX.Value Then
                        .Body = .Body & "The address of the NAS (COMMON) is: \\" & IPCOMMON.Value & "\COMMON\" & Chr(10) & Chr(13)
                        End If
                        'Signature
                        If EN.Value Then
                        .Body = .Body & "CIS TEAM" & Chr(10) & Chr(13) & "------------------------------------------------------------------------------------------------------------------------------"
                        End If
                    End If
            If TextBox1.Value <> "" Then .Attachments.Add (Me.TextBox1.Value)
            If TextBox2.Value <> "" Then .Attachments.Add (Me.TextBox2.Value)
            If TextBox3.Value <> "" Then .Attachments.Add (Me.TextBox3.Value)

                .Display
            
        End With
        
        Set MItem = Nothing
        GoTo Endsub
nextI:
    Next
Endsub:
    
End Sub

'ok
Private Sub RemoveFile1_Click()
TextBox1.Text = ""
End Sub
'ok
Private Sub RemoveFile2_Click()
TextBox2.Text = ""
End Sub

'ok
Private Sub RemoveFile3_Click()
TextBox3.Text = ""
End Sub
'ok
Private Sub SendMail_Click()
    Dim ListeDest() 'variable dans tableau USERS
    Dim ListeService() 'variable dans tableau USERS
    Dim ListeDistribution() 'variable dans tableau USERS
    Dim ListeServiceExtra() 'variable dans tableau USERS
    Dim i As Long
    Dim Outlookapp As Object
    Dim MItem As MailItem
    Dim sListeDest As String
    Set Outlookapp = CreateObject("outlook.application")
    Set Outlookapp = New Outlook.Application
    
    On Error Resume Next
    
    ListeDest() = Range("USERS_CDN[CDN MAIL]") 'variable dans tableau USERS
    ListeService() = Range("USERS_CDN[SERVICE MAIL UNCLASS]") 'variable dans tableau USERS
    ListeServiceExtra() = Range("USERS_CDN[SERVICE MAIL UNCLASS EXTRA]") 'variable dans tableau USERS
    ListeDistribution() = Range("USERS_CDN[DISTRIBUTION LIST UNCLASS]") 'variable dans tableau USERS



For i = LBound(ListeDest(), 1) To UBound(ListeDest(), 1)
        If ListeDest(i, 1) = "" Then
           GoTo nextI
        End If
        
Set MItem = Outlookapp.CreateItem(olMailItem) 'create new mail

        With MItem
            .SentOnBehalfOfName = TextBoxFrom.Text
            .To = ListeDest(i, 1)
            If FR.Value Then .Subject = .Subject & Worksheets("Mail").Range("B4") & "/"
            If NL.Value Then .Subject = .Subject & Worksheets("Mail").Range("B8") & "/"
            If EN.Value Then .Subject = .Subject & Worksheets("Mail").Range("B12")
                
                'BODY
                If FR.Value Then
                    .Body = .Body & Worksheets("Mail").Range("B5") & Chr(10) & Chr(13) & "Vous avez été ajouté à la boite de service suivante: " & ListeService(i, 1) & Chr(10) & Chr(13) & "Vous avez été ajouté à la boite de service supplémentaire suivante: " & ListeServiceExtra(i, 1) & Chr(10) & Chr(13) & "Vous appartenez à la liste de distribution suivante: " & ListeDistribution(i, 1) & Chr(10) & Chr(13)
                    'COMMON
                    If COMMON_BOX.Value Then
                    .Body = .Body & "L'addresse du NAS (COMMON) est: \\" & IPCOMMON.Value & "\COMMON\" & Chr(10) & Chr(13)
                    End If
                    
                    'Signature
                    If FR.Value Then
                    .Body = .Body & "CIS TEAM" & Chr(10) & Chr(13) & "------------------------------------------------------------------------------------------------------------------------------"
                    End If
                End If
                'BODY
                If NL.Value Then
                    .Body = .Body & Worksheets("Mail").Range("B9") & Chr(10) & Chr(13) & "U bent toegevoegd aan de volgende servicebox: " & ListeService(i, 1) & Chr(10) & Chr(13) & "U bent toegevoegd aan de volgende aanvullende servicebox: " & ListeServiceExtra(i, 1) & Chr(10) & Chr(13) & "U behoort tot de volgende distributielijst: " & ListeDistribution(i, 1) & Chr(10) & Chr(13)
                    'COMMON
                    If COMMON_BOX.Value Then
                    .Body = .Body & "Het adres van de NAS (COMMON) is: \\" & IPCOMMON.Value & "\COMMON\" & Chr(10) & Chr(13)
                    End If
                    'Signature
                    If NL.Value Then
                    .Body = .Body & "CIS TEAM" & Chr(10) & Chr(13) & "------------------------------------------------------------------------------------------------------------------------------"
                    End If
                End If
                    'BODY
                    If EN.Value Then
                        .Body = .Body & Worksheets("Mail").Range("B13") & Chr(10) & Chr(13) & "You have been added to the following service box: " & ListeService(i, 1) & Chr(10) & Chr(13) & "You have been added to the following additional service box: " & ListeServiceExtra(i, 1) & Chr(10) & Chr(13) & "You belong to the following distribution list: " & ListeDistribution(i, 1) & Chr(10) & Chr(13)
                        'COMMON
                        If COMMON_BOX.Value Then
                        .Body = .Body & "The address of the NAS (COMMON) is: \\" & IPCOMMON.Value & "\COMMON\" & Chr(10) & Chr(13)
                        End If
                        'Signature
                        If EN.Value Then
                        .Body = .Body & "CIS TEAM" & Chr(10) & Chr(13) & "------------------------------------------------------------------------------------------------------------------------------"
                        End If
                    End If
            If TextBox1.Value <> "" Then .Attachments.Add (Me.TextBox1.Value)
            If TextBox2.Value <> "" Then .Attachments.Add (Me.TextBox2.Value)
            If TextBox3.Value <> "" Then .Attachments.Add (Me.TextBox3.Value)
            
            BoxPreviewMsg = MsgBox("would you like to see the email before sending", vbQuestion + vbYesNoCancel + vbDefaultButton2, "Preview?")
                If BoxPreviewMsg = vbYes Then
                        .Display
                ElseIf BoxPreviewMsg = vbNo Then
                        .Send
                ElseIf BoxPreviewMsg = vbCancel Then
                Exit Sub
                
            End If
            
            '.Send

        End With
        
        Set MItem = Nothing
nextI:
    Next
End Sub
'ok
Private Sub Cancel_Click()
Unload Me
End Sub

quand on regarde le code, il fait ceci: dans le sheet USERS_CDN et USER_MDN (appel du USERFORM)

1) voir dans la colonne CDN MAIL du sheet USER_CDN l'adresse qui est présente et dnner les informations présentes sur la ligne lui correspondant
2) il va faire un préview de chaque mail pour voir si la mise en forme est bonne... Sauf que tout les mails seront les meme, donc juste voir un seul mail suffit.
3) une fois le préview fait, il faut que TOUT les mails s'envoit, dans mon cas, il faut faire a chacun des mails la validation de l'envois.
4) pour diminuer l'envois multiple, il serait préférable d'avoir un mail avec les memes informations qui sont regroupés dans les destinataires.

Exemple:

User 1 boite yyy
User 2 boite www
User 3 boite xxx
User 4 boite yyy
User 5 boite xxx



Le résultat serait dans destinataire :

user1;user4 reçoivent le mail avec l’info qu’ils appartiennent a la boite yyy
user2 reçoit le mail avec l’info qu’ils appartiennent a la boite www
user3;user5 reçoivent le mail avec l’info qu’ils appartiennent a la boite xxx

Il faut garder aussi le USERFORM


Merci d'avance à tous
 

Pièces jointes

  • TEMPLATE-CISSM_2.0_externe.xlsm
    763.3 KB · Affichages: 17
Trier par date Trier par votes

Discussions similaires

halecs93
  • Question
Microsoft 365 Générer mail via Excel
Réponses
2
Affichages
574
halecs93
halecs93
O
  • Question
Send ne fonctionne pas pour mon publipostage
Réponses
2
Affichages
551
OlivierHervé
O
ELSONCe
  • Question
Microsoft 365 Attachments.Add Fonctionne mais erreur
Réponses
10
Affichages
844
ELSONCe
ELSONCe
O
  • Question
XL 2013 Publipostage avec pièce jointe via Excel
Réponses
1
Affichages
982
kiki29
kiki29
C
  • Question
Microsoft 365 Excel VBA
Réponses
14
Affichages
742
Dranreb
Dranreb
K
  • Résolu(e)
XL 2019 Probleme codage
Réponses
2
Affichages
344
Kevin42560
K
M
  • Question
XL 2016 Erreur d'execution '52': Nom ou numéro de fichier incorrect
Réponses
4
Affichages
978
macseb
M
S
  • Résolu(e)
Microsoft 365 Fusion de 2 macro VBA (selection envoi de mail + envoie de fichier PDF)
Réponses
6
Affichages
1 K
soNZOOO
S
G
  • Question
Envoi mail avec pièce jointe
Réponses
2
Affichages
1 K
Gwendoline
G
B
  • Question
XL 2016 Send from...Account or Send on behalf
Réponses
0
Affichages
767
Bullrot
B

Membres actuellement en ligne

18 membres et 321 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh