Excel - Outlook
Le
lululanantaise2
Bonjour à toutes et à tous,
je souhaite lire l'intégralité des messages s'une base Outlook y
compris dans les sous répertoires, j'ai utilisé la macro suivante
trouvée et faite par JB je crois :
Sub LitMessage()
Set XOUTLOOK = CreateObject("Outlook.Application")
Set XMAPI = XOUTLOOK.GetNamespace("MAPI")
For Each xMailFolder In XMAPI.Folders
Dossier1 = xMailFolder.Name & ""
If xMailFolder.Name = "Dossiers personnels" Then
For Each xFolder In xMailFolder.Folders
Dossier = Dossier1 & "" & xFolder.Name
xNbMsg = 2
GoTo Suite
'If xFolder.Name = "Zozo" Then
For Each xMsg In xFolder.Items
Cells(xNbMsg, 1) = Dossier
Cells(xNbMsg, 2) = xMsg.creationtime
Cells(xNbMsg, 3) = xMsg.Subject
Cells(xNbMsg, 4) = xMsg.SenderName
CorpsMsg = Replace(xMsg.body, Chr(13),
Chr(10))
Do While CorpsMsg Like ("*" & Chr(10) &
Chr(10) & "*")
CorpsMsg = Replace(CorpsMsg, Chr(10) &
Chr(10), Chr(10))
Loop
Cells(xNbMsg, 5) = CorpsMsg
If xMsg.UnRead Then
Range(Cells(xNbMsg + 1, 1),
Cells(xNbMsg + 1, 3)).Font.Bold = True
End If
xNbMsg = xNbMsg + 1
Next xMsg
Suite:
'End If
Next xFolder
End If
Next xMailFolder
End Sub
Mais elle ne parcoure pas l'intégralité des répertoires et surtout de=
s
sous-Répertoires.
Merci de votre aide,
Lulu
je souhaite lire l'intégralité des messages s'une base Outlook y
compris dans les sous répertoires, j'ai utilisé la macro suivante
trouvée et faite par JB je crois :
Sub LitMessage()
Set XOUTLOOK = CreateObject("Outlook.Application")
Set XMAPI = XOUTLOOK.GetNamespace("MAPI")
For Each xMailFolder In XMAPI.Folders
Dossier1 = xMailFolder.Name & ""
If xMailFolder.Name = "Dossiers personnels" Then
For Each xFolder In xMailFolder.Folders
Dossier = Dossier1 & "" & xFolder.Name
xNbMsg = 2
GoTo Suite
'If xFolder.Name = "Zozo" Then
For Each xMsg In xFolder.Items
Cells(xNbMsg, 1) = Dossier
Cells(xNbMsg, 2) = xMsg.creationtime
Cells(xNbMsg, 3) = xMsg.Subject
Cells(xNbMsg, 4) = xMsg.SenderName
CorpsMsg = Replace(xMsg.body, Chr(13),
Chr(10))
Do While CorpsMsg Like ("*" & Chr(10) &
Chr(10) & "*")
CorpsMsg = Replace(CorpsMsg, Chr(10) &
Chr(10), Chr(10))
Loop
Cells(xNbMsg, 5) = CorpsMsg
If xMsg.UnRead Then
Range(Cells(xNbMsg + 1, 1),
Cells(xNbMsg + 1, 3)).Font.Bold = True
End If
xNbMsg = xNbMsg + 1
Next xMsg
Suite:
'End If
Next xFolder
End If
Next xMailFolder
End Sub
Mais elle ne parcoure pas l'intégralité des répertoires et surtout de=
s
sous-Répertoires.
Merci de votre aide,
Lulu
On 23 fév, 11:55, lululanantaise2
Voici un exemple pour travailler avec tous les fichiers contenus dans tous les sous-répertoires.
Dans cet exemple, il s'agit de copier les fichiers vers une autre destination... à toi de modifier
le code pour effectuer le traitement des fichiers.
'Déclaration des variables dans le haut d'un module standard
Dim FSO As Object
Dim myBaseFolder As Object
Dim myFolder As Object
Dim F As Object
'-------------------------------------------
Sub FoldersList()
Dim répertoireSource As String
Dim RépertoireDestination As String
'********Définir les variables***********
répertoireSource = "c:denis" 'Répertoire de départ
RépertoireDestination = "c:denis1" 'Répertoire pour la copie
'Ne pas oublier le ""
'****************************************
Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
'Si tu n'as pas besoin du répertoire de destination, tu le supprimes dans cette ligne de code
'et aussi dans la déclaration de la procédure
'Sub FoldersInFolder(myFolderName As String, Dest As String)
'Et dans la ligne Call FoldersInFolder(myFolder.Path, Dest)
Call FoldersInFolder(répertoireSource, RépertoireDestination)
End Sub
'-------------------------------------------
Sub FoldersInFolder(myFolderName As String, Dest As String)
Set myBaseFolder = FSO.getfolder(myFolderName)
'Une boucle sur chacun des fichiers du répertoire
For Each F In myBaseFolder.Files
If F.Name Like "*.xl*" Then 'à toi de déterminer les actions à exécuter sur chacun des fichiers
F.Copy Dest & F.Name
End If
Next
'La boucle sur chacun des sous-répertoire...
For Each myFolder In myBaseFolder.SubFolders
Call FoldersInFolder(myFolder.Path, Dest)
Next
End Sub
==================================================================
Cette approche reproduit la même structure hiérarchique des répertoires dans
le répertoire de destination, mais ne copiera que les fichiers Excel.
'------------------------------------------
Sub test()
Dim Source As String
Dim destination As String
'*****VARIABLES À DÉFINIR*********
Source = "c:MichD*.xl*"
destination = "c:Excel"
'**********************************
MichD
------------------------------------------
"lululanantaise2" a écrit dans le message de groupe de discussion :
Bonjour à toutes et à tous,
je souhaite lire l'intégralité des messages s'une base Outlook y
compris dans les sous répertoires, j'ai utilisé la macro suivante
trouvée et faite par JB je crois :
Sub LitMessage()
Set XOUTLOOK = CreateObject("Outlook.Application")
Set XMAPI = XOUTLOOK.GetNamespace("MAPI")
For Each xMailFolder In XMAPI.Folders
Dossier1 = xMailFolder.Name & ""
If xMailFolder.Name = "Dossiers personnels" Then
For Each xFolder In xMailFolder.Folders
Dossier = Dossier1 & "" & xFolder.Name
xNbMsg = 2
GoTo Suite
'If xFolder.Name = "Zozo" Then
For Each xMsg In xFolder.Items
Cells(xNbMsg, 1) = Dossier
Cells(xNbMsg, 2) = xMsg.creationtime
Cells(xNbMsg, 3) = xMsg.Subject
Cells(xNbMsg, 4) = xMsg.SenderName
CorpsMsg = Replace(xMsg.body, Chr(13),
Chr(10))
Do While CorpsMsg Like ("*" & Chr(10) &
Chr(10) & "*")
CorpsMsg = Replace(CorpsMsg, Chr(10) &
Chr(10), Chr(10))
Loop
Cells(xNbMsg, 5) = CorpsMsg
If xMsg.UnRead Then
Range(Cells(xNbMsg + 1, 1),
Cells(xNbMsg + 1, 3)).Font.Bold = True
End If
xNbMsg = xNbMsg + 1
Next xMsg
Suite:
'End If
Next xFolder
End If
Next xMailFolder
End Sub
Mais elle ne parcoure pas l'intégralité des répertoires et surtout des
sous-Répertoires.
Merci de votre aide,
Lulu
mais dans Outlook sur mes messages...
Ca pourrait fonctionner aussi ?
On 24 fév, 17:03, "MichD"
Tu dois ajouter la référence suivante à Excel à partir de la fenêtre de l'éditeur de code / barre des menus / outils /
références /
Tu dois cocher : "Microsoft OutlookXX Objects Library"
L'original du message est ici :
http://www.gregthatcher.com/Scripts/VBA/Outlook/GetListOfFolders.aspx
'------------------------------------------------------------
Public Sub GetListOfFolders()
On Error GoTo On_Error
Dim Session As Outlook.Namespace
Dim Report As String
Dim Folders As Outlook.Folders
Dim Folder As Outlook.Folder
Dim reply As Integer
Set Session = Outlook.Session
Set Folders = Session.Folders
For Each Folder In Folders
Call RecurseFolders(Folder, vbTab, Report)
Report = Report & "---------------------------------------------------------------------------" & vbCrLf
Next
Dim retValue As Boolean
retValue = CreateReportAsEmail("List of Folders", Report)
Exiting:
Set Session = Nothing
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Sub
'------------------------------------------------------------
Private Sub RecurseFolders(CurrentFolder As Outlook.Folder, Tabs, Report As String)
Dim Table As Outlook.Table
Dim Row As Outlook.Row
Dim rowValues() As Variant
Dim SubFolders As Outlook.Folders
Dim SubFolder As Outlook.Folder
Static A
With Worksheets("Feuil1") 'Nom Feuille à adapter
A = A + 1
.Range("A" & A) = CurrentFolder.Name
End With
Report = Report & Tabs & "Folder Name: " & CurrentFolder.Name & " (Store: " & CurrentFolder.Store.DisplayName & ")" &
vbCrLf
Set SubFolders = CurrentFolder.Folders
For Each SubFolder In SubFolders
Call RecurseFolders(SubFolder, Tabs & vbTab, Report)
Next SubFolder
End Sub
'------------------------------------------------------------
' VBA Function which displays a report inside an email
Public Function CreateReportAsEmail(Title As String, Report As String)
On Error GoTo On_Error
Dim Session As Outlook.Namespace
Dim mail As MailItem
Dim MyAddress As addressEntry
Dim Inbox As Outlook.Folder
CreateReportAsEmail = True
Set Session = Outlook.Session
Set Inbox = Session.GetDefaultFolder(olFolderInbox)
Set mail = Inbox.Items.Add("IPM.Mail")
Set MyAddress = Session.CurrentUser.addressEntry
mail.Recipients.Add (MyAddress.Address)
mail.Recipients.ResolveAll
mail.Subject = Title
mail.Body = Report
mail.Save
mail.Display
Exiting:
Set Session = Nothing
Exit Function
On_Error:
CreateReportAsEmail = False
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Function
'------------------------------------------------------------
MichD
------------------------------------------
"lululanantaise2" a écrit dans le message de groupe de discussion :
Merci, mais ce n'est pas sur les répertoires du DD que je travaille,
mais dans Outlook sur mes messages...
Ca pourrait fonctionner aussi ?
On 24 fév, 17:03, "MichD"