Envoi de mail avec fichier attaché

**burnsybreed** · 19/11/2015, 10h09

Bonjour à tous,

Je vient vers vous à nouveau (précédent problème résolu) car je me trouve devant un autre problème, je doit envoyer un mail avec un fichier .xlsx en appuyant sur un bouton appelé "envoyer" sur ma Feuille "Pannes du Jour", jusque là tout vas bien, là ou les choses se corsent c'est que dans le fichier il ne me faut qu'une plage de cellule (A1:E20) et uniquement si elles contiennent des données tout en sachant que sur ma feuille les deux boutons présents ne doivent pas figurer sur mon fichier .xlsx qui est envoyé et pour le moment ils s'affichent toujours malgré après avoir changer le format de contrôle en "Ne pas déplacer ou dimensionner avec les cellules".

Voici le code 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
 
Private Sub OptionButton3_Click() 'Envoi mail
'
' Mise en forme pour le mail
'
'
Unload Me
 
    With Range("A1:E31")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Range("E2:E4")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
'-- Envoi du mail
 
'Cells.Select
    'Range("A1").Activate
 '   Selection.Copy
'    Workbooks.Add
'    ActiveSheet.Paste
'    Cells.Select
'    Application.CutCopyMode = False
'    Selection.Copy
'    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'        :=False, Transpose:=False
    Columns("A:E").Select
    Application.CutCopyMode = False
    'Selection.Delete Shift:=xlToLeft
    Range("A1").Select
    ActiveWindow.DisplayZeros = False
 
    With ActiveSheet.PageSetup
        .PrintTitleRows = "A:E"
        .PrintTitleColumns = "A:E"
    End With
 
 
 
 
 
    Sheets("Pannes du Jour").Copy
    Application.DisplayAlerts = False
    ' Fich1 = "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & Range("M4").Value & ".xlsx"
    ActiveWorkbook.SaveAs "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & " - " & Range("M4").Value & ".xlsx"
    ActiveWorkbook.Close "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & Range("M4").Value & ".xlsx"
 
 
 
'---------------------------------------------------
Fichier = "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & " - " & Range("M4").Value & ".xlsx"
Set cdomsg = CreateObject("CDO.message")
With cdomsg.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "adresse mail"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "mot de passe"
.Update
End With
'Construction du contenu de l'email Technique
With cdomsg
.To = "adresse mail, adresse mail"
.From = "adresse mail"
.Subject = Range("M4").Value
.TextBody = ""
.AddAttachment "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & " - " & Range("M4").Value & ".xlsx"
.Send
End With
Rep = MsgBox("Email Expédié", vbOKOnly)
    Set cdomsg = Nothing
 
' Effacement des données après envoi du mail.
 
Range("A2:A20,C2:E20").ClearContents
 
 
End Sub

Merci d'avance pour votre aide et je vous joint le fichier

Test Programme Pannes.3.1.xlsm

**parmi** · 19/11/2015, 16h24

Bonjour,

Après avoir copié ton onglet, supprime les boutons avant la sauvegarde.

Code :

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

1
2
3
4
5
6
Dim Shp as Shape
........
Sheets("Pannes du Jour").Copy
For Each Shp In ActiveWorkbook.ActiveSheet.Shapes
   Shp.Delete
Next

Aussi, ces 3 lignes pourraient être modifiées

ActiveWorkbook.SaveAs "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & " - " & Range("M4").Value & ".xlsx"
ActiveWorkbook.Close "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & Range("M4").Value & ".xlsx"
'---------------------------------------------------
Fichier = "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & " - " & Range("M4").Value & ".xlsx"

Code :

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

1
2
3
Fichier = "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & " - " & Range("M4").Value & ".xlsx"
ActiveWorkbook.SaveAs Fichier
ActiveWorkbook.Close False

**burnsybreed** · 20/11/2015, 08h35

Envoyé par parmi

Bonjour,

