Récuperer en automatique les emails outlook avec VBA
bonjour à tous ,
Je souhaite récuperer en automatique les courriel de outlook
le problème : je voudrais récuperer les courriels de la date (ReceivedTime) que j'aurais choisit.
Pour le moment l'ensemble des courriels de ma boite outlook sont récupérés
D'avance merci
Sub Macro1()
Dim olapp As New Outlook.Application
Dim ns As Object, Dossier As Object
Dim OlExp As Object
Dim i As Object
Application.Worksheets("email").Range("A2:R60000").Clear
Sheets("email").Select
Set ns = olapp.GetNamespace("MAPI")
Set Dossier = ns.GetDefaultFolder(olFolderInbox).Folders("RH") 'Dans la boite de reception dans le repertoire Courriers Traités
b = 2
For Each i In Dossier.Items
Cells(b, 2) = i.ReceivedTime
Cells(b, 1) = i.Subject
b = b + 1
Next i
End Sub '
Bonjour,
à tester,
Sub test()
Dim objNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim Item As Object
Dim dt1 As Double, dt2 As Double
Set objNS = GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
dt1 = DateSerial(2019, 6, 7)
dt2 = DateSerial(2019, 6, 8)
With olFolder
For i = 1 To .Items.Count
If TypeOf .Items(i) Is Outlook.MailItem Then
If .Items(i).ReceivedTime >= dt1 And .Items(i).ReceivedTime < dt2 Then
n = n + 1
Cells(n, 1) = .Items(i).Subject
Cells(n, 2) = .Items(i).ReceivedTime
End If
End If
Next
End With
End Sub
bonjour à tous ,
merci i20100 pour ton aide
je rencontre toujours un soucis pour pouvoir sélectionner les courriel avec la date ReceivedTime
Le format de ma date de mon extraction est sous le format 08/11/2018 16:37:27
but: pourvoir extraire les courriels d'une date sélectionnée
Sub Macro1()
Dim objNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim Item As Object
Dim dt1 As Date
Dim dt2 As Date
Application.Worksheets("email").Range("A2:R60000").Clear
Sheets("email").Select
Set objNS = GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("RH")
dt1 = ("03/11/2018 ")
dt2 = ("03/11/2018 ")
With olFolder
For i = 1 To .Items.Count
If TypeOf .Items(i) Is Outlook.MailItem Then
If .Items(i).ReceivedTime >= dt1 And .Items(i).ReceivedTime < dt2 Then
n = n + 1
Cells(n, 1) = .Items(i).Subject
Cells(n, 2) = .Items(i).ReceivedTime
End If
End If
Next
End With
End Sub
je rencontre toujours un soucis pour pouvoir sélectionner les courriel avec la date ReceivedTime
Le format de ma date de mon extraction est sous le format 08/11/2018 16:37:27
but: pourvoir extraire les courriels d'une date sélectionnée
si tu utilises DateSerial
et que tu déclares les variables correctement tu n'aura pas de problème de format de date.
Ca marche !!! par contre Attention ne pas avoir une boite émail trop volumineuse sinon ça ne marchera pas.
Merci i20100
Sub Macro1()
Dim objNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim Item As Object
Dim dt1 As Date
Dim dt2 As Date
Dim RT As Long
Application.Worksheets("email").Range("A2:R60000").Clear
Sheets("email").Select
Set objNS = GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("1")
dt1 = DateSerial(2019, 6, 1)
dt2 = DateSerial(2019, 6, 31)
MsgBox dt1
MsgBox dt2
With olFolder
For i = 1 To .Items.Count
If TypeOf .Items(i) Is Outlook.MailItem Then
If .Items(i).ReceivedTime >= dt1 And .Items(i).ReceivedTime <= dt2 Then
n = n + 1
Cells(n, 1) = .Items(i).Subject
Cells(n, 2) = .Items(i).ReceivedTime
End If
End If
Next
End With
End Sub