Microsoft 365 Récupération PJ Outlook Auto via VBA

[M7cks]

Bonjour à tous !

Voilà j'essaye d’adapter ce code que j'utilise tous les jours pour récupérer des PJs en masse des mails que je sélectionne, j'aimerai optimiser ce code en le rendant plus autonome, et là je bloque complètement 😵

J'aimerai que la bonne boite mail ce sélectionne car j'en est plusieurs sur Outlook, que ça sélectionne tous les mails présent dans la boîte de réception, là le reste du code actuel enregistre toutes les pièces jointes dans le dossier indiqué puis là, déplacer tout les mails dans le dossier "Archives".

Voilà voilà, quelqu'un peut m'aider ? M’aiguiller un peu ? 🙄

Sub test1()
Dim MonMail As Outlook.MailItem
Dim Olk_selex As Outlook.Selection
Dim OutlookApp As New Outlook.Application
Dim OutlookExp As Outlook.Explorer
Dim MonNSpace As Outlook.NameSpace
Dim MyPath, myort, ext, a As String
Dim i, j As Integer
Dim MesAttachments

Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookExp = OutlookApp.ActiveExplorer
Set MonNSpace = OutlookApp.GetNamespace("MAPI")
Set Olk_selex = OutlookExp.Selection

For i = 1 To Olk_selex.Count
        Set MonMail = Olk_selex.Item(i)
        Set MesAttachments = MonMail.Attachments
        If MesAttachments.Count > 0 Then
             For j = 1 To MesAttachments.Count

                    MesAttachments(j).SaveAsFile "C:\dossier\" & _
                    MesAttachments(j).DisplayName

            Next j
         End If
Next i

End Sub

 

[Yaloo]

Bonsoir M7cks,

Comment peut-on savoir qu'elle est la bonne boite mail à traiter ? Si ce n'est par une information humaine.

A+

Martial

 

[M7cks]

Bonjour Martial,
Elle doit être défini dans le code manuellement bien sur, je ne cherche pas créer une IA capable de trouver toute seule la bonne adresse à traiter ^^

D'après mes recherches il semblerait que cette commande pourrait selectionner la boite mail défini avec le dossier voulu :

.GetNamespace("MAPI").Folders("boite3@mail.com").Folders("Boite de reception")

Je continue mes recherches et j'apprend, je posterai l'évolution de mon projet afin que cela puisse aider les personnes qui souhaite faire quelque chose de similaire.

 

[M7cks]

Re-Bonjour à tous,

Bon et bien j'ai fini par trouver la solution à quasiment tout, j'ai essayé de commenter au mieux afin que cela soit compréhensible, si quelqu'un à des optimisations à proposer et surtout une solution pour que ça s’exécute automatiquement à une heure précise par exemple ça serait top.

Voici :

Sub extractemail()

Dim OlApp As Object
Dim OlMail As Object
Dim OlItems As Object
Dim OlFolder As Object
Dim OlFolderDST As Object

On Error Resume Next
Set OlApp = GetObject(, "Outlook.Application")

If Err.Number = 429 Then
    Set OlApp = CreateObject("Outlook.Application")
End If

'Définir les valeurs des variable
Set OlFolder = OlApp.GetNamespace("MAPI").Folders("Maboite@mail.fr").Folders("Boîte de réception") 'Valeur de la Boite mail à traiter
Set OlItems = OlFolder.Items 'Valeur total des objects dans la boite mail (OlFolder)
Set OlFolderDST = OlFolder.Folders("Archives") 'Valeur de la Boite mail de destination donc le sous dossier de la boite de réception

strFolder = "C:\ICI\" 'Destination des PJs

'Boucle pour checker chaque mail dans le total (OlItems)
For Each OlMail In OlItems
    If OlMail.Attachments.Count > 0 Then 'Test du nombre de PJ sup à 0
        'Exécution de la boucle si le test est positif
        For j = 1 To OlMail.Attachments.Count 'Boucle 1ere PJ jusqu'au nombre total de PJ
            OlMail.Attachments.Item(j).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(j).FileName
        Next j 'j +1
    End If
Next

'Boucle For UnRead un mail et le déplacer dans OlFolderDST
For j = OlItems.Count To 1 Step -1
    OlItems(j).UnRead = False
    OlItems(j).Move OlFolderDST
Next j


'Reset
Set OlFolderDST = Nothing
Set OlFolder = Nothing
Set OlItems = Nothing
Set OlMail = Nothing
Set OlApp = Nothing

'MsgBox "Done", vbInformation

End Sub

Voilà voilà si ça peu aider