EXCEL ->OUTLOOK Boucle If folder.Items.Restrict("[UnRead] = True").Count = 0 Then

[Regueiro]

Bonsoir à Tous.
Depuis Excel je veux vérifier sur ma boîte de Reception.
Si il y a des messages Non lu.
Si Ok transférer dans Excel.
Merci de votre aide.
Voici le code :

Option Explicit

Sub Import_Mails_NonLus()
    Dim ol As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim ns As Namespace
    Dim folder As MAPIFolder
    Dim ws As Worksheet
    Dim i As Integer
    Dim strResultat As String
    Set ol = CreateObject("Outlook.Application")
    Set ns = ol.GetNamespace("MAPI")
    'ns.Logon

    Set folder = ns.GetDefaultFolder(olFolderInbox)
 
    Set ws = Worksheets("Emails_Non_Lus")
    
    Application.ScreenUpdating = False
    
    'MsgBox ("vous avez mail non lus" & folder.Items.Count)

    If folder.Items.Restrict("[UnRead] = True").Count = 0 Then
    MsgBox "vous n'avez pas de Message non Lus"
    Exit Sub
    End If
    
    For Each olMail In folder.Items.Restrict("[UnRead] = True")
    If olMail.Attachments.Count <> 0 Then
    
    'For Each olMail In folder.Items.
        'If olMail.UnRead = True Then

            For i = 1 To folder.Items.Count
                With folder.Items
                    With ws
                            .Cells(i + 1, 1) = olMail.Subject
                           .Cells(i + 1, 2) = olMail.To
                    End With
                End With
        Next i
    End If
    Exit For
    
    Next
    
    Set ol = Nothing
    Application.ScreenUpdating = True  
End Sub

Merci de Votre Aide.
A+

 

[Staple1600]

Re : EXCEL ->OUTLOOK Boucle If folder.Items.Restrict("[UnRead] = True").Count = 0 The

Bonsoir à tous

Regueiro
Cette petite macro fonctionne sur mon notebook (XP+XL2K3)
En espérant que cela t'inspire pour modifier ton code en conséquence.
Code vba:
Sub ListeEmailsNonLus()
'inspiré d'un code de : Timothy Chen Allen
On Error GoTo e_Rr:
Dim ns As Outlook.Namespace, folder As MAPIFolder
Dim item As Object, msg As MailItem, i&

Set ns = Session.Application.GetNamespace("MAPI")
Set folder = ns.GetDefaultFolder(olFolderInbox)
i = Cells(Rows.Count, 1).End(xlUp)(2).Row

For Each item In folder.Items
DoEvents
If (item.Class = olMail) And (item.UnRead) Then
Set msg = item
Cells(i, "A") = msg.Subject
Cells(i, "B") = msg.SenderEmailAddress
i = i + 1
End If
Next
Exit Sub

e_Rr:
MsgBox Err.Description, vbCritical, Err.Number
End Sub

 

[Regueiro]

Re : EXCEL ->OUTLOOK Boucle If folder.Items.Restrict("[UnRead] = True").Count = 0 The

Bonsoir à Tous, Staple1600
Ton code Marche parfaitement et il comme d'habitude très propre
Je vais voir ce qui clochais sur le mien.
MERCI.
A+

 

[Regueiro]

Re : EXCEL ->OUTLOOK Boucle If folder.Items.Restrict("[UnRead] = True").Count = 0 The

Bonsoir à Tous, Stample1600
J'ai améliorer ton code pour qu'il s'applique uniquement la Feuille "EMAILS"
Code :

Public Sub ListeEmailsNonLus2()
'Code de Staple1600
'http://www.excel-downloads.com/forum/211935-excel-outlook-boucle-if-folder-items-restrict-unread-true-count-0-then.html
'inspiré d'un code de : Timothy Chen Allen
On Error GoTo e_Rr:
Dim ns As Outlook.Namespace, folder As MAPIFolder
Dim item As Object, msg As MailItem, i&
Dim Ws As Worksheet
Set ns = Session.Application.GetNamespace("MAPI")
Set folder = ns.GetDefaultFolder(olFolderInbox)

Set Ws = Worksheets("EMAILS")

i = Ws.Cells(Rows.Count, 3).End(xlUp)(2).Row


For Each item In folder.Items
DoEvents
If (item.Class = olMail) And (item.UnRead) Then
Set msg = item
Cells(i, "A") = msg.ReceivedTime
Cells(i, "B") = msg.SenderEmailAddress
Cells(i, "C") = msg.SenderName
Cells(i, "D") = msg.Subject
i = i + 1
End If
Next
Exit Sub
Ws.Activate
Columns("A:H").Select
Columns("A:H").EntireColumn.AutoFit


e_Rr:
MsgBox Err.Description, vbCritical, Err.Number
End Sub

Mais la Macro s'exécute également sur les autres feuilles, si je la lance depuis une autre feuille
Merci de ton Aide

 

[Staple1600]

Re : EXCEL ->OUTLOOK Boucle If folder.Items.Restrict("[UnRead] = True").Count = 0 The

RE

Regueiro
Essaies avec ces modifs et ... bonne nuit je vais au dodo

Public Sub ListeEmailsNonLus3()
'Code de Staple1600
'http://www.excel-downloads.com/forum/211935-excel-outlook-boucle-if-folder-items-restrict-unread-true-count-0-then.html
'inspiré d'un code de : Timothy Chen Allen
On Error GoTo e_Rr:
Dim ns As Outlook.Namespace, folder As MAPIFolder
Dim item As Object, msg As MailItem, i&, Ws As Worksheet
Set ns = Session.Application.GetNamespace("MAPI")
Set folder = ns.GetDefaultFolder(olFolderInbox)
Set Ws = Worksheets("EMAILS")
With Ws
    i = .Cells(Rows.Count, 3).End(xlUp)(2).Row
    For Each item In folder.Items
    DoEvents
    If (item.Class = olMail) And (item.UnRead) Then
        Set msg = item
        .Cells(i, "A") = msg.ReceivedTime: .Cells(i, "B") = msg.SenderEmailAddress
        .Cells(i, "C") = msg.SenderName: .Cells(i, "D") = msg.Subject
        i = i + 1
        End If
    Next
Exit Sub
.Columns("A:H").Columns.AutoFit
End With
e_Rr:
MsgBox Err.Description, vbCritical, Err.Number
End Sub

 

[Regueiro]

Re : EXCEL ->OUTLOOK Boucle If folder.Items.Restrict("[UnRead] = True").Count = 0 The

Bonsoir à Tous, Staple1600.
Voici le code qui fonctionne.

Public Sub ListeEmailsNonLus2()
'Code de Staple1600
'http://www.excel-downloads.com/forum/211935-excel-outlook-boucle-if-folder-items-restrict-unread-true-count-0-then.html
'inspiré d'un code de : Timothy Chen Allen
On Error GoTo e_Rr:
Dim ns As Outlook.Namespace, folder As MAPIFolder
Dim item As Object, msg As MailItem, i&
Dim Ws As Worksheet
Set ns = Session.Application.GetNamespace("MAPI")
Set folder = ns.GetDefaultFolder(olFolderInbox)

Set Ws = Worksheets("EMAILS NON LUS")
Ws.Activate
 i = Cells(Rows.Count, 3).End(xlUp)(2).Row
For Each item In folder.Items
    DoEvents
If (item.Class = olMail) And (item.UnRead) Then
Set msg = item
    Cells(i, "A") = msg.ReceivedTime
    Cells(i, "B") = msg.SenderEmailAddress
    Cells(i, "C") = msg.SenderName
    Cells(i, "D") = msg.Subject
    Cells(i, "E") = msg.SenderEmailType
 i = i + 1
End If
Next
Columns("A:E").EntireColumn.AutoFit
Columns("A:A").NumberFormat = "yyyy/mm/dd - hh:mm"
Exit Sub
e_Rr:
 MsgBox Err.Description, vbCritical, Err.Number
End Sub

Merci pour ton Aide

J'aimerais appliquer la même procédure
pour importer mes contacts.
Voici mon Code mais rien de marche :

Public Sub ImporterContactOutlook()
Dim ns As Outlook.Namespace, folder As MAPIFolder
Dim item As Object, Cont As ContactItem
Dim i As Integer, j As Integer
Dim Ws As Worksheet

Set ns = Session.Application.GetNamespace("MAPI")
Set folder = ns.GetDefaultFolder(olFolderContacts)
On Error GoTo e_Rr:
 'Verifie si le dossier des contacts contient des éléments
    If folder.Items.Count = 0 Then Exit Sub
    
    Set Ws = Worksheets("CONTACTS OUTLOOK")
    Ws.Activate
    i = Cells(Rows.Count, 3).End(xlUp)(2).Row

For Each item In folder.Items
'If folder.Items.Count <> " " Then

    DoEvents
If folder.Items.Count <> " " Then

'If (item.Class = olMail) And (item.UnRead) Then
Set Cont = item
Cells(i, "A") = Cont.LastName


 i = i + 1
' Next
 End If
 Next
 
 Exit Sub
e_Rr:
 MsgBox Err.Description, vbCritical, Err.Number

End Sub

MErci
A+