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

Roland_M · 1 Décembre 2019

re

probablement un histoire de config CDO

mais comme tout est mis en dur Sheets(Machun).[B!?]
impossible de résoudre le problème ainsi sans un classeur clair bien ordonné et surtout accessible !

tu parles de mon classeur qui fonctionne mais ne convient pas !? (encore que je sais pas si c'est la dernière version)
pourtant là tu as la possibilité de sélectionner un fichier quelconque par boite de dialogue !?

bellenm · 1 Décembre 2019

Re

Donc comme dans le message précédent il faudrait qu'il prend le fichier sur le disque là où se trouve le fichier.

Roland_M · 1 Décembre 2019

évidemment, tu n'avais pas compris le principe ?

bellenm · 1 Décembre 2019

Oui mais je ne'arrive à insérer auomatiquement les destinataire se trouvant sur ma feuille cellule ""E120", comme le sujet en "E121" et le message en "E122" si non choix des fichiers extra envois ok de plus tu garde une trace des envois super

Roland_M · 1 Décembre 2019

re

je crois qu'il y a méprise ! ce n'est ni mon classeur ni mes codes !?

bellenm · 1 Décembre 2019

Avec ton fichier mais il faudrait que le sujet sois la cellule "E121" de la feuille "F1 et le coprs du message la celule "E122" de la feuille "F1"

A savoir que j'aurais la même manipulation à faire pour une autre feuille apprelée "F2"

Bien à toi et merci d'avance de regarder pour mon problème .

Le voici

Roland_M · 1 Décembre 2019

re

excuses moi mais s'il fallait que je modifie le classeur à chaque fois j'en sortirais jamais !

c'est à toi d'adapter, le classeur est prévu pour ça
mettre le sujet dans la cellule réservée
mettre le message dans le cadre réservé

et pas faire l'inverse, adapter le code !
on voit que tu ne connais pas la programmation, Y'a qu'à, faut qu'on . . . ce serait trop facile !

bellenm · 1 Décembre 2019

Re Roland_ M,

C'est vrai que je n'y connais rien ! Et merci de nous donné les voies a suivre afin de trouver.
je pense avoir trouvé le moyen d'utilisé correctement ton fichier mais il reste une chose sur mon fichier de base j'ai déjà "MENU" ou puis je modifier le nom dans le code afin de créer deux"Envois1 et Envois2" à la place de menu est ce possible Roland_M?

Merci pour ton aide.

Roland_M · 1 Décembre 2019

re

1) tu modifies le nom de l'onglet "MENU" exemple "ACCUEIL"
2) tu fais alt+F11

là tu verras à gauche Mod1_Base, tu cliques deux fois dessus pour éditer le code

dans le code affiché à droite tu dois voir cette ligne:
Public Const NomDeLaFeuilMENU$ = "MENU" 'impératif

il suffit de mettre le nom de l'onglet que tu auras mis !
si tu as renommé MENU par exemple ACCUEIL, alors tu corriges comme ceci:
Public Const NomDeLaFeuilMENU$ = "ACCUEIL" 'impératif

bellenm · 1 Décembre 2019

Super merci Roland_M je teste cette solution et reviens pour donner mon retour et clôturer si c'est ok

Bon dimanche à toi.

bellenm · 1 Décembre 2019

re bonjour Roland_M, Daniel et les autres,

La version de Roland très compliqué à incorporer dans un fichier j'ai essayer mais beaucoup de chose ne vont pas!

Je vais garder dans un premier temps la version simplifié puisqu'il me faut simplement l'accès au transfert de fichier.

Mon but était de simplifié la manipulation au plus simple.

Je garde mon fichier de base pour nos feuille de match puis j'ouvre celui de Roland pour l'envois de celles-ci. Mais il faudrait que l'objet et les destinataires qui seront sur la feuille "F1" et ou "F2" dans les mêmes cellules soit copier dans le fichier de Roland automatiquement.
Pour une ca vas mais les deux, y aurait il un moyen pour que sur ton fichier Roland je puisse choisir la feuille à utiliser pour les destinataires et l'objet?
Un bouton ou macro qui me permettrait de choisir, 1 , 2 ou 3 par exemple et en fonction il mettrait dans les destinataires si un choisis les destinataires de la feuille "F1" cellules "E120" ?

Merci pour ta solution a ma demande.

Marc

bellenm · 1 Décembre 2019

Un grand merci pour le fichier de Roland_M qui me sera très utile a utilisé.
Voici la manière dont j'ai procédé, vu qu'il m'étais difficile à intégrer le classeur de base:

J'ai rentré les données utile,
insérer dans les cellules destinataire la formule "SI"
J'ai choisi la cellule "C1" pour entré la feuille choisie laissant cette cellule non protégée
J'ai créer une feuille nommée "TEMP" afin d'y amener les données recherchées.
Ensuite dans la cellule "C2" la formule: =si(c1=1;TEMP!c2; si(C1=2;TEMP!c3;si(C1=3;TEMP!c5)))
Et de même pour la cellule "objet"
Protéger la feuille et le tour est joué.

Solution simple efficace et surtout pas lourd puisque tourne même le classeur d'origine fermé, super merci Roland et Daniel de m'avoir donné la possibilité d'entrevoir ce qui était pour moi impossible il y a peux

bellenm · 3 Décembre 2019

Pour que le tout fonctionne il faut impérativement que le module "CDOConfiguration Class" soit coché dans le module Macro complémentaire et moi j'ai en plus afin d'être sûr activé "CDOMessage Class", dans la section Développeur.

Ensuite ouvrir Gmail (si vous utilisez Gmail comme distributeur de courriel),
Allez dans paramètre,
dans paramètre choisir "Compte et importation",
Choisir "Autres paramètre de votre compte",
Dans préférence de compte : choisir "Accessibilité",
Descendre en bas de la page jusqu'au paragraphe "Paramètre "Autoriser les applications moins sécurisées" " et déplacer le curseur à droite pour activer cette fonction.
Dans EXCEL:
Menu Outils d'Excel, allez dans Macro - > Sécurité -> Onglets Sources fiables -> cocher "Faire confiance au projet Visual Basic"
Redémarrer le Pc

Voilà vous pourrez envoyer des mail avec Excel et ce fichier

Roland_M · 3 Décembre 2019

Bonjour,

j'ai trouvé la solution pour envoi mail avec image dans le corps du message !

je viens de modifier ton classeur en conséquence, voir si ça te va !? j'ai essayé avec mon adresse c'est OK !
concernant les envois mail avec Gmail j'avais mis une note à ce sujet dans mon classeur !

PS: cette fonction n'est incorporée que pour toi et uniquement avec l'envoi fichier(s) en pièce jointe !

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

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums