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

Les meilleurs sources pour Excel

Les meilleurs sources pour ExcelConsultez toutes les FAQ

Nombre d'auteurs : 10, nombre de questions : 65, dernière mise à jour : 26 mars 2022 

 
OuvrirSommaireAutomationOutlook

Ce code permet, en pilotant Outlook par Automation, de boucler sur les messages de tous les dossiers Outlook (boite de réception, éléments envoyés, éléments supprimés ... et tous leurs sous dossiers) pour en extraire les pièces jointes et les enregistrer sur le disque dur.

Vba
Sélectionnez
Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------


Dim x As Integer
    'La boite de réception, la boite des éléments supprimés et tous leurs
    'sous dossiers sont pris en compte.
     Sub ExportePiecesJointes()
    Dim Ol As New Outlook.Application
    Dim Ns As Outlook.Namespace
    Dim Dossier As Outlook.MAPIFolder
    
    Set Ns = Ol.GetNamespace("MAPI")
    Set Dossier = Ns.Folders(1)
    
    SearchFolders Dossier
    x = 0
End Sub


Private Sub SearchFolders(ByVal Fld As Outlook.MAPIFolder)
Dim y As Integer
Dim OLmail 'As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim SousDossier As Outlook.MAPIFolder

For Each SousDossier In Fld.Folders
    If SousDossier.DefaultItemType = 0 Then
        For Each OLmail In SousDossier.Items
            If Not OLmail.Attachments.Count = 0 Then
                For y = 1 To OLmail.Attachments.Count
                     Set pceJointe = OLmail.Attachments(y)
                     x = x + 1
                     pceJointe.SaveAsFile "C:\" & x & "_" & pceJointe
                    Set pceJointe = Nothing
                Next y
            End If
        Next OLmail
    End If
    SearchFolders SousDossier
Next SousDossier
End Sub
Créé le 15 mai 2007  par SilkyRoad
Vba
Sélectionnez
Sub CreationMailEtLienHypertexte()
    Dim OlApp As Outlook.Application
    Dim OlItem As Outlook.MailItem
    'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
    
    Set OlApp = New Outlook.Application
    Set OlItem = OlApp.CreateItem(olMailItem)
    
    With OlItem
        .To = "NomPrenom@mail.fr"
        .Subject = "Le titre du message"
        .Body = "Découvrez Microsoft Office sur le site Developpez" & _
            vbLf & "http://www.developpez.com" & vbLf & vbLf & _
            "Cordialement" & vbLf & "mailto:emetteur@mail.fr"
        .Display
        .Save
        .Send
    End With
    
    Set OlItem = Nothing
    Set OlApp = Nothing
End Sub



Un autre exemple en utilisant la méthode CDO.


Vba
Sélectionnez
Sub liensDansCorpsDuMessage_CDO()
'adapté de : http://support.microsoft.com/default.aspx?kbid=286430
Dim iMsg As Object, iConf As Object
Dim strHTML As String

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

strHTML = ""
strHTML = strHTML & "<HEAD>"
strHTML = strHTML & "<BODY>"
strHTML = strHTML & "Bonjour , <BR>Découvrez Microsoft Office sur le site Developpez<BR><BR>"
strHTML = strHTML & "<A href='http://www.developpez.com'>Cliquez ici.</A>"

strHTML = strHTML & "<BR><BR>Cordialement<BR>" & Environ("UserName") & "<BR>"
strHTML = strHTML & "<A href=mailto:emetteur@mail.fr>Mon adresse mail</A>"
strHTML = strHTML & "</BODY>"
strHTML = strHTML & ""

With iMsg
    Set .Configuration = iConf
    .To = "NomPrenom@mail.fr" 'Renvoie une erreur si l'adresse est non valide
    '.From = "youralias@yourdomain.com"
    .Subject = "Test Envoi liens par mail"
    .HTMLBody = strHTML
    .Send
End With
End Sub
Créé le 16 mai 2007  par SilkyRoad
Vba
Sélectionnez
Sub creationDossierDansBoiteReception()
    Dim olApp As New Outlook.Application
    Dim olSpace As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim olInbox As Outlook.MAPIFolder
    
    Set olSpace = olApp.GetNamespace("MAPI")
    Set olInbox = olSpace.GetDefaultFolder(olFolderInbox)
    Set olFolder = olInbox.Folders.Add("nouveau dossier " & Format(Date, "yyyymmdd"))
End Sub
Créé le 16 mai 2007  par SilkyRoad
Vba
Sélectionnez
Sub controleLastName_contactsOutlook()
    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
    
    'Recherche dans le champ Nom
    Set Cible = dossierContacts.Items.Find("[LastName] = ""mimi""")
    
    'Un autre exemple qui utilise une variable pour définir la donnée à rechercher:
    'Dim Mot As String
    'Mot = "mimi"
    'Set Cible = dossierContacts.Items.Find("[LastName] = '" & Mot & "'")
    
    If Not Cible Is Nothing Then
        MsgBox "Existe"
        Else
        MsgBox "N'existe pas"
    End If
End Sub
Créé le 16 mai 2007  par SilkyRoad

La procédure vérifie si le champ personnalisé nommé "MonChampPerso" Existe pour chaque contact.
Si le champ n'existe pas , la macro va le créer et y insérer des informations.


Vba
Sélectionnez
Sub Controle_Ajout_ChampPerso_ContactsOutlook()
    Dim olApp As New Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim usProp As Outlook.UserProperty
    
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
    
    'Boucle sur les contacts
    For Each Cible In dossierContacts.Items
        'Renvoie Nothing si le champ n'existe pas
        Set usProp = Cible.UserProperties("MonChampPerso")
        
        If usProp Is Nothing Then
            'olText définit le type de données que va contenir le champ
            Set usProp = Cible.UserProperties.Add("MonChampPerso", olText)
            'Ajoute données dans le champ
            usProp.Value = "informations complémentaires personnelles"
            Cible.Save
        End If
    Next Cible
End Sub
Créé le 16 mai 2007  par SilkyRoad
Vba
Sélectionnez
Sub ListeRDV()
'Nécessite d'activer la référence Microsoft Outlook 10.0 Object Library
Dim OlApp As Outlook.Application
Dim OlMapi As Outlook.NameSpace
Dim OlFolder As Outlook.MAPIFolder
Dim OlItems As Outlook.Items
Dim OlAppointment As Outlook.AppointmentItem
Dim i As Byte
    
Set OlApp = New Outlook.Application
    
Set OlMapi = OlApp.GetNamespace("MAPI")
Set OlFolder = OlMapi.GetDefaultFolder(olFolderCalendar)
Set OlItems = OlFolder.Items
    
'Remarque :
'la macro liste les rendez vous par ordre d'index (de création)
' et non par ordre de date
For Each OlAppointment In OlItems
        With OlAppointment
        i = i + 1
            Cells(i, 1) = .Subject 'sujet
            Cells(i, 2) = .Start 'début
            Cells(i, 3) = .End 'fin
            Cells(i, 4) = .RequiredAttendees 'convoqués
            Cells(i, 5) = .OptionalAttendees 'invités
            Cells(i, 6) = .Location 'lieu
        End With
Next OlAppointment

Columns("A:F").AutoFit
Set OlApp = Nothing
End Sub
Créé le 17 juin 2007  par SilkyRoad

Testé avec Office 2007.

Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library".
Dans l'éditeur de macros:
Menu Outils
Références

Vba
Sélectionnez
Sub ExtraireContactsOutlook()
    'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
    
    '
    'Créé avec Office 2007
    '
    
    Dim olApp As Outlook.Application
    Dim dossierContacts As Outlook.MAPIFolder
    Dim Contact As Outlook.ContactItem
    Dim i As Integer, j As Integer
    
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
    
    'Verifie si le dossier des contacts contient des éléments
    If dossierContacts.Items.Count = 0 Then Exit Sub
    
    'Création d'un entête dans la 1ere ligne
    j = 1
    For i = 0 To dossierContacts.Items(1).ItemProperties.Count - 1
        Cells(j, i + 1) = dossierContacts.Items(1).ItemProperties.Item(i).Name
    Next i
    
    On Error Resume Next
    
    'Boucle sur les éléments pour récupérer les infos
    For Each Contact In dossierContacts.Items
        j = j + 1
        For i = 0 To Contact.ItemProperties.Count - 1
            Cells(j, i + 1) = Contact.ItemProperties.Item(i).Value
        Next i
    Next Contact
    
    Columns.AutoFit
    MsgBox "Opération terminée."
End Sub




Pour récupérer quelques informations spécifiques, utilisez la procédure suivante.
(Exemple: extraire les numéros de téléphone)

Vba
Sélectionnez
Sub numeroTelephone_contactsOutlook()
    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
    
    For Each Cible In dossierContacts.Items
        Debug.Print Cible.HomeTelephoneNumber & vbTab & Cible.LastNameAndFirstName
    Next
End Sub
Créé le 8 juillet 2007  par SilkyRoad

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 © 2007 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.