extraire d'un fichier une ou plusieurs pour joindre à un email

**meumeu73.1** · 09/10/2020, 16h23

Bonjour,

J'ai une macro qui me permet de créer des emails à partir d'excel en intégrant une feuille pour l'intégrer à un envoi d'email.

Le soucis, je voudrai que la feuille sélectionnée n'ait pas de formules, je voudrai juste valeurs.

Je voudrai éventuellement ajouter d'autres feuilles à la routin.

je vous joins la macro que j'ai actuellement :

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
Sub Mail_TS()
'Working in 2000-2010
 
    Dim SigString As String
    Dim Signature As String
 
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim TheActiveWindow As Window
    Dim TempWindow As Window
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
 
    'Copy the sheets to a new workbook
    'We add a temporary Window to avoid the Copy problem
    'if there is a List or Table in one of the sheets and
    'if the sheets are grouped
    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("FOCUS_Travail")).Copy
 
 
    End With
 
With Sheets("FOCUS_Travail")
 
    CA_Mail = .Range("D2").Value
    CC_Mail = .Range("E4").Value
 
End With
    'Close temporary Window
    TempWindow.Close
 
    Set Destwb = ActiveWorkbook
 
 
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2010, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With
 
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
 
 
    On Error Resume Next
 
        With OutMail
''' destinataire
            .To = CA_Mail
''' copie
            .CC = ""
            .BCC = ""
''' Object
            .Subject = "Objet"
 
''' corps du mail
            .BodyFormat = olFormatHTML
                .HTMLBody = "<HTML><body>Bonjour,<p>" _
                & "Veuillez trouver ci-joint xxxxxxx<p>" _
                & "Cordialement,<p>" 
                '& "Ce " & "<i>mot</i> est en italique.<p>" & _
                '"<b><i><u><font color=green>Ce format est vert, gras, italique et souligné !</font></u></i></b></body><HTML>"
 
            .Attachments.Add Destwb.FullName
 
            '.Send   'or use
            .Display
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

**joe.levrai** · 09/10/2020, 16h44

Bonjour,

je pense que c'est ici :

Code :

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

1
2
3
4
5
6
With Sheets("FOCUS_Travail")
 
    CA_Mail = .Range("D2").Value
    CC_Mail = .Range("E4").Value
     .UsedRange.Value = .UsedRange.Value
End With

à tester

**meumeu73.1** · 09/10/2020, 16h49

Super merci.

je fais essayé d'ajouter d'autres feuilles maintenant.

extraire d'un fichier une ou plusieurs pour joindre à un email [XL-365]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager