Suivi de l'état des mails Outlook

Question

Bonjour à tous, J'ai un projet qui consiste à suivre l'état des mails Outlook entre 5 parties prenantes, et l'afficher sur Excel en 3 couleurs pour chaque mail: Mail reçu: en rouge Mail ouvert (en cours de traitement): en jaune Mail terminé (ordre effectué; couleur cochée manuellement par l'employé): en vert Remarque: Le contenu des mails ne me regarde pas. (Ci-dessous un fichier qui illustre l'idée); Le Code VBA pour exporter les mails de Outlook vers Excel pour suivre leurs états Erreur de compilation: type défini par l'utilisateur non défini Public Sub Dashboard() Dim outlookApp As Outlook.Application, oOutlook As Object Dim oInbox As Outlook.Folder, oMail As Outlook.MailItem Dim strAddress As String, strEntryId As String, getSmtpMailAddress As String Dim objAddressentry As Outlook.AddressEntry, objExchangeUser As Outlook.ExchangeUser Dim objReply As Outlook.MailItem, objRecipient As Outlook.Recipient Set outlookApp = New Outlook.Application Set oOutlook = outlookApp.GetNamespace("MAPI") Set oInbox = oOutlook.GetDefaultFolder(olFolderInbox) For Each oMail In oInbox.Items If oMail.SenderEmailType = "SMTP" Then strAddress = oMail.SenderEmailAddress Else Set objReply = oMail.Reply() Set objRecipient = objReply.Recipients.Item(1) strEntryId = objRecipient.EntryID objReply.Close OlInspectorClose.olDiscard strEntryId = objRecipient.EntryID Set objAddressentry = oOutlook.GetAddressEntryFromID(strEntryId) Set objExchangeUser = objAddressentry.GetExchangeUser() strAddress = objExchangeUser.PrimarySmtpAddress() End If getSmtpMailAddress = strAddress Debug.Print getSmtpMailAddress Next oMail End Sub...

Eric Kergresse · Answer

Ce code a été créé par OLIV (dans un autre forum) et il fonctionne très bien. Vous aurez néanmoins à l'adapter, si vous souhaitez ne plus choisir la boite de réception. Je ne pourrai pas vous aider plus car mon Outlook est en rade. Sub ExportFolderItemsToExcel() '--------------------------------------------------------------------------------- ' Procedure : ExportFolderItemsToExcel ' Author : Oliv ' Date : 10/11/2017 ' Purpose : export des informations d'Emails de la boite de reception vers excel '--------------------------------------------------------------------------------- ' Dim oFolder As Object Dim criteria Dim oTable As Object Dim i, oRow, R, arr Dim Wk As Workbook Dim Ws As Worksheet Const olFolderInbox = 6 Const olUserItems = 0 Dim OL As Object If UCase(Application) = "OUTLOOK" Then Set OL = Application Else Set OL = CreateObject("outlook.application") End If 'Si on connait le nom 'Set oFolder = OL.Session.GetDefaultFolder(olFolderInbox).Store.GetSearchFolders.Item("tout") 'si on veut choisir Set oFolder = OL.Session.PickFolder 'Pour ne prendre que les EMAILS criteria = "&#91;MessageClass&#93;='IPM.Note' or &#91;MessageClass&#93;='IPM.Post'" 'Pour tous les éléments 'criteria = "&#91;MessageClass&#93;&lt;&gt;'zzz'" Set oTable = oFolder.GetTable(criteria, olUserItems) MsgBox oTable.GetRowCount On Error Resume Next With oTable.Columns .RemoveAll .Add ("Subject") .Add ("CreationTime") .Add ("LastModificationTime") .Add ("MessageClass") .Add ("ReceivedTime") .Add ("Senton") .Add ("Size") .Add ("To") .Add ("Cc") .Add ("Bcc") .Add ("Categories") .Add ("ConversationTopic") .Add ("ReceivedByName") .Add ("SenderName") .Add ("SenderEmailAddress") .Add ("Unread") .Add ("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B") 'PR_HASATTACH .Add ("ConversationIndex") .Add ("http://schemas.microsoft.com/mapi/proptag/0x66700102") .Add ("http://schemas.microsoft.com/mapi/proptag/0x1000001F") '="Body" ''.Add ("Sent") 'KO ''.Add ("Duration") 'KO ''.Add ("Type") 'KO End With 'MsgBox oTable.GetRowCount ' Dim AppExcel As Object ' Dim Wk As Object, Ws As Object ' If InStr(1, Application, "Excel", vbTextCompare) &gt; 0 Then ' Set AppExcel = Application ' Else ' Set AppExcel = CreateObject("Excel.application") ' AppExcel.Visible = True ' End If Set Wk = ActiveWorkbook 'AppExcel.Workbooks.Add Set Ws = Wk.Sheets("Liste des mails") 'Wk.ActiveSheet R = 2 'Enumerate the table using test for EndOfTable For i = 1 To oTable.Columns.Count Ws.Cells(1, i).Value = oTable.Columns.Item(i).Name If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B" Then Ws.Cells(1, i).Value = "PR_HASATTACH" If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x66700102" Then Ws.Cells(1, i).Value = "EntryIdLong" If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x1000001F" Then Ws.Cells(1, i).Value = "Body" Next i Ws.Cells.NumberFormat = "@" Ws.Range("C:H").NumberFormat = "General" 'GoTo parcourir ' one row spanning several columns oTable.Sort "LastModificationTime", True arr = oTable.GetArray(oTable.GetRowCount) Dim Destination As Range Set Destination = Ws.Range("a2") Set Destination = Destination.Resize(UBound(arr, 1) + 1 - LBound(arr, 1), UBound(arr, 2) + 1 - LBound(arr, 2)) On Error Resume Next Destination.Value = arr If Err = 1004 Then GoTo parcourir 'quand cela ne marche pas cela vient du format de la colonne destination On Error GoTo 0 GoTo mef 'AUTRE METHODE on écrit en parcourant les enregistrement et les colonnes parcourir: 'pour parcourir la table champs par champs oTable.MoveToStart Do Until (oTable.EndOfTable) On Error Resume Next Set oRow = oTable.GetNextRow() For i = 1 To oTable.Columns.Count Debug.Print oRow("Body") Ws.Cells(R, i).Value = oRow(oTable.Columns(i).Name) Next i R = R + 1 Loop GoTo mef mef: 'mise en forme With Ws.Cells .AutoFilter .EntireColumn.AutoFit End With With Ws.Rows("1:1").Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 .PatternTintAndShade = 0 .Parent.Font.Bold = True End With Ws.Cells.WrapText = True Ws.Cells.WrapText = False Ws.Activate Set OL = Nothing Set Wk = Nothing Set Ws = Nothing Set oTable = Nothing Set oRow = Nothing Set Destination = Nothing Exit Sub End Sub...

Eric Kergresse · Answer

Edit : "Je suis pas convaincu par ce code mais" Ce n'est pas grave, le mieux est de le laisser tomber. Bon courage...