Initiation au VBA d'Outlook

strVariable = "Bonjour"

Sub Variable()

    Dim strVariable As String
    Dim strDate As String
    Dim strResultat As String
    
    strVariable = "Bonjour, nous sommes le "
    strDate = "29/03/2008"
    strResultat = strVariable & strDate
    
    MsgBox strResultat
    
End Sub

Sub Variable()

    Dim strVariable As String
    Dim dtmDate As Date
    Dim strResultat As String
    
    strVariable = "Bonjour, nous sommes le "
    dtmDate = Date
    strResultat = strVariable & dtmDate
    
    MsgBox strResultat
    
End Sub

Sub Variable()

    Const strConstante As String = "Bonjour, nous sommes le "
    Dim dtmDate As Date
    Dim strResultat As String
    
    dtmDate = Date
    strResultat = strConstante & dtmDate
    
    MsgBox strResultat
    
End Sub

MsgBox(prompt[, buttons] [, title] [, helpfile, context])

MsgBox "Voulez-vous réellement vider ce dossier ?", vbYesNo + vbInformation, "ATTENTION"

If MsgBox("Voulez-vous réellement vider ce dossier ?", _
              vbYesNo + vbInformation, "ATTENTION") = vbYes Then
        'Code à réaliser car l'utilisateur à répondu Yes
    End If

MsgBox "Première ligne" & vbCr & "Seconde ligne" & Chr(13) & "Troisième ligne"

InputBox(prompt[, title] [, default] [, xpos] [, ypos] [, helpfile, context])

Dim strRetourInput As String
strRetourInput = InputBox("Bonjour," & vbCr & "Quel âge avez-vous ?", "Demande d'âge")

Dim strRetourInput As String
strRetourInput = InputBox("Bonjour," & vbCr & "Quel âge avez-vous ?", "Demande d'âge", 0)

Sub EssaisCode()
'Déclaration variable
    Dim strRetourInput As String
    'Affichage InputBox
    strRetourInput = InputBox("Bonjour," & vbCr & "Quel âge avez-vous ?", "Demande d'âge", 0)
    'Test si chaîne Vide
    If strRetourInput = "" Then
        'Chaîne Vide
        MsgBox "Action annulée par l'utilisateur ou bien aucune saisie de l'utilisateur."
    Else
        'Chaîne non vide
        MsgBox strRetourInput
    End If
End Sub

If condition Then Instruction

Sub EssaisCode()
    Const blnTest As Boolean = True
    If blnTest = True Then MsgBox "La valeur est vraie"
End Sub

If Condition Then
        'Instruction si condition Vraie
    Else
        'Instruction si condition Fausse
    End If

If Condition Then
        'Instruction si condition Vraie
    ElseIf Condition2 Then
        'Instruction si condition Fausse
    End If

If Condition Then
        'Instruction si condition Vraie
    ElseIf Condition2 Then
        'Instruction si condition Fausse
    Else
        'Instruction si aucune condition n'est vraie
    End If

If Condition Then
        'Instruction si Condition est vraie
        If Condition2 Then
            'Instruction si Condition est vraie et Condition2 est vraie
        Else
            'Instruction si Condition est vraie et Condition2 est fausse
        End If
    Else
        'Instruction si Condition est fausse
    End If

Select Case Condition
    Case 1
        'Instruction si Condition = 1
    Case 2
        'Instruction si Condition = 2
    Case 3
        'Instruction si Condition = 3
    Case 4
        'Instruction si Condition = 4
    Case Else
        'Instruction si Condition n'est égale avec aucun test
    End Select

    Select Case Condition
    Case Is <= 10
        'Instruction si Condition est strictement inférieure ou égale à 10
    Case Is <= 20
        'Instruction si Condition est strictement inférieure ou égale à 20
    Case Is <= 30
        'Instruction si Condition est strictement inférieure ou égale à 30
    Case Is <= 40
        'Instruction si Condition est strictement inférieure ou égale à 40
    Case Else
        'Instruction si Condition n'est égale avec aucun test
    End Select

Select Case Condition
    Case Is <= 10
        'Instruction si Condition est strictement inférieure ou égale à 10
    Case Is <= 20
        'Instruction si Condition est strictement inférieure ou égale à 20
    Case 30, 31, 32, 33
        'Instruction si Condition = 30, 31, 32 ou 33
    Case 34 To 40
        'Instruction si Condition est comprise entre 34 et 40
    Case Else
        'Instruction si Condition n'est égale avec aucun test
    End Select

    For i = 1 To 4
        MaVar = MaVar + 10
    Next i

    For i = 1 To 30 Step 3
        MaVar = MaVar + 10
    Next i

    For i = 1 To 4
        MaVar = MaVar + 10
        If MaVar = 20 Then Exit For
    Next i

Sub EssaisCode()
'---------------------------------------------------------------------------------------
' Procédure : EssaisCode
' Auteur    : Dolphy35
' Site      : http://dolphy35.developpez.com
' Détail    : Permet de lister les noms d'expéditeur des Mails présent dans la
'             boîte de réception.
'---------------------------------------------------------------------------------------
'
    'Déclarations
    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim mapDossier As Outlook.MAPIFolder
    Dim strResultat As String
    'Instancies
    Set olApp = Outlook.Application
    Set mapDossier = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    'Boucle parcourant les Emails de la boîte de réception
    For Each olMail In mapDossier.Items
        strResultat = strResultat & olMail.SenderName & vbCr
    Next
    'Affichage du résultat
    MsgBox strResultat, , "Liste de Noms des Mails reçus"
End Sub

    Dim bytCompteur As Byte
    bytCompteur = 0
    Do While bytCompteur < 4
        bytCompteur = bytCompteur + 1
    Loop
    MsgBox bytCompteur

    Dim bytCompteur As Byte
    bytCompteur = 0
    Do
        bytCompteur = bytCompteur + 1
    Loop While bytCompteur < 4
    MsgBox bytCompteur

    Dim bytCompteur As Byte
    bytCompteur = 0
    Do Until bytCompteur > 4
        bytCompteur = bytCompteur + 1
    Loop
    MsgBox bytCompteur

    Dim bytCompteur As Byte
    bytCompteur = 0
    Do
        bytCompteur = bytCompteur + 1
    Loop Until bytCompteur > 4
    MsgBox bytCompteur

    Dim bytCompteur As Byte
    bytCompteur = 0
    While bytCompteur < 4
        bytCompteur = bytCompteur + 1
    Wend
    MsgBox bytCompteur

[Optional] [ByVal | ByRef] [ParamArray] Nom [( )] [As type] [= ValeurDéfaut]

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 que 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

Public blnStopSearch As Boolean

Sub Recherche()
'---------------------------------------------------------------------------------------
' Procédure : Recherche
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 21/04/2008
' Détail    : Effectue une recherche par la méthode AdvancedSearch
'---------------------------------------------------------------------------------------
'
'Déclaration de l'objet et de la variable
    Dim ObjSearch As Outlook.Search
    Dim i As Integer

    'Initialisation du boolean
    blnStopSearch = False

    'Déclaration et chargement des constantes, pour le filtre et le dossier de recherche
    Const strFiltre As String = "urn:schemas:mailheader:subject = 'Salut'"
    Const strDossier As String = "Inbox"

    'Instancie l'objet à la méthode AdvancedSearch
    Set ObjSearch = Application.AdvancedSearch(strDossier, strFiltre)

    'Boucle tant que AdvancedSearch n'a pas fini sa recherche, déclenche l'événement AdvancedSearchComplete
    While blnStopSearch = False
        DoEvents
    Wend

End Sub

Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
'---------------------------------------------------------------------------------------
' Procédure : Application_AdvancedSearchComplete
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 21/04/2008
' Détail    : utilise l'événement AdvancedSearchComplete suite à une recherche
'---------------------------------------------------------------------------------------
'
'Déclaration de l'objet
    Dim objResultat As Outlook.Results

    'Instancie à l'objet le résultat de la recherche
    Set objResultat = SearchObject.Results
    If objResultat.Count > 0 Then
        'Boucle en fonction du nombre d'occurrences trouvées
        For i = 1 To objResultat.Count
            'Affichage du résultat dans une msgbox
            MsgBox objResultat.Item(i).SenderName
        Next
    Else
        MsgBox "La recherche n'a trouvé aucune occurrence"
    End If
    'Passage à True de la Variable pour stopper la boucle
    blnStopSearch = True

End Sub

Sub StopSearch()
'---------------------------------------------------------------------------------------
' Procédure : StopSearch
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 21/04/2008
' Détail    : Réalise une recherche et exécute la méthode Stop de l'objet Search
'---------------------------------------------------------------------------------------
'
'Déclaration de l'objet
    Dim objSearch As Outlook.Search

    'Déclaration des constantes et chargement
    Const strDossier As String = "Inbox"
    Const strFiltre As String = "urn:schemas:mailheader:subject = 'Salut"

    'Instancie l'objet Search
    Set objSearch = Application.AdvancedSearch(strDossier, strFilter)

    'Méthode Stop de l'objet Search
    objSearch.Stop

End Sub

Private Sub Application_AdvancedSearchStopped(ByVal SearchObject As Search)
'---------------------------------------------------------------------------------------
' Procédure : Application_AdvancedSearchStopped
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 21/04/2008
' Détail    : Survient lors de l'exécution de la méthode Stop de l'objet Search
'---------------------------------------------------------------------------------------
'
'Affichage d'un message lors de la levée de l'événement
    MsgBox "La méthode Stop de l'objet Search a été exécutée"

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

Dim strSelection As String

Private Sub Application_FolderContextMenuDisplay( _
        ByVal CommandBar As Office.CommandBar, _
        ByVal fldFolder As Folder)

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

    Set objButton = CommandBar.Controls.Add( _
                    msoControlButton, , , , True)
    With objButton
        .Style = msoButtonIconAndCaption
        .Caption = "Infos sur le Dossier"
        .FaceId = 463
        .OnAction = "Projet 1.ThisOutlookSession.InfosDossier"
    End With

    strSelection = fldFolder.Name
    
End Sub

Sub InfosDossier()

    MsgBox strSelection

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

Sub InfosMail()
'---------------------------------------------------------------------------------------
' Procédure : InfosMail
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 25/04/2008
' Détail    : Macro permettant de parcourir les pièces jointes d'une sélection et affiche
'             le nom et la taille de chaque pièce jointe dans une boîte de message
'---------------------------------------------------------------------------------------
'
'Déclarations des objets et variables
    Dim objItem As Object
    Dim objAttachment As Attachments
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim i As Integer

    'Instancie les objets
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection

    'Boucle permettant de parcourir les pièces jointes une à une
    For Each myItem In myOlSel
        'instancie l'objet avec la pièce jointe en cours
        Set objAttachment = myItem.Attachments
        'Si pièce jointe affichage
        If objAttachment.Count > 0 Then
            For i = 1 To objAttachment.Count
                MsgBox "Nom : " & objAttachment(i).FileName & vbCr & _
                       "Taille : " & MEF_Octet(objAttachment(i).Size), , "Informations sur Pièces Jointes"
            Next i
        End If
    Next

    'Vide des objets pour libération de la mémoire
    Set objItem = Nothing
    Set objAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing

End Sub

Public Function MEF_Octet(lgValeur As Long) As String
'---------------------------------------------------------------------------------------
' Procédure : MEF_Octet
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 25/04/2008
' Détail    : Fonction permettant un affichage en octet, kilo, mega ou giga selon valeur passée en paramètre
'---------------------------------------------------------------------------------------
'
'test si la valeur correspond à l'octet
    If (lgValeur / 1024 > 1) Then
        lgValeur = lgValeur / 1024
        'test si la valeur correspond au kilo
        If (lgValeur / 1024 > 1) Then
            lgValeur = lgValeur / 1024
            'test si la valeur correspond au méga
            If (lgValeur / 1024 > 1) Then
                lgValeur = lgValeur / 1024
                'test si la valeur correspond au giga
                If (lgValeur / 1024 > 1) Then
                    lgValeur = lgValeur / 1024
                Else
                    MEF_Octet = CStr(lgValeur) & " Go"    'charge la valeur convertie en string dans la variable
                End If
            Else
                MEF_Octet = CStr(lgValeur) & " Mo"  'charge la valeur convertie en string dans la variable
            End If
        Else
            MEF_Octet = CStr(lgValeur) & " Ko"    'charge la valeur convertie en string dans la variable
        End If
    Else
        MEF_Octet = CStr(lgValeur) & " Oct"    'charge la valeur convertie en string dans la variable
    End If
 
End Function

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procédure : Application_ItemSend
' Auteur    : Dolphy35
' Site      : http://dolphy35.developpez.com
' Détail    : Demande une confirmation avant l'envoi d'un élément
'---------------------------------------------------------------------------------------
'Demande à l'utilisateur de valider si l'envoi doit être réaliser
    If MsgBox("Voulez-vous réellement envoyer cet élément ???", _
              vbQuestion + vbYesNo, "Are You Sure !!") = vbNo Then
        Cancel = True
    End If
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 que 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 Sub Application_ItemLoad(ByVal Item As Object)
    Select Case Item.Class
    Case olMail
        MsgBox "Vous ouvrez le Formulaire Mail"
    Case olContact
        MsgBox "Vous ouvrez le Formulaire Contact"
    Case olJournal
        MsgBox "Vous ouvrez le Formulaire Journal"
    Case olNote
        MsgBox "Vous ouvrez le Formulaire Notes"
    End Select
End Sub

Private Sub Application_MAPILogonComplete()
'Occurs when a user has logged on

    MsgBox "Logon complete."

End Sub

Private Sub Application_NewMail()
    MsgBox "Vous venez de recevoir un nouveau Mail !", vbExclamation
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éclarations
    Dim MonApp As Outlook.Application
    Dim MonMail As Object
    Dim MonNameSpace As Outlook.NameSpace
    Dim MonDossier As Outlook.Folder
    
    'Instance des objets
    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 correspond dans ce cas on déplace 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

Private Sub Application_Quit()
    MsgBox "Au revoir, " & Application.GetNamespace("MAPI").CurrentUser
End Sub

Private Sub Application_Reminder(ByVal Item As Object)
    MsgBox "Attention une alarme s'active", vbInformation
End Sub

Dim strSelection As String

Private Sub Application_ShortcutContextMenuDisplay( _
        ByVal CommandBar As Office.CommandBar, _
        ByVal shctSelect As OutlookBarShortcut)

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

    Set objButton = CommandBar.Controls.Add( _
                    msoControlButton, , , , True)
    With objButton
        .Style = msoButtonIconAndCaption
        .Caption = "Infos sur le Dossier"
        .FaceId = 463
        .OnAction = "Projet 1.ThisOutlookSession.InfosDossier"
    End With

    strSelection = shctSelect.Name
    
End Sub

Sub InfosDossier()

    MsgBox strSelection

End Sub

Private Sub Application_Startup()
    MsgBox "Bonjour, " & Application.GetNamespace("MAPI").CurrentUser
End Sub