Discussion :

[victor37]

Bonjour,

Je suis nouveau sur le forum. Tout d'abord un grand merci à vous pour le service que vous rendez, ce site et votre contribution m'ont souvent permis de me débloquer dans mes projets.

Je travaille actuellement sur un outil de mailing qui génère des emails en grande quantité.
Je souhaiterais savoir comment indiquer dans ma macro par une instruction de ne pas enregistrer les mails envoyés (pour ne pas obstruer la boite mail).
Si en plus vous savez comment venir lire la checkbox dans Outlook qui dit si le mail va être enregistré ou non (Outils->Options->Préférences->Options de la messagerie->Enregistrer une copie des éléments envoyés) ce serait super !

Merci à vous,

[Kimy_Ire]

Je ne suis pas sûr...

Tente ceci lorsque tu fermes chaque mail envoyé:

Code :

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

1
2
3
Dim myItem As Outlook.MailItem
'...
myItem.Close olDiscard

[victor37]

Merci pour ton aide Kimy_Ire mais cela ne fonctionne pas... Il envoie quand même le mail et l'enregistre. D'autres idées ?

[Kimy_Ire]

D'après ce que j'ai trouvé sur le web, tu ne peux pas clairement supprimer les mails envoyés dans ta boite d'envoie. Mes investigations sont à poursuivre.

CEPENDANT...

Il existe un workaround qui consiste à sauvegarder les mails envoyés dans un fichier et de le supprimer.

Voici le code que j'ai trouvé à ce sujet :

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
Sub Mail_ActiveSheet() 
     'Working in 2000-2010
    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 
    With Application 
        .ScreenUpdating = False 
        .EnableEvents = False 
    End With 
    Set Sourcewb = ActiveWorkbook 
     'Copy the sheet to a new workbook
    ActiveSheet.Copy 
    Set Destwb = ActiveWorkbook 
     'Determine the Excel version and file extension/format
    With Destwb 
        If Val(Application.Version) < 12 Then 
             'You use Excel 2000-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 
     '    'Change all cells in the worksheet to values if you want
     '    With Destwb.Sheets(1).UsedRange
     '        .Cells.Copy
     '        .Cells.PasteSpecial xlPasteValues
     '        .Cells(1).Select
     '    End With
     '    Application.CutCopyMode = False
     '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 
        With OutMail 
            .To = "<a href="mailto:test@yahoo.com">test@yahoo.com</a>" 
            .CC = "" 
            .BCC = "" 
            .Subject = Sheets("MainMenu").Range("G8").Value & " Operations Scorecard opened " & Format(Date, "mm/dd/yy") & " by " & Sheets("MainMenu").Range("A1").Value 
            .Body = "" 
            .Attachments.Add Destwb.FullName 
            .DeleteAfterSubmit = True 'This would let Outlook send the note without storing it in your sent bin
             'You can add other files also like this
             '.Attachments.Add ("C:\test.txt")
            .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 
    Set OutMail = Nothing 
    Set OutApp = Nothing 
    With Application 
        .ScreenUpdating = True 
        .EnableEvents = True 
    End With 
End Sub

Tout n'est pas à prendre, surtout pour toi, mais cela pourra peut-être t'aider à résoudre ton problème.

Tiens moi au courant !

[victor37]

With OutMail
.DeleteAfterSubmit = True 'This would let Outlook send the note without storing it in your sent bin

Parfait !!!
J'ai trouvé ce que je cherchais dans le code que tu m'as passé Kimy_Ire, c'est ce qui apparait au-dessus. Ça me permet d'envoyer le mail sans l'enregistrer.
Merci beaucoup pour le temps que tu as passé.

A bientôt

Victor

[Oliv-]

Bonjour,
Avec Outlook il faut effectivement utiliser
.DeleteAfterSubmit = True

mais le mieux c'est d'utiliser CDO il faut par contre un serveur smtp accessible.

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
 
