Discussion :

[Stéphane Olivier BERNARD]

J'ai trouvé lors de mes recherches une amorce de solution à la problématique d'envoyer des mails quel que soit le logiciel de messagerie utilisé OUTLOOK ou OUTLOOK Express.
Le code suivant qui marche parfaitement et crée une fonction SENDMAIL supporte "OUTLOOK" et "OUTLLOOK EXPRESS" et peut même permettre l'envoi de pièces jointes.
Cependant, il est très complexe, il fouille la base de registre et je me demande quelles modifications réaliser pour le cas ou le logiciel de messagerie detecté serait "THUNDERBIRD" par exemple.
Je souhaite recueillir des avis et des propositions pour une plus grande portabilité.

Le principe est de créer deux modules qui contienent les lignes suivantes ainsi qu'un formulaire qui contiendra les champs TO, CC, CCI et autres necessaires ainsi que le bouton faisant appel à la fonction SENDMAIL.

Module BasReadRegistry:

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
Option Compare Database
Option Explicit
 
'********Code Start**************
'This code was originally written by Terry Kreft
' and Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of Dev Ashish & Terry Kreft
'
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
 
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const SYNCHRONIZE = &H100000
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
                        KEY_QUERY_VALUE Or _
                        KEY_ENUMERATE_SUB_KEYS Or _
                        KEY_NOTIFY) And _
                        (Not SYNCHRONIZE))
Private Const MAXLEN = 256
Private Const ERROR_SUCCESS = &H0&
 
Const REG_NONE = 0
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_DWORD_LITTLE_ENDIAN = 4
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_LINK = 6
Const REG_MULTI_SZ = 7
Const REG_RESOURCE_LIST = 8
 
Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Private Declare Function apiRegOpenKeyEx Lib "advapi32.dll" _
        Alias "RegOpenKeyExA" (ByVal hKey As Long, _
        ByVal lpSubKey As String, ByVal ulOptions As Long, _
        ByVal samDesired As Long, ByRef phkResult As Long) _
        As Long
 
Private Declare Function apiRegCloseKey Lib "advapi32.dll" _
        Alias "RegCloseKey" (ByVal hKey As Long) As Long
 
Private Declare Function apiRegQueryValueEx Lib "advapi32.dll" _
        Alias "RegQueryValueExA" (ByVal hKey As Long, _
        ByVal lpValueName As String, ByVal lpReserved As Long, _
        ByRef lpType As Long, lpData As Any, _
        ByRef lpcbData As Long) As Long
 
Private Declare Function apiRegQueryInfoKey Lib "advapi32.dll" _
        Alias "RegQueryInfoKeyA" (ByVal hKey As Long, _
        ByVal lpClass As String, ByRef lpcbClass As Long, _
        ByVal lpReserved As Long, ByRef lpcSubKeys As Long, _
        ByRef lpcbMaxSubKeyLen As Long, _
        ByRef lpcbMaxClassLen As Long, _
        ByRef lpcValues As Long, _
        ByRef lpcbMaxValueNameLen As Long, _
        ByRef lpcbMaxValueLen As Long, _
        ByRef lpcbSecurityDescriptor As Long, _
        ByRef lpftLastWriteTime As FILETIME) As Long
 
Function fReturnRegKeyValue(ByVal lngKeyToGet As Long, _
                            ByVal strKeyName As String, _
                            ByVal strValueName As String) _
                            As String
Dim lnghKey As Long
Dim strClassName As String
Dim lngClassLen As Long
Dim lngReserved As Long
Dim lngSubKeys As Long
Dim lngMaxSubKeyLen As Long
Dim lngMaxClassLen As Long
Dim lngValues As Long
Dim lngMaxValueNameLen As Long
Dim lngMaxValueLen As Long
Dim lngSecurity As Long
Dim ftLastWrite As FILETIME
Dim lngType As Long
Dim lngData As Long
Dim lngTmp As Long
Dim strRet As String
Dim varRet As Variant
Dim lngRet As Long
On Error GoTo fReturnRegKeyValue_Err
 
    'Open the key first
    lngTmp = apiRegOpenKeyEx(lngKeyToGet, _
                strKeyName, 0&, KEY_READ, lnghKey)
 
    'Are we ok?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.RaiselngTmp vbObjectError
 
    lngReserved = 0&
    strClassName = String$(MAXLEN, 0):  lngClassLen = MAXLEN
 
    'Get boundary values
    lngTmp = apiRegQueryInfoKey(lnghKey, strClassName, _
        lngClassLen, lngReserved, lngSubKeys, lngMaxSubKeyLen, _
        lngMaxClassLen, lngValues, lngMaxValueNameLen, _
        lngMaxValueLen, lngSecurity, ftLastWrite)
 
    'How we doin?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.RaisengTmp vbObjectError
 
    'Now grab the value for the key
    strRet = String$(MAXLEN - 1, 0)
    lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
    Select Case lngType
      Case REG_SZ
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
        varRet = Left(strRet, lngData - 1)
      Case REG_DWORD
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, lngRet, lngData)
        varRet = lngRet
      Case REG_BINARY
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
        varRet = Left(strRet, lngData)
      Case REG_EXPAND_SZ
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
        varRet = Left(strRet, lngData)
 
    End Select
 
    'All quiet on the western front?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.RaiselngTmp vbObjectError
 
fReturnRegKeyValue_Exit:
    fReturnRegKeyValue = varRet
    lngTmp = apiRegCloseKey(lnghKey)
    Exit Function
fReturnRegKeyValue_Err:
    varRet = "Erreur: Clef ou valeur non trouvée."
    Resume fReturnRegKeyValue_Exit
End Function

Module BasSendMailMAPI:

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
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
Option Compare Database
Option Explicit
 
'Declare Special Types for use with MAPI
Type MAPIMessage
   Reserved As Long
   Subject As String
   NoteText As String
   MessageType As String
   DateReceived As String
   ConversationID As String
   flags As Long
   RecipCount As Long
   FileCount As Long
End Type
 
Type MapiRecip
   Reserved As Long
   RecipClass As Long
   Name As String
   Address As String
   EIDSize As Long
   EntryID As String
End Type
 
Type MapiFile
   Reserved As Long
   flags As Long
   Position As Long
   PathName As String
   FileName As String
   FileType As String
End Type
 
Global Dialogue As MAPIMessage
 
'DLL Functions in MAPI module
Declare Function MAPISendMailOE _
                 Lib "C:\Program Files\Outlook Express\Msoe.dll" _
                 Alias "BMAPISendMail" _
                 (ByVal Session&, _
                  ByVal UIParam&, _
                  Message As MAPIMessage, _
                  Recipient() As MapiRecip, _
                  File() As MapiFile, _
                  ByVal flags&, _
                  ByVal Reserved&) As Long
 
Declare Function MAPISendMail _
                 Lib "MAPI32.DLL" _
                 Alias "BMAPISendMail" (ByVal Session&, _
                 ByVal UIParam&, _
                 Message As MAPIMessage, _
                 Recipient() As MapiRecip, _
                 File() As MapiFile, _
                 ByVal flags&, _
                 ByVal Reserved&) As Long
 
Global Const SUCCESS_SUCCESS = 0
Global Const MAPI_TO = 1
Global Const MAPI_CC = 2
Global Const MAPI_CCO = 3
Global Const MAPI_LOGON_UI = &H1
Global Const MAPI_DIALOG = &H8
 
' FUNCTION NAME: SendMail
'
' Usage:
'   This is the front-end function to the MAPISendMail function. You
'   pass a semicolon-delimited list of To and CC recipients, a
'   subject, a message, and a delimited list of file attachments.
'   This function prepares MapiRecip and MapiFile structures with the
'   data parsed from the information provided using the ParseRecord
'   sub. Once the structures are prepared, the MAPISendMail function
'   is called to send the message.
'
' INPUT PARAMETERS:
'   sSubject: The text to appear in the subject line of the message
'   sTo:      Semicolon-delimited list of names to receive the
'             message
'   sCC:      Semicolon-delimited list of names to be CC'd
'   sCCO:     Semicolon-delimited list of names to be CCO'd
'   sAttach:  Semicolon-delimited list of files to attach to
'             the message
' RETURN
'   SUCCESS_SUCCESS if successful, or a MAPI error if not.
'*************************************************************
 
Function SendMail(sSubject As String, _
                  sTo As String, _
                  sCC As String, _
                  sCCO As String, _
                  sAttach As String, _
                  sMessage As String, _
                  Optional sImmediateSend As Boolean = True) _
                  As Long
 
   Dim i, cTo, cCC, cCCO, cAttach ' variables holding counts
   Dim MAPI_Message As MAPIMessage
 
   ' Count the number of items in each piece of the mail message
   cTo = CountWords(sTo, ";")
   cCC = CountWords(sCC, ";")
   cCCO = CountWords(sCCO, ";")
   cAttach = CountWords(sAttach, ";")
 
   ' Create arrays to store the semicolon delimited mailing
   ' .. information after it is parsed
   ReDim rTo(0 To cTo) As String
   ReDim rCC(0 To cCC) As String
   ReDim rCCO(0 To cCCO) As String
   ReDim rAttach(0 To cAttach) As String
 
   ' Parse the semicolon delimited information into the arrays.
   ParseWords rTo(), sTo, ";"
   ParseWords rCC(), sCC, ";"
   ParseWords rCCO(), sCCO, ";"
   ParseWords rAttach(), sAttach, ";"
 
   ' Create the MAPI Recip structure to store all the To and CC
   ' .. information to be passed to the MAPISendMail function
   ReDim MAPI_Recip(0 To cTo + cCC + cCCO - 1) As MapiRecip
 
   ' Setup the "TO:" recipient structures
   For i = 0 To cTo - 1
      MAPI_Recip(i).Name = rTo(i)
      MAPI_Recip(i).RecipClass = MAPI_TO
   Next i
 
   ' Setup the "CC:" recipient structures
   For i = 0 To cCC - 1
      MAPI_Recip(cTo + i).Name = rCC(i)
      MAPI_Recip(cTo + i).RecipClass = MAPI_CC
   Next i
 
   ' Setup the "CCO:" recipient structures
   For i = 0 To cCCO - 1
      MAPI_Recip(cTo + cCC + i).Name = rCCO(i)
      MAPI_Recip(cTo + cCC + i).RecipClass = MAPI_CCO
   Next i
 
   ' Create the MAPI File structure to store all the file attachment
   ' .. information to be passed to the MAPISendMail function
   ReDim MAPI_File(0 To cAttach) As MapiFile
 
   ' Setup the file attachment structures
   MAPI_Message.FileCount = cAttach
   For i = 0 To cAttach - 1
      MAPI_File(i).Position = -1
      MAPI_File(i).PathName = rAttach(i)
   Next i
 
   ' Set the mail message fields
   MAPI_Message.Subject = sSubject
   MAPI_Message.NoteText = sMessage
   MAPI_Message.RecipCount = cTo + cCC + cCCO
 
   ' Define Immediate_Sending Option
    If sImmediateSend = True Then
        Dialogue.flags = MAPI_LOGON_UI
    Else
        Dialogue.flags = MAPI_LOGON_UI + MAPI_DIALOG
    End If
   'Send the mail message
 
  Select Case GetDefaultMailSoftware()
 
  Case "Outlook Express"
      SendMail = MAPISendMailOE(0&, 0&, _
                                MAPI_Message, _
                                MAPI_Recip(), _
                                MAPI_File(), _
                                Dialogue.flags, 0)
 
  Case "Microsoft Outlook", "Outlook"
      SendMail = MAPISendMail(0&, 0&, _
                                MAPI_Message, _
                                MAPI_Recip(), _
                                MAPI_File(), _
                                Dialogue.flags, 0)
 
  Case Else
      MsgBox "Votre client de messagerie n'est pas supporté"
  End Select
 
End Function
 
Function CountWords(ByVal sSource As String, _
                    ByVal sDelim As String)
 
Dim iDelimPos As Integer
Dim iCount As Integer
 
 If sSource = "" Then
    CountWords = 0
 Else
    iDelimPos = InStr(1, sSource, sDelim)
 
    Do Until iDelimPos = 0
        iCount = iCount + 1
        iDelimPos = InStr(iDelimPos + 1, sSource, sDelim)
    Loop
        CountWords = iCount + _
                     IIf(Right(sSource, 1) = sDelim, 0, 1)
 End If
End Function
Function GetWords(sSource As String, _
                  ByVal sDelim As String) As String
 
Dim iDelimPos As Integer
 
iDelimPos = InStr(1, sSource, sDelim)
 
    If (iDelimPos = 0) Then
        GetWords = Trim$(sSource)
        sSource = ""
    Else
        GetWords = Trim$(Left$(sSource, iDelimPos - 1))
        sSource = Mid$(sSource, iDelimPos + 1)
    End If
 
End Function
 
Sub ParseWords(mArray() As String, _
               ByVal sTokens As String, _
               ByVal sDelim As String)
Dim i As Integer
 
For i = LBound(mArray) To UBound(mArray)
    mArray(i) = GetWords(sTokens, sDelim)
Next i
 
End Sub
 
Function GetDefaultMailSoftware() As String
 
GetDefaultMailSoftware = fReturnRegKeyValue(HKEY_LOCAL_MACHINE, _
"Software\Clients\Mail\", "")
End Function
 
Function GetDefaultMailAccount() As String
 
Dim IAM_Path As String
 
IAM_Path = fReturnRegKeyValue(HKEY_CURRENT_USER, _
  "Software\Microsoft\Internet Account Manager\", _
  "Default Mail Account")
 
GetDefaultMailAccount = fReturnRegKeyValue(HKEY_CURRENT_USER, _
  "Software\Microsoft\Internet Account Manager\Accounts\" & IAM_Path, _
  "SMTP Email Address")
 
End Function

Je pense qu'un code aussi génial mérite que l'on s'y interresse afin de lui donner l'opportunité de survivre aux différentes modes en ce qui concerne les logiciels de messagerie.

D'avance Merci.

[argyronet]

Bonjour,

Un tutoriel est en cours de rédaction à ce sujet...

Argy