Boucle Outlook

[Phil]

Bonjour à tous,

J'ai adapté un petit script qui me permet de copier un fichier présent
dans un répertoire des Dossiers Publics d'Outlook vers un répertoire
local, qui fonctionne très bien.
Cependant, je voudrais ajouter une boucle qui me permette de faire la
même chose pour un nombre indéfini de fichiers présents dans ce
dossier Outlook, chaque fichier gardant son nom d'origine bien
entendu. Je ne maitrise pas assez les commandes Outlook. Merci
d'avance de votre aide précieuse.

Sub OpenOutlookURL()
Dim openstr As String
'Dim ol As Outlook.Application
'Dim olns As Outlook.NameSpace
Dim myfolder As Variant
'Dim xlfile As Outlook.DocumentItem
Dim FileName As String
Dim wb As Excel.Workbook

FileName = "Test.xls"

Set ol = GetObject("", "Outlook.Application")
Set olns = ol.GetNamespace("MAPI")
Set myfolder = olns.Folders("Dossiers Publics").Folders _
("Tous les dossiers publics").Folders("Fichiers")

Set xlfile = myfolder.Items(FileName)

xlfile.Display
Set wb = Workbooks(FileName)
Workbooks(FileName).SaveAs FileName:="c:\local\" & FileName,
FileFormat:=xlNormal

End Sub

 

[Jon]

bonjour

ne peux-tu pas manipuler tous les fichiers d'un répertoire ainsi :

For Each itm In myfolder.Items
itm.display
next itm

pourquoi qui plus est ouvres tu le fichier pour le sauvegarder ?
en supposant que tu n'es que des classeurs excel dans ce répertoire tu peux faire :

For Each itm In myfolder.Items
i = i + 1
itm.SaveAs "C:\Documents and Settings\royers.POEDIWS0003\Bureau\" & "file" & i & ".xls"
Next itm

 

[Phil]

Tout d'abord merci pour la réponse. Entre temps j'ai un peu modifié le script, mais le but est de récupérer chaque fichier avec son nom. J'obtiens une erreur de type, mais la solution ne dois pas être loin ! je n'arrive pas à comprendre où je me suis planté ?!



Sub OpenOutlookURL()
Dim openstr As String
'Dim ol As Outlook.Application
'Dim olns As Outlook.NameSpace
Dim myfolder As Variant
'Dim xlfile As Outlook.DocumentItem
Dim FileName As String
Dim wb As Excel.Workbook
Dim FileNameNew As String

'FileName = "Test.xls"

Set myOlApp = GetObject("", "Outlook.Application")
Set myNS = myOlApp.GetNamespace("MAPI")
Set myfolder = myNS.PickFolder
'On Error Resume Next
Set objFolder = myfolder

'?????????
cu = myfolder.Items.Count
For i = 1 To cu
Set myItem = myfolder.Items(i)
'MsgBox myItem
FileName = myItem
FileNameNew = Left$(FileName, Len(FileName) - 4)
Set wb = Workbooks(FileName)
Workbooks(FileNameNew).SaveAs FileName:="c:\local\mailbox\" & FileNameNew, FileFormat:=xlNormal

Next i
End Sub

 

[Phil]

Ok, le vba marche. Voici le script :

Sub OpenOutlookURL()
Dim openstr As String
'Dim ol As Outlook.Application
'Dim olns As Outlook.NameSpace
Dim myfolder As Variant
'Dim xlfile As Outlook.DocumentItem
Dim FileName As String
Dim wb As Excel.Workbook
Dim FileNameNew As String

Let i = 0


Set myOlApp = GetObject("", "Outlook.Application")
Set myNS = myOlApp.GetNamespace("MAPI")
Set myfolder = myNS.PickFolder

Set objFolder = myfolder


Set myOlApp = GetObject("", "Outlook.Application")
cu = myfolder.Items.Count
For i = 1 To cu
Set myItem = myfolder.Items(i)
Set myAttachments = myItem.Attachments
myAttachments.Item(1).SaveAsFile "C:\Local\" & myAttachments.Item(1).DisplayName
Next i


End Sub