Après avoir copié ton onglet, supprime les boutons avant la sauvegarde.

Code :

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

1
2
3
4
5
6
Dim Shp as Shape
........
Sheets("Pannes du Jour").Copy
For Each Shp In ActiveWorkbook.ActiveSheet.Shapes
   Shp.Delete
Next

Aussi, ces 3 lignes pourraient être modifiées

Code :

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

1
2
3
Fichier = "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & " - " & Range("M4").Value & ".xlsx"
ActiveWorkbook.SaveAs Fichier
ActiveWorkbook.Close False

Merci pour ce début de solution, mais au moment de la save il m'affiche un message pas d'erreur mais comme quoi il faut cliquer sur oui pour pouvoir enregistrer le fichier , message exact:

Les fonctionnalités suivantes ne peuvent pas être enregistrées dans des classeurs sans macro:

- Projet VB

Pour enregistrer un fichier avec ces fonctionnalités, cliquez sur Non puis sélectionnez un type de fichier prenant en charge les macros dans la liste Type de fichier.

Pour continuer à enregistrer en tant que classeur sans macro, cliquez sur Oui.

Ma question est comment faire pour que cela se valide automatiquement ou alors contourner pour éviter se message et surtout pour qu'il n'y ai que les cellules A1:E20 qui soit affichées uniquement si il y as des données inscrites.

**vinc_bilb** · 20/11/2015, 10h14

Bonjour,

Attention, danger, vous risquez de tout perdre ....

