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

bellenm

XLDnaute Impliqué
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
 

Pièces jointes

  • F1 Marc.xlsm
    233.7 KB · Affichages: 12
Dernière édition:

bellenm

XLDnaute Impliqué
Bonjour Danielco,

oui il est connu car générer à chaque fois pour une nouvelle feuille: le nom du fichier est écrit de par le résultats de plusieurs cellule et donc par conséquent sera à chaque fois différent.
Exempel:
Cellule "Y2" + " " + "[" + cellule "B18" + cellule"G18" + " contre "+ cellule"H18"+cellule"y18"+ "] = " + cellule"Y41" + " - "+ cellule"aa41"

Ce qui pourrait donner: R 074 [AC GRACE 1 contre AC TRUC 2] = 6-4.PDF

Merci pour ta lecture
 
Dernière édition:

danielco

XLDnaute Accro
Essaie :

VB:
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") _
                   = "smtp.free.fr" '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") = "***@***.***" 'modifier l'adresse expéditeur
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "***" 'Modifier le mot de passe SMTP
    'avis de lecture
    iConf.Fields("urn:schemas:mailheader:disposition-notification-to") = _
    "***@***.***" 'adresse expéditeur
    iConf.Fields("urn:schemas:mailheader:return-receipt-to") = _
    "***@***.***" 'adresse expéditeur
    .Update
  End With
  With Sheets("F1")
    PDF = "C:\FM\" & .[Y2] & "[" & .[B18] & .[G18] & " contre " & .[H18] & .[Y18] & "] = " & .[Y41] & _
      " - " & .[AA41] & ".PDF" 'modifier le chemin
  End With
  With iMsg
    Set .Configuration = iConf
    .To = Sheets("F1").[E120]
    .From = "***@***.***" 'adresse expéditeur
    .Subject = Sheets("F1").[E121]
    .TextBody = Sheets("F1").[E122]
    .AddAttachment PDF
    .Send
  End With
End Sub

Il faut modifier les lignes que j'ai indiquées par des commentaires. Si tu as des problèmes pour installer la macro, dis-le.

Daniel
 

bellenm

XLDnaute Impliqué
Re Daniel,

la macro se déroule bien jusqu'a .AddAttachment PDF

Erreur du à ?
et dans la ligne Whith sheets("F1")
PDF = ":\FM\" & .[y2] etc..
Faut il obligatoirement le chemin du disque c:\ car comme j'utilise le fichier sur deux pc le disque non pas la même lettre.

Merci d'avance pour ta réponse Daniel.

Marc
 
Dernière modification par un modérateur:

bellenm

XLDnaute Impliqué
re,
les adresses

VB:
 iConf.Fields("urn:schemas:mailheader:disposition-notification-to") = _
    "***@***.***" 'adresse expéditeur
    iConf.Fields("urn:schemas:mailheader:return-receipt-to") = _
    "***@***.***" 'adresse expéditeur
    .Update

Je ne doit rien mettre à la place des * ?
 

danielco

XLDnaute Accro
Re Daniel,

la macro se déroule bien jusqu'a .AddAttachment PDF
Ce lien n'existe plus
Erreur du à ?
et dans la ligne Whith sheets("F1")
PDF = ":\FM\" & .[y2] etc..
Faut il obligatoirement le chemin du disque c:\ car comme j'utilise le fichier sur deux pc le disque non pas la même lettre.

Merci d'avance pour ta réponse Daniel.

Marc
Non, il faut modifier la ligne :
VB:
    PDF = "C:\FM\" & .[Y2] & "[" & .[B18] & .[G18] & " contre " & .[H18] & .[Y18] & "] = " & .[Y41] & _
      " - " & .[AA41] & ".PDF"

Daniel
 

bellenm

XLDnaute Impliqué
re Daniel,
PDF = "C:\FM\" & .[Y2] & "[" & .[B18] & .[G18] & " contre " & .[H18] & .[Y18] & "] = " & .[Y41] & _
" - " & .[AA41] & ".PDF"
même si le fichier se trouve sur un autre disque que "C" puisque les différent pc ne mette pas la même lettre car j'utilise une clée USB.

iConf.Fields("urn:schemas:mailheader:disposition-notification-to") = _
"***@***.***" 'adresse expéditeur
iConf.Fields("urn:schemas:mailheader:return-receipt-to") = _
"***@***.***" 'adresse expéditeur
.Update
Donc si je comprend il n'y a pas moyen de mettre les adresse des destinataires "E120" dans la formule!

Bien à toi
Marc
 

bellenm

XLDnaute Impliqué
re:

N'y a t'il pas une erreur pour l'attachement , je ne sais pas les termes à définir mais si j'essaye de comprendre là est aussi le but de ses forum:
PDF= "c:\FM\" ,l'endroit ou se trouve le dossier, ok mais il se trouve sur le même disque que le fichier utiliser Chez moi c'est "F" et l'autre pc c'est "D".
Ensuite viens le nom du fichier. ok mais pourquoi est il rattacher à C:\FM\
le nom du fichier est: R 074 [ A.C. GRACE 1 contre A.C. TRUC 2 ] = 6 - 4.pdf et il se trouve dans le répertoire "\FM\" du même disque.

La commande ne devrait pas être:
le nom du fichier est
& .[Y2] & "[" & .[B18] & .[G18] & " contre " & .[H18] & .[Y18] & "] = " & .[Y41] & " - " & .[AA41] qui se trouve sur le disque courant dans le répertoire \FM\

Désolé de me pas comprendre vite mais je fais beaucoup d'effort et je te remercie pour ta patience Daniel
 
Dernière édition:

danielco

XLDnaute Accro
N'y a t'il pas une erreur pour l'attachement , je ne sais pas les termes à définir mais si j'essaye de comprendre là est aussi le but de ses forum:
PDF= "c:\FM\" ,l'endroit ou se trouve le dossier, ok mais il se trouve sur le même disque que le fichier utiliser Chez moi c'est "F" et l'autre pc c'est "D".
Si le fichier se trouve dans le même dossier que le classeur contenant, je peux m'en sortir, sinon, oui, j'afficherai une boîte de dialogue.

Daniel
 

Statistiques des forums

Discussions
311 720
Messages
2 081 896
Membres
101 833
dernier inscrit
sandra25