Gmail via CDO, attacher un fichier PDF, des adresses, un objet et un corps bien définit, code de Roland_M.

bellenm · 29 Novembre 2019

Bonjour à tous,

Une fois de plus je me reviens vers vous pour un sujet que j'ai déjà poser mais dont on avait pas trouver de solution à l'époque.
J'ai réduit la difficulté et trouver certaine chose solution.

J'ai essayer un fichier de Roland_M qui fonctionne bien mais serait plus compliquer à utiliser pour le moment car trop de manipulation. Je sais que je pourrais remplir les cellules approprier par des liens qui renverront l'information mais cela ne risquerait elle pas d'alourdir un peux plus le fichier et le ralentir aussi ?

OS: Windows 10
Smpt: gmail
Excel: 2016

VB:

'                                                      .
' BoutonEnvoiMail avec fich.joint sélectionné sur disque
'                                                      .
' msoFileDialogOpen         : ouvrir un fichier
' msoFileDialogSaveAs       : sauver un fichier
' msoFileDialogFilePicker   : sélect un fichier
' msoFileDialogFolderPicker : sélect un dossier
'                                             .
Public Sub BoutonEnvoiMailFichJOINT()
ThisWorkbook.Activate: If FSiErrSurObjetNommes Then Exit Sub '<ceci aux Sub appelés par button
'
Dim FichItem As Variant, M$
PathFichier$ = ""
If SvgSourceFichEnvoi$ = "" Then SvgSourceFichEnvoi$ = ThisWorkbook.Path
With Application.FileDialog(msoFileDialogFilePicker)
  .InitialFileName = SvgSourceFichEnvoi$ 'chemin
'.AllowMultiSelect = False '1seul fich
  .AllowMultiSelect = True '+sieurs fich
