Fonction Envoyer vers\destinataire [Résolu]

[PapouDomi]

Bonjour.
Par code VBA, j'aimerai envoyer par mail des données extraites de ma base de données et qui pourront être soit le corps du message, soit un fichier joint créé à partir des données.
Pour cela, on trouve de très bons exemples sur le site, mais tous envoient directement le mail.
J'aimerai plutôt ouvrir Outlook et remplir les champs par code (dans le style de la commande existante dans l'explorateur windows "click droit sur un fichier, envoyer vers , destinataire" qui ouvre Outlok Express en ayant rempli les champs sujet, corps du message et fichier joint) afin de pouvoir modifier, selon les besoins et les circonstances, ces champs avant l'envoi.

Cordialement, Dominique.

[LedZeppII]

Bonjour,

Voici un truc que j'avais trouvé en ajoutant une référence Visual Basic
à Microsoft Shell Controls And Automation et qui fonctionne sous XP.

Code :

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
Sub SendToMailRecepient(strFileFullName As String)
Dim strPath As String, strFileName As String, p As Long
Dim oShell As Shell32.Shell
Dim oFld As Shell32.Folder, oFldItemAttch As Shell32.FolderItem
Dim oFldItem As Shell32.FolderItem
Dim oFldSendTo As Shell32.Folder, oItmMailTo As Shell32.FolderItem
 
On Error GoTo ErrH
 
' Eclate le chemin complet en chemin + fichier
p = InStrRev(strFileFullName, "\")
If p > 0 Then
   strPath = Left(strFileFullName, p - 1)
   strFileName = Mid(strFileFullName, p + 1)
Else
   Exit Sub
End If
 
Set oShell = New Shell32.Shell
 
' Référence le dossier contenant le fichier
Set oFld = oShell.NameSpace(strPath)
If oFld Is Nothing Then Err.Raise 513, , _
   "Chemin '" & strPath & "' non trouvé"
 
' Référence le fichier
Set oFldItemAttch = oFld.ParseName(strFileName)
If oFldItemAttch Is Nothing Then Err.Raise 513, , _
   "Fichier '" & strFileName & "' non trouvé"
 
' Cherche dossier système "SendTo"
Set oFldSendTo = oShell.NameSpace(ssfSENDTO) ' ssfSENDTO = 9
If oFldSendTo Is Nothing Then Err.Raise 513, , _
   "Dossier 'SendTo' non trouvé"
 
' Cherche fichier système "Destinataire"
For Each oFldItem In oFldSendTo.Items
    If oFldItem.Name Like "Destinataire" Then
       Set oItmMailTo = oFldItem
       Exit For
    End If
Next
If oItmMailTo Is Nothing Then Err.Raise 513, , _
   "Fichier 'Destinataire' non trouvé dans 'SendTo'" & vbCrLf & _
   oFldSendTo.Self.Path
 
' Utiliser verbe "Copier" sur le ficher à attacher
oFldItemAttch.InvokeVerb "copy"
' Utiliser verbe "Coller" sur fichier système "Destinataire"
oItmMailTo.InvokeVerb "paste"
 
ExitPoint:
Set oFldItem = Nothing
Set oItmMailTo = Nothing
Set oFldSendTo = Nothing
Set oFldItemAttch = Nothing
Set oFld = Nothing
Set oShell = Nothing
Exit Sub
 
ErrH:
If Err.Number = 513 Then
   MsgBox Err.Description
Else
   MsgBox "Erreur No. " & Err.Number & " : " & Err.Description
End If
Resume ExitPoint
End Sub

Exemple d'utilisation :

Code :

SendToMailRecepient "C:\Mes Documents\Excel\FichierAattacher.xls"

Même Chose sans référence VB (liaison tardive => CreateObject)

Code :

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
' Version liaison tardive
Sub SendToMailRecepient(strFileFullName As String)
Dim strPath As Variant, strFileName As Variant, p As Long
Dim oShell As Object
Dim oFld As Object, oFldItemAttch As Object
Dim oFldItem As Object
Dim oFldSendTo As Object, oItmMailTo As Object
 
On Error GoTo ErrH
 
' Eclate le chemin complet en chemin + fichier
p = InStrRev(strFileFullName, "\")
If p > 0 Then
   strPath = Left(strFileFullName, p - 1) & vbNullChar
   strFileName = Mid(strFileFullName, p + 1)
Else
   Exit Sub
End If
 
Set oShell = CreateObject("Shell.Application")
 
' Référence le dossier contenant le fichier
Set oFld = oShell.NameSpace(strPath)
If oFld Is Nothing Then Err.Raise 513, , _
   "Chemin '" & strPath & "' non trouvé"
 
' Référence le fichier
Set oFldItemAttch = oFld.ParseName(strFileName)
If oFldItemAttch Is Nothing Then Err.Raise 513, , _
   "Fichier '" & strFileName & "' non trouvé"
 
' Cherche dossier système "SendTo"
Set oFldSendTo = oShell.NameSpace(9) ' ssfSENDTO = 9
If oFldSendTo Is Nothing Then Err.Raise 513, , _
   "Dossier 'SendTo' non trouvé"
 
' Cherche fichier système "Destinataire"
For Each oFldItem In oFldSendTo.Items
    If oFldItem.Name Like "Destinataire" Then
       Set oItmMailTo = oFldItem
       Exit For
    End If
Next
If oItmMailTo Is Nothing Then Err.Raise 513, , _
   "Fichier 'Destinataire' non trouvé dans 'SendTo'" & vbCrLf & _
   oFldSendTo.Self.Path
 
' Utiliser verbe "Copier" sur le ficher à attacher
oFldItemAttch.InvokeVerb "copy"
' Utiliser verbe "Coller" sur fichier système "Destinataire"
oItmMailTo.InvokeVerb "paste"
 
ExitPoint:
Set oFldItem = Nothing
Set oItmMailTo = Nothing
Set oFldSendTo = Nothing
Set oFldItemAttch = Nothing
Set oFld = Nothing
Set oShell = Nothing
Exit Sub
 
ErrH:
If Err.Number = 513 Then
   MsgBox Err.Description
Else
   MsgBox "Erreur No. " & Err.Number & " : " & Err.Description
End If
Resume ExitPoint
End Sub

A+

[PapouDomi]

Merci beaucoup.
Ce code fonctionne parfaitement mais j'aimerai pouvoir personnaliser le titre et le corps du message.
Cordialement, Dominique

[PapouDomi]

En fait, la solution est évidente et disponible dans la FAQ Access mais ...
J'ai utilisé le code proposé en http://access.developpez.com/faq/?page=Outlook#outlook mais en remplaçant l'instruction d'envoi

Code :

oEmail.Send

par l'instruction d'affichage

Code :

oEmail.Display

Je peut ainsi paramétrer totalement mon mail, le vérifier avant envoi ou même l'annuler.

Encore merci. Cordialement, Dominique

[LedZeppII]

Bonsoir,

Ok, je n'avais pas compris que tu avais Outlook.
Je pensais que tu voulais utiliser Outlook Express.

A+