Envoyer des mails par une messagerie systeme microsoft (outook, outlook express) sous xp

Télécharger le projet
Commenter

Description

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
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (mrtang)