C@thy
XLDnaute Barbatruc
Bonsoir le forum,
je cherche sous Outlook (je précise : je pars bien d'une macro sous Outlook) à copier vers un tableau excel tous les mails d'un répertoire.
Pour chaque message d'un certain répertoire situé sous la boîte de réception, je copie les éléments : expéditeur, date, objet dans un tableau excel puis j'archive le mail que je viens de traiter dans un sous-répertoire traité.
(au début je l'avais fait sous excel, mais il le faut sous outlook)
voici la macro sous excel :
	
	
	
	
	
		
le seul problème c'est que je suis obligée de faire 2 fois le For Each OLmail In myInbox.Items car sinon le dernier mail n'est pas traité😕😕😕
En fait je crois que je m'y prends mal,
je devrais sans doute constituer un tableau
	
	
	
	
	
		
merci pour vos conseils, je ne sais pas trop comment m'y prendre...😱
j'ai commencé un truc :
	
	
	
	
	
		
Un grand Merci à vous
Bises
C@thy
	
		
			
		
		
	
				
			je cherche sous Outlook (je précise : je pars bien d'une macro sous Outlook) à copier vers un tableau excel tous les mails d'un répertoire.
Pour chaque message d'un certain répertoire situé sous la boîte de réception, je copie les éléments : expéditeur, date, objet dans un tableau excel puis j'archive le mail que je viens de traiter dans un sous-répertoire traité.
(au début je l'avais fait sous excel, mais il le faut sous outlook)
voici la macro sous excel :
		Code:
	
	
	Public num_id_arrivé As String
Sub start()
With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
Mails_contactsOutlook
With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
End Sub
Private Sub Mails_contactsOutlook()
    Dim myOlApp As New Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim myInbox As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim Ns As Outlook.Namespace
    Dim OLmail As Outlook.MailItem
    Dim nbmsg As Integer
    
    Dim NbJours As Long, DatePlusCinq As Date
    Dim an As Integer
    Dim myItems As Outlook.Items
    
    Set olApp = CreateObject("Outlook.Application")
    Set Ns = olApp.GetNamespace("MAPI")
    Set myInbox = Ns.GetDefaultFolder(olFolderInbox) 'Boîte de réception
     Dim myInbox As Outlook.MAPIFolder
    'balOutlook = Cells(2, 7).Value
     v = Split(myInbox.FolderPath, "\") ''
     balOutlook = v(UBound(v) - 1) ''Boîte de réception
     Set myInbox = Ns.Folders(balOutlook).Folders("Prise en charge demande") 'Dossiers d'archivage, dossiers locaux, IMAP, BAL BANCILLON C, Dossiers Personnels, ArchivOulookBANCILLON, Dossiers d'archives, Dossiers publics
     NbJours = CLng(Date)
     DatePlusCinq = CDate(NbJours + 5)
     
     For Each OLmail In myInbox.Items
                a = Range("A" & Cells.Rows.Count).End(xlUp)(2, 1).Row
                id_courrier_arr
                Range("A" & a) = num_id_arrivé
                Range("B" & a) = OLmail.CreationTime
                Range("C" & a) = Date
                Range("D" & a) = OLmail.SenderName
                Range("F" & a) = OLmail.Subject
                Range("G" & a) = DatePlusCinq
                Range("R" & a) = DatePlusCinq + 42
                Archivage
     Next OLmail
     For Each OLmail In myInbox.Items
                a = Range("A" & Cells.Rows.Count).End(xlUp)(2, 1).Row
                id_courrier_arr
                Range("A" & a) = num_id_arrivé
                Range("B" & a) = OLmail.CreationTime
                Range("C" & a) = Date
                Range("D" & a) = OLmail.SenderName
                Range("F" & a) = OLmail.Subject
                Range("G" & a) = DatePlusCinq
                Range("R" & a) = DatePlusCinq + 42
                Archivage
     Next OLmail
                
                End Sub
                
  Sub id_courrier_arr()
  Dim an_arr As Integer
  Dim incremen_arr As Variant
'recherche la derniére cellule non vide
    Range("A65536").End(xlUp).Select
'déconposition de l'id arrivé
   an_arr = Left(ActiveCell.Value, 4)
'   Stop
an = Year(Date)
   If an_arr <> an Then
      an_arr = Year(Date)
      incremen_arr = "00"
   Else
      incremen_arr = Right(ActiveCell.Value, Len(ActiveCell.Value) - 5)
   End If
   
   incremen_arr = incremen_arr + 1
   Do Until Len(incremen_arr) = 3
      incremen_arr = "0" & incremen_arr
   Loop
'incrémente la partie droite du num id
   num_id_arrivé = an_arr & "-" & incremen_arr
End Sub
                
Sub Archivage()
Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim myInbox As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder 'dossier de destination pour l'archivage
    Dim Ns As Outlook.Namespace
    Dim OLmail As Outlook.MailItem
    Dim NbJours As Long, DatePlusCinq As Date
    Dim an As Integer
    
    Set olApp = CreateObject("Outlook.Application")
    Set Ns = olApp.GetNamespace("MAPI")
    
    Set myInbox = Ns.GetDefaultFolder(olFolderInbox)
    v = Split(myInbox.FolderPath, "\") ''
    balOutlook = v(UBound(v) - 1)
    Set myInbox = Ns.Folders(balOutlook).Folders("Prise en charge demande")
    Set myDestFolder = myInbox.Folders("suivi demandes")
  
                myInbox.Items(1).UnRead = False 'courriel le plus ancien
                myInbox.Items(1).Move myDestFolder
End Sub
	En fait je crois que je m'y prends mal,
je devrais sans doute constituer un tableau
		Code:
	
	
	ReDim Preserve emails(1)
	j'ai commencé un truc :
		Code:
	
	
	Sub test()
    Dim myOlApp As New Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim myItems As Outlook.Items
  
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myInbox.Items
      
    i = myInbox.Items.Count 'dernier message
    MsgBox myInbox.Items(i).Subject
End Sub
Sub Application_NewMail()
    Dim myOlApp As New Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim myItems As Outlook.Items
    Dim myItem As Object
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myInbox.Items
    Set myDestFolder = myInbox.Folders("Temp")
    Dim strName As String
    For Each myItem In myInbox.Items
        strName = myItem.EntryID
        myItem.SaveAs "C:\temp\" & strName & ".txt", olTXT
        myItem.Move myDestFolder ' déplace
        Set myItem = myItems.GetNext
    Next myItem
End Sub
Private Sub Mails_contactsOutlook()
    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim Dossier As Outlook.MAPIFolder
    Dim Ns As Outlook.NameSpace
    Dim OLmail As Outlook.MailItem
    Dim NbJours As Long, DatePlusCinq As Date
    Dim an As Integer
    
    Set olApp = CreateObject("Outlook.Application")
    Set Ns = olApp.GetNamespace("MAPI")
   
    'balOutlook = Cells(2, 7).Value
    'Set Dossier = Ns.Folders(balOutlook).Folders("Prise en charge demande") 'Dossiers d'archivage, dossiers locaux, IMAP, BAL BANCILLON C, Dossiers Personnels, ArchivOulookBANCILLON, Dossiers d'archives, Dossiers publics
     Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
NbJours = CLng(Date)
DatePlusCinq = CDate(NbJours + 5)
For Each OLmail In Dossier.Items
                a = Range("A" & Cells.Rows.Count).End(xlUp)(2, 1).Row
                id_courrier_arr
                Range("A" & a) = num_id_arrivé
                Range("B" & a) = OLmail.CreationTime
                Range("C" & a) = Date
                Range("D" & a) = OLmail.SenderName
                Range("F" & a) = OLmail.Subject
                Range("G" & a) = DatePlusCinq
                Range("R" & a) = DatePlusCinq + 42
Next OLmail
                'OLmail.Body
                End Sub
                
  Sub id_courrier_arr()
  Dim an_arr As Integer
  Dim incremen_arr As Variant
'recherche la derniére cellule non vide
    Range("A65536").End(xlUp).Select
'déconposition de l'id arrivé
   an_arr = Left(ActiveCell.Value, 4)
'   Stop
an = Year(Date)
   If an_arr <> an Then
      an_arr = Year(Date)
      incremen_arr = "00"
   Else
      incremen_arr = Right(ActiveCell.Value, Len(ActiveCell.Value) - 5)
   End If
   
   incremen_arr = incremen_arr + 1
   Do Until Len(incremen_arr) = 3
      incremen_arr = "0" & incremen_arr
   Loop
'incrémente la partie droite du num id
   num_id_arrivé = an_arr & "-" & incremen_arr
End Sub
                
Sub Archivage()
Dim olApp As Outlook.Application
    Dim myInbox As Outlook.MAPIFolder
    Dim Ns As Outlook.NameSpace
    Dim OLmail As Outlook.MailItem
    Dim NbJours As Long, DatePlusCinq As Date
    Dim an As Integer
    
    Set olApp = CreateObject("Outlook.Application")
    Set Ns = olApp.GetNamespace("MAPI")
   
    balOutlook = Cells(2, 7).Value
    Set Dossier = Ns.Folders(balOutlook).Folders("Prise en charge demande")
    Set Dossier2 = Dossier.Folders("suivi demandes")
    
    'si toute la ligne remplie alors archivage
                myInbox.Items(i).UnRead = False
                myInbox.Items(i).Move Dossier2
End Sub
        
Sub OuvrirExcel()
Dim appExcel As Excel.Application 'Application Excel
Dim wbExcel As Excel.Workbook 'Classeur Excel
Dim wsExcel As Excel.Worksheet 'Feuille Excel
'Ouverture de l'application Excel
Set appExcel = CreateObject("Excel.Application")
'Ouverture du classeur Excel
Set wbExcel = appExcel.Workbooks.Open("C:\MonFichierExcel.xls")
'wsExcel correspond à la première feuille du fichier
Set wsExcel = wbExcel.Worksheets(1)
'Fin de traitement
wbExcel.Close 'Fermeture du classeur Excel
appExcel.Quit 'Fermeture de l'application Excel
'Désallocation mémoire
Set wsExcel = Nothing
Set wbExcel = Nothing
Set appExcel = Nothing
End Sub
Sub Essai()
'Déclaration des Objets et variables
    Dim MonApply As Outlook.Application
    Dim MonMail As Outlook.MailItem
    Dim MonNSpace As Outlook.NameSpace
    Dim FldDossier As Outlook.MAPIFolder
    Dim strInfos As String
    'Instance des Objets
    Set MonApply = Outlook.Application    'Application Outlook
    Set MonNSpace = MonApply.GetNamespace("MAPI")    'Banque MAPI
    Set FldDossier = MonNSpace.GetDefaultFolder(olFolderInbox)    'Dossier boîte de réception
    'Initialisation de la chaîne de caractères
    strInfos = ""
    'Boucle afin de parcourir l'ensemble des E-mails présents dans le dossier Boîte de réception
    For i = 1 To FldDossier.Items.Count
        'instancie le mail suivant la valeur de la boucle
        Set MonMail = FldDossier.Items(i)
        'Récupère les diverses informations du Mail
            With MonMail
                'SenderEmailAddress
                'CreationTime
            End With
     Next i
 End Sub
	Un grand Merci à vous
Bises
C@thy