'.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
.Title = "Sélectionner un fichier ou plusieurs avec touche ctrl"
.Show
  If .SelectedItems.Count > 0 Then
     I = InStrRev(.SelectedItems(1), "\"): SvgSourceFichEnvoi$ = Left(.SelectedItems(1), I) 'svg dossier source
     For Each FichItem In .SelectedItems: PathFichier$ = PathFichier$ & FichItem & ";": Next
     'If .SelectedItems.Count > 0 Then PathFichier$ = .SelectedItems(1)
  End If
End With
If PathFichier$ > "" Then
   If Right(PathFichier$, 1) = ";" Then PathFichier$ = Left(PathFichier$, Len(PathFichier$) - 1)
   FichItem = Split(PathFichier$, ";")
   For I = LBound(FichItem) To UBound(FichItem)
    If Dir(FichItem(I)) = "" Then MsgBox FichItem(I) & vbLf & vbLf & "Chemin/Fichier invalide !?", vbExclamation, "Erreur fichier": GoTo Sortie
    M$ = M$ & FichItem(I) & vbLf
   Next
   M$ = "Envoyer le Mail avec Fichier(s)?" & vbLf & M$
   If MsgBox(M$, vbQuestion + vbYesNo, "Envoi Mail") = vbYes Then
     'load param et MsgHTMLBody puis envoi mail avec fichier joint
      If FSiLoadParamSmtpAdresMail_OK("") Then
         LoadMsgHTMLBody ""
         If FSiEnvoyerLeMailDirectOK(PathFichier$) Then SaveMailEnvoye True, Fichier$, "joint"
      End If
   End If
End If
Sortie:
RetourFeuilMenu
End Sub

Voici son code ne connaissant pas le langage, je ne sais pas quel son les lignes à modifier.

Sur mon fichier une macro crée un PDF dans le répertoire "\FM" et c'est ce fichier crée qu'il faut envoyer aux destinataires qui sont sur la cellule "E120" l'objet se trouve en "E121" et le corps du message en "E122" .

Le nom du fichier sera chaque fois différent ainsi que les destinataires, l'objet et le corps du message.

Voici tous le code du fichier de Roland_M:

Code:

             '#########################################################
             '### ROUTINES APPEL BUTTONS                            ###
             '### BoutonEnvoiMailMsgSeul()                          ###
             '### BoutonEnvoiMailFichJOINT()                        ###
             '### BoutonEnvoiMailFeuilJOINTouMSG()                  ###
             '### BoutonEnvoiMailRangJOINTouMSGDestinMultiple() plus###
             '#########################################################


'                                                 .
' BoutonEnvoiMail message seul sans aucune donnée .
'                                                 .
Public Sub BoutonEnvoiMailMsgSeul()
ThisWorkbook.Activate: If FSiErrSurObjetNommes Then Exit Sub '<ceci aux Sub appelés par button
M$ = "Envoyer le Mail uniquement sans aucune donnée ?"
If MsgBox(M$, vbQuestion + vbYesNo, "Envoi Mail") <> vbYes Then Exit Sub
'load param et MsgHTMLBody et envoi
If FSiLoadParamSmtpAdresMail_OK("") Then LoadMsgHTMLBody "seul" Else Exit Sub
If Trim(MsgHTMLBody) > "" Then
   If FSiEnvoyerLeMailDirectOK("") Then SaveMailEnvoye True, "", ""
Else
   MsgBox "Il n'y a aucun message à envoyer !?", vbExclamation, "Envoi Mail"
End If
RetourFeuilMenu
End Sub


'                                                      .
' BoutonEnvoiMail avec fich.joint sélectionné sur disque
'                                                      .
' msoFileDialogOpen         : ouvrir un fichier
' msoFileDialogSaveAs       : sauver un fichier
' msoFileDialogFilePicker   : sélect un fichier
' msoFileDialogFolderPicker : sélect un dossier
'                                             .
Public Sub BoutonEnvoiMailFichJOINT()
ThisWorkbook.Activate: If FSiErrSurObjetNommes Then Exit Sub '<ceci aux Sub appelés par button
'
Dim FichItem As Variant, M$
PathFichier$ = ""
If SvgSourceFichEnvoi$ = "" Then SvgSourceFichEnvoi$ = ThisWorkbook.Path
With Application.FileDialog(msoFileDialogFilePicker)
  .InitialFileName = SvgSourceFichEnvoi$ 'chemin
'.AllowMultiSelect = False '1seul fich
  .AllowMultiSelect = True '+sieurs fich
'.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
.Title = "Sélectionner un fichier ou plusieurs avec touche ctrl"
.Show
  If .SelectedItems.Count > 0 Then
     I = InStrRev(.SelectedItems(1), "\"): SvgSourceFichEnvoi$ = Left(.SelectedItems(1), I) 'svg dossier source
     For Each FichItem In .SelectedItems: PathFichier$ = PathFichier$ & FichItem & ";": Next
     'If .SelectedItems.Count > 0 Then PathFichier$ = .SelectedItems(1)
  End If
End With
If PathFichier$ > "" Then
   If Right(PathFichier$, 1) = ";" Then PathFichier$ = Left(PathFichier$, Len(PathFichier$) - 1)
   FichItem = Split(PathFichier$, ";")
   For I = LBound(FichItem) To UBound(FichItem)
    If Dir(FichItem(I)) = "" Then MsgBox FichItem(I) & vbLf & vbLf & "Chemin/Fichier invalide !?", vbExclamation, "Erreur fichier": GoTo Sortie
    M$ = M$ & FichItem(I) & vbLf
   Next
   M$ = "Envoyer le Mail avec Fichier(s)?" & vbLf & M$
   If MsgBox(M$, vbQuestion + vbYesNo, "Envoi Mail") = vbYes Then
     'load param et MsgHTMLBody puis envoi mail avec fichier joint
      If FSiLoadParamSmtpAdresMail_OK("") Then
         LoadMsgHTMLBody ""
         If FSiEnvoyerLeMailDirectOK(PathFichier$) Then SaveMailEnvoye True, Fichier$, "joint"
      End If
   End If
End If
Sortie:
RetourFeuilMenu
End Sub


'                                                          .
' BoutonEnvoiMail avec une feuille sélect dans ce classeur .
' en pièce jointe ou dans le corps du message              .
'                                                          .
Public Sub BoutonEnvoiMailFeuilJOINTouMSG()
ThisWorkbook.Activate: If FSiErrSurObjetNommes Then Exit Sub '<ceci aux Sub appelés par button
Dim Sh As Object
ReDim Tablo$(0): I = 0
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> NomDeLaFeuilMENU$ Then
    I = I + 1: ReDim Preserve Tablo$(I): Tablo$(I) = Sh.Name
End If
Next
Set Sh = Nothing
If I > 0 Then
   FeuilEnvoi$ = FMsgBoxInputListe("Saisie feuille à envoyer ?", Tablo$())
   If FeuilEnvoi$ = "" Then Exit Sub
Else
   MsgBox "Aucune feuille disponible !?", vbInformation, "": Exit Sub
End If

'confirmation (test s'il y a des shapes dans la feuille)
M$ = "Envoyer les données de la feuille: " & FeuilEnvoi$
If Sheets(FeuilEnvoi$).Shapes.Count > 0 Then
   M$ = M$ & vbLf & vbLf & "ATTENTION: cette feuille contient des objets graph ou autres !?" & vbLf & _
           "Il serait peut être préférable de la mettre en pièce jointe" & vbLf & _
           "car ceux-ci ne seront pas copiés !"
End If
M$ = M$ & vbLf & vbLf & "(Oui )= Envoyer en pièce jointe" & vbLf & _
                        "(Non)= Envoyer dans le corps du message"
ReponseMsgBox = MsgBox(M$, vbQuestion + vbYesNoCancel, "Envoi Mail")
If ReponseMsgBox = vbYes Then GoTo RoutDonEnJoint
If ReponseMsgBox = vbNo Then GoTo RoutDonDansMsg
Exit Sub

'                                                     .
'copy FeuilEnvoi$ sélectionnée et récupère path.complet
'                                                     .
RoutDonEnJoint: 'load param et MsgHTMLBody
If FSiLoadParamSmtpAdresMail_OK("") Then LoadMsgHTMLBody "" Else Exit Sub
'active et copie FeuilEnvoi$ sélectionnée
Application.ScreenUpdating = False
Application.DisplayAlerts = False
InitFormatExtentFichier FilFormatSVG, ExtSVG$
F$ = ThisWorkbook.Path & "\" & NomDuFichierEnvoiTemp$ & "." & ExtSVG$
Sheets(FeuilEnvoi$).Copy
ActiveWorkbook.SaveAs Filename:=F$, FileFormat:=FilFormatSVG
PathFichierTemp$ = ActiveWorkbook.FullName
ActiveWorkbook.Close
Application.DisplayAlerts = True
'fin envoi mail
If FSiEnvoyerLeMailDirectOK(PathFichierTemp$) Then SaveMailEnvoye True, FeuilEnvoi$, "joint"
On Error Resume Next
If PathFichierTemp$ > "" Then Kill PathFichierTemp$ 'ici kill
RetourFeuilMenu
Exit Sub

'                                                    .
'copi les données FeuilEnvoi$ dans le corps du message
'                                                    .
RoutDonDansMsg: 'load param et MsgHTMLBody pour suite tablo HTML !
If FSiLoadParamSmtpAdresMail_OK("") Then LoadMsgHTMLBody "" Else Exit Sub
'active FeuilEnvoi$ sélectionnée et init vars Lig/Col du range à copier
Application.ScreenUpdating = False
Sheets(FeuilEnvoi$).Activate: Cells(1, 1).Select
Dim NoDeLaPremLIG, NoDeLaDernLIG, NoDeLaPremCOL, NoDeLaDernCOL
Dim CellVal As String, AlignerH As String, CoulFont As String, CoulFond As String
With ActiveSheet.UsedRange: NoDeLaDernLigDonnees = .Cells(.Rows.Count, .Columns.Count).Row: End With
With ActiveSheet.UsedRange: NoDeLaDernColDonnees = .Cells(.Rows.Count, .Columns.Count).Column: End With
Rang$ = Range(Cells(1, 1), Cells(NoDeLaDernLigDonnees, NoDeLaDernColDonnees)).Address
With Sheets(FeuilEnvoi$)
NoDeLaPremLIG = .Range(Rang$).Row
NoDeLaPremCOL = .Range(Rang$).Column
NoDeLaDernLIG = NoDeLaPremLIG + .Range(Rang$).Rows.Count - 1
NoDeLaDernCOL = NoDeLaPremCOL + .Range(Rang$).Columns.Count - 1
End With
'création du tableau HTML
CreationDuTableauMsgHTMLFeuilActive "deb", NoDeLaPremLIG, NoDeLaDernLIG, NoDeLaPremCOL, NoDeLaDernCOL, "fin"
'fin envoi mail
If FSiEnvoyerLeMailDirectOK("") Then SaveMailEnvoye True, FeuilEnvoi$, "msg"
RetourFeuilMenu
End Sub


'                                                           .
' BoutonEnvoiMail * Spécial Feuille DataDestinMultiples *   .
' envoi mail à un ou plusieurs destinataires présents       .
' dans cette feuille avec leurs champs de données perso     .
Public Sub BoutonEnvoiMailRangJOINTouMSGDestinMultiple() '(plus)
ThisWorkbook.Activate: If FSiErrSurObjetNommes Then Exit Sub '<ceci aux Sub appelés par button
On Error Resume Next: Err.Clear
Sheets(NomDeLaFeuilDestinMultiples$).Select: Range("A1").Select
If Err Then MsgBox "Feuille: " & NomDeLaFeuilDestinMultiples$ & vbLf & "Vous avez supprimée cette feuille !?", vbInformation, "": Exit Sub
'sélect choix envoi
Sheets(NomDeLaFeuilDestinMultiples$).Select: Range("A1").Select
M$ = "Envoyer les données à chaque destinataire présent dans cette feuille." & vbLf & _
      "(les adresses mails dans feuil.menu ne sont pas concernées)" & vbLf & vbLf & _
      "Comment souhaitez vous les envoyer ?" & vbLf & _
      "(Oui )= Envoyer en pièce jointe" & vbLf & _
      "(Non)= Envoyer dans le corps du message"
ReponseMsgBox = MsgBox(M$, vbQuestion + vbYesNoCancel, "Envoi Mail")
If ReponseMsgBox = vbYes Then
   ChoixEnvoi$ = "joint"
ElseIf ReponseMsgBox = vbNo Then
   ChoixEnvoi$ = "msg"
Else
   RetourFeuilMenu
   Exit Sub
End If

'                                                   .
'load les vars et paramètres pour envoi             .
'en "joint" MsgHTMLBody init en une seule fois      .
'dans "msg" MsgHTMLBody avant création tableau HTML .
'l'adres.fictive c'est juste pour éviter l'erreur dans la fonction d'appel
If FSiLoadParamSmtpAdresMail_OK("adresfictive@fre.fr") Then LoadMsgHTMLBody "" Else RetourFeuilMenu: Exit Sub
Dim Tablo As Variant
'select la FeuilDestinMultiples et init pour boucle envoi
Application.ScreenUpdating = False
Sheets(NomDeLaFeuilDestinMultiples$).Select
NoDeLaLigEntete = 1
NoDeLaColNomClient = 1
NoDeLaColAdresClient = 2
NoDeLaPremLigDonnees = 2
NoDeLaPremColDonnees = 3
NoPremLigRang = 0 '....
NoDernLigRang = 0 '....
With ActiveSheet.UsedRange: NoDeLaDernLigDonnees = .Cells(.Rows.Count, .Columns.Count).Row: End With
With ActiveSheet.UsedRange: NoDeLaDernColDonnees = .Cells(.Rows.Count, .Columns.Count).Column: End With
'test si données!?
If NoDeLaDernLigDonnees < 2 Or NoDeLaDernColDonnees < 2 Then
   MsgBox "Il n'y a aucune données à envoyer !?", vbExclamation, "": RetourFeuilMenu: Exit Sub
End If
'boucle load les destinataires et leurs données
LigEnCours = NoDeLaPremLigDonnees - 1: ListeDesAdresEnvoyee$ = ""
Do 'boucle sur le champ des destinataires et de leurs données
  LigEnCours = LigEnCours + 1: If LigEnCours > NoDeLaDernLigDonnees Then Exit Do
  ChaineAdresDestinataires$ = Cells(LigEnCours, NoDeLaColAdresClient)
  NoPremLigRang = LigEnCours: NoDernLigRang = 0
  If LigEnCours = NoDeLaDernLigDonnees Then
     If ChaineAdresDestinataires$ > "" Then NoPremLigRang = LigEnCours: NoDernLigRang = LigEnCours
  Else
     Do 'test sur base adres.mail
       If Cells(LigEnCours + 1, NoDeLaColAdresClient) = "" Then
          LigEnCours = LigEnCours + 1
          If LigEnCours = NoDeLaDernLigDonnees Then
             NoDernLigRang = LigEnCours: Exit Do
          ElseIf LigEnCours > NoDeLaDernLigDonnees Then
             Exit Do
          End If
       Else
          NoDernLigRang = LigEnCours: Exit Do
       End If
     Loop
  End If
  If NoDernLigRang > 0 And ChoixEnvoi$ = "joint" Then '==============================================================

    'vide feuil.envoi/copie données/créat.classeur/envoi/sup.fich.temp/mail suivant
    On Error Resume Next: Err.Clear
    Sheets(NomDeLaFeuilTemp$).Cells.Clear
    If Err Then ThisWorkbook.Sheets.Add: ActiveSheet.Name = NomDeLaFeuilTemp$
    '1'copie l'entête dans la feuille envoi temp
    '2'copie les données dans la feuille envoi temp
    Rang$ = Range(Cells(NoDeLaLigEntete, NoDeLaPremColDonnees), Cells(NoDeLaLigEntete, NoDeLaDernColDonnees)).Address
    Sheets(NomDeLaFeuilDestinMultiples$).Range(Rang$).Copy Destination:=Sheets(NomDeLaFeuilTemp$).Range("A1")
    Rang$ = Range(Cells(NoPremLigRang, NoDeLaPremColDonnees), Cells(NoDernLigRang, NoDeLaDernColDonnees)).Address
    Sheets(NomDeLaFeuilDestinMultiples$).Range(Rang$).Copy Destination:=Sheets(NomDeLaFeuilTemp$).Range("A2")
    'select feuille et formate le champ complet
    Sheets(NomDeLaFeuilTemp$).Select
    With ActiveSheet.UsedRange: NoDernLig = .Cells(.Rows.Count, .Columns.Count).Row: End With
    With ActiveSheet.UsedRange: NoDernCol = .Cells(.Rows.Count, .Columns.Count).Column: End With
    Range(Cells(NoDeLaLigEntete, 1), Cells(NoDernLig, NoDernCol)).Borders.ColorIndex = 1 'bordures noires
    Columns.AutoFit
    'création du fichier avec la feuille envoi temp
    'boucle envoi(+sieurs!? dans la cell adres;adres; pour même champ)
    CreationDuClasseurEnvoiTemp PathFichierTemp$
    If PathFichierTemp$ = "" Then MsgBox "Abandon !", vbCritical: Exit Do
    Tablo = Split(ChaineAdresDestinataires$, ";")
    For Adres = LBound(Tablo) To UBound(Tablo)
      Par_LesAdresDestinatairesTO$ = Tablo(Adres)
      If FSiEnvoyerLeMailDirectOK(PathFichierTemp$) Then
         SaveMailEnvoye False, NomDeLaFeuilDestinMultiples$, "joint"
         ListeDesAdresEnvoyee$ = ListeDesAdresEnvoyee$ & Par_LesAdresDestinatairesTO$ & vbLf
      Else: Exit Do
      End If
    Next
    'del et reselect feuille DestinMultiples suite ...
    If PathFichierTemp$ > "" Then On Error Resume Next: Kill PathFichierTemp$: On Error GoTo 0: Err.Clear
    Sheets(NomDeLaFeuilDestinMultiples$).Select

  ElseIf NoDernLigRang > 0 And ChoixEnvoi$ = "msg" Then '===========================================================
    'création du tableau HTML 1'LoadMsgHTMLBody 2'LigEntete 3'Range
    'boucle envoi(+sieurs!? dans la cell adres;adres; pour même champ)
    LoadMsgHTMLBody ""
    CreationDuTableauMsgHTMLFeuilActive "deb", NoDeLaLigEntete, NoDeLaLigEntete, NoDeLaPremColDonnees, NoDeLaDernColDonnees, ""
    CreationDuTableauMsgHTMLFeuilActive "", NoPremLigRang, NoDernLigRang, NoDeLaPremColDonnees, NoDeLaDernColDonnees, "fin"
    Tablo = Split(ChaineAdresDestinataires$, ";")
    For Adres = LBound(Tablo) To UBound(Tablo)
      Par_LesAdresDestinatairesTO$ = Tablo(Adres)
      If FSiEnvoyerLeMailDirectOK("") Then
         SaveMailEnvoye False, NomDeLaFeuilDestinMultiples$, "msg"
         ListeDesAdresEnvoyee$ = ListeDesAdresEnvoyee$ & Par_LesAdresDestinatairesTO$ & vbLf
      Else: Exit Do
      End If
    Next

  End If '==========================================================================================================

Loop

'fin
If ChoixEnvoi$ = "joint" Then
   Application.DisplayAlerts = False
   Sheets(NomDeLaFeuilTemp$).Delete 'suppr feuille envoi
   Application.DisplayAlerts = True
   If PathFichierTemp$ > "" Then On Error Resume Next: Kill PathFichierTemp$: On Error GoTo 0: Err.Clear
End If
RetourFeuilMenu
If ListeDesAdresEnvoyee$ > "" Then
   MsgBox "Mail envoyé à:" & vbLf & ListeDesAdresEnvoyee$, vbInformation, "EnvoiMail": ListeDesAdresEnvoyee$ = ""
Else
   MsgBox "Aucun Mail envoyé !", vbInformation, "EnvoiMail"
End If
End Sub



             '##################################################
             '### SOUS ROUTINES DIVERS POUR Sub DE CE MODULE ###
             '### CreationDuClasseurEnvoiTemp                ###
             '### CreationDuTableauMsgHTMLFeuilActive        ###
             '##################################################


Private Sub RetourFeuilMenu()
On Error GoTo 0: Err.Clear: MsgHTMLBody = ""
Sheets(NomDeLaFeuilMENU$).Select: Range("A1").Select: Application.ScreenUpdating = True
End Sub

'avec Sub BoutonEnvoiMailRangJOINTouMSGDestinMultiple()
'avec les données dans la NomDeLaFeuilTemp$ qui existe avant appel !
Private Sub CreationDuClasseurEnvoiTemp(PathFichierTemp$)
On Error Resume Next: Err.Clear
Application.DisplayAlerts = False
InitFormatExtentFichier FilFormatSVG, ExtSVG$
F$ = ThisWorkbook.Path & "\" & NomDuFichierEnvoiTemp$ & "." & ExtSVG$
Sheets(NomDeLaFeuilTemp$).Copy
ActiveWorkbook.SaveAs Filename:=F$, FileFormat:=FilFormatSVG
PathFichierTemp$ = ActiveWorkbook.FullName 'init PathFichierTemp$
ActiveWorkbook.Close
Application.DisplayAlerts = True
'test si ok
If Dir(PathFichierTemp$) = "" Then
   M$ = "Problème à la création du fichier !?" & vbLf & " la variable suivante(PathFichierTemp$ ) est= " & PathFichierTemp$
   MsgBox M$, vbCritical: PathFichierTemp$ = "" '
End If
On Error GoTo 0: Err.Clear
End Sub


'appel BoutonEnvoiMailFeuilJOINTouMSG()
'----- BoutonEnvoiMailRangJOINTouMSGDestinMultiple()
'load MsgHTMLBody avant appel puis ici création du tableau
'MsgHTMLBody = "<TABLE BORDER CELLSPACING=0 CELLPADDING=1>"
'CELLSPACING=épais.trait.cell CELLPADDING=space.text.dans.cell
Private Sub CreationDuTableauMsgHTMLFeuilActive(Deb$, NoPremLig, NoDernLig, NoPremCol, NoDernCol, Fin$)
Dim CellVal As String, AlignerH As String, CoulFont As String, CoulFond As String
If MsgHTMLBody = "" Then MsgHTMLBody = DebMsgHTML
If Deb$ > "" Then MsgHTMLBody = MsgHTMLBody & "<TABLE BORDER CELLSPACING=0 CELLPADDING=1>" 'grille cellules
For Lig = NoPremLig To NoDernLig
   'déclaration de ligne "<TR align='center'>"(Left/center/right)
   'et boucles lig/col dans cet ordre
   MsgHTMLBody = MsgHTMLBody & "<TR>"
   For Col = NoPremCol To NoDernCol
      'load cellule et init /AlignerH/CoulFont/CoulFond
      CellVal = Cells(Lig, Col).Value: GoSub InitFormatCell
      'si cell vide mettre un car ici"." et idem CoulFont&CoulFond(pour invisible)
      If Trim(CellVal) = "" Then CellVal = ".": CoulFont = CoulFond
      MsgHTMLBody = MsgHTMLBody & "<TD " 'création de cellule
      MsgHTMLBody = MsgHTMLBody & "bgcolor='" & CoulFond & "'" 'couleur fond (Hex)
      MsgHTMLBody = MsgHTMLBody & "align='" & AlignerH & "'>" 'align horizontal(seul)(Left/center/Right)
      MsgHTMLBody = MsgHTMLBody & "<FONT COLOR='" & CoulFont & "'" 'couleur car (Hex)
      MsgHTMLBody = MsgHTMLBody & "SIZE=3>" 'taille car(1=petit 2=moyen 3=normal 4=gros ... 7 maxi)
      MsgHTMLBody = MsgHTMLBody & CellVal 'contenu de la cellule
      MsgHTMLBody = MsgHTMLBody & "</FONT>" 'fin font
      MsgHTMLBody = MsgHTMLBody & "</TD>"  ' fin de cellule
   Next Col '
   MsgHTMLBody = MsgHTMLBody & "</TR>" 'fin de ligne
Next Lig '
If Fin$ > "" Then
   MsgHTMLBody = MsgHTMLBody & "</TABLE>" 'fin du tableau
   MsgHTMLBody = MsgHTMLBody & FinMsgHTML 'fin du message
End If
Exit Sub 'sortie

InitFormatCell: 'appel gosub INIT /AlignerH/CoulFont/CoulFond
Select Case Cells(Lig, Col).HorizontalAlignment
  Case -4131: AlignerH = "left"
  Case -4108: AlignerH = "center"
  Case -4152: AlignerH = "right"
  Case Else: AlignerH = "left"
End Select
'une couleur inexistante peut causer une erreur vbNull!
If Not IsNull(Cells(Lig, Col).Font.Color) And Not IsNull(Cells(Lig, Col).Interior.Color) Then
   C1& = Cells(Lig, Col).Font.Color: C2& = Cells(Lig, Col).Interior.Color
Else: C1& = 0: C2& = &HFFFFFF 'font noir/fond blanc
End If
R% = Int(C1& And &HFF): G% = Int((C1& And &H100FF00) / &H100): B% = Int((C1& And &HFF0000) / &H10000)
CoulFont = "#" & Format(Hex(R%), "00") & Format(Hex(G%), "00") & Format(Hex(B%), "00")
R% = Int(C2& And &HFF): G% = Int((C2& And &H100FF00) / &H100): B% = Int((C2& And &HFF0000) / &H10000)
CoulFond = "#" & Format(Hex(R%), "00") & Format(Hex(G%), "00") & Format(Hex(B%), "00")
Return
End Sub

Ci-joint le fichier auquel je crois bien avoir enlever tous les liens qui ne vous serviront pas.

Merci à vous qui prendrez le temps de m'aider dans ma quête.

Bien à Vous

bellenm · 30 Novembre 2019

J'ai cela à faire pour deux feuille identique une nomée "F1" et l'autre "F2"
Si j'ai bien compris ± la formule

Pour la deuxieme feuille à With Sheets("F1") je peux le remplacer par F2 et changer simplement le nom du sub en "CDO_mail2 par exemple est ce correct?

bellenm · 30 Novembre 2019

sans abuser Daniel,

Y a t'il moyen de placer et le mon d'expéditeur et le mot de passe sur une feuille différente du classeur afin de regrouper les information à modifier le cas échéant

Je mettrais par exemple sur une feuille que je nommerais "MAIL" et la en B1 j'aurais l'identifiant, en B2 le mot de pass
en B3 le smtp.

Comment faut il définir tous ces paramètre si c'est possible?

Merci beaucoupDaniel

bellenm · 30 Novembre 2019

rere:

je viens de penser à une chose, y a t'il moyen en fin de macro d'insérer une box, fenêtre me disant message envoyé à ..... (les destinataires) et qui s'enlève après l'appui d'une touche du clavier? Ultime confirmation du travail bien effetué.

Marc

David Aubert · 30 Novembre 2019

Bonjour à tous,
Je supprime les copies d’écran car on y voit une adresse email.
Bonne journée

bellenm · 30 Novembre 2019

oups désolé c'était une des mienne.

danielco · 30 Novembre 2019

cela peut ce faire aussi je déplace simplement le fichier de répertoire Daniel, merci.

Fait.

J'ai cela à faire pour deux feuille identique une nomée "F1" et l'autre "F2"
Si j'ai bien compris ± la formule

Pour la deuxieme feuille à With Sheets("F1") je peux le remplacer par F2 et changer simplement le nom du sub en "CDO_mail2 par exemple est ce correct?

Oui. Il faut aussi modifier :

VB:

    .To = Sheets("F1").[E120]
    .From = Sheets("MAIL").[B1] 'adresse expéditeur
    .Subject = Sheets("F1").[E121]
    .TextBody = Sheets("F1").[E122]

Y a t'il moyen de placer et le mon d'expéditeur et le mot de passe sur une feuille différente du classeur afin de regrouper les information à modifier le cas échéant

Je mettrais par exemple sur une feuille que je nommerais "MAIL" et la en B1 j'aurais l'identifiant, en B2 le mot de pass
en B3 le smtp.

Fait.

Code:

Sub CDO_Mail()
  Dim iMsg As Object
  Dim iConf As Object
  Dim strbody As String
  Dim Flds As Variant, PDF As String

  Set iMsg = CreateObject("CDO.Message")
  Set iConf = CreateObject("CDO.Configuration")
 
  iConf.Load -1    ' CDO Source Defaults
  Set Flds = iConf.Fields
  With Flds
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
                   = Sheets("MAIL").[B3] 'nom du serveur SMTP
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 '*** Modifier ne numéro de port
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Sheets("MAIL").[B1] 'modifier l'adresse expéditeur
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Sheets("MAIL").[B2] 'Modifier le mot de passe SMTP
    'avis de lecture
    iConf.Fields("urn:schemas:mailheader:disposition-notification-to") = Sheets("MAIL").[B1] 'adresse expéditeur
    iConf.Fields("urn:schemas:mailheader:return-receipt-to") = Sheets("MAIL").[B1] 'adresse expéditeur
    .Update
  End With
  With Sheets("F1")
    PDF = ThisWorkbook.Path & "\" & .[Y2] & "[" & .[B18] & .[G18] & " contre " & .[H18] & .[Y18] & "] = " & .[Y41] & _
      " - " & .[AA41] & ".PDF"
  End With
  With iMsg
    Set .Configuration = iConf
    .To = Sheets("F1").[E120]
    .From = Sheets("MAIL").[B1] 'adresse expéditeur
    .Subject = Sheets("F1").[E121]
    .TextBody = Sheets("F1").[E122]
    .AddAttachment PDF
    .Send
  End With
  MsgBox "masssage bien envoyé à " & Sheets("F1").[E120]
End Sub

bellenm · 30 Novembre 2019

Super Daniel,

mais dommage je viens de m'apercevoir après une recherche du pourquoi j'avais toujours le même problème:

donc il vas falloir trouver une autre solution, j'avais peur de ne pas avoir modifier correctement les codes ou oublier la feuille "MAIL" mais non cette fois le problème était tout autre!
As tu une solution je vais également chercher sur le web une alternative et te la signale si j'en trouve un.

Par contre d'après ce que j'ai vu comme modification sur le code cela d'être au top, déjà un grand merci, il suffit plus que de joindre ce fichus fichier PDF

Merci Daniel
Marc

bellenm · 30 Novembre 2019

Re Daniel,

Au final pour la sélection du fichier PDF ne serait il pas plus simple de faire comme a ta première suggestion ouvrir un box et choisir la pièce jointe, par ailleurs tout au plus il ne devrait y en avoir que deux.

Le addAttachement est encore d'actualité ou non pour CDO envois de fichier joint PDF?

Bien à toi et bonne soirée

bellenm · 30 Novembre 2019

Qui peut m'aider svp,

quel est l'erreur sur cette ligne?

VB:

 .AddAttachment ("f:\" & .Range("Y2").Value & " [ " & Range("b18").Value & Range("g18").Value & " contre " & Range("h18").Value & " " & Range("Y18").Value & " ] = " & Range("Y41").Value & " - " & Range("aa41"))

cette ligne devrait donner le chemin du fichier :
f:\R 074 [ A.C. GRÂCE 1 contre A.C. FLEMALLE 2 ] = - .pdf

Mais a chaque fois j'ai une erreur.
Et lorsque je met le chemin et nom du fichier en direct j'ai une autre erreur:
.AddAttachment ("f:\R 074 [ A.C. GRÂCE 1 contre A.C. FLEMALLE 2 ] = - .pdf")
Send

Voici le code utiliser:

La formule du PDF est
PDF = ThisWorkbook.Path & "\" & .Range("Y2").Value & " [ " & Range("b18").Value & Range("g18").Value & " contre " & Range("h18").Value & " " & Range("Y18").Value & " ] = " & Range("Y41").Value & " - " & Range("aa41")

Je suis bloqué merci pour votre aide et à Daniel pour tous le travail déjà fait.

Roland_M · 1 Décembre 2019

Bonjour,

je prend en cours j'ai pas tout suivi et pas tout compris . . .
mais c'est pas possible de t'aider sans savoir ce que contiennent toutes ces adresses cellules !?

et puis tu as plusieurs déclarations de chemin !?
PDF ThisWorkbook.Path & "\" . . .
puis :
("f:\" & .Range("Y2").Value & " [ " & Range("b18").Value & Range("g18").Value & " contre " & Range("h18").Value & " " & Range("Y18").Value & " ] = " & Range("Y41").Value & " - " & Range("aa41"))

donc, ils posent tous problème !?

il faudrait récupérer la chaîne complète avec Debug.Print pour pouvoir l'analyser !
Debug.Print PDF
ou
Debug.Print ("f:\" & .Range("Y2").Value & " [ " & Range("b18").Value & Range("g18").Value & " contre " & Range("h18").Value & " " & Range("Y18").Value & " ] = " & Range("Y41").Value & " - " & Range("aa41"))

déjà ce qui saute à l'oeil c'est ici> .Range("Y2").Value
pourquoi le point(.)Range et les autres pas !?

si tu fais .Range c'est que tu as With UneFeuille !? sinon c'est une erreur, il faut supprimer ce point !

bellenm · 1 Décembre 2019

Bonjour Roland_M,

Ces cellules contiennent les valeurs pour former le nom du fichier PDF:
Y2 donne la référence du match exp "R 074"
B18 donne le nom de l'équipe visité " AC GRACE"
G18 donne l'index de l'équipe visité " 1 ou 2 ou 3 etc.."
H18 donne le nom de l'équipe visiteuse " AC FLEMALLE"
Y18 donne l'index de l'équipe visiteuse "1 ou 2 ou 3 etc.."
Y41 donne le résultat des visités
AA41 donne le résultat des visiteurs

ce qui donne comme résultats: R 074 [ A.C. GRÂCE 1 contre A.C. FLEMALLE 2 ] = 6 - 4.pdf

Pour ce qui est du . je ne sais pas erreur de copie?

Le mieux au final ce serais d'avoir une box pour choisir le fichier à envoyer.

je partais sur ton fichier EnvoiMail_Cdo_5simple qui fonctionne très bien mais ne convient pas parce que je ne sais pas définir les destinataires via la sheets"f1, E120" ainsi que l'objet et le coprs du message.

Merci pour ton passage sur ce post Roland_M.

Marc

Roland_M · 1 Décembre 2019

bonjour,

donc le point tu sais pas !? c'est mal barré non !?

tu crois pas qu'il faudrait commencer par le supprimer et faire un essai ?

bellenm · 1 Décembre 2019

Roland_M à dit:
Debug.Print ("f:\" & .Range("Y2").Value & " [ " & Range("b18").Value & Range("g18").Value & " contre " & Range("h18").Value & " " & Range("Y18").Value & " ] = " & Range("Y41").Value & " - " & Range("aa41"))

Comment peux t'on récupérer cette valeur?

bellenm · 1 Décembre 2019

Oui c'est déjà fait ça devait être une erreur,

sur ton fichier ca fonctionne je peux envoyer les fichiers joint ici j'ai encore l'erreur .send

bellenm · 1 Décembre 2019

Le point c'est une erreur de retranscription car voilà où la création du PDF part sur une autre Macro:

VB:

Else
     chemin = ThisWorkbook.Path & ""
       NomFichier = Range("Y2").Value & " [ " & Range("b18").Value & Range("g18").Value & " contre " & Range("h18").Value & " " & Range("Y18").Value & " ] = " & Range("Y41").Value & " - " & Range("aa41")

Et le fichier est bien créer avec le bon nom .

Gmail via CDO, attacher un fichier PDF, des adresses, un objet et un corps bien définit, code de Roland_M.

bellenm

XLDnaute Impliqué

Pièces jointes

bellenm

XLDnaute Impliqué

bellenm

XLDnaute Impliqué

bellenm

XLDnaute Impliqué

David Aubert

XLDnaute Barbatruc

bellenm

XLDnaute Impliqué

danielco

XLDnaute Accro

bellenm

XLDnaute Impliqué

bellenm

XLDnaute Impliqué

bellenm

XLDnaute Impliqué

Roland_M

XLDnaute Barbatruc

bellenm

XLDnaute Impliqué

Roland_M

XLDnaute Barbatruc

bellenm

XLDnaute Impliqué

bellenm

XLDnaute Impliqué

bellenm

XLDnaute Impliqué

Discussions similaires