Faites comme celà vous a été suggéré (copie de l'onglet) mais sur un nouveau workbook pour lequel vous n'aurez que ça, et pas de VBA....

Voir en complément (vieil et mal écrit) exemple ci-dessous si ça peut servir ....

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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
Sub EXPORT_ACTIVWSH(Optional Email As Boolean = False)
'=============================================================================
' Copy the active sheet to a new book for publication, email if input parameter is true
 
    Subname = "EXPORT_ACTIVWSH"
 
    Dim Ext_Wbkk  As Workbook, NewWs As Worksheet, WS As Worksheet, Shap As Shape
    Dim SrcWsname As String, Ext_Wbkkname As String, chk_field As String, Msgprompt As String, Msganswer As String
    Dim ValidCopy As Boolean, DelShapHL As Boolean
    Dim RngName As Name, Copyrng As Range
    Dim SavExtrpath As String, Signature As String, Warnmsg As String, InfoLog As String
    Dim FileFmt As XlFileFormat
 
        ' Init
    ThisWorkbook.Activate
    On Error GoTo Err_EXPORT_ACTIVWSH
    Application.ScreenUpdating = False
 
    SrcWsname = ActiveSheet.Name
    SavExtrpath = Range("T_Savpath")(2, 1).Value
    Signature = Range("T_IDENTIF")(6, 2).Value
    Dispmsg = Range("T_OPTIONS")(1, 2)
    DelShapHL = Range("T_OPTIONS")(6, 2)
 
        ' Check the path for the extract
    If CHCK_EXIST_DIR(SavExtrpath) = "False" Then
 
            ' If blank, current directory with a "EXTRACT_DEFAULT" sub-directory creation
        If SavExtrpath = vbNullString Then
 
            SavExtrpath = ThisWorkbook.Path
            SavExtrpath = UPDATE_PATHSEP(SavExtrpath)
            SavExtrpath = UPDATE_PATHSEP(SavExtrpath & "EXTRACT_DEFAULT")
 
            Infomsg = CREATE_DIR(SavExtrpath)
 
        End If
 
        If CHCK_EXIST_DIR(SavExtrpath) = "False" Then
            Warnmsg = "Export folder: " & SavExtrpath & vbCrLf & "=> Folder doesnt exist"
            Msganswer = Msgbox(Warnmsg & vbCrLf & vbCrLf & "Would you like to create it?", vbExclamation + vbYesNo, _
                "WARNING: " & Subname)
 
            If Msganswer = vbYes Then
 
                Infomsg = CREATE_DIR(SavExtrpath)
                Msgbox Infomsg, vbInformation, Subname
 
            Else:
                Warnmsg = Subname & "Select a directory for the extract"
                SavExtrpath = SET_REF_PATH(2, Warnmsg)
 
            End If
 
        End If
 
        Range("T_Savpath")(2, 1).Value = SavExtrpath
 
    End If
 
        ' Set the name of the extracted workbook (radical)
    Call UPDATE_PATHSEP(SavExtrpath)
    Ext_Wbkkname = Range("T_REFER_NAM").Value & "_EXTR_" & SrcWsname
 
        ' Copy the activesheet in a new workbook
    ThisWorkbook.Worksheets(SrcWsname).Copy
 
    Set Ext_Wbkk = ActiveWorkbook
    Set NewWs = ActiveWorkbook.Worksheets(1)
    NewWs.Activate
    ActiveSheet.Unprotect
 
    ' Clean the sheets + links, buttons, protection, references
    Application.DisplayAlerts = False
 
        ' Delete the empty sheets created by default
    For Each WS In Ext_Wbkk.Worksheets
        If (WS.Name) <> SrcWsname Then Worksheets(WS.Name).Delete
    Next WS
 
        ' Delete all the Shaps except the graphs
    If DelShapHL = True Then
 
        For Each Shap In ActiveSheet.Shapes
 
            If Shap.Type <> 3 Then
 
                InfoLog = InfoLog & "Shape Name: " & Shap.Name & vbTab & "Type: " & Shap.Type & vbCrLf
                Shap.Delete
 
            End If
 
        Next Shap
 
        ' Delete links and names
        For Each RngName In ActiveWorkbook.Names
 
 
            Debug.Print "Deleteting range name " & RngName, ActiveWorkbook.Name, RngName.RefersTo
            If InStr(1, RngName.RefersTo, "#REF!") > 0 Then
                InfoLog = InfoLog & "Range Name: " & RngName & vbTab & "Address: " & Range(RngName).Address & vbCrLf
                RngName.Delete
            End If
 
        Next RngName
 
        InfoLog = InfoLog & "Hyperlinks: " & ActiveSheet.Hyperlinks.Count
        ActiveSheet.Hyperlinks.Delete
        InfoLog = "Following items have been deleted: " & vbCrLf & InfoLog
 
    End If
 
    If DelShapHL = False Then
 
        InfoLog = InfoLog & ActiveSheet.Shapes.Count & " shapes not deleted" & vbCrLf
        InfoLog = InfoLog & ActiveWorkbook.Names.Count & " named ranges not deleted" & vbCrLf
        InfoLog = InfoLog & ActiveSheet.Hyperlinks.Count & " hyperlinks not deleted"
 
    End If
 
    Msgbox InfoLog, vbInformation, Subname
 
           ' Set the inputs for copy
    Set Copyrng = ActiveWorkbook.Worksheets(SrcWsname).UsedRange
    Debug.Print Copyrng.Address
 
    Copyrng.Copy
    Copyrng.PasteSpecial Paste:=xlPasteValues
    'Range(Copyrng.Address).PasteSpecial Paste:=xlPasteFormats
    Copyrng.PasteSpecial Paste:=xlPasteValidation
    Range("A1").Select
 
        ' Set the source file as hyperlink
    Range("C4").Value = "Extract from"
    ActiveSheet.Hyperlinks.Add Anchor:=Range("D4"), _
        Address:=ThisWorkbook.FullNameURLEncoded, _
        TextToDisplay:=ThisWorkbook.Name
 
        ' Get the extension
    Ext_Wbkkname = Ext_Wbkkname & SET_DEF_FILE_EXT(Ext_Wbkk)
    FileFmt = SET_DEF_FILE_FMT(Ext_Wbkk)
 
        ' Check if the worlbook for extract is already open, propose to close it or Abort
    If IS_WBK_OPEN(Ext_Wbkkname) = True Then
        Msgprompt = "The workbook " & Ext_Wbkkname & " is already open" & _
        vbCrLf & "Would you like to close it?" & vbCrLf & vbCrLf & "Aborting if No!"
        Msganswer = Msgbox(Msgprompt, vbExclamation + vbYesNo, Subname)
        If Msganswer = vbYes Then
            Application.DisplayAlerts = False
            Workbooks(Ext_Wbkkname).Close SaveChanges:=True
        Else:
            End 'Abort
        End If
    End If
 
        ' Save it
    Debug.Print Ext_Wbkk.Name, SavExtrpath, Ext_Wbkkname, FileFmt
 
            ' Prompt if applicable
    Msgprompt = "Exporting sheet in file " & Ext_Wbkkname & vbCrLf & "Path " & SavExtrpath & _
        vbCrLf & vbCrLf & "=> CONFIRM?"
    Msganswer = Msgbox(Msgprompt, vbYesNo, Subname)
 
    If Msganswer <> vbNo Then
 
        Application.DisplayAlerts = False
 
        Ext_Wbkk.SaveAs Filename:=SavExtrpath & Ext_Wbkkname, FileFormat:=FileFmt, _
            CreateBackup:=False, AddToMru:=True, ReadOnlyRecommended:=False
        Ext_Wbkk.Saved = True
 
        Application.DisplayAlerts = True
    End If
 
        ' Email and propose to delete
    If Email = True Then
 
        Call SEND_WBK(Ext_Wbkk, Signature)
 
        Msgprompt = "Would you like to delete this workbook from disk? " & vbCrLf & _
            Ext_Wbkk.FullName
        Msganswer = Msgbox(Msgprompt, vbYesNo, Subname)
 
        If Msganswer = vbYes Then
            ThisWorkbook.Activate
            Workbooks(Ext_Wbkkname).Close SaveChanges:=False
            Kill (SavExtrpath & Ext_Wbkkname)
        End If
 
    End If
 
        ' Closure, propose to close if still open
    If IS_WBK_OPEN(Ext_Wbkkname) = True Then
        Msgprompt = "Would you like to close this extract workbook?"
        Msganswer = Msgbox(Msgprompt, vbYesNo, Subname)
        If Msganswer <> vbNo Then Workbooks(Ext_Wbkkname).Close SaveChanges:=True
    End If
 
    Application.EnableEvents = True
    Application.DisplayAlerts = True
 
    If Dispmsg = True And Infomsg <> vbNullString Then
        Msgbox Infomsg, vbInformation, Subname
    End If
 
 
Err_EXPORT_ACTIVWSH:
    If Err.Number <> 0 Then
        Msgprompt = "There is an error during the copy" & vbCrLf & Err.Description
        Msgbox Msgprompt, vbCritical, Subname
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.DisplayAlerts = True
        End
    End If
 
End Sub

**parmi** · 20/11/2015, 11h27

Essaie comme ceci

Code :

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

1
2
3
4
5
Fichier = "W:\Services\Exploitation\Voie publique\Pannes\Pannes" & " - " & Range("M4").Value & ".xlsx"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Fichier
Application.DisplayAlerts = True
ActiveWorkbook.Close False

**burnsybreed** · 25/11/2015, 16h18

Bonjour à tous,

Merci des précieux coups de pouces, merci à vinc_bilb mais je voulais éviter de devoir faire une feuille supplémentaire, mais j'ai résolu mon problème avec un simple code mais encore merci pour tout.

Code en question:

Code :

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

1
2
3
4
5
6
7
 
Dim Shp As Shape
 
Sheets("Pannes du Jour").Copy
For Each Shp In ActiveWorkbook.ActiveSheet.Shapes
   Shp.Delete
Next

Envoi de mail avec fichier attaché [XL-2013]

Excel

Discussions similaires

Partager

Partager