Copier coller des cellules visibles excel dans email [Résolu/Fermé]

Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
-
Bonjour à tous.

Je suis débutant dans les macros et je galère à deux niveaux même en ayant essayé des solutions dans d'autres forums.

1. Je veux copier coller coller des cellules visibles d'une feuille excel et les coller dans le cors de mon email en format "picture (enhanced metafile).

2. J'aimerais inlcure dans le corps du mail le total de ma sélection (référence cellule avec formule subtotal). Je ne vous remercierai jamais assez pour votre aide.

Voici que j'ai eu a mettre dans mon code ;

 ' Copier donner à coller dans le corps du texte

ActiveSheet.Range("$A$1:$X$361").AutoFilter Field:=23, Criteria1:= _
"Anne "
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

Range("Y44").Select
Range("Y1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,C[-22]:C[-18])"

Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Selection.NumberFormat = "_-* #,##0.0 $_-;-* #,##0.0 $_-;_-* ""-""?? $_-;_-@_-"
Selection.NumberFormat = "_-* #,##0 $_-;-* #,##0 $_-;_-* ""-""?? $_-;_-@_-"
Selection.Font.Bold = True

With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With


'Envoidu_Mail_Outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'corps du message
strbody = Contenu
With OutMail
.To = "=anne.b@fr.com" 'destinataire(s)
.CC = "ab@fr.com" ' copie
.Subject = "Validation de ton équipe" ' Sujet
.Body = " Bonjour XXX, tu trouveras ci-dessous le récapitulatiif ."

'ouvre Outlook
.display

End With
Set OutMail = Nothing
Set OutApp = Nothing

End Sub
Afficher la suite 

6 réponses

Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
1190
0
Merci
Bonjour,

Avez-vous regardez ici,

http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9
0
Merci
Bonjour f894009,

Merci pour ta réponse.
En fait, c'est ce que j'ai fait en gros dans ma macro. Ce que je n'arrive pas à comprendre c'est pourquoi cela ne colle pas dans le corps du texte. Je ne sais pas si mon code est 100% juste à priori non mais je ne sais pas ou ça déconne..
f894009
Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
1190 -
Re,

C'est le "en gros" qui pose problème, je ne vois pas cette fonction
Function RangetoHTML(rng As Range)

qui justement traite ce que le "en gros" ne fait pas et qui est appelée par
.HTMLBody = RangetoHTML(rng)
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9
0
Merci
Re,

Du coup j'ai du réorganiser le code j'ai mis un lien vers une cellule pour lire automatiquement le texte avec le montant que je veux faire apparaitre dedans (au lieu de créer un code spécifique) :


With OutMail
.To = "=anne.b@fr.com" 'destinataire(s)
.CC = "ab@fr.com" ' copie
.Subject = "Validation de ton équipe" ' Sujet
.HTMLbody = Sheet2.Range("Y1")


Mais à chaque fois que j'arrive sur cette ligne ca bloque et j'arrive pas à debuger.
f894009
Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
1190 -
Re,

Et y a quoi comme erreur ????????????????????????????
solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9 -
Re,

Il n' ya pas d'erreur a ce niveau, cela me sort juste l'email avec le corps du message sans copier coller les infos du tableau excel.
f894009
Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
1190 > solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
-
Bonjour,

Tout a fait normal Thierry.

Un exemple d'envoi d'une selection cellules avec le code de Ron de Bruin que j'ai adapte a mon besoin du moment. J'ai mis les infos To,CC,Sujet, mais a vous de faire le reste pour la selection cellules

http://www.cjoint.com/c/FFjhsNCgoff
solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9 -
Bonjour,
Merci d'avoir pris le temps. Il y'a une erreur sur la ligne
 DIM Outapp As outlook.Application
dans le début du code : compile error user defined type not defined
f894009
Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
1190 > solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
-
Re,

Ok, c'est une histoire de references. Il y a deux facons de faire.

fichier sans utiliser la ref Outlook xx.x library, donc declarations de variable differente

http://www.cjoint.com/c/FFji2hV5SQf
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9
0
Merci
Ok Super cela fonctionne !

Du coup j'ai modifié le code et tout est nickel sauf une derniere partie : quand j'envoi le mail avec le fichier joint ca me met deux fois l'extension (eporting.xls.xls) du coup le recpteur du mail n peut pas l'ouvrir. Et je ne sais pas comment récupérer le nom du fichier sans l'extension :/
f894009
Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
1190 > solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
-
Re,

Mais non, faut pas remplacer la ligne, il faut la mettre apres !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9 -
Bonjour,
Dsl d'essayer de comprendre je sais que c'est chiant.

Alors j'ai rajouté la ligne en dessous, mais cela n'a aucun impact à la fin. Je oins quand même le fichier en .xls.xlxs rien à faire.
Limite je change l'extension du fichier en rien et ca fonctionne donc c'est idouiller mais bon.

Par contre là ou je galére vraiment, peut etre pourra tu m'aider encore une fois c'est dans les boucles
Là c'est mon filtre que j'applique
ActiveSheet.Range("$A$1:$X$361").AutoFilter Field:=23, Criteria1:= _
"Ab"

ensuite je fais l'envoi du mail.

Ce que je veux faire c'est inclure une boucle qui filtre les noms 1 par 1 et envoi l'émail. en gros envoi email, puis retour et filtre encore une fois et envoi email et ainsi de suite jusqu'a la fin de tous les filtres. J'en ai une 20taine.
f894009
Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
1190 > solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
-
Bonjour,

Dsl d'essayer de comprendre je sais que c'est chiant.
Y a pas d'lezard, tout le monde a commencer un jour.

La, il me faut votre code car je ne sais pas du tout comment il est fait!!!!
solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9 > f894009
Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
-
Ok. Voila

 ' Appliquer filtre

ActiveSheet.Range("$A$1:$X$361").AutoFilter Field:=23, Criteria1:= _
"Ab"

' Formule subbtotal de la cellule

Range("Y1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,C[-22]:C[-18])"


'Envoidu_Mail_Outlook()

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim Rng As Range

Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String

Set Rng = Nothing
On Error Resume Next

Set Rng = Range("A1:W361")
On Error GoTo 0
If Rng Is Nothing Then
MsgBox "The selection is not valid please make sure it is " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If

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

Set Sourcewb = ActiveWorkbook


'Copie de la plage de cellules dans un nouveau classeur
Set Destwb = Workbooks.Add

'copy avec format
Sourcewb.Sheets("sheet1").Range("A1:W361").Copy Destwb.ActiveSheet.Range("A1").Resize(Rng.Rows.Count, Rng.Columns.Count)

'Ajustement colonne
Destwb.ActiveSheet.Cells.EntireColumn.AutoFit

'sauvegarde du nouveau fichier pour joindre dans le mail
TempFilePath = Environ$("temp") & "\" 'repertoire du fichier
TempFileName = "Validation déplacements AMEX " & Format(Now, "dd-mmm-yy h-mm-ss") & Sourcewb.Name 'Nom du fichier avec date
FileExtStr = ".xlsx": FileFormatNum = 51 'extension du fichier en XLS


With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum 'sauvegarde du fichier sous
.Close SaveChanges:=False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


'corps du message si besoin


With OutMail
.To = ThisWorkbook.Sheets("Sheet1").Range("Z1").Value 'destinataire(s) A MODIFIER
.CC = "ab@b.com" ' copie
.Subject = "Validation " ' Sujet

.HTMLBody = "Bonjour A," & _
vbNewLine & "Merci de valider les engagées qui s'élévent à" & " " & Range("Y1") & "€" & ". Voici le détail :" & RangetoHTML(Rng)
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Display

End With

On Error GoTo 0

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


Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006 SUITE DE LA MACRO PUIS RETOUR A ATTACEMENTS
' Modified by f894009

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
Rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close SaveChanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function
f894009
Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
1190 > solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
-
Re,

Ok, je regarde la chose
Messages postés
14858
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 novembre 2019
1190
0
Merci
Re,

fichier avec code a recopier dans votre classeur

http://www.cjoint.com/c/FFkolOSMK4f
solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9 -
Re,
Je vais voir le code et reviens vers toi, merci beaucoup pour ton aide !!!
solidarinfo
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9 -
Merci Beaucoup, tu assures f894009!
Messages postés
146
Date d'inscription
jeudi 26 mars 2009
Statut
Membre
Dernière intervention
26 octobre 2018
9
0
Merci
Hello f894009,

J'ai un petit soucis sur la macro une nouvelle fois, je peux compter sur ton aide ?

j'ai assemblé ton code et au moment de lancer (aprés avoir raccordé l'ensemble du code) il me lance une erreur en selectionnant END SUB: compile error for without next

pour info j'ai collé le code que tu m'as envoyé à la suite d'un code dont voici l'intégralité


Public Sub Test_AMX()

Dim wbSource, wbFichierUsager As Workbook
Dim strFileName As String
Dim intChoice As Integer 'Déclarer les variables de base


Set wbFichierUsager = ThisWorkbook
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False 'on indique que nous ne voulons qu’un seul fichier
intChoice = Application.FileDialog(msoFileDialogOpen).Show 'On affiche l’écran de dialogue de MS Office
If intChoice <> 0 Then 'On s’assure que la personne a fait un choix
strFileName = Application.FileDialog(msoFileDialogOpen).SelectedItems(1) 'On récupère le nom complet du fichier
Workbooks.Open strFileName


Else 'Sinon, on arrête tout en notifiant l’usager

MsgBox "La procédure est annulée car aucun fichier n’a été entré. Merci de recommencer et de choisir le fichier AMEX" 'S’il n’y a pas de fichier, on quitte sans rien faire
Exit Sub

End If

' Ouverture fichier Associés
Workbooks.Open Filename:="C:\Users\nelly\Desktop\Listing .xlsx"

Set wbSource = ActiveWorkbook 'definir comme fichier source à fermer apres le copier coller
' Coper les données dans le fichier AMEX

Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows( _
"American .xls" _
).Activate
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.AutoFilter
Range("A1").Select

wbSource.Close SaveChanges:=False 'Application comme fichier source à fermer apres le copier coller

' CopierColler_Infos Macro

Sheets("Rapport Détaillé").Select
Range("H8:M8").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Statistique Factures").Select
Range("I10").Select
ActiveSheet.Paste

Range("O10").Select

Sheets("Rapport Détaillé").Select

Range("Q8:Y8").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Statistique Factures").Select
ActiveSheet.Paste
Range("O10").Select
ActiveSheet.Paste


Range("I11").Select

' Reperage Macro
'

'
Sheets("Rapport Détaillé").Select
Range("G6").Select
Application.CutCopyMode = False

ActiveCell.FormulaR1C1 = "1"
Range("H6").Select
ActiveCell.FormulaR1C1 = "2"
Range("I6").Select
ActiveCell.FormulaR1C1 = "3"
Range("G6:I6").Select
Selection.AutoFill Destination:=Range("G6:AM6"), Type:=xlFillDefault
Range("G6:AM6").Select

Range("AM6").Select

Range("H6:M6").Select
Selection.Copy

Sheets("Statistique Factures").Select
Range("I9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("O9").Select
Sheets("Rapport Détaillé").Select

Range("Q6").Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Statistique Factures").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("I11").Select

' Fill_Infos Macro

Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC2,'Rapport Détaillé'!R8C7:R853C39,'Statistique Factures'!R9C,0)"
Range("I11").Select
Selection.AutoFill Destination:=Range("I11:W11"), Type:=xlFillDefault
Range("I11:W11").Select


'Format date courte invoice date

Range("I11:J11").Select
Selection.NumberFormat = "m/d/yyyy"


'Format date courte travel date

Range("R11:S11").Select
Selection.NumberFormat = "m/d/yyyy"

Range("I11").Select

' Etalage_Formule Macro
'

'
Range("I11").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFill Destination:=Range("I11:W370")


' Matchingg Macro

' VlookUp Manager
Range("X11").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC3,Sheet2!C9:C11,2,0)"

' VlookUp Email
Range("Y11").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC3,Sheet2!C9:C11,3,0)"

'Extension formule
Range("X11:Y11").Select
Selection.AutoFill Destination:=Range("X11:Y370")
Range("X11:Y370").Select

Range("X10").Select

' Naming Macro

' Renomme cellule manager
Range("X10").Select
ActiveCell.FormulaR1C1 = "Manager"

' Renomme cellule email
Range("Y10").Select
ActiveCell.FormulaR1C1 = "Email"

' Renomme feuille
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "BDD ASSOCIES"

Sheets("Statistique Factures").Select


' Filtering Macro

Range("B10").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Application.CutCopyMode = False

Selection.Copy
Sheets("Sheet1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Selection.AutoFilter
Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
Columns("A:X").EntireColumn.AutoFit

Range("C:G").EntireColumn.Hidden = True

' Fine_tunning Macro
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 8367104
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16711681
.TintAndShade = 0
End With
Selection.Font.Bold = True
Range("A1").Select
Selection.End(xlToRight).Select
Range("X2").Select
Range(Selection, Selection.End(xlDown)).Select

Columns("Q:R").Select
Selection.NumberFormat = "m/d/yyyy"

Columns("H:I").Select
Selection.NumberFormat = "m/d/yyyy"

Range("W1").Select
'-----------------------------------------------------------------------------------------
Dim Liste_Flitre_W, N, Nb

Application.ScreenUpdating = False

'Creation table flitre colonne W
Call Liste_Infos_sans_doublon(Liste_Flitre_W)

Nb = UBound(Liste_Flitre_W)
'si entete colonne commence a 1 sinon a 0
For N = 1 To Nb
' Appliquer filtre
Worksheets("Sheet1").ShowAllData
ActiveSheet.Range("$A$1:$X$361").AutoFilter Field:=23, Criteria1:=Liste_Flitre_W(N)
'----------------------------------------------------------------------------------------------

' Formule subbtotal de la cellule

Range("Y1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,C[-22]:C[-18])"

' Mise en format nombre

Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Selection.NumberFormat = "_-* #,##0.0 $_-;-* #,##0.0 $_-;_-* ""-""?? $_-;_-@_-"
Selection.NumberFormat = "_-* #,##0 $_-;-* #,##0 $_-;_-* ""-""?? $_-;_-@_-"
Selection.Font.Bold = True

' Mise en format couleur
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With


'Envoidu_Mail_Outlook()

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim Rng As Range

Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String

Set Rng = Nothing
On Error Resume Next

Set Rng = Range("A1:W361")
On Error GoTo 0
If Rng Is Nothing Then
MsgBox "The selection is not valid please make sure it is " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If

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

Set Sourcewb = ActiveWorkbook


'Copie de la plage de cellules dans un nouveau classeur
Set Destwb = Workbooks.Add

'copy avec format
Sourcewb.Sheets("sheet1").Range("A1:W361").Copy Destwb.ActiveSheet.Range("A1").Resize(Rng.Rows.Count, Rng.Columns.Count)

'Ajustement colonne
Destwb.ActiveSheet.Cells.EntireColumn.AutoFit

'sauvegarde du nouveau fichier pour joindre dans le mail
TempFilePath = Environ$("temp") & "\" 'repertoire du fichier
TempFileName = "Validation déplacements AMEX " & Format(Now, "dd-mmm-yy h-mm-ss") & Sourcewb.Name 'Nom du fichier avec date
FileExtStr = ".xlsx": FileFormatNum = 51 'extension du fichier en XLS


With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum 'sauvegarde du fichier sous
.Close SaveChanges:=False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


'corps du message si besoin


With OutMail
.To = ThisWorkbook.Sheets("Sheet1").Range("Z1").Value 'destinataire(s) A MODIFIER
.CC = "" ' copie
.Subject = "Validation déplacement de ton équipe" ' Sujet

.HTMLBody = "Bonjour ," & _
vbNewLine & "Tu trouveras ci-dessous les qui s'élévent à" & " " & Range("Y1") & "€" & ". Voici le détail :" & RangetoHTML(Rng)
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Display 'OU send pour envoyer

End With

On Error GoTo 0

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


Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006 SUITE DE LA MACRO PUIS RETOUR A ATTACEMENTS
' Modified by f894009

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
Rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close SaveChanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function

'
Sub Liste_Infos_sans_doublon(TMP)
Dim Dico_Data As Object, Plage, x

With Worksheets("sheet1")
Set Dico_Data = CreateObject("Scripting.Dictionary")
derlig = .Range("W" & Rows.Count).End(xlUp).Row 'derniere cellule non vide colonne A
Plage = .Range("W1:W" & derlig) 'mise en memoire
'boucle sur plage
For x = 1 To UBound(Plage, 1)
Dico_Data(Plage(x, 1)) = ""
Next x
End With
'transfert infos en tableau
TMP = Dico_Data.Keys 'Table sans doublon
End Sub