Export feuille dans un nouveau classeur + envoi email en pièce jointe

**captfreud** · 22/11/2019, 09h49

Bonjour à tous,

Après avoir résolu mon problème d'exportation de feuille, je reviens vers vous pour un autre grattage de tête !

Post sur l'exportation: https://www.developpez.net/forums/d2.../#post11240281

Voilà donc le moment du grattage:

J'ai besoins que ce fichier nouvellement (ou un fichier temporaire) créer soit envoyé par email au client (Son adresse Email est dans la case D22 de la feuille "Attest Entretien" ainsi qu'a une adresse mail Fixe (qui peux etre dans le code ou sur une case a part dans la feuille.

Voici mon code actuel (qui est une adaptation de ce que j'ai trouvé ci et là) mais qui n'envoie rien ... mais ne pose pas d'erreur non plus, part de la création d'un fichier temporaire pour exporter les 2 feuilles puis est supprimer a la fin une fois envoyé.

L'idéal serai que ET la sauvegarde ET l'envoi du mail se fasse en une seule macro !

A savoir qu'a ce stade, je n'ai pas résolu encore le problème du mail dans la case D22 car l'adaptation de la ligne:

Code :

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

.SendMail "mailfixe@gmail.com", _

par la ligne

Code :

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

.SendMail Recipients:=Array("Range("Attest Entretien!D22").value,"mailfixe@gmail.com"),_

fini en "Erreur de compilation" - "Attendu séparateur de liste ou )"

Code actuel(en créant un fichier temporaire - une autre macro l'exporte pour l'enregistrer):

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
Sub ATTENT_PDF_MAIL()
 
 
    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 sh As Worksheet
    Dim TheActiveWindow As Window
    Dim TempWindow As Window
    Dim I As Long
    Application.DisplayAlerts = False
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
 
    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("Attest Entretien", "Mesures Entretien")).Copy
    End With
 
 
    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-2016
            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 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")
 
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 3
            '.SendMail Recipients:=Array("Range("Attest Entretien!D22").value,"mailfixe@gmail.com"),_
            .SendMail "mailfixe@gmail.com", _
                      "Test envoi mail"
            If Err.Number = 0 Then Exit For
        Next I
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

**halaster08** · 22/11/2019, 10h24

Bonjour,

Si tu utilise Outlook comme messagerie, je te propose le code ci-dessous que j'utilise pour envoyé des mails
J'ai déjà pré-rempli d'après ce que j'ai lu de ta macro

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
Dim ObjOutlook As Object,
Set ObjOutlook = CreateObject("outlook.application")    
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
        With oBjMail
            .Display 'pour afficher la signature
            .To = ThisWorkbook.Sheets("Attest Entretien").Range("D22") 'destinataire
            .CC = "" 'copie
            .Subject =  'titre
            .Body =  'message
            .Attachments.Add TempFilePath & TempFileName & FileExtStr 'pièces jointes
 
            'au choix l'une des trois lignes suivantes
            .Display 'pour afficher le message dans outlook
            '.Save 'pour le sauver dans les brouillons
            '.send 'pour l'envoyer
 
        End With

**captfreud** · 08/12/2019, 11h01

Bonjour halaster08,

Désolé de revenir que si longtemps après mais j'ai été débordé .. :-)

J'ai regardé ta proposition de code pour l'envoi du classeur par mail mais j'ai quelques questions:

1) Ca va fonctionner aussi avec Courrier (Win10)?
2) quand je copie ton code en ajoutant mon Sub et endSub il me dit : Erreur de syntaxe avec ta première ligne en rouge ..

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
Sub recept_mail()
 
Dim ObjOutlook As Object,
Set ObjOutlook = CreateObject("outlook.application")
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
        With oBjMail
            .Display 'pour afficher la signature
            .To = ThisWorkbook.Sheets("Attest Entretien").Range("D22") 'destinataire
            .CC = "" 'copie
            .Subject = "Attesttaiton de réception Chaudière/Chauffe bain"
            .Body = "Bonjour, Veuillez trouver ci-joint l'attestation de réception d'une chaudière/Chauffe bain. Bonne Journée."
            .Attachments.Add TempFilePath & TempFileName & FileExtStr 'pièces jointes
 
            'au choix l'une des trois lignes suivantes
            .send 'pour afficher le message dans outlook
            '.Save 'pour le sauver dans les brouillons
            '.send 'pour l'envoyer
 
        End With
End Sub

3) Pour moi améliorer un peu l'affichage du contenu texte de l'email même, je peux y aller en html ? ou il y a des balises spéciales ?

Merci beaucoup pour le retour info.

Fred

**halaster08** · 09/12/2019, 07h41

Envoyé par captfreud

1) Ca va fonctionner aussi avec Courrier (Win10)?
2) quand je copie ton code en ajoutant mon Sub et endSub il me dit : Erreur de syntaxe avec ta première ligne en rouge ..
3) Pour moi améliorer un peu l'affichage du contenu texte de l'email même, je peux y aller en html ? ou il y a des balises spéciales ?

1) J'ai bien peur que non
2) Oups, j'ai laissé une virgule à la fin de la ligne qu'il faut supprimé
3) Oui remplace .body par .htmlbody ou .bodyhtml

**captfreud** · 01/01/2020, 22h32

Bonjour Halaster08,

On avance mais il ne joint pas le fichier qui a été créer et il s'affiche mais ne s'envoie pas.

Un erreur surviens a cette ligne:

Code :

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

.Attachments.Add TempFilePath & TempFileName & FileExtStr 'pièces jointes

Voici mon code actuel

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
Sub Attest_envoi()
 
 
    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 sh As Worksheet
    Dim TheActiveWindow As Window
    Dim TempWindow As Window
    Dim I As Long
    Application.DisplayAlerts = False
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
 
    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("Attest Entretien", "Mesures Entretien")).Copy
    End With
 
 
    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-2016
            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 With
 
    Dim ObjOutlook As Object
Set ObjOutlook = CreateObject("outlook.application")
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
        With oBjMail
            .Display 'pour afficher la signature
            .To = ThisWorkbook.Sheets("Attest Entretien").Range("D22") 'destinataire
            .CC = "" 'copie
            .Subject = "Test envoi"
            .Body = "Bonjour, "
            .Attachments.Add TempFilePath & TempFileName & FileExtStr 'pièces jointes
 
            'au choix l'une des trois lignes suivantes
            .send 'pour afficher le message dans outlook
            '.Save 'pour le sauver dans les brouillons
            '.send 'pour l'envoyer
 
        End With
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Merci beaucoup pour le coup de main !