Private Sub Application_NewMail()
    Dim myOlApp As New Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myInbox As Outlook.Folder
    Dim myDestFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myItem As Object
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myInbox.Items
    Set myDestFolder = myInbox.Folders("Temp")
    Dim strName As String
    
    For Each myItem In myInbox.Items
    
        strName = myItem.EntryId
        
        myItem.SaveAs "C:\temp\" & strName & ".txt", olTXT
        myItem.Move myDestFolder
        Set myItem = myItems.GetNext
        
    Next myItem
End Sub

Sub SaveAttachment()

    'Declaration
    Dim myItems, myItem, myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim i As Integer
    
    'Boîte de dialogue simple pour le chemin de sauvegarde
    myOrt = InputBox("Destination", "Save Attachments", "C:\temp\")

    On Error Resume Next
    
    'Actions sur les objets sélectionnés
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    
    'boucle
    For Each myItem In myOlSel
        Set myAttachments = myItem.Attachments
        If myAttachments.Count > 0 Then
            'Ajoute une remarque dans le corps du message
            myItem.Body = myItem.Body & vbCrLf & _
                "pièce jointe enlevée:" & vbCrLf
                
            'for all attachments do...
            For i = 1 To myAttachments.Count
            
                'save them to destination
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                    myAttachments(i).DisplayName & vbCrLf
                    
            Next i
            
            'Enlève les pièces jointes du message
            While myAttachments.Count > 0
            
                myAttachments(1).Delete
                
            Wend
            
            'Sauvegarde le message sans ses pièces jointes
            myItem.Save
        End If
        
    Next
    
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
    
End Sub

Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
'By Oliv' juillet 2007 pour OUTLOOK 2003

    If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem

    'Ici on construit le nom du fichier qui sera créé
    NomExport = objCurrentMessage.Subject & objCurrentMessage.CreationTime

    'Ici on défini le répertoire où l'enregistrer
    repertoire = "c:\mail\"
    'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"

    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & "Email " & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"

    'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
    n = 1
    MemPath = PathNomExport
    While Dir(PathNomExport) <> ""
        MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
        PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
        n = n + 1

    Wend
    objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG

End Sub

Sub LanceSurOuvert()
    sav_mail_as_msg
End Sub


Sub LanceSurSelection()
    Dim MonOutlook As Outlook.Application
    Dim LeMail As Object
    Dim LesMails As Outlook.Selection
    Set MonOutlook = Outlook.Application

    Set LesMails = MonOutlook.ActiveExplorer.Selection

    For Each LeMail In LesMails
        sav_mail_as_msg LeMail
    Next LeMail

    Set LesMails = Nothing
    MsgBox "Fin de traitement"
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, _

                                 Cancel As Boolean)

'By Oliv' 29/06/2007 pour Outlook 2003

    Dim myRecipient As Outlook.Recipient

    If Not Item.Class = olMail Then GoTo fin

    Dim prompt As String

    ' ici renseigner le destinataire

    cci = "MonDestinataire@sonDomaine.fr"

    'commentez au choix l'option non voulue

    '########################Option CCI############################

    prompt = "Ajouter le cci " & cci & " à " & Item.Subject & "?"

    If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbYes Then

        Set myRecipient = Item.Recipients.Add(cci)

        myRecipient.Type = olBCC

        myRecipient.Resolve

        If myRecipient.Resolved = False Then

            MsgBox "L'adresse Email n'est pas correcte !", vbCritical, "Erreur"

            Cancel = True
        End If

    End If

    '########################Option CC##############################

    prompt = "Ajouter le cc " & cci & " à " & Item.Subject & "?"

    If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbYes Then

        Set myRecipient = Item.Recipients.Add(cci)

        myRecipient.Type = olCC

        myRecipient.Resolve

        If myRecipient.Resolved = False Then

            MsgBox "L'adresse Email n'est pas correcte !", vbCritical, "Erreur"

            Cancel = True
        End If

    End If

    '#######################FIN#####################################

fin:

End Sub

Sub ParcourirInBox()
Dim oMail As MailItem
Dim myFolder As Folder
Dim myOlApp As Outlook.Application
Dim myNamespace As NameSpace


Set myOlApp = Outlook.Application
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
For Each oMail In myFolder.Items
    Debug.Print oMail.Subject
Next oMail

End Sub

For Each oMail In myFolder.Items
If Left(oMail.Subject, 2 ) <> "KO" Then
    oMail.Subject = "KO " & Date & oMail.Subject
End If 
Next oMail

oMail.SaveAs

Public Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
MsgBox "Envoi d'un mail"
End Sub

Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
                                                                             ByVal uFlags As Long) As Long

Public Sub Application_NewMail()
    ' ===== jouer un son lors de la réception d'un mail =====
    sndPlaySound "c:\WINDOWS\MEDIA\ringin.wav", 1
End Sub

Sub EnvoiTouteLaSelection()
    Dim MonOutlook As Outlook.Application
    Dim Mail As Object
    Dim LeMail As Outlook.MailItem
    Dim LesMails As Object
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
    For Each LeMail In LesMails
        LeMail.To = LeMail.SenderEmailAddress
    Next LeMail
    Set LesMails = Nothing
End Sub

Sub controle_meeting()
    Dim oitem
    Set oitem = ActiveInspector.CurrentItem
    oitem.Send
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procédure : Application_ItemSend
' Auteur    : Dolphy35
' Site      : http://dolphy35.developpez.com
' Détail    : Permet de tester si présence d'un sujet avant l'envoi d'un Mail
'---------------------------------------------------------------------------------------
'
    'Test si c'est un Email
    If Not Item.Class = olMail Then Exit Sub
    'Déclaration de la variable en tant Mail
    Dim monMail As MailItem
    'Instancie L'élément à la variable Mail
    Set monMail = Item
    'Test si le sujet n'est pas vide
    If monMail.Subject = "" Then
        'Message si sujet vide
        MsgBox "Veuillez saisir un Sujet à votre E-Mail"
        'Annule l'envoi
        Cancel = True
    End If
End Sub

Private Function EmailExisteDansContact(Email As String) as boolean
'by Oliv' 7/11/2007 pour Outlook 2003
    Dim myolApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myContacts As Outlook.Items
    Dim myItems As Outlook.Items
    Dim myItem As Object
 
    Set myolApp = CreateObject("Outlook.Application")
    Set myNamespace = myolApp.GetNamespace("MAPI")
    Set myContacts = myNamespace.GetDefaultFolder(olFolderContacts).Items
    strWhere = "[Email1Address] ='" & Email & "' or [Email2Address] ='" & Email & "' or [Email3Address] ='" & Email & "'"
    Set myItems = myContacts.Restrict(strWhere)
    If myItems.Count > 0 Then
    EmailExisteDansContact = True
    Else
    EmailExisteDansContact = False
    End If
End Function

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As _
Boolean)
 
'By Oliv' 9/02/2007 pour Outlook 2003
If Not Item.Class = olMail Then GoTo fin
 
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
 
            Set objNS = Application.GetNamespace("MAPI")
            Set objFolder = objNS.PickFolder
            If TypeName(objFolder) = "Nothing" Then
                Set objNS = Application.GetNamespace("MAPI")
                Set objFolder = objNS.Folders("Dossiers personnels").Folders("Divers")
            End If
        Set Item.SaveSentMessageFolder = objFolder
fin:
End Sub

Sub change_html()

'By Oliv' 02/2007 pour Outlook 2003

    Dim oitem As Outlook.MailItem
    Set oitem = ActiveInspector.CurrentItem
    With New DataObject
        .GetFromClipboard
        contenu = .GetText(1)
    End With
    'MsgBox Contenu
    oitem.HTMLBody = contenu
    oitem.Display
    'décommentez pour enregistrer
    'oitem.save
End Sub

' REGISTRY ACCESS FUNCTIONS
' Created by E.Spencer - This code is public domain.
'
Option Explicit
'Security Mask constants
Public Const READ_CONTROL = &H20000
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const STANDARD_RIGHTS_READ = READ_CONTROL
Public Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or _
                                KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or _
                                KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or _
                          KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Public Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Public Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE _
                           Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
' Possible registry data types
Public Enum InTypes
    ValNull = 0
    ValString = 1
    ValXString = 2
    ValBinary = 3
    ValDWord = 4
    ValLink = 6
    ValMultiString = 7
    ValResList = 8
End Enum
' Registry value type definitions
Public Const REG_NONE As Long = 0
Public Const REG_SZ As Long = 1
Public Const REG_EXPAND_SZ As Long = 2
Public Const REG_BINARY As Long = 3
Public Const REG_DWORD As Long = 4
Public Const REG_LINK As Long = 6
Public Const REG_MULTI_SZ As Long = 7
Public Const REG_RESOURCE_LIST As Long = 8
' Registry section definitions
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
' Codes returned by Reg API calls
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
' Registry API functions used in this module (there are more of them)
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
                                    (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
                                      (ByVal hKey As Long, ByVal lpSubKey As String, _
                                       ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
                                         (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, _
                                          ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
                                      (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
                                       lpcbValueName As Long, ByVal lpReserved As Long, _
                                       lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
                                      (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" _
                                             (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
                                              ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" _
                                           (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
                                            ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegFlushKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
                                    (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
                                      (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
                                        (ByVal hKey As Long, ByVal lpValueName As String) As Long

' This routine allows you to get values from anywhere in the Registry, it currently
' only handles string, double word and binary values. Binary values are returned as
' hex strings.
'
' Example
' Text1.Text = ReadRegistry(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "DefaultUserName")
'
Public Function ReadRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String) As String

    Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long, lValueLength As Long, sValue As String, td As Double, TStr2 As String
    Dim i As Integer, TStr1 As String


    On Error Resume Next
    lResult = RegOpenKey(Group, Section, lKeyValue)
    sValue = Space$(2048)
    lValueLength = Len(sValue)
    lResult = RegQueryValueEx(lKeyValue, Key, 0&, lDataTypeValue, sValue, lValueLength)
    If (lResult = 0) And (err.Number = 0) Then
        If lDataTypeValue = REG_DWORD Then
            td = Asc(Mid$(sValue, 1, 1)) + &H100& * Asc(Mid$(sValue, 2, 1)) + &H10000 * Asc(Mid$(sValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(sValue, 4, 1)))
            sValue = Format$(td, "000")
        End If
        If lDataTypeValue = REG_BINARY Then
            ' Return a binary field as a hex string (2 chars per byte)
            TStr2 = ""
            For i = 1 To lValueLength
                TStr1 = Hex(Asc(Mid(sValue, i, 1)))
                If Len(TStr1) = 1 Then TStr1 = "0" & TStr1
                TStr2 = TStr2 + TStr1
            Next
            sValue = TStr2
        Else
            sValue = Left$(sValue, lValueLength - 1)
        End If
    Else
        sValue = "Not Found"
    End If
    lResult = RegCloseKey(lKeyValue)
    ReadRegistry = sValue
End Function

' This routine allows you to write values into the entire Registry, it currently
' only handles string and double word values.
'
' Example
' WriteRegistry HKEY_CURRENT_USER, "SOFTWARE\My Name\My App\", "NewSubKey", ValString, "NewValueHere"
' WriteRegistry HKEY_CURRENT_USER, "SOFTWARE\My Name\My App\", "NewSubKey", ValDWord, "31"
'
Public Sub WriteRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String, ByVal ValType As InTypes, ByVal Value As Variant)
    Dim lResult As Long
    Dim lKeyValue As Long
    Dim InLen As Long
    Dim lNewVal As Long
    Dim sNewVal As String
    On Error Resume Next
    lResult = RegCreateKey(Group, Section, lKeyValue)
    If ValType = ValDWord Then
        lNewVal = CLng(Value)
        InLen = 4
        lResult = RegSetValueExLong(lKeyValue, Key, 0&, ValType, lNewVal, InLen)
    Else
        ' Fixes empty string bug - spotted by Marcus Jansson
        If ValType = ValString Then Value = Value + Chr(0)
        sNewVal = Value
        InLen = Len(sNewVal)
        lResult = RegSetValueExString(lKeyValue, Key, 0&, 1&, sNewVal, InLen)
    End If
    lResult = RegFlushKey(lKeyValue)
    lResult = RegCloseKey(lKeyValue)
End Sub

' This routine enumerates the subkeys under any given key
' Call repeatedly until "Not Found" is returned - store values in array or something
'
' Example - this example just adds all the subkeys to a string - you will probably want to
' save then into an array or something.
'
' Dim Res As String
' Dim i As Long
' Res = ReadRegistryGetSubkey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\", i)
' Do Until Res = "Not Found"
'   Text1.Text = Text1.Text & " " & Res
'   i = i + 1
'   Res = ReadRegistryGetSubkey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\", i)
' Loop

Public Function ReadRegistryGetSubkey(ByVal Group As Long, ByVal Section As String, Idx As Long) As String
    Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long, lValueLength As Long, sValue As String, td As Double
    On Error Resume Next
    lResult = RegOpenKey(Group, Section, lKeyValue)
    sValue = Space$(2048)
    lValueLength = Len(sValue)
    lResult = RegEnumKey(lKeyValue, Idx, sValue, lValueLength)
    If (lResult = 0) And (err.Number = 0) Then
        sValue = Left$(sValue, InStr(sValue, Chr(0)) - 1)
    Else
        sValue = "Not Found"
    End If
    lResult = RegCloseKey(lKeyValue)
    ReadRegistryGetSubkey = sValue
End Function

' This routine allows you to get all the values from anywhere in the Registry under any
' given subkey, it currently only returns string and double word values.
'
' Example - returns list of names/values to multiline text box
' Dim Res As Variant
' Dim i As Long
' Res = ReadRegistryGetAll(HKEY_CURRENT_USER, "Software\Microsoft\Notepad", i)
' Do Until Res(2) = "Not Found"
'    Text1.Text = Text1.Text & Chr(13) & Chr(10) & Res(1) & " " & Res(2)
'    i = i + 1
'    Res = ReadRegistryGetAll(HKEY_CURRENT_USER, "Software\Microsoft\Notepad", i)
' Loop
'
Public Function ReadRegistryGetAll(ByVal Group As Long, ByVal Section As String, Idx As Long) As Variant
    Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long
    Dim lValueLength As Long, lValueNameLength As Long
    Dim sValueName As String, sValue As String
    Dim td As Double
    On Error Resume Next
    lResult = RegOpenKey(Group, Section, lKeyValue)
    sValue = Space$(2048)
    sValueName = Space$(2048)
    lValueLength = Len(sValue)
    lValueNameLength = Len(sValueName)
    lResult = RegEnumValue(lKeyValue, Idx, sValueName, lValueNameLength, 0&, lDataTypeValue, sValue, lValueLength)
    If (lResult = 0) And (err.Number = 0) Then
        If lDataTypeValue = REG_DWORD Then
            td = Asc(Mid$(sValue, 1, 1)) + &H100& * Asc(Mid$(sValue, 2, 1)) + &H10000 * Asc(Mid$(sValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(sValue, 4, 1)))
            sValue = Format$(td, "000")
        End If
        sValue = Left$(sValue, lValueLength - 1)
        sValueName = Left$(sValueName, lValueNameLength)
    Else
        sValue = "Not Found"
    End If
    lResult = RegCloseKey(lKeyValue)
    ' Return the datatype, value name and value as an array
    ReadRegistryGetAll = Array(lDataTypeValue, sValueName, sValue)
End Function

' This routine deletes a specified key (and all its subkeys and values if on Win95) from the registry.
' Be very careful using this function.
'
' Example
' DeleteSubkey HKEY_CURRENT_USER, "Software\My Name\My App"
'
Public Function DeleteSubkey(ByVal Group As Long, ByVal Section As String) As String
    Dim lResult As Long, lKeyValue As Long
    On Error Resume Next
    lResult = RegOpenKeyEx(Group, vbNullChar, 0&, KEY_ALL_ACCESS, lKeyValue)
    lResult = RegDeleteKey(lKeyValue, Section)
    lResult = RegCloseKey(lKeyValue)
End Function

' This routine deletes a specified value from below a specified subkey.
' Be very careful using this function.
'
' Example
' DeleteValue HKEY_CURRENT_USER, "Software\My Name\My App", "NewSubKey"
'
Public Function DeleteValue(ByVal Group As Long, ByVal Section As String, ByVal Key As String) As String
    Dim lResult As Long, lKeyValue As Long
    On Error Resume Next
    lResult = RegOpenKey(Group, Section, lKeyValue)
    lResult = RegDeleteValue(lKeyValue, Key)
    lResult = RegCloseKey(lKeyValue)
End Function
' =====================================================================================================================================
' GET/SET SPELLING LANGUAGE FOR OUTLOOK 2003
'
' Created by D.Hlad - This code is public domain
'
Sub GetCurrentSpellingLanguage()

    Dim CurrentSpellingLanguage As String

    CurrentSpellingLanguage = ReadRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Office\11.0\Outlook\Options\Spelling\", "Speller")

End Sub
Sub SetSpellingLanguage(LanguageCode As String)

    Dim NewSpellingLanguage As String

    NewSpellingLanguage = LanguageCode & "\Normal"

    WriteRegistry HKEY_CURRENT_USER, "Software\Microsoft\Office\11.0\Outlook\Options\Spelling\", "Speller", ValString, NewSpellingLanguage

End Sub

Sub SetLanguageUK()

    SetSpellingLanguage ("2057")

End Sub

Sub SetLanguageUS()

    SetSpellingLanguage ("1033")

End Sub

Sub SetLanguageES()

    SetSpellingLanguage ("3082")

End Sub
Sub SetLanguageHR()

    SetSpellingLanguage ("1050")

End Sub
Sub SetLanguageCAT()

    SetSpellingLanguage ("1027")

End Sub
Sub SetLanguagePOR()

    SetSpellingLanguage ("2070")

End Sub

Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'By Oliv' 9/02/2007 pour Outlook 2003     Dim prompt As String
    Dim taille, pieces
    Dim objCurrentMessage As MailItem
    If Not Item.Class = olMail Then GoTo fin
    Set objCurrentMessage = Item
    On Error GoTo 0
    objCurrentMessage.Save
    '#######première verif####### If objCurrentMessage.Attachments.Count > 0 Then firstattch = _
     objCurrentMessage.Attachments.Item(1)
    If objCurrentMessage.Size * 1.33 > 100 And firstattch <> _
       "Documents.zip " Then
        taille = Round(objCurrentMessage.Size * 1.33 / 1000000, 2)
        pieces = objCurrentMessage.Attachments.Count
        Title = "Voulez-vous Zipper les pièces jointes ?"
        prompt = Item.Subject & vbCr & vbCr & "Attention votre mail est" _
               & " très volumineux : " & vbCr & taille & " Mo" & vbCr & pieces _
               & " pièces jointes" & vbCr & vbCr & "Z I P P E R ?"
        If MsgBox(prompt, vbYesNo + vbQuestion, Title) = vbYes Then

            'ici la macro qui va zipper le contenu des PJ
            'décommenter les 2 lignes ci-dessous
            'zip
            'objCurrentMessage.Save
        End If
    End If
    '#######deuxième verif####### If objCurrentMessage.Size * 1.33 > 5000000 Then
    taille = Round(objCurrentMessage.Size * 1.33 / 1000000, 2)
    pieces = objCurrentMessage.Attachments.Count
    Title = "Etes-vous sûr de vouloir envoyer ?"
    prompt = Item.Subject & vbCr & vbCr & "Attention votre mail est" _
           & " très volumineux : " & vbCr & taille & " Mo" & vbCr & pieces & _
           " pièces jointes" & vbCr & vbCr & "E N V O Y E R ?"
    If MsgBox(prompt, vbYesNo + vbExclamation, Title) = vbNo Then
        Cancel = True
        GoTo fin
    End If
'#######dernière verif####### If objCurrentMessage.Size * 1.33 > 10000000 Then
taille = Round(objCurrentMessage.Size * 1.33 / 1000000, 2)
pieces = objCurrentMessage.Attachments.Count
Title = "Envoi impossible"
prompt = Item.Subject & vbCr & vbCr & "Votre mail est" _
       & " trop volumineux : " & vbCr & taille & " Mo" & vbCr & pieces & _
         "pièces jointes" & vbCr & vbCr & "Envoi impossible"
MsgBox prompt, vbOKOnly + vbExclamation, Title
Cancel = True
fin:
End Sub

Sub script(Mail As MailItem)

    MsgBox "Vous venez de recevoir un Mail de " & Mail.SenderName & vbCrLf & "Ayant pour sujet " & Mail.Subject

End Sub

Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)

' ***olivier CATTEAU***

' 23 avril 2007

    Dim olNS As Outlook.namespace
    Dim MyMail As Outlook.MailItem

    Dim expediteur
    Set olNS = Application.GetNamespace("MAPI")
    Set MyMail = olNS.GetItemFromID(strID.EntryID)

    'MsgBox "nouveau message"

    If MyMail.Attachments.Count > 0 Then

        expediteur = MyMail.SenderEmailAddress

        'on crée le répertoire où mettre les fichiers joints ##########################################################

        'c:\temp\pj\ doit déjà exister !!!

        Repertoire = "c:\temp\pj\" & expediteur & "\"

        If Repertoire <> "" Then

            If "" = Dir(Repertoire, vbDirectory) Then

                MkDir Repertoire

            End If

        End If

        'on traite les pj

        Dim PJ, typeatt

        For Each PJ In MyMail.Attachments
            'vérification si c'est une PJ Embedded

            typeatt = Isembedded(strID, PJ.Index)

            If typeatt = "" Then

                If "" <> Dir(Repertoire & PJ.FileName, vbNormal) Then

                    MsgBox Repertoire & PJ.FileName & " existe !!"

                    'si existe copie vers le répertoire old

                    If "" = Dir(Repertoire & "old", vbDirectory) Then

                        MkDir Repertoire & "old"

                    End If

                    FileCopy Repertoire & PJ.FileName, Repertoire & "old\" & PJ.FileName

                End If

                PJ.SaveAsFile Repertoire & PJ.FileName

            End If

        Next PJ

        'drapeau vert

        MyMail.FlagIcon = olGreenFlagIcon

        'Marque lu

        MyMail.UnRead = False

        MyMail.Save

        'on déplace le mail vers un sous dossier outlook

        Dim myDestFolder As Outlook.MAPIFolder

        Set myDestFolder = MyMail.Parent.Folders("test")
        MyMail.Move myDestFolder

    End If

    Set MyMail = Nothing
    Set olNS = Nothing

Fin:

End Sub



' Function: Fields_Selector

' Purpose: View type of attachment

' olivier catteau fevrier 2006

Function Isembedded(ByVal strEntryID As String, attindex As Integer) As Variant

    Dim oSession As MAPI.Session
    ' CDO objects

    Dim oMsg As MAPI.Message
    Dim oAttachs As MAPI.Attachments

    Dim oAttach As MAPI.Attachment

    ' initialize CDO session

    On Error Resume Next

    Set oSession = CreateObject("MAPI.Session")
    oSession.Logon "", "", False, False

    ' get the message created earlier

    Set oMsg = oSession.GetMessage(strEntryID)
    ' set properties of the attached graphic that make

    ' it embedded and give it an ID for use in an image tag

    Set oAttachs = oMsg.Attachments
    Set oAttach = oAttachs.Item(attindex)
    Dim strCID As String

    strCID = oAttach.Fields(&H3712001E)

    Isembedded = strCID

    Set oMsg = Nothing

    oSession.Logoff

    Set oSession = Nothing

End Function

Private Sub ShowDialog()
    Dim objInsp
    Dim colCB
    Dim objCBB
    On Error Resume Next
    Set objInsp = ActiveInspector
    Set colCB = objInsp.CommandBars
    Set objCBB = colCB.FindControl(, 748)             'enregistrer  sous
    If Not objCBB Is Nothing Then
        objCBB.Execute
    End If
End Sub

Function ParcourirContact(categorie As String) As String
    
'---------------------------------------------------------------------------------------
' Procedure : ParcourirContact
' DateTime  : 08/01/2008 11:00
' Author    : Dolphy35 (http://dolphy35.developpez.com/)
' Purpose   : Permet de retourner toutes les @ d'une catégorie passé en paramètre
'---------------------------------------------------------------------------------------
'
    'Déclarations des variables
    Dim oContact As ContactItem
    Dim oDossier As Folder
    Dim NSpace As NameSpace
    Dim olApp As Outlook.Application

    'Instance
    Set olApp = Outlook.Application
    Set NSpace = olApp.GetNamespace("MAPI")
    Set oDossier = NSpace.GetDefaultFolder(olFolderContacts)
    
    'Parcour le dossier contacts, avec test catégorie passée en paramètre et renvoi adresse mail 1
    For Each oContact In oDossier.Items
        If ParcourirContact <> "" Then ParcourirContact = ParcourirContact & ";"
        If oContact.Categories = categorie Then
            ParcourirContact = ParcourirContact & oContact.Email1Address
        End If
    Next oContact
    
    'Vides des instances
    Set olApp = Nothing
    Set NSpace = Nothing
    Set oDossier = Nothing
    
End Function

Function ParcourirContact2(categorie As String) As String
    Dim myOlApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myContacts As Outlook.Items
    Dim myItems As Outlook.Items
    Dim myItem As Object

    Set myOlApp = Outlook.Application
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myContacts = myNamespace.GetDefaultFolder(olFolderContacts).Items
    Set myItems = myContacts.Restrict("[Catégories] = '" & categorie & "'")
    For Each myItem In myItems
        If (myItem.Class = olContact) Then
            If ParcourirContact2 <> "" Then ParcourirContact2 = ParcourirContact2 & ";"
            If myItem.Email1Address <> "" Then
                ParcourirContact2 = ParcourirContact2 & myItem.Email1Address
            End If
        End If
    Next
End Function

Sub test()

    Debug.Print ParcourirContact("DVP")
	'Debug.Print ParcourirContact2("DVP")
	
End Sub

Dim WithEvents oTaskItems As Outlook.Items
 
Private Sub Application_Startup()
 
'Evénement déclenché lors du démarrage d'Outlook
 
'Charger la collection des tâches existantes
Set oTaskItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks).Items
 
End Sub
 
Private Sub oTaskItems_ItemAdd(ByVal Item As Object)
 
'Evénement déclenché lors de la création d'une tâche
 
MsgBox "Vous venez de créer la tâche " & Item.Subject
 
End Sub
 
Private Sub oTaskItems_ItemChange(ByVal Item As Object)
 
'Evénement déclenché lors de la modification d'une tâche
 
MsgBox "Vous venez de modifier la tâche " & Item.Subject
 
End Sub

Function DeplacerMessage(Nom As String, Dossier As String)
    Dim myOlApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
 
    Set myOlApp = Outlook.Application
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myFolder.Items
    Set myRestrictItems = myItems.Restrict("[De] = '" & Nom & "'")
    For i = myRestrictItems.Count To 1 Step -1
        myRestrictItems(i).Move myFolder.Folders(Dossier)
    Next
End Function

Sub test()
 
   DeplacerMessage "dolphy", "dolphy_essais"
 
End Sub

Sub Save_vCard()
'---------------------------------------------------------------------------------------
' Procédure : Save_vCard
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 20/04/2008
' Détail    : Permet d'importer en masse des vCard vers le dossier Contact
'---------------------------------------------------------------------------------------
'
'Déclarations des variables
    Dim fsoObject As Scripting.FileSystemObject
    Dim fldDossier As Scripting.Folder
    Dim fleFichier As Scripting.File
    Dim MavCard As ContactItem
    Dim MonDossier As Folder
    Dim MonApp As New Outlook.Application
    Dim MonNamespace As Outlook.namespace
    'charge le répertoire dans la variable
    strRepertoire = "C:\temp"
    'instancie les FSO
    Set fsoObject = CreateObject("Scripting.FileSystemObject")
    Set fldDossier = fsoObject.GetFolder(strRepertoire)
    'Instancie l'espace "MAPI" - Session
    Set MonNamespace = MonApp.GetNamespace("MAPI")
    'Test si fichier *.vcf dans le dossier et ajout de celui-ci
    If (fldDossier.Files.Count > 0) Then
        For Each fleFichier In fldDossier.Files
            If (InStr(1, fleFichier.Name, ".vcf", 1) > 0) Then
                Set MavCard = MonNamespace.OpenSharedItem(strRepertoire & "\" & fleFichier.Name)
                MavCard.Save
            End If
        Next
    End If
    'Récupère le dossier Contacts par défaut
    Set MonDossier = MonNamespace.GetDefaultFolder(olFolderContact)
    'Affichage d'outlook dans le dossier
    MonDossier.Display
    'Vide les instances
    Set fsoObject = Nothing
    Set fldDossier = Nothing
    Set MonNamespace = Nothing
    Set MavCard = Nothing
    Set MonDossier = Nothing
End Sub

Sub Save_vCard_2003()
'---------------------------------------------------------------------------------------
' Procédure   : Save_vCard_2003
' Auteur      : Dolphy35 - http://dolphy35.developpez.com/
' Modifié par : Oliv- pour OUTLOOK 2003
' Date        : 20/04/2008
' Détail      : Permet d'importer en masse des vCard vers le dossier Contact
'---------------------------------------------------------------------------------------
'
'Déclarations des variables
    Dim fsoObject As Scripting.FileSystemObject
    Dim fldDossier As Scripting.Folder
    Dim fleFichier As Scripting.File
    Dim MavCard As ContactItem
    Dim MonDossier As MAPIFolder
    Dim MonApp As New Outlook.Application
    Dim MonNamespace As Outlook.NameSpace
    'charge le répertoire dans la variable
    strRepertoire = "C:\temp"
    'instancie les FSO
    Set fsoObject = CreateObject("Scripting.FileSystemObject")
    Set fldDossier = fsoObject.GetFolder(strRepertoire)
    'Instancie l'espace "MAPI" - Session
    Set MonNamespace = MonApp.GetNamespace("MAPI")
    'Test si fichier *.vcf dans le dossier et ajout de celui-ci
    If (fldDossier.Files.Count > 0) Then
        For Each fleFichier In fldDossier.Files
            If (InStr(1, fleFichier.Name, ".vcf", 1) > 0) Then
            shellcommande = """C:\Program Files\Microsoft Office\OFFICE11\OUTLOOK.EXE"" /v """ & fleFichier.path & """"
 
            RetVal = Shell(shellcommande, 1)
            DoEvents
            Set MavCard = MonApp.ActiveInspector.CurrentItem
            MavCard.Save
            MavCard.Close olSave
            End If
        Next
    End If
    'Récupère le dossier Contacts par défaut
    Set MonDossier = MonNamespace.GetDefaultFolder(olFolderContacts)
    'Affichage d'outlook dans le dossier
    MonDossier.Display
    'Vide les instances
    Set fsoObject = Nothing
    Set fldDossier = Nothing
    Set MonNamespace = Nothing
    Set MavCard = Nothing
    Set MonDossier = Nothing
    MsgBox "Terminé"
End Sub

Sub ImportMultipleVcf()
    Dim toggle As Boolean
    Dim card As ContactItem
    Dim app As New Outlook.Application
    Dim namespace As Outlook.namespace
    Dim temporary_filename As String
    toggle = False
    temporary_filename = "c:\temp\tmp.vcf"
    Set namespace = app.GetNamespace("MAPI")
    ' Changer ici le nom du fichier vcf multiple issu de Palm Desktop
    Open "c:\temp\all.vcf" For Input As #1
    Do While Not EOF(1)
        Line Input #1, inputdata
        If inputdata = "BEGIN:VCARD" Then
            toggle = True
            Open temporary_filename For Output As #2
        End If
        If toggle Then Print #2, inputdata
        If inputdata = "END:VCARD" Then
            Close #2
            toggle = False
            Set card = namespace.OpenSharedItem(temporary_filename)
            card.Save
        End If
    Loop
    Close #1
End Sub

Private Sub MAJ()
'Connect to Ms Outlook
    Dim objOutlook As Outlook.Application
    Dim objFolder As Outlook.MAPIFolder
    Dim objAllContacts As Outlook.Items
    Dim Contact As Outlook.ContactItem
    Dim newContact As Object
    Dim prenom As String
    Dim nom As String
    Dim mail As String
    Set objOutlook = CreateObject("Outlook.Application")
    Set objFolder = objOutlook.GetNamespace("MAPI")
    objFolder.Logon
    'connect to MySQL server using MySQL ODBC 3.51 Driver
    Dim conn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim sql As String
    Set conn = New ADODB.Connection
    conn.ConnectionString = "DRIVER={MySQL ODBC 3.51 Driver};" _
                          & "SERVER=localhost;" _
                          & "DATABASE=gestion_email;" _
                          & "UID=venu;PWD=venu; OPTION=3"
    'open Database
    conn.Open
    Set rs = New ADODB.Recordset
    rs.Open "SELECT * FROM adresse", conn
    Debug.Print rs.RecordCount
    rs.MoveFirst
    Debug.Print String(50, "-") & "Updated my_ado Result Set " & String(50, "-")
    For Each fld In rs.Fields
        Set newContact = objOutlook.CreateItem(olContactItem)
        Debug.Print
        newContact.FullName = fld.nom
        newContact.FirstName = neContact.fld.prenom
        newContact.Email1Address = fld.Adresse_mail
    Next fld
    Debug.Print
End Sub

Sub ExportCalendrier_ics()
'---------------------------------------------------------------------------------------
' Procédure : ExportCalendrier_ics
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 08/04/2008
' Détail    : Exporte le calendrier par défaut dans un fichier ics
'---------------------------------------------------------------------------------------
'***************************************
'* NE FONCTIONNE QUE SOUS OUTLOOK 2007 *
'***************************************
 
    'Déclaration des objets
    Dim nsMAPI As NameSpace
    Dim fldDossier As Folder
    Dim cldExport As CalendarSharing
 
    'Instance des objets
    Set nsMAPI = Application.GetNamespace("MAPI")
    Set fldDossier = nsMAPI.GetDefaultFolder(olFolderCalendar)
 
    'Instancie le dossier Calendrier pour l'export
    Set cldExport = fldDossier.GetCalendarExporter
 
    'instance de l'objet Calendrier (dossier)
    With cldExport
        'information de disponibilité
        .CalendarDetail = olFullDetails
        'N'exporte que les éléments situés dans les horaires de travail
        .RestrictToWorkingHours = True
        'Exclu les pièces jointe
        .IncludeAttachments = False
        'Ajoute les éléments privés
        .IncludePrivateDetails = True
        'Sauvegarde le fichier au chemin définit
        .SaveAsICal "C:\MonCalendrier.ics"
    End With
 
    'vide les instances
    Set cldExport = Nothing
    Set fldDossier = Nothing
    Set nsMAPI = Nothing
 
End Sub

Sub Export_CalendrierCSV()
'---------------------------------------------------------------------------------------
' Procédure : Export_CalendrierCSV
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 09/04/2008
' Détail    : Permet d'exporter le calendrier sous forme CSV
'---------------------------------------------------------------------------------------
'
'Quelques explications :
' - Création d'un fichier au format csv (séparation avec des ;).
'
' - Crétaions des entêtes de colonnes.
'
' - Définition si élément sur une journée, dans ce cas on met une croix dans la première colonne
'   et on ne met que la date de l'événement, sinon on met rien dans la première colonne mais on
'   charge les colonne Date et heure de début ainsi que dtae et heure de fin.
'
' - On charge ensuite le Sujet, la Description
'
' - La Priorité     0 -> faible importance
'                   1 -> moyenne importante
'                   2 -> haute importance
'
' - La Catégorie.
'
' - La Disponibilité  0 -> disponible
'                     1 -> rendez-vous provisoire
'                     2 -> occupé
'                     3 -> absent
'
' - La classification de l'élément  0 -> Normal
'                                   1 -> Personnel
'                                   2 -> Privé
'                                   3 -> Confidentiel
'
    'Déclarations des variables et objets
    Dim objApply As Outlook.Application
    Dim objNameSpace As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Dim objCalendrier As Outlook.AppointmentItem
    Dim intNbr As Integer
    Dim strStream As String
    Dim objFSO As New Scripting.FileSystemObject
    Dim fsoFichier As Scripting.TextStream
 
    'Instance et création du fichier texte
    Set fsoFichier = objFSO.CreateTextFile("C:\test.csv", True)
    'Chargement des entêtes de colonnes
    strStream = "Evénement sur une journée;Date Début;Heure Début;Date Fin;Heure Fin;Sujet;Description;Lieu;" & _
                "Organisateur;Priorité;Catégorie;Dispo;Classification"
    'Ecriture dans le fichier
    fsoFichier.WriteLine (strStream)
    'Instance des objets Outlook
    Set objApply = Outlook.Application
    Set objNameSpace = objApply.GetNamespace("MAPI")
    Set objFolder = objNameSpace.GetDefaultFolder(olFolderCalendar)
    'Boucle en focnction du nombre d'éléments
    For intNbr = 1 To objFolder.Items.Count
        'Instance du Calendrier
        Set objCalendrier = objFolder.Items.Item(intNbr)
        'Teste si élément sur un journée
        If objCalendrier.AllDayEvent = True Then
            'si sur 1 journée
            strStream = "X;" & Format(objCalendrier.Start, "dd/mm/yyyy") & ";;;;"
        Else
            'pas sur 1 journée
            strStream = ";" & Format(objCalendrier.Start, "dd/mm/yyyy") & ";" & Format(objCalendrier.Start, "hh:mm") & ";" & _
                        Format(objCalendrier.End, "dd/mm/yyyy") & ";" & Format(objCalendrier.End, "hh:mm") & ";"
        End If
        'Chargement dans la variable de la partie commune
        strStream = strStream & objCalendrier.Subject & ";" & objCalendrier.Body & ";" & objCalendrier.Location & ";" & _
                    objCalendrier.Organizer & ";" & objCalendrier.Importance & ";" & objCalendrier.Categories & ";" & _
                    objCalendrier.BusyStatus & ";" & objCalendrier.Sensitivity
        'Ecriture dans le fichier
        fsoFichier.WriteLine (strStream)
    Next
    'Fermeture du fichier
    fsoFichier.Close
    'Message de fin d'export
    MsgBox "Export terminé"
End Sub

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'---------------------------------------------------------------------------------------
' Procédure : Application_NewMailEx
' Auteur    : Dolphy35
' Site      : http://dolphy35.developpez.com
' Détail    : Permet de déplacer le nouveau message si celui-ci est envoyé par un expéditeur précis
'---------------------------------------------------------------------------------------
'
    'Déclartions
    Dim MonApp As Outlook.Application
    Dim MonMail As Object
    Dim MonNameSpace As Outlook.NameSpace
    Dim MonDossier As Outlook.Folder
    
    'Instance des variables
    Set MonApp = Outlook.Application
    Set MonNameSpace = MonApp.GetNamespace("MAPI")
    Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox)
    Set MonMail = Application.Session.GetItemFromID(EntryIDCollection)
    
        'Test si l'expéditeur correpond dans ce cas on déploce le mail
        'vers le dossier Temp de votre boîte de réception
        If MonMail.SenderEmailAddress = "personne@domaine.fr" Then
            MonMail.Move MonDossier.Folders("Temp")
        End If
        
End Sub

Sub CreateDossier()

    Dim monOutlook As New Outlook.Application
    Dim ns As namespace
    Dim dossier As MAPIFolder
    Dim myNewFolder As MAPIFolder

    Set ns = monOutlook.GetNamespace("MAPI")
    Set dossier = ns.Folders("Dossiers personnels").Folders("Boîte de réception")
    Set myNewFolder = dossier.Folders.Add("Test")

End Sub

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub script(MyMail As MailItem)
    Set fichier = MyMail.Attachments
    Repertoire = "C:\temp\"
    fichier(1).SaveAsFile Repertoire & fichier(1).FileName
    ShellExecute 0, "print", fichier(1).FileName, "", Repertoire, 0
End Sub

Sub test_script()
    Dim Oitem As Outlook.MailItem
    Set Oitem = ActiveInspector.CurrentItem
    script Oitem
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procédure : Application_ItemSend
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 07/05/2008
' Détail    : Déplace le mail envoyé vers le dossier "dolphy_essais"
'---------------------------------------------------------------------------------------
'
'Déclarations des objets
    Dim objNSpace As namespace
    Dim fldDestination As MAPIFolder
    'Test si l'élément envoyé est un E-mail
    If Not Item.Class = olMail Then Exit Sub
    'Instance des objets
    Set objNSpace = Application.GetNamespace("MAPI")
    Set fldDestination = objNSpace.Folders("Dossiers personnels").Folders("Boîte de réception").Folders("dolphy_essais")
    Set Item.SaveSentMessageFolder = fldDestination

    'Vide des instances
    Set objNSpace = Nothing
    Set fldDestination = Nothing

End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procédure : Application_ItemSend
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 07/05/2008
' Détail    : Déplace le mail envoyé vers le dossier "dolphy_essais"
'---------------------------------------------------------------------------------------
'
'Déclarations des objets
    Dim objNSpace As namespace
    Dim fldDestination As MAPIFolder
    'Test si l'élément envoyé est un E-mail
    If Not Item.Class = olMail Then Exit Sub
    'Instance des objets
    Set objNSpace = Application.GetNamespace("MAPI")
    Set fldDestination = objNSpace.PickFolder
    Set Item.SaveSentMessageFolder = fldDestination

    'Vide des instances
    Set objNSpace = Nothing
    Set fldDestination = Nothing

End Sub

Private Sub Application_ItemContextMenuDisplay( _
        ByVal CommandBar As Office.CommandBar, _
        ByVal Selection As Selection)

    Dim objButton As CommandBarButton
    Dim intButtonIndex As Integer
    Dim intCounter As Integer

    'Test si 1 seul mail est sélectionné
    If Selection.Count = 1 Then
        'Test si la sélection correspond à un E-mail
        If Selection.Item(1).Class = olMail Then
            Set objButton = CommandBar.Controls.Add( _
                            msoControlButton, , , , True)
            With objButton
                .Style = msoButtonIconAndCaption
                .Caption = "Infos sur le Mail"
                .FaceId = 463
                .OnAction = "Projet 1.ThisOutlookSession.InfosMail"
            End With
        End If
    End If

End Sub

'Déclare l'objet comme jeu d'objets correspondant aux pièces jointes sélectionnées
Dim objAttachments As AttachmentSelection

Private Sub Application_AttachmentContextMenuDisplay( _
        ByVal CommandBar As Office.CommandBar, _
        ByVal Attachments As AttachmentSelection)
'---------------------------------------------------------------------------------------
' Procédure : Application_AttachmentContextMenuDisplay
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 24/04/2008
' Détail    : Création d'un contrôle dans le menu contextuel des pièces jointes et
'             affecte une macro
'---------------------------------------------------------------------------------------
'
'Déclaration de l'objet en tant que bouton de commande
    Dim objButton As CommandBarButton
    'Instancie à l'objet la sélection des pièces jointes
    Set objAttachments = Attachments
    'Instancie l'objet en tant que nous nouveau contrôle : Bouton
    Set objButton = CommandBar.Controls.Add( _
                    msoControlButton, , , , True)
    'Paramétrage du nouveau bouton
    With objButton
        .Style = msoButtonIconAndCaption    'Icône + commentaire
        .Caption = "Test"    'Commentaire
        .FaceId = 355    'ID de l'icône du bouton
        .OnAction = "Projet 1.ThisOutlookSession.InfosPJ"    'Affectation de la macro au bouton lors du clic
    End With
End Sub

Sub InfosPJ()
'---------------------------------------------------------------------------------------
' Procédure : msgtest
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 24/04/2008
' Détail    : Affiche dans une boite de dialogue le nom des pièces jointes
'             sélectionnées ainsi que la taille en octets
'---------------------------------------------------------------------------------------
'
'Déclaration des objets et variables
    Dim objAttachment As Attachment
    Dim strTemp As String
    'initialisation de la variable
    strTemp = ""
    'boucle permettant de sortir les pièces jointes du jeu de sélection des pièces jointes
    For Each objAttachment In objAttachments
        'Objet pièce jointe
        With objAttachment
            strTemp = "Nom : " & .FileName    'nom de la pièce jointe
            strTemp = strTemp & vbCr & "Taille : " & .Size & " octets"    'taille de la pièce jointe
        End With
        'affichage des infos de la pièce jointe contenus dans la variable.
        MsgBox strTemp
    Next
End Sub

Sub CreationReunion()
'---------------------------------------------------------------------------------------
' Procédure : CreationReunion
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 2008-09-08
' Détail    : Création d'une nouvelle réunion
'---------------------------------------------------------------------------------------
'
'Déclaration des objets
    Dim objOutlook As Outlook.Application
    Dim objReunion As Outlook.AppointmentItem
 
    'Instance des Objets
    Set objOutlook = Outlook.Application    'Instance de l'application
    Set objReunion = objOutlook.CreateItem(olAppointmentItem)  'Instance de la nouvelle entrée du calendrier
    
    'définition de la réunion
    With objReunion
        .MeetingStatus = olMeeting
        .Subject = "Sujet de la réunion"  'Sujet de la réunion
        .Location = "Mon Bureau"  'Lieu de la réunion
        .Recipients.Add ("email@fai.fr") 'destinataire de la réunion
        .Display  'affichage de la réunion
    End With
    
    'Vide des instances
    Set objOutlook = Nothing
    Set objReunion = Nothing

End Sub

Private Sub Application_Startup()
'---------------------------------------------------------------------------------------
' Procédure : Application_Startup
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 2008-09-08
' Détail    : Création d'un controle dans le menu d'Outlook
'---------------------------------------------------------------------------------------
'
'Déclarations desobjets
    Dim objExplorer As Outlook.Explorer
    Dim objCommandBar As Office.CommandBar
    Dim objControl As Office.CommandBarButton
 
    'instance des objets
    Set objExplorer = Outlook.ActiveExplorer
    Set objCommandBar = objExplorer.CommandBars.Item("Menu Bar")
    Set objControl = objCommandBar.Controls.Add(, , , , True)
 
    'objet Control
    With objControl
        .Caption = "Cliquez ici ..."
        .FaceId = 463
        .Style = msoButtonIconAndCaption
        .Tag = "Test Bouton"
        .OnAction = "TestBouton"
        .Visible = True
    End With
 
    'libération des instances
    Set objExplorer = Nothing
    Set objCommandBar = Nothing
    Set objControl = Nothing
    
End Sub

Sub TestBouton()

    MsgBox "Vous venez de cliquez sur le bouton"
    
End Sub

Public Sub ListeBarreOutils()
'---------------------------------------------------------------------------------------
' Procédure : ListeBarreOutils
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 2008-09-08
' Détail    : Permet de lister les barre d'outils et menu d'Outlook
'---------------------------------------------------------------------------------------
'
'déclaration de l'objet CommandBar
    Dim objCommandBar As Office.CommandBar
    'boucle liste les barres et menu
    For Each objCommandBar In Application.ActiveExplorer.CommandBars
        Debug.Print objCommandBar.Name    'affichage du nom dans la fenêtre d'exécution
    Next objCommandBar
End Sub

Sub OpenFenContacts()
    Dim CBp As Variant
    Set CBp = ActiveInspector.CommandBars.FindControl(, 353)    'carnet d'adresse
    CBp.Execute
End Sub

Dim WithEvents colRDVItems As items
 
Private Sub Application_Startup()
Dim NS As Outlook.namespace
Set NS = Application.GetNamespace("MAPI")
Set colRDVItems = NS.GetDefaultFolder(olFolderCalendar).items
Set NS = Nothing
End Sub

Private Sub colRDVItems_ItemAdd(ByVal Item As Object)
'By Oliv ' janv 2008 pour Outlook 2003 feat. Sue Mosher
'http://www.outlookcode.com/codedetail.aspx?id=456
    If Item.Class = olAppointment Then
        If Item.Subject = "" Then
            Item.Display
            MsgBox "vous devez indiquer un objet"
        End If
    End If
End Sub
 
Private Sub colRDVItems_ItemChange(ByVal Item As Object)
'By Oliv ' janv 2008 pour Outlook 2003 feat. Sue Mosher
'http://www.outlookcode.com/codedetail.aspx?id=456
    If Item.Class = olAppointment Then
        If Item.Subject = "" Then
            Item.Display
            MsgBox "vous devez indiquer un objet"
        End If
    End If
End Sub

Sub PilotageExcel ()
'Déclaration des variables
        Dim appExcel As Excel.Application    'Application Excel
        Dim wbExcel As Excel.Workbook    'Classeur Excel
        Dim wsExcel As Excel.Worksheet    'Feuille Excel
        Dim xlmacroBook As Excel.Workbook
        Dim MavarXL
 
        'Ouverture de l'application
        Set appExcel = CreateObject("Excel.Application")
        appExcel.Visible = False
        'Ouverture d'un fichier Excel
        Set wbExcel = appExcel.Workbooks.Open(Repertoire & "monfichier.xls")
        'wsExcel correspond à la première feuille du fichier
        Set wsExcel = wbExcel.Worksheets(1)
'ici la macro est dans un fichier différent
        Set xlmacroBook = appExcel.Workbooks.Open("\c:\temp\MonfichierMACRO.xls", 0, 1)
'je lance la macro ouverture avec un paramétre
          MavarXL = appExcel.Run(xlmacroBook.Name & "!ouverture", Left(CStr(ObjCurrentMessage.ReceivedTime), 10))
End Sub