1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
|
Public Sub GetFromInbox()
'Macro permettant d'obtenir le PJ des mails d'une boite mail donnée
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
' Dim Fldr As MAPIFolder
Dim Fldr As Outlook.MAPIFolder
' Dim OLmail As Variant
Dim OLmail As Outlook.MailItem
Dim myRecipient As Outlook.Recipient
Dim i As Integer, j As Integer
Dim pceJointe As Outlook.Attachment, strInfo As String
Dim dossier As String
Dim fld As FileDialog
Dim fg As MAPIFolder
'initialiser l'objet Outlook :
Set olApp = CreateObject("Outlook.Application")
olApp.Session.Logon
Set olNs = olApp.GetNamespace("MAPI")
'Définir la boîte à lettre à prendre en compte :
Set myRecipient = olNs.CreateRecipient("DED CWT-PAR")
myRecipient.Resolve
'si la boîte à lettre existe bien alors définir le répertoire :
If myRecipient.Resolved Then
Set Fldr = olNs.GetSharedDefaultFolder(myRecipient, olFolderInbox).Parent.Folders("01 DED")
End If
i = 1
'lancer la boîte de dialog de sélection du répertoire à copier:
Set fld = Application.FileDialog(msoFileDialogFolderPicker)
fld.Show
'si on a sélection rien alors
If fld.SelectedItems.Count > 0 Then dossier = fld.SelectedItems(1) Else Exit Sub
For Each OLmail In Fldr.Items
With OLmail
If .Attachments.Count > 0 Then
For Each pceJointe In OLmail.Attachments
'traitement des PJ
Next pceJointe
End If
i = i + 1
End With
Next OLmail
MsgBox "Enregistrement terminé"
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub |
Partager