'---------------------------------------------------------------------------------------
' Procedure : SendMailCDO
' Author    : Oliv'
' Date      : 24/04/2008
' Purpose   :
'---------------------------------------------------------------------------------------
'
Function SendMailCDO(Sender As String, Receiver As String, _
                     subject As String, BodyText As String, _
                     Optional BodyHTML As String, _
                     Optional Cc As String, _
                     Optional Bcc As String, _
                     Optional pvarAttachFile As Variant)
' Microsoft CDO for Windows 2000 Library
    Dim Cdo_Message As New CDO.Message
 
    Set Cdo_Message.Configuration = GetSMTPServerConfig()
 
    With Cdo_Message
        .To = Receiver
        .From = Sender
        .subject = subject
        .Cc = Cc
        .Bcc = Bcc
        '.DSNOptions = 2 ' Delivery Status Notification
 
        'pour indiquer le Corps du Mail en brut.
        .TextBody = BodyText
 
        'Décommenter pour indiquer le Corps du Mail en HTML.
        '.HTMLBody = BodyHTML
 
        'Pour envoyer une page WEB en tant que corps du Mail.
        '.CreateMHTMLBody _
         "http://groups.google.com/group/microsoft.public.fr.outlook", _
         CDO.CdoMHTMLFlags.cdoSuppressNone , "", ""
 
        'ou se trouvant sur son pc
        '.CreateMHTMLBody "file:\\C:\INFORMAT\exemples\événements.htm"
 
        ' Ajout de la pièce jointe, 1 ou plusieurs fichiers
        If Not IsMissing(pvarAttachFile) Then
            If IsArray(pvarAttachFile) Then
                ' parcourrir le tableau
                For i = LBound(pvarAttachFile) To UBound(pvarAttachFile)
                    objEmail.AddAttachment pvarAttachFile(i)
                Next i
            Else
                objEmail.AddAttachment pFileAttach
            End If
        End If
 
'        If Attach1 <> "" Then
'            If Len(Dir(Attach1)) > 0 Then
'                .AddAttachment (Attach1)
'            Else: MsgBox Attach1 & vbCr & "Ce fichier sera ignoré", _
'                       , "Fichier à Attacher introuvable !"
'            End If
'        End If
 
        'Cette commande envoi le Mail
        On Error Resume Next
        DoEvents
        .Send
        If Err <> 0 Then
Debug.Print Err.Number & Err.Description & Err.LastDllError
 
            Err.Clear
        End If
    End With
    Set Cdo_Message = Nothing
End Function
 
 
 
Function GetSMTPServerConfig() As Object
' Microsoft CDO for Windows 2000 Library
 
    Dim Cdo_Config As New CDO.Configuration
    Dim Cdo_Fields As Object
    Set Cdo_Fields = Cdo_Config.Fields
 
    With Cdo_Fields
        .Item(cdoSendUsingMethod) = cdoSendUsingPort
        .Item(cdoSMTPServer) = "smtp.free.fr"
        .Item(cdoSMTPServerPort) = 25
 
        .Item(cdoSMTPConnectionTimeout) = 10    ' quick timeout
        '.Item(cdoSMTPAuthenticate) = cdoBasic
 
        ' IMPORTANT: Storing user names and passwords inside source code
        ' can lead to security vulnerabilities in your software. Do not
        ' store user names and passwords in your production code.
        '.Item(cdoSendUserName) = "username"
        '.Item(cdoSendPassword) = "password"
        '.Item (cdoSMTPUseSSL) = False 'Use SSL for the connection (True or False)
        '.Item(cdoURLProxyServer) = "server:80"
        '.Item(cdoURLProxyBypass) = "<local>"
        '.Item(cdoURLGetLatestVersion) = True
 
        .Update
    End With
 
    Set GetSMTPServerConfig = Cdo_Config
    Set Cdo_Config = Nothing
    Set Cdo_Fields = Nothing
 
End Function