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 à 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 à 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 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 :
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 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
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 :
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 :
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
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
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 :
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