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
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:
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
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 SubVoici 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 SubMerci à vous qui prendrez le temps de m'aider dans ma quête.
Bien à Vous
Dernière édition:
