Ben c un sujet qui m a soulé pendant un bon mois (tout un stage en fait) sur l envoi de mails. ça utilise les fonctions mapi de la librairie kernel32.dll de windows xp, et ça marche en appelant la fonction SendMail(), par exemple:
SendMail("mon_sujet", "mon_poto@son_domaine.com", "mon_deuxieme_poto@son_domaine.com", "mon_poto_caché@son_domaine.com", "ma_piece_jointe.rar", "Le corps du message en français dans le texte", true, "mon_compte_messagerie", "mon_mot_de_passe")
Ca marche très bien avec un petit logiciel entièrement libre appelé "clickyes" qui évite le message d avertissement de Outook "un programme tente d envoyer un mail en votre nom (...)". Le probleme c que pour un envoi groupé de mails, outook fait autant de messages d avertissement que de mails, soit 5 secondes par mail pour cliquer sur ok… d où clickyes.
Outook express ne fait pas de message d avertissement si on décoche l option "m avertir lorsqu un logiciel tente d envoyer un message en mon nom" dans l onglet sécurité des options. Pour killer clickyes après l envoi, utiliser le module que j ai mis dans un autre post sur le kernel32.dll
Amusez vous bien les loulous !
Source / Exemple :
Attribute VB_Name = "mapi"
Option Compare Database
Option Explicit
'----------------------------------------------------------------------------------------------------------'
' déclaration des types utilisés
'----------------------------------------------------------------------------------------------------------'
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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
'----------------------------------------------------------------------------------------------------------'
' déclaration de constantes
'----------------------------------------------------------------------------------------------------------'
Global Dialogue As MAPIMessage
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
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
'----------------------------------------------------------------------------------------------------------'
' Déclaration des fonctions de kernerl32.dll (qui devrait etre dans c:\windows\system32\)
'----------------------------------------------------------------------------------------------------------'
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function MAPILogon Lib "MAPI32.DLL" (ByVal lUIParam As Long, ByVal user As String, ByVal Password As String, ByVal lFlags As Long, ByVal lReserved As Long, lSession As Long) As Long
Private Declare Function MAPILogoff Lib "MAPI32.DLL" (ByVal lSession As Long, ByVal lUIParam As Long, ByVal lFlags As Long, ByVal lReserved As Long) As Long
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Any) As Long
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
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
Private zlSessionID As Long, zlParentHwnd As Long, zlShowDialogs As Long
'----------------------------------------------------------------------------------------------------------'
' envoi du mail (avec les parametres normaux d'un mail: sujet, destinataire, dest. caché...)
'----------------------------------------------------------------------------------------------------------'
Public 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, _
Optional zsusername As String="Outlook", Optional zspassword As String="") As Long
Dim MAPI_Message As MAPIMessage
Dim i As Integer
Dim cTo As Integer
Dim cCC As Integer
Dim cCCO As Integer
Dim cAttach As Integer
Dim Resultat As Long
cTo = CountWords(sTo, ";")
cCC = CountWords(sCC, ";")
cCCO = CountWords(sCCO, ";")
cAttach = CountWords(sAttach, ";")
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
ParseWords rto(), sTo, ";"
ParseWords rCC(), sCC, ";"
ParseWords rCCO(), sCCO, ";"
ParseWords rAttach(), sAttach, ";"
ReDim mapi_recip(0 To cTo + cCC + cCCO - 1) As MapiRecip
For i = 0 To cTo - 1
mapi_recip(i).Name = rto(i)
mapi_recip(i).RecipClass = MAPI_TO
Next i
For i = 0 To cCC - 1
mapi_recip(cTo + i).Name = rCC(i)
mapi_recip(cTo + i).RecipClass = MAPI_CC
Next i
For i = 0 To cCCO - 1
mapi_recip(cTo + cCC + i).Name = rCCO(i)
mapi_recip(cTo + cCC + i).RecipClass = MAPI_CCO
Next i
ReDim MAPI_file(0 To cAttach) As MapiFile
MAPI_Message.FileCount = cAttach
For i = 0 To cAttach - 1
MAPI_file(i).POSITION = -1
MAPI_file(i).PathName = rAttach(i)
Next i
MAPI_Message.Subject = sSubject
MAPI_Message.NoteText = sMessage
MAPI_Message.RecipCount = cTo + cCC + cCCO
If sImmediateSend = True Then
Dialogue.flags = MAPI_LOGON_UI
Else
Dialogue.flags = MAPI_LOGON_UI + MAPI_DIALOG
End If
Select Case GetDefaultMailSoftware() 'Fonctions API disponibles ici
Case "Outlook Express"
SendMail = MAPISendMailOE(0&, 0&, _
MAPI_Message, _
mapi_recip(), _
MAPI_file(), _
Dialogue.flags, 0)
Case "Microsoft Outlook", "Outlook"
Logon zsusername, zspassword
SendMail = MAPISendMail(0&, 0&, _
MAPI_Message, _
mapi_recip(), _
MAPI_file(), _
Dialogue.flags, 0)
LogOff
Case Else
MsgBox "Votre client de messagerie n'est pas supporté"
End Select
End Function
'----------------------------------------------------------------------------------------------------------'
' je sais plus
'----------------------------------------------------------------------------------------------------------'
Private Sub Class_Initialize()
zlShowDialogs = MAPI_DIALOG
zlParentHwnd = GetActiveWindow 'Seed parent window handle
End Sub
'----------------------------------------------------------------------------------------------------------'
' Connection au compte MAPI Outlook (pas Express)
'----------------------------------------------------------------------------------------------------------'
Public Function Logon(Optional zsusername As String, Optional zspassword As String) As String
' renvoit 0 si ok
Dim lReturnValue As Long
If IsMissing(zsusername) Or zsusername = "" Then
zsusername = "Outlook"
zspassword = ""
End If
Class_Initialize
'On Error Resume Next
If zlSessionID Then
'End existing session
LogOff
zlSessionID = 0
End If
zlSessionID = 0
lReturnValue = MAPILogon(zlParentHwnd, zsusername, zspassword, MAPI_LOGON_UI, 0&, zlSessionID)
Logon = ErrorDescription(lReturnValue)
End Function
'----------------------------------------------------------------------------------------------------------'
' Deconnection du compte
'----------------------------------------------------------------------------------------------------------'
Public Function LogOff() As Long 'retourne 0 si ok
If zlSessionID Then
LogOff = MAPILogoff(zlSessionID, zlParentHwnd, 0&, 0&)
zlSessionID = 0
End If
End Function
'----------------------------------------------------------------------------------------------------------'
' Compte les mots dans sSource par rapport à sDelim (c marqué dessus, comme le porsalu)
'----------------------------------------------------------------------------------------------------------'
Public Function CountWords(ByVal sSource As String, ByVal sDelim As String) As Integer
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
'----------------------------------------------------------------------------------------------------------'
' Découpe la chaine nSource en un certain nombre de paramètres
'----------------------------------------------------------------------------------------------------------'
Public 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
Public 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
'----------------------------------------------------------------------------------------------------------'
' Extraire le compte de messagerie par défaut
'----------------------------------------------------------------------------------------------------------'
Public 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
'----------------------------------------------------------------------------------------------------------'
' Extraire le nom du logiciel de messagerie par défaut
'----------------------------------------------------------------------------------------------------------'
Public Function GetDefaultMailSoftware() As String
GetDefaultMailSoftware = fReturnRegKeyValue(HKEY_LOCAL_MACHINE, "Software\Clients\Mail\", "")
End Function
'----------------------------------------------------------------------------------------------------------'
' Retourne une clé de registre (string)
'----------------------------------------------------------------------------------------------------------'
Public Function fReturnRegKeyValue(ByVal lngKeyToGet As Long, ByVal strKeyName As String, _
ByVal strValueName As String) As String
On Error GoTo fReturnRegKeyValue_Err
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
'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 = "Error: Key or Value Not Found."
Resume fReturnRegKeyValue_Exit
End Function
'----------------------------------------------------------------------------------------------------------'
' Transforme un numéro d'erreur en description d'erreur
'----------------------------------------------------------------------------------------------------------'
Function ErrorDescription(ByVal lErrorNumber As Long) As String
Const FORMAT_MESSAGE_FROM_HMODULE = &H800, FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Const NERR_BASE = 2100, MAX_NERR = NERR_BASE + 899
Const LOAD_LIBRARY_AS_DATAFILE = &H2
Dim sMsg As String
Dim sRtrnCode As String
Dim lFlags As Long
Dim hModule As Long
Dim lRet As Long
hModule = 0
sRtrnCode = Space$(256)
lFlags = FORMAT_MESSAGE_FROM_SYSTEM
'If lRet is in the network range, load the message source
If (lErrorNumber >= NERR_BASE And lErrorNumber <= MAX_NERR) Then
hModule = LoadLibraryEx("netmsg.dll", 0&, LOAD_LIBRARY_AS_DATAFILE)
If (hModule <> 0) Then
lFlags = lFlags Or FORMAT_MESSAGE_FROM_HMODULE
End If
End If
'Call FormatMessage to allow for message text to be acquired
'from the system or the supplied module handle.
lRet = FormatMessage(lFlags, hModule, lErrorNumber, 0&, sRtrnCode, 256&, 0&)
If (hModule <> 0) Then
'Unloaded message source
FreeLibrary hModule
End If
ErrorDescription = "ERROR: " & lErrorNumber & " - " & sRtrnCode
'Clean message
lRet = InStr(1, ErrorDescription, vbNullChar)
If lRet Then
ErrorDescription = Left$(ErrorDescription, lRet - 1)
End If
lRet = InStr(1, ErrorDescription, vbNewLine)
If lRet Then
ErrorDescription = Left$(ErrorDescription, lRet - 1)
End If
End Function
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.