Envoi Multiples Emails a partir de differentes Ranges

Le 29/10/2020 à 05:12

Bonjour à tous,

Je galere un peu avec mon code d'envoi d'email a differents destinataires dont l'adresse email est renseignee dans differentes celulles, colonnes.

ThisWorkbook.Sheets("Vendors List").Activate
'selection la derniere ligne de la colonne x contenant une adresse email
lstRow = Cells(Rows.Count, 3).End(xlUp).Row
lstRow1 = Cells(Rows.Count, 5).End(xlUp).Row
Set rng = Range("C5:C" & lstRow, "E5:E" & lstRow1)

For Each cell In rng
    sendTo = Range(cell.Address).Offset(0, 0).Value2

Le but serait d'envoyer autant d'email que de compagnie listee en colonnes B, D, F, H en utilisant les emails respectifs listes en colonnes C, E, G, I.

Le tri des compagnies se fait par location AAA, BBB, CCC, DDD.

Avec mon code ci-dessus ca marche pour l'envoi d'email pour les compagnies situees en AAA mais pour BBB ca envoie des emails en reprenant la colonne "Company Name" et la colonne "Email Adress".

Avez-vous une solution?

7test.xlsx (17.26 Ko)
Le 29/10/2020 à 15:08

Bonjour Jeremy,

C'est tout ce que tu as fait en code VBA !?

Qu'est-ce que tu as comme application de messagerie ?

@+

Le 30/10/2020 à 04:52

Bonjour Bruno,

Mon but est d'envoye un fichier Excel a un certain nombre de societes references dans le dernier onglet de mon fichier.

Ce dernier onglet est identique au fichier "test.xlsx" que j'ai mis en attache.

En utilisant le code que j'ai trouve et bidouiller un peu j'arrive a envoyer 8 emails diffents aux 8 societes de la ville AAA mais deux que je vous reiterer le process pour la ville BBB, CCC, DDD je n'obtiens pas le resultat chercher.

Par exemple avec la partie de code ci-dessous qui a pour but d'envoyer un email different a chaque societe pour les villes AAA et BBB, le resultat est que je me retrouve avec des emails envoyés :

  • C5:C12 = OK
  • D5:D8 = pas souhaité
  • E5:E8 = OK

L'idee est que la macro envoie des emails avec le meme fichier Excel en attache aux destinataires :

  1. C5:C12 = 8 emails
  2. E5:E8 = 4 emails
  3. G5:G8 = 3 emails
  4. I5:I7 = 3 emails

Est-ce plus clair?

Merci pour ton aide.

Le 30/10/2020 à 05:19

Je met le code en full car j'ai aussi un peu de mal avec la sauvegarde / envoi de la PJ (fichier Excel) :

Sub CopyasXlsmandsend()

Dim xOutlookObj As Object, xEmailObj As Object
Dim xWb As Workbook
Dim xUsedRng As Range
Dim xFolder$, xName1$, xName2$, xDate$, xFilename$
Dim xDest$
Dim xYesorNo As Integer
Dim lstRow, lstRow1 As Long
Dim sendTo As String
Dim rng As Range

'Initialisation des variables
Set xWb = ThisWorbook

With xWb
    xFolder = "C:\xxxxxx"
    xName1 = .Range("B1").Value
    xName2 = .Range("B2").Value

End With

xDate = Format(Now, "mm-dd-yyyy")
xFilename = xFolder & "\" & xName1 & " - " & xName2 & " - " & xDate & ".xlsm"

ThisWorkbook.Sheets("Vendors List").Activate
'Saisie la derniere cellule contenant une adresse email des colonnes 3 et 5
lstRow = Cells(Rows.Count, 3).End(xlUp).Row
lstRow1 = Cells(Rows.Count, 5).End(xlUp).Row
Set rng = Range("C5:C" & lstRow, "E5:E" & lstRow1)

For Each cell In rng
    sendTo = Range(cell.Address).Offset(0, 0).Value2

'------------------------------------------------------------------------------------
'Sauvegarde avec copie du fichier Excel
On Error Resume Next
xWb.Copy 'copie dans nouveau classeur
With ActiveWorkbook
    .SaveAs Filename:=xFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'sauver nv classeur sous nom xFileName
    .Close 'fermeture
End With
If Err.Number <> 0 Then
    MsgBox "If the file already exists, please make sure it is not open or write protected." _
        & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Save File"
    GoTo TheEnd
End If

'Creation Email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
    .Display
    .To = sendTo
    .CC = "xxx"
    .Subject = xName1 & " - " & xName2 & " - " & xDate
    .HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear" & " " & Partner & "," & _
    "<br><br>" & _
    " xxxx" & " " & ActiveSheet.Range("B11").Value & "." & _
    "<br><br>" & _
    "Thank you," & _
    .HTMLBody & "</font>"
    .Attachments.Add xFilename
    '.send
End With
 Next cell 'loop ends

TheEnd:
Set xUsedRng = Nothing: xSht = Nothing
Set xEmailObj = Nothing: xOutlookObj = Nothing

End Sub
Le 30/10/2020 à 12:46

Re,

Je ne comprends pas la définition du nom de fichier avec xname1 et xname2 !?

De plus suivant le code, tu envoies la feuille contenant les adresses mail des différentes société ?

Sinon, voici le code modifié, avec les informations que j'ai

Sub CopyasXlsmandsend()
  Dim OutlookObj As Object, EmailObj As Object
  Dim Wbk As Workbook, Sht As Worksheet
  Dim sFolder$, sName1$, sName2$, sDate$, sPartner As String
  Dim sDest$, sPath$, sFilename$
  Dim Col As Long, Lig As Long, lstRow, lstCol As Long
  Dim sendTo As String

  'Initialisation des variables
  Set Sht = ThisWorkbook.ActiveSheet
  sPath = "C:\Temp\"
  sDate = Format(Now, "mm-dd-yyyy")
  'Saisie la derniere cellule contenant une adresse email des colonnes 3 et 5
  lstRow = Cells(Rows.Count, 3).End(xlUp).Row
  lstCol = Cells(4, Columns.Count).End(xlToLeft).Column

  For Lig = 5 To lstRow
    For Col = 3 To lstCol Step 2
      ' Adresse mail du destinataire
      sendTo = Cells(Lig, Col).Value
      If sendTo = "" Then GoTo SuiteCol
      ' Nom du fichier à envoyer : Société et eMail
      sName1 = Cells(Lig, Col - 1).Value
      sName2 = Cells(Lig, Col).Value
      sFilename = sName1 & " - " & sName2 & " - " & sDate & ".xlsm"
      sPartner = "???"
      '------------------------------------------------------------------------------------
      'Sauvegarde avec copie du fichier Excel
      On Error Resume Next
      Sht.Copy 'copie dans nouveau classeur
      With ActiveWorkbook
        .SaveAs Filename:=sPath & sFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'sauver nv classeur sous nom xFileName
        .Close SaveChanges:=True                                    'fermeture
      End With
      If Err.Number <> 0 Then
        MsgBox "If the file already exists, please make sure it is not open or write protected." _
             & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Save File"
        GoTo TheEnd
      End If

      'Creation Email
      Set OutlookObj = CreateObject("Outlook.Application")
      Set EmailObj = OutlookObj.CreateItem(0)
      With EmailObj
        .Display
        .to = sendTo
        .CC = "xxx"
        .Subject = sName1 & " - " & sName2 & " - " & sDate
        .HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear" & " " _
          & sPartner & ",<br><br>" _
          & " xxxx" & " " & ActiveSheet.Range("B11").Value & ".<br><br>" _
          & "Thank you," & "</font>" & .HTMLBody
        .Attachments.Add sPath & sFilename
        '.send
      End With
SuiteCol:
    Next Col
  Next Lig

TheEnd:
  Set Wbk = Nothing
  Set EmailObj = Nothing: Set OutlookObj = Nothing

End Sub

@+

Le 02/11/2020 à 11:26

Hello Bruno,

Merci pour ton aide.

Pour repondre a tes questions car il est vrai que ce n'etait pas preciser.

Le fichier Excel est compose de plusieurs feuilles (en attache pour mieux comprendre).

Le but est d'envoyer le meme fichier a plusieurs societes listees dans sur la feuille "vendors list".

Pour chaque zone geographique les societes ont ete listees avec les emails correspondant.

La macro doit activer l'envoi d'un email a chacune de ces societes avec le fichier en attache (excepte la feuille "vendors list" car pour des raisons de confidentialite la societe ne doit pas connaitre ses concurrents sur cet appel d'offre).

  • sName1 => correpond à B1 sur la feuille cover - cette variable est fixe quelque soit le destinataire
  • sName 2 => correspondrait en effet au nom de la societe a laquelle l'email serait envoyé; elle varie en fonction des destinataires
  • sPartner = sName 2 donc pas besoin de créer une autre variable

Lorsque j'execute ta macro j'ai un probleme pour lequel Excel me propose de debuguer et cela me ramene sur :

image image
14depot-tender.xlsm (169.77 Ko)
Le 02/11/2020 à 14:21

Bonjour,

Navré, comme on veut mettre à vide une variable objet, il faut utiliser "Set" devant

Set EmailObj = Nothing: Set OutlookObj = Nothing

Voilà, tiens nous au courant

Le 03/11/2020 à 02:14

Hello,

Lorsque que je clique sur le bouton cense enclenché la macro RAS.

Est ce tu peux jeter un oeil a mon dernier fichier mis en attache sur le post d'hier?

Peut etre ma requete sera plus claire car je pense qu'il y a une confusion sur les feuilles Excel activees dans le classeur.

Jeremy

Le 03/11/2020 à 04:42

J'ai essayé ca sans succes.

Mon but est d'envoyer le fichier entier (excepté certaines feuilles), d'ou le Wbk = ThisWorkbook.Sheets("xxx","xxx")

Les adresses emails doivent etre reprises dans la feuille "vendors List" d'ou mon idee de l'activer lors qu'on definit les variables des colonnes pour les adresses emails et noms de societe.

Sub CopyasXlsmandsend()
  Dim OutlookObj As Object, EmailObj As Object
  Dim Wbk As Workbook
  Dim sFolder$, sName1$, sName2$, sDate$, sPartner As String
  Dim sDest$, sPath$, sFilename$
  Dim Col As Long, Lig As Long, lstRow, lstCol As Long
  Dim sendTo As String

  'Initialisation des variables
  Set Wbk = ThisWorkbook.Sheets("Cover", "Depot SLA", "Depot SLA")
  sPath = "C:\Users\jeremy\Desktop\Bin\"
  sDate = Format(Now, "mm-dd-yyyy")

  'Active la feuille dans laquelle sont listées adresses emails et nom de chaque societe
  ThisWorkbook.Sheets("Vendors List").Activate
  'Saisie la derniere cellule contenant une adresse email des colonnes 3 et 5
  lstRow = Cells(Rows.Count, 3).End(xlUp).Row
  lstCol = Cells(4, Columns.Count).End(xlToLeft).Column

  For Lig = 5 To lstRow
    For Col = 3 To lstCol Step 2
      ' Adresse mail du destinataire
      sendTo = Cells(Lig, Col).Value
      If sendTo = "" Then GoTo SuiteCol
      ' Nom du fichier à envoyer : Société et eMail
      sName1 = Cells(Lig, Col - 1).Value
      sName2 = Cells(Lig, Col).Value
      sFilename = sName1 & " - " & sName2 & " - " & sDate & ".xlsm"
      '------------------------------------------------------------------------------------
      'Sauvegarde avec copie du fichier Excel
      On Error Resume Next
      Wbk.Copy 'copie dans nouveau classeur
      With ActiveWorkbook
        .SaveAs Filename:=sPath & sFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'sauver nv classeur sous nom xFileName
        .Close SaveChanges:=True                                    'fermeture
      End With
      If Err.Number <> 0 Then
        MsgBox "If the file already exists, please make sure it is not open or write protected." _
             & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Save File"
        GoTo TheEnd
      End If

      'Creation Email
      Set OutlookObj = CreateObject("Outlook.Application")
      Set EmailObj = OutlookObj.CreateItem(0)
      With EmailObj
        .Display
        .To = sendTo
        .cc = "xxx"
        .Subject = sName1 & " - " & sName2 & " - " & sDate
        .HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear" & " " _
          & sName2 & ",<br><br>" _
          & " xxxx" & " " & ActiveSheet.Range("B11").Value & ".<br><br>" _
          & "Thank you," & "</font>" & .HTMLBody
        .Attachments.Add sPath & sFilename
        '.send
      End With
SuiteCol:
    Next Col
  Next Lig

TheEnd:
  Set Wbk = Nothing
  Set EmailObj = Nothing: Set OutlookObj = Nothing

End Sub
Le 03/11/2020 à 07:26

Ca y est j'ai fixé mon probleme de selection d'email a partir de la feuille de calcul ou se trouvent les adresses.

Selon code ci-dessous je souhaiterais garder l'original du fichier intacte et envoye/sauvegarde une copie (ne comprenant pas toutes les feuilles):

Definition des feuilles de la copie envoyee :

Set xwbk = ThisWorkbook.Sheets("Cover", "Depot SLA")

Sauvegarde et envoie une copie sous format XLSM :

On Error Resume Next
      xwbk.Copy 'copie dans nouveau classeur
      With ActiveWorkbook
        .SaveAs Filename:=xFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'sauver nv classeur sous nom xFileName
        .Close SaveChanges:=True                                    'fermeture
      End With

Malheureusement quand je clique sur le bouton pour lancer la macro rien ne se passe. Ni sauvegarde ni ouverture d'email sous outlook pour envoi.

Sub Saveasxlsmandsend()
Dim xOutlookObj As Object, xEmailObj As Object
Dim xwbk As Workbook, xSht As Worksheet
Dim xUsedRng As Range
Dim xSaveDate$, xFolder$, xName1$, xName2$, xName3$, xDate$, xFilename$
Dim xDest$

'INITIALIZATION OF VARIABLES
Set xwbk = ThisWorkbook.Sheets("Cover", "Depot SLA")
Set xSht = Worksheets("Cover")

With xSht
    xFolder = "C:\Users\xxxx\Desktop\Bin\"
    xName1 = .Range("A3").Value
    xName2 = .Range("B11").Value
    xDest = .Range("B8").Value
End With

xDate = Format(Now, "mm-dd-yyyy")
xFilename = xFolder & "\" & xName1 & " - " & xName2 & " - " & xName3 & " - " & xDate & ".xlsm"

'Activation de la feuille Vendor List pour retrouver les adresses emails
ThisWorkbook.Sheets("Vendors List").Activate
'Obtention de toutes les adresses emails jusqu'a la dernierea compte de la 5 lignes et 4 ieme colonne
  lstRow = Cells(Rows.Count, 5).End(xlUp).Row
  lstCol = Cells(4, Columns.Count).End(xlToLeft).Column

'Selection uniquement des adresses email via Step 2 sur la selection des colonnnes
For Lig = 5 To lstRow
    For Col = 4 To lstCol Step 2
      ' Adresse mail du destinataire
      sendTo = Cells(Lig, Col).Value
      If sendTo = "" Then GoTo SuiteCol

'------------------------------------------------------------------------------------
'SAVE AS XLSM FILE

On Error Resume Next
      xwbk.Copy 'copie dans nouveau classeur
      With ActiveWorkbook
        .SaveAs Filename:=xFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'sauver nv classeur sous nom xFileName
        .Close SaveChanges:=True                                    'fermeture
      End With
If Err.Number <> 0 Then
    MsgBox "If the file already exists, please make sure it is not open or write protected." _
        & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Save File"
    GoTo TheEnd
End If

'CREATE OUTLOOK EMAIL
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
    .Display
    .To = sendTo
    .CC = "my172-tender.process.com"
    .Subject = xName1 & " - " & xName2 & " - " & xName3 & " - " & xDate
    .HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear" & " " & ActiveSheet.Range("B7").Value & "," & _
    "<br><br>" & _
    " You will find attached my approval on the waiver for" & " " & ActiveSheet.Range("B11").Value & "." & _
    "<br><br>" & _
    "Thank you," & _
    .HTMLBody & "</font>"
    .Attachments.Add xFilename
    '.send
End With

SuiteCol:
    Next Col
  Next Lig

TheEnd:
Set xSht = Nothing
Set xEmailObj = Nothing: xOutlookObj = Nothing

End Sub
Le 03/11/2020 à 07:45

Bonjour Jérémy,

Tu as changé apparemment le nom de ta procédure entre temps

Avant :

Sub CopyasXlsmandsend()

Après :

Sub Saveasxlsmandsend()

Donc normal,

Le 03/11/2020 à 10:38

Bonjour Bruno,

Oui c'est parce que je fais des mix entre plusieurs macros. A partir du moment ou j'assigne le bouton a la nouvelle macro le nom de la macro ne devrait pas poser probleme.

La sauvegarde se fait bien mais l'envoi via Outlook a tous les destinataires de la feuille "Vendors List" ne s'enclenche pas.

J'aimerais egalement que ma variable Wbk reprenne tout le classeur mais en excluant la feuille "Vendors List".

J'y suis presque mais je trouve pas ce qui cloche.

Sub CopyasXlsmandsend()
  Dim OutlookObj As Object, EmailObj As Object
  Dim Wbk As Workbook, Sht As Worksheet
  Dim sPath$, sFilename$, sName1$, sDate$
  Dim Col As Long, Lig As Long, lstRow, lstCol As Long
  Dim sendTo As String

'INITIALIZATION OF VARIABLES
Set Wbk = ThisWorkbook
Set Sht = Worksheets("Cover")

With Sht
    sName1 = .Range("B1").Value
End With

sDate = Format(Now, "mm-dd-yyyy")
sPath = "C:\Users\jeremy.franc\Desktop\Bin\"
sFilename = sPath & sName1 & " - " & sDate & ".xlsm"

ThisWorkbook.Sheets("Vendors List").Activate
'Getting last row of containing email id in column 4.
  lstRow = Cells(Rows.Count, 5).End(xlUp).Row
  lstCol = Cells(4, Columns.Count).End(xlToLeft).Column

'Selection uniquement des adresses email via Step 2 sur la selection des colonnnes
For Lig = 5 To lstRow
    For Col = 4 To lstCol Step 2
      ' Adresse mail du destinataire
      sendTo = Cells(Lig, Col).Value
      If sendTo = "" Then GoTo SuiteCol

'------------------------------------------------------------------------------------
'SAVE AS XLSM FILE

      On Error Resume Next
      Wbk.Copy 'copie dans nouveau classeur avec nom du fichier = sFilenam
      With Wbk
        .SaveAs Filename:=sFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'sauver nv classeur sous nom sFileName
        .Close SaveChanges:=True                                    'fermeture
      End With
If Err.Number <> 0 Then
    MsgBox "If the file already exists, please make sure it is not open or write protected." _
        & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Save File"
    GoTo TheEnd
End If

'Creer email et envoyer le fichier xlsm en PJ
Set OutlookObj = CreateObject("Outlook.Application")
Set EmailObj = OutlookObj.CreateItem(0)
With EmailObj
    .Display
    .To = sendTo
    .CC = "my172-tender.process.com"
    .Subject = " - " & " - " & " - " & sDate
    .HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear" & _
    "<br><br>" & _
    " You will find attached my approval on the waiver for." & _
    "<br><br>" & _
    "Thank you," & _
    .HTMLBody & "</font>"
    .Attachments.Add sFilename
    '.send
End With

SuiteCol:
    Next Col
  Next Lig

TheEnd:
Set Sht = Nothing: Set Wbk = Nothing
Set xEmailObj = Nothing: Set xOutlookObj = Nothing

End Sub
Le 03/11/2020 à 18:12

Re,

jeremy22175 a écrit :

J'y suis presque mais je trouve pas ce qui cloche.

Et sais-tu pourquoi cet état de fait

Tu n'as pas mis en tête de tes modules : Option Explicit

Ensuite compile ton projet dans le menu débogage... et tu découvrira ce qui ne va pas

@+

Le 08/11/2020 à 08:52

Salut,

J'ai cherché un peu de mon côté et plutôt bien avancé. Merci pour tes coups de pouce et pistes de reflexion.

  • Envoi automatique de plusieurs emails en fonction des differentes adresses sur la feuille "Vendors List" = OK
  • Selection du compte Outlook comme émetteur = OK (si vous avez plusieurs comptes sur votre Outlook)
  • Sauvegarde en XLSM selon nom de la societe referencée sur la feuille "Vendors List" = OK

En pending :

  • Selection de certaines feuilles sur le classeur :
    • Pour le moment la feuille que je ne souhaite pas qui soit revelee aux societes receptionnaires du fichier ==> je suis passé par le Properties Window / Very Hidden ==> idealement je souhaiterais selectionner les feuilles de calcul du fichier Wbk sauvé. J'ai essaye avec le code ci-dessous mais ce ne marche pas :
With Wbk
        .Sheets(Array("Sheet1", "Sheet3")).Copy
End With
  • Autselection de la signature Outlook liee au compte selectionne : avec .HTMLBody mais ca ne marche aucune signature n'est selectionne lors de l'envoi de l'email
Option Explicit
Sub Bulkemails()
  Dim OutApp As Outlook.Application
  Dim OutMail As Outlook.MailItem
  Dim OutAccount As Outlook.Account
  Dim Wbk As Workbook, Sht As Worksheet
  Dim sPath, sFilename, sName1, sName2, sDate As String
  Dim Col As Long, Lig As Long, lstRow, lstCol As Long
  Dim sendTo As String

'INITIALIZATION OF VARIABLES
Set Wbk = ThisWorkbook
Set Sht = Worksheets("Cover")

With Sht
    sName1 = .Range("B1").Value
End With

ThisWorkbook.Sheets("Vendors List").Activate
'Getting last row of containing email id in column 4.
  lstRow = Cells(Rows.Count, 5).End(xlUp).Row
  lstCol = Cells(4, Columns.Count).End(xlToLeft).Column

For Lig = 5 To lstRow
    For Col = 4 To lstCol Step 2
      ' Adresse mail du destinataire
      sendTo = Cells(Lig, Col).Value
      If sendTo = "" Then GoTo SuiteCol
      sName2 = Cells(Lig, Col - 1).Value
      sDate = Format(Now, "mm-dd-yyyy")
      sPath = "C:\Users\xxxx\Desktop\Bin\"
      sFilename = sPath & sName1 & " - " & sName2 & " - " & sDate & ".xlsm"

'------------------------------------------------------------------------------------
'SAVE AS XLSM FILE

On Error Resume Next
  Wbk.Copy
  Wbk.SaveAs Filename:=sFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled

'CREATE OUTLOOK EMAIL
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
    Set OutAccount = OutApp.Session.Accounts("comptedenvoi@xxx.com")
With OutMail
    .To = sendTo
    .CC = "xxx@sss.fr"
    .Subject = " - " & " - " & " - " & sDate
    .HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear" & _
    "<br><br>" & _
    " We are pleased to announce you that you have been selected for this tender." & _
    "<br><br>" & _
    "Thank you," & "</font>" & .HTMLBody
    .Attachments.Add sFilename
    .SendUsingAccount = OutAccount
    .Send
End With

SuiteCol:
    Next Col
  Next Lig

TheEnd:
Set Sht = Nothing: Set Wbk = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Set OutAccount = Nothing

End Sub
Le 08/11/2020 à 15:28

Voici mon code final pour ceux que ca pourrait aider.

Le seul point que je n'ai pas réussi à résoudre c'est l'instertion automatique de la signature via .HTLMBody donc j'ai forcé en posant la Signature comme variable puis une fonction chopée sur un autre forum. C'est OK, juste les images de la signature en moins.

Si jamais quelqu'un a la solution pour fixer la signature avec images, comme lors de creation d'un nouveau message depuis Outlook, je suis preneur.

Bonne fin de dimanche à tous:

Option Explicit
Sub Bulkemails()
  Dim OutApp As Outlook.Application
  Dim OutMail As Outlook.MailItem
  Dim OutAccount As Outlook.Account
  Dim DestWbk As Workbook, SourceWbk As Workbook, Sht As Worksheet
  Dim sPath, sFilename, sName1, sName2, sDate, SBody, Signature, SigString As String
  Dim Col As Long, Lig As Long, lstRow, lstCol As Long
  Dim sendTo As String
  Dim TheActiveWindow As Window
  Dim TempWindow As Window

With Application
        .ScreenUpdating = False
        .EnableEvents = False
End With

'INITIALIZATION OF VARIABLES
Set SourceWbk = ActiveWorkbook

    'Copy the sheets to a new workbook
    'We add a temporary Window to avoid the Copy problem
    'if there is a List or Table in one of the sheets and
    'if the sheets are grouped

With SourceWbk
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("Cover", "Depot SLA", "1. Company Identity Card", "2. Your Svc Commitment", "3. Quotation_Depot", "4. Contact_Matrix", "MSC Volumes 2020", "Service Standard", "List")).Copy
End With

    'Close temporary Window
TempWindow.Close

Set DestWbk = ActiveWorkbook

Set Sht = Worksheets("Cover")

With Sht
    sName1 = .Range("B1").Value
End With

ThisWorkbook.Sheets("Vendors List").Activate
'Getting last row of containing email id in column 4.
  lstRow = Cells(Rows.Count, 5).End(xlUp).Row
  lstCol = Cells(4, Columns.Count).End(xlToLeft).Column

For Lig = 5 To lstRow
    For Col = 4 To lstCol Step 2
      ' Adresse mail du destinataire
      sendTo = Cells(Lig, Col).Value
      If sendTo = "" Then GoTo SuiteCol
      sName2 = Cells(Lig, Col - 1).Value
      sDate = Format(Now, "mm-dd-yyyy")
      sPath = "C:\Users\jeremy.franc\Desktop\Bin\"
      sFilename = sPath & sName1 & " - " & sName2 & " - " & sDate & ".xlsm"

SBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear Partner" & _
    "<br><br>" & _
    " We are pleased to select you xxx" & "." & _
    "<br><br>" & _
    "Thank you in advance for your kind consideration," & "</font>"
'------------------------------------------------------------------------------------
'SAVE AS XLSM FILE
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\TenderProcess.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

On Error Resume Next
  DestWbk.Copy
  DestWbk.SaveAs filename:=sFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled

'CREATE OUTLOOK EMAIL
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
    Set OutAccount = OutApp.Session.Accounts("my172-tender.process@msc.com")
With OutMail
    .To = sendTo
    .CC = "jeremy.franc@msc.com"
    .Subject = " - " & " - " & " - " & sDate
    .HTMLBody = SBody & "<br>" & Signature
    .Attachments.Add sFilename
    .SendUsingAccount = OutAccount
    .Send
End With

SuiteCol:
    Next Col
  Next Lig

TheEnd:
Set Sht = Nothing: Set DestWbk = Nothing: Set SourceWbk = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Set OutAccount = Nothing

With Application
        .ScreenUpdating = True
        .EnableEvents = True
End With

End Sub

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
Le 08/11/2020 à 17:38

Bonjour jeremy22175 et merci du retour

Pour la signature, une chose toute simple, afficher le mail avant de le remplir 

With OutMail
  .Display
  .To = sendTo
  .CC = "jeremy.franc@msc.com"
  .Subject = " - " & " - " & " - " & sDate
  .HTMLBody = SBody & "<br>" & .HTMLBody
  .Attachments.Add sFilename
  .SendUsingAccount = OutAccount
  .Send
End With

@+

Le 09/11/2020 à 01:57

Bonjour Bruno,

J'ai essayé mais ca selectionne la signature du compte principal enregistre sur mon Outlook et non celle qui est liee au compte - OutAccount.

En naviguant sur les forums, j'ai lu qu'il fallait placer l'instruction SendUsingAccount juste apres With OutMail mais cela ne fonctionne pas. L'email part mais sans signature

With OutMail
    .SendUsingAccount = OutAccount
    .Display
    .To = sendTo
    .CC = "jeremy.xxx@xxx.com"
    .Subject = " - " & " - " & " - " & sDate
    .HTMLBody = SBody & "<br>" & .HTMLBody
    .Attachments.Add sFilename
    .Send
End With

J'ai essaye ca aussi mais ne fonctionne pas. Email envoye depuis l'adresse principale (et non celle designee comme OutAccount) et signature compte principal.

With OutMail
    Set .SendUsingAccount = OutAccount
    .Display
    .To = sendTo
    .CC = "jeremy.xxx@xxx.com"
    .Subject = " - " & " - " & " - " & sDate
    .HTMLBody = SBody & "<br>" & .HTMLBody
    .Attachments.Add sFilename
    .Send
End With

J'ai essaye d'enlever la Dim OutAccount et de directement definir le compte a utiliser entre With Outmail et End With. Email envoye du bon compte mais pas de signature du tout.

With OutMail
    .SendUsingAccount = OutApp.Session.Accounts("my172-tender.process@msc.com")
    .Display
    .To = sendTo
    .CC = "jeremy.xxx@xxx.com"
    .Subject = " - " & " - " & " - " & sDate
    .HTMLBody = SBody & "<br>" & .HTMLBody
    .Attachments.Add sFilename
    .Send
End With

J'ai regarde au niveau d'Outlook les signatures sont bien assignees a chaque compte respectif... Je ne comprends pas.

Je garde pour l'instant mon code repris sur Ron de Bruin pour contourner et selectionner la signature en HTM, sans images.

Si jamais tu as une idee d'ou ca cloche je suis preneur.

Bonne journee.

Jeremy

Rechercher des sujets similaires à "envoi multiples emails partir differentes ranges"