Discussion :

[sarah0105]

Bonjour à tous,

Vous m'avez déjà bien aidé précédemment et j'ai encore besoin de vous

J'ai réussi à insérer une plage de cellule dans le corps de mon mail mais la mise en forme conditionnelle de mes tableaux saute une fois dans le mail, je me dis donc qu'il serait plus judicieux du coup de le coller en format image mais je n'ai absolument aucune idée de comment faire... Voici la macro que j'utilise :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
Sub synthèse()
Dim sh As Worksheet
Dim shencours As Worksheet
Dim shsynthese As Worksheet
 
 
 
 
Dim AireACopier As Range
 
Dim LigneDeTitreSynthese As Long
Dim DerniereLigneSynthese As Long
Dim PremiereColonneSynthese As Long
Dim LigneDebutSynthese As Long
 
Windows("Cadencement des expés 2016.xlsm").Activate
 
 
    Application.ScreenUpdating = False
 
    Set shsynthese = SHEETS("Synthèse")
    LigneDeTitreSynthese = 10
    PremiereColonneSynthese = 1
 
    ' Effacement de la feuille synthèse
    shsynthese.Range(shsynthese.Cells(LigneDeTitreSynthese + 5, 1), shsynthese.Cells(shsynthese.Rows.Count, shsynthese.Columns.Count)).ClearContents
    DerniereLigneSynthese = shsynthese.Cells(shsynthese.Rows.Count, PremiereColonneSynthese).End(xlUp).Row
 
 
      For Each sh In Worksheets
 Set shencours = SHEETS(sh.Name)
 
 If shencours.Visible = True Then
 
         If sh.Name <> "AFFICHAGE" And sh.Name <> "Synthèse" Then
 
           Set AireACopier = shencours.Range("A1:CK85").SpecialCells(xlCellTypeVisible)
 
           With shsynthese
                LigneDebutSynthese = DerniereLigneSynthese
                AireACopier.Copy
                Cells(DerniereLigneSynthese, PremiereColonneSynthese).Select
                shsynthese.Paste
                DerniereLigneSynthese = shsynthese.Cells(shsynthese.Rows.Count, PremiereColonneSynthese).End(xlUp).Row
 
 
           End With
 
           Set AireACopier = Nothing
           Set shencours = Nothing
 
DerniereLigneSynthese = DerniereLigneSynthese + 40
       End If
 
 Else
         GoTo Feuil
       End If
Feuil:
 
    Next sh
 
SHEETS("Synthèse").Activate
 
 
b = 1
Do While Range("B" & b) = ""
 
b = b + 1
 
Loop
derniereligne = b
 
Range("A" & derniereligne, "O" & DerniereLigneSynthese).Select
 
 
 
    Set shsynthese = Nothing
    Application.ScreenUpdating = True
 
 
 
 
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
 
    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "RO S"
        .HTMLBody = "<font style='font-family: Calibri ;font-size: 12pt;'>" & "Hello" & ",<br/><br/> Voici le point stock de la semaine : " & "<br/><br/><font style='font-size: 15pt;'>" & "EN RESUME : " & "<br/><br/><font style='font-size: 12pt;'>" & " - Pays : <br/> - Ventes : <br/> - Stock : <br/> - NBS : <br/><br/><br/><font style='font-size: 15pt;'>" & "FAITS MARQUANTS :" & "<br/><br/>" & "RECEPTIONS ET COURBES DE STOCK :" & RangetoHTML(rng) & "<br/><br/><br/><font style='font-size: 15pt;'>" & "PERFORMANCES S-1 :" & "<br/><br/> ACTIONS A VENIR :" & "<br/><br/> SUIVI DES PMA :"
        .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
' Working in Office 2000-2016
    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

Merci d'avance

[QuestVba]

Bonjour,

As-tu vu ceci ?

Sinon, Google m'avait déjà donné ceci (à adapter) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Dim Img As String, Plage As Range, PathTmp As String
    PathTmp = Environ$("temp") & ""
    Img = "Image.jpg"
    Set Plage = Range("B2:X53")
 
    'Création d'un fichier image dans le répertoire temporaire
    Plage.CopyPicture
    With ActiveSheet.ChartObjects.Add(0, 0, Plage.Width, Plage.Height)
        .Activate
        .Chart.Paste
        .Chart.Export PathTmp & Img, "JPG"
    End With
 
    ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete
 
 
 
    Set OutApp = CreateObject("outlook.application")
    Set OutMail = OutApp.CreateItem(olMailItem)
 
    With OutMail
        .TO = "ventesjour"
        '.CC = ""
        '.BCC = ""
        .Subject = "Ventes jour au " & Format(JourJ, "dd/mm/yyyy")
        .Attachments.Add PathTmp & Img, olByValue, 0
        .HTMLBody = "<span LANG=FR><p class=style2>" _
            & "<font FACE=Calibri SIZE=3>Bonjour,<br><br>" _
            & "Veuillez trouver ci-dessous les ventes jour au " _
            & Format(JourJ, "dd/mm/yyyy") & "<br><br>" _
            & "Bien cordialement<br><br>" _
            & "<img src='cid:" & Img & "'</font></span>"
 
        .Display
    End With
 
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing

[sarah0105]

Hello,

Non je n'avais pas vu ce post, je vais regarder ça !!

Merci beaucoup