Excel - Outlook

Personne ne peut m'aider à fouiller dans les sous-répertoires ?



On 23 fév, 11:55, lululanantaise2 <sbran...@gmail.com> wrote:

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 & "" & xFol der.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 = Repl ace(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 Th en
                                Range(Cel ls(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

Bonjour,

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 :
9f918f8f-b2a4-471e-90b3-f0ccf7af2312@s13g2000yqe.googlegroups.com...

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

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" <michde...@hotmail.com> wrote:

Bonjour,

Voici un exemple pour travailler avec tous les fichiers contenus dans tou s les sous-répertoires.
Dans cet exemple, il s'agit de copier les fichiers vers une autre destina tion... à 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 da ns 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 actio ns à 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éperto ires 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 :
9f918f8f-b2a4-471e-90b3-f0ccf7af2...@s13g2000yqe.googlegroups.com...

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 & "" & xFol der.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 = Repl ace(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 Th en
                                Range(Cel ls(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

Copie ce qui suit dans un module standard d'Excel.
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 :
0a790a4d-b750-449d-a2e0-30ae45860d9e@m7g2000vbw.googlegroups.com...

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" <michde...@hotmail.com> wrote:

Bonjour,

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 :
9f918f8f-b2a4-471e-90b3-f0ccf7af2...@s13g2000yqe.googlegroups.com...

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