IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)

FAQ MS-Outlook (Toutes Versions)

FAQ MS-Outlook (Toutes Versions)Consultez toutes les FAQ

Nombre d'auteurs : 15, nombre de questions : 199, dernière mise à jour : 21 juin 2021 

 
OuvrirSommaireVBA


Le code qui suit va s'exécuter lors de chaque arrivée de message dans la boîte de réception.
Les actions qui vont être exécutées sont :
Sauvegarde en fichier txt du message dans le dossier c:\temp
Transfert du message dans un dossier temporaire situé dans le dossier Boîte de réception.

 
Sélectionnez
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
Créé le 10 mai 2007  par Olivier LEBEAU

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Le code suivant vous permet de sauvegarder les pièces jointes d'un message, ou d'une sélection sans ouvrir ce message. Il efface après sauvegarde les
pièces jointe du Mail

 
Sélectionnez
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
Créé le 12 mai 2007  par Olivier LEBEAU

Lien : Comment enregistrer les pièces jointe d'un mail sur une règle à la réception d'un mail ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

 
Sélectionnez
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
Créé le 6 octobre 2007  par Oliv'

Lien : Comment sauvegarder une sélection de mails au format msg sans code ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY


Ce code est à copier dans This Outlook Session.

 
Sélectionnez
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
Créé le 6 octobre 2007  par Oliv'

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

 
Sélectionnez
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


On peut par exemple ajouter un texte au titre du message.

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


On peut extraire d'autres données que le sujet.
On peut également agir sur le message, le sauver

 
Sélectionnez
oMail.SaveAs
Créé le 14 décembre 2007  par Olivier LEBEAU

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

L'évènement qui permet l'exécution d'un code lors de l'envoi d'un message est ItemSend. Ce code est à placer dans ThisOutlookSession.

 
Sélectionnez
Public Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
MsgBox "Envoi d'un mail"
End Sub
Créé le 14 décembre 2007  par Olivier LEBEAU

Lien : Initiation au VBA d'Outlook, par Morgan BILLY


Dans les options, vous pouvez définir comment vous devez être averti de la réception d'un nouveau message. Cependant, il n'existe qu'une seule possibilité sonore : un beep.
En recourant à VBA, il est possible de jouer n'importe quel son, par exemple un fichier wav.

Dans un premier temps il faut désactiver l'avertissement sonore, pour cela il faut décocher la case "émettre un signal sonore" dans les options de messagerie.

Image non disponible


Ensuite dans l'éditeur VBE :

1 - Créer un module dans lequel nous allons écrire l'API suivante :

Déclaration de l'API
Sélectionnez
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
                                                                             ByVal uFlags As Long) As Long


2 - Ensuite sur l'évènement NewMail de l'objet application nous allons écrire :

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


Lors de la réception d'un message vous allez maintenant entendre une sonnerie de téléphone. A vous de mettre le son que vous voulez.

Testé sous Office 2002 et Office 2007

Créé le 14 décembre 2007  par Philippe JOCHMANS

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Pour renvoyer les mails sélectionnés dans un dossier à leur destinataire d'origine utilisez le code ci-dessous :

 
Sélectionnez
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

Si vous voulez réexpédier le mail ouvert à son destinatire utilisez ce code

 
Sélectionnez
Sub controle_meeting()
    Dim oitem
    Set oitem = ActiveInspector.CurrentItem
    oitem.Send
End Sub
Créé le 14 décembre 2007  par Oliv', Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Ce code est à ajouter dans le module ThisOutlookSession

 
Sélectionnez
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
Créé le 14 décembre 2007  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY
Lien : Comment obliger la saisie d'un sujet en VBA ?

Ce code permet de tester l'existence d'une adresse E-mail d'un contact contenu dans votre carnet d'adresses.
Collez ce code dans un module et appelez la fonction en passant en paramètre l'E-mail à tester. Celle-ci retourne True en cas de succès de la recherche.

 
Sélectionnez
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
Créé le 14 décembre 2007  par Oliv'

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Ce code permet d'ouvrir un boîte de sélection afin de choisir la destination de sauvegarde de l'E-mail envoyé.
Si rien n'est sélectionné, par défaut il sera enregistré sous 'Dossiers personnels' -> 'Divers'

Code à placer dans le Module ThisOutlookSession

 
Sélectionnez
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
Créé le 14 décembre 2007  par Oliv'

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Pour ce faire nous allons utiliser le presse papier de Windows, il suffit de réaliser un copier de code HTML depuis votre éditeur.
Ensuite exécutez la procédure suivante afin de définir votre code HTML en tant que contenu

N'oubliez pas d'activer la référence 'Microsoft Form 2.0 Object Library'

 
Sélectionnez
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
Créé le 14 décembre 2007  par Oliv'

Lien : Comment activer une référence VBA dans l'éditeur Outlook ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY
Lien : Les modèles et papiers à lettres sous Outlook, par Morgan BILLY

Pour activer une référence dans un projet Outlook :
1- Ouvrez votre éditeur de code (VBE) -> Outils -> Macro -> Visual Basic Editor (ALT+F11)

Image non disponible



2- Dans le menu Outils -> sélectionnez 'Références' -> Sélectionnez la référence voulue dans la liste jointe, il vous est possible dans ajouter par le bouton
'Parcourir'
Conseil : placez les fichiers dll dans le répertoire Système de votre poste, car une fois installée vous ne devez pas la déplacer.

Image non disponible
Image non disponible
Créé le 14 décembre 2007  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Ce code permet de changer la valeur de 'speller' dans la base de registre

Attention toutefois, veillez à renseigner la bonne version d'Outlook

 
Sélectionnez
' 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
Créé le 14 décembre 2007  par Oliv'

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

A copier dans ThisOutlookSession
il y a 3 vérifications :
1. au-delà de 3 Mo on demande de zipper
2. au-delà de 5 Mo on demande de confirmer l'envoi
3. au-delà de 10 Mo envoi impossible.

Si vous n'avez rien pour zipper commentez le bloc if de la première vérification

 
Sélectionnez
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
Créé le 14 décembre 2007  par Oliv'

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Lors de la définition des règles d'Outlook, vous avez la possibilité d'exécuter un script à la réception d'un mail.

Pour de plus amples renseignements concernant la création de règles, je vous invite à consulter le tutoriel d'Olivier LEBEAU

Important votre script doit avoir comme argument l'objet MailItem, ci-dessous un code qui permet d'afficher une boîte de dialogue affichant le nom de l'éxpéditeur et le sujet du mail.

 
Sélectionnez
Sub script(Mail As MailItem)

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

End Sub

La macro s'affichera dans la boîte de dialogue lors de la sélection du Script.

Image non disponible



"action personnalisée" n'est pas la même chose qu' exécuter un script, cela fait référence à des actions disponible dans des ADDIN type dll ou exe.

Créé le 14 décembre 2007  par Morgan BILLY, Oliv'

Lien : Créez des règles pour Outlook
Lien : Comment créer un script dans une règle d'arrivée d'un message ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Voici une autre façon de faire cela en contrôlant les doublons des PJ et si la PJ est une PJ incorporée dans le mail (comme les images) ou non.

A partir de 2003 préférer l'événement NewMailEx pour ne pas parcourir tout le dossier ou l'exécution d'un script sur une règle.
"Cet événement se produit lors de la réception d'un ou plusieurs éléments dans la Boîte de réception.
Cet événement transmet une liste d'identificateurs d'entrée de tous les éléments reçus dans la Boîte de réception depuis le dernier déclenchement de l'événement."

Copiez ce code dans un module. Puis créez une règle à l'arrivée d'un nouveau message selon les conditions que vous souhaitez et
choisissez comme action Exécuter un script + arrêter de traiter plus de règles.
Dans cet exemple le répertoire C:\TEMP\pj doit exister.
Vous devez aussi référencer Microsoft CDO 1.21 Library dans VBE.

 
Sélectionnez
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
Créé le 2 mai 2008  par Oliv'

Lien : Comment activer une référence VBA dans l'éditeur Outlook ?
Lien : Comment sauvegarder les pièces jointes d'un message sans ouvrir ce message ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Ce code doit être exécuté avec un E-mail ouvert

 
Sélectionnez
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
Créé le 2 mai 2008  par Oliv'

Lien : Initiation au VBA d'Outlook, par Morgan BILLY


Ci-joint une fonction qui permet de récupérer une liste d'adresses en fonction d'une catégorie passée en paramètre.
Il vous suffit de bien catégoriser vos contacts et cette fonction pourra créer une liste de diffusion pour une catégorie entière.

 
Sélectionnez
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




Autre possibilité en appelant la Méthode Restrict

 
Sélectionnez
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




Pour appeler ces fonctions il vous suffit de créer une procédure en passant comme paramètre la catégorie

 
Sélectionnez
Sub test()

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




Pour lister les contacts d'un dossier Publique (utilisation avec MS Exchange), il vous suffit de modifier la constante de GetDefaultFolder en mettant olPublicFoldersAllPublicFolders

Créé le 2 mai 2008  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Ci-joint vous trouverez un code à ajouter dans ThisOutlookSession vous permettant de déclencher un événement lors de la création ou modification d'une tâche :

 
Sélectionnez
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
Créé le 2 mai 2008  par wape

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

En passant par VBA, il vous est possible de déplacer en masse les E-mails d'un expéditeur précis contenu dans la boîte de réception vers un dossier précis.

 
Sélectionnez
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

Pour utiliser cette fonction il vous suffit de l'appeler et de lui passer en paramètres le nom de l'expéditeur et du dossier de destination

 
Sélectionnez
Sub test()
 
   DeplacerMessage "dolphy", "dolphy_essais"
 
End Sub
Créé le 2 mai 2008  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Vous trouverez ci-joint une procédure permettant d'importer des fichiers vCard contenus dans un dossier.

Code ne fonctionnant qu'avec Outlook 2007, car la méthode OpenSharedItem n'est disponible que depuis la suite office 2007

 
Sélectionnez
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


Pour Outlook 2003, veuillez utiliser ce code modifié par Oliv -

 
Sélectionnez
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
Créé le 2 mai 2008  par Morgan BILLY, Oliv'

Lien : Comment importer des fichiers VCF multiples issus de Palm Desktop ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Ci-joint une procédure permettant d'importer des fichiers vcf issus de Palm Desktop.

 
Sélectionnez
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
Créé le 2 mai 2008  par hibou78

Lien : Comment importer des fichiers VCF multiples issus de Palm Desktop ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Pour utiliser cette procédure il vous faut activer la référence Microsoft ADO

 
Sélectionnez
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
Créé le 2 mai 2008  par pbatty1

Lien : Comment activer une référence VBA dans l'éditeur Outlook ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Le code suivant permet d'exporter votre calendrier sous un fichier *.ics

 
Sélectionnez
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

Ce code ne fonctionne qu'avec Outlook 2007

Créé le 2 mai 2008  par Morgan BILLY

Lien : Comment exporter le calendrier sous un fichier de type csv ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Ce code permet d'exporter votre calendrier sous un fichier de type csv, l'avantage de cet export est que vous pouvez reprendre le fichier généré sous MS Excel :

 
Sélectionnez
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
Créé le 2 mai 2008  par Morgan BILLY

Lien : Comment exporter le calendrier sous un Fichier ics ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

L'exemple suivant permet lors de l'arrivée d'un nouvel E-mail de tester l'adresse de l'expéditeur et si celui-ci correspond à notre occurrence nous déplaçons le message vers le dossier Temp :

 
Sélectionnez
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
Créé le 2 mai 2008  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Le code ci-dessous permet de créer un dossier nommé test dans la boîte de réception :

 
Sélectionnez
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
Créé le 8 septembre 2008  par Oliv'

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Le code suivant permet d'imprimer la pièce jointe d'un E-mail arrivant dans la boîte de réception. Pour cela nous utiliserons une API ainsi qu'une règle sur l'arrivée d'un E-mail.

Dans un premier temps il vous faut déclarer un nouveau module dans votre projet, puis y déclarer l'API, ensuite vous collez la macro Script

 
Sélectionnez
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

Vous pouvez tester ce code directement depuis un mail ouvert en exécutant cette macro :

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

Pour exécuter cette macro lors d'une règle je vous invite à consulter les liens ci-dessous.

Créé le 8 septembre 2008  par Oliv'

Lien : Créez des règles pour Outlook
Lien : Comment créer un script dans une règle d'arrivée d'un message ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Lors d'un envoi d'E-mail Outlook permet de créer sur une règle une copie du Mail dans un dossier spécifique, maintenant si vous désirez déplacer l'E-mail vers un dossier spécifique vous devez le faire par le biais d'une macro.

Placez dans le module de classe ThisOutlookSession le code suivant :

 
Sélectionnez
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

Vous pouvez avec ce même code demander le dossier de destination par le biais d'une boîte de dialogue en sélectionnant un dossier. Pour cela nous utiliserons la méthode PickFolder :

 
Sélectionnez
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
Créé le 8 septembre 2008  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Oui, il est possible d'ajouter un nouveau contrôle dans le menu contextuel lors d'un clic droit sur un élément comme un message. Pour cela nous utiliserons l'événement ItemContextMenuDisplay de l'objet Application du module de classe ThisOutlookSession

Ce code ne fonctionne que sous Outlook 2007

 
Sélectionnez
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

Lors du clic sur le nouveau contrôle du menu contextuel vous exécuterez la macro InfosMail.

Créé le 8 septembre 2008  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY
Lien : Comment ajouter un contrôle dans le menu d'Outlook ?
Lien : Est-il possible de personnaliser le menu contextuel "Pièce jointe" d'un message sous Outlook 2007 ?

Oui, il est possible de personnaliser le menu contextuel d'une pièce jointe dans un message, pour cela nous utiliserons une nouveauté d'Outlook 2007 : l'événement AttachmentContextMenuDisplay de l'objet Apllication dans le module de classe ThisOutlookSession. Cet événement se déclenche avant l'ouverture du menu contextuel correspondant au jeu de collection de pièces jointes.

Pour créer un nouveau contrôle dans ce menu contextuel utiliser le code suivant :

Ce code ne fonctionne que sous Outlook 2007

 
Sélectionnez
'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

Lors du clic sur le nouveau contrôle du menu contextuel, vous exécuterez la macro InfosPJ.

 
Sélectionnez
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
Créé le 8 septembre 2008  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY
Lien : Comment ajouter un contrôle dans le menu d'Outlook ?
Lien : Est-il possible de personnaliser le menu contextuel lors d'un clic droit sur un message avec Outlook 2007 ?

La création d'une réunion en VBA ressemble beaucoup à la création d'un rendez-vous :

 
Sélectionnez
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
Créé le 8 septembre 2008  par Morgan BILLY

Lien : Comment créer une réunion ?
Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Il peut s'avérer intéressant de créer un bouton dans la barre de menus d'Outlook ou bien dans une des barres d'outils, ceci dans le but de donner un accès rapide à une macro que vous avez créée. La création de contrôle diffère légèrement des autres applications d'Office. Le code suivant crée un bouton et lors du clic exécute la Macro TestBouton :

 
Sélectionnez
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



Placez le code suivant dans un nouveau Module :

 
Sélectionnez
Sub TestBouton()

    MsgBox "Vous venez de cliquez sur le bouton"
    
End Sub
Créé le 8 septembre 2008  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY
Lien : Est-il possible de personnaliser le menu contextuel lors d'un clic droit sur un message avec Outlook 2007 ?
Lien : Est-il possible de personnaliser le menu contextuel "Pièce jointe" d'un message sous Outlook 2007 ?

Le code suivant permet de lister dans la fenêtre d'exécution les barres de menus et d'outils d'Outlook :

 
Sélectionnez
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
Créé le 8 septembre 2008  par Morgan BILLY

Lien : Initiation au VBA d'Outlook, par Morgan BILLY

Ajouter le code ci-dessous dans un nouveau module, il vous suffit d'exécuter celui-ci depuis un nouveau message. La fenêtre de sélection de contact comme destinataire du message s'ouvrira

 
Sélectionnez
Sub OpenFenContacts()
    Dim CBp As Variant
    Set CBp = ActiveInspector.CommandBars.FindControl(, 353)    'carnet d'adresse
    CBp.Execute
End Sub
Créé le 8 septembre 2008  par Oliv'

Pour obliger la saisie d'un sujet d'un élément lors de son enregistrement, placez le code ci-dessous dans le Module ThisOutlookSession.
Ce code correspond pour une entrée dans le calendrier mais il est possible de l'adapter pour les autres éléments

A partir d'Outlook 2007, il existe un événement ItemLoad qui facilite ce contrôle, pour plus d'informations consultez le lien ci-dessous.

 
Sélectionnez
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
Créé le 8 septembre 2008  par Oliv'

Lien : Initiation au VBA d'Outlook, par Morgan BILLY
Lien : Comment obliger la saisie d'un sujet en VBA ?

Pour ouvrir un fichier Excel et exécuter une macro d'un autre fichier Excel, copiez ce code dans un nouveau Module :

 
Sélectionnez
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
Créé le 8 septembre 2008  par Oliv'

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2009 Developpez Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.