Extraction plusieurs pj de plusieurs mails

Bonjour,

Comme son non l'indique je souhaite exporter dans un dossier toutes les PJ de plusieurs mails reçus

J'ai trouvé une macro qui le fait parfaitement, le seul problème c'est que 500 PJ max peuvent être exporter

J'ai mis en PJ la macro, je souhaiterais que l'on m'indique si cela est normal ou si on peux faire plus, quelque chose ma peux être échappé

Merci d'avance pour votre aide

Sub ExportPJmail()
Dim GCount As Integer
Dim GFilepath As String
Public Sub SaveAttachments()
'Update 20200821
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.Attachments
Dim xSelection As Outlook.Selection
Dim i As Long
Dim xAttCount As Long
Dim xFilePath As String, xFolderPath As String, xSaveFiles As String
On Error Resume Next
xFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
Set xSelection = Outlook.Application.ActiveExplorer.Selection
xFolderPath = xFolderPath & "\Attachments\"
If VBA.Dir(xFolderPath, vbDirectory) = vbNullString Then
    VBA.MkDir xFolderPath
End If
GFilepath = ""
For Each xMailItem In xSelection
    Set xAttachments = xMailItem.Attachments
    xAttCount = xAttachments.Count
    xSaveFiles = ""
    If xAttCount > 0 Then
        For i = xAttCount To 1 Step -1
            GCount = 0
            xFilePath = xFolderPath & xAttachments.Item(i).FileName
            GFilepath = xFilePath
            xFilePath = FileRename(xFilePath)
            If IsEmbeddedAttachment(xAttachments.Item(i)) = False Then
                xAttachments.Item(i).SaveAsFile xFilePath
                If xMailItem.BodyFormat <> olFormatHTML Then
                    xSaveFiles = xSaveFiles & vbCrLf & "<Error! Hyperlink reference not valid.>"
                Else
                    xSaveFiles = xSaveFiles & "<br>" & "<a href='file://" & xFilePath & "'>" & xFilePath & "</a>"
                End If
            End If
        Next i
    End If
Next
Set xAttachments = Nothing
Set xMailItem = Nothing
Set xSelection = Nothing
End Sub

Function FileRename(FilePath As String) As String
Dim xPath As String
Dim xFso As FileSystemObject
On Error Resume Next
Set xFso = CreateObject("Scripting.FileSystemObject")
xPath = FilePath
FileRename = xPath
If xFso.FileExists(xPath) Then
    GCount = GCount + 1
    xPath = xFso.GetParentFolderName(GFilepath) & "\" & xFso.GetBaseName(GFilepath) & " " & GCount & "." + xFso.GetExtensionName(GFilepath)
    FileRename = FileRename(xPath)
End If
xFso = Nothing
End Function

Function IsEmbeddedAttachment(Attach As Attachment)
Dim xItem As MailItem
Dim xCid As String
Dim xID As String
Dim xHtml As String
On Error Resume Next
IsEmbeddedAttachment = False
Set xItem = Attach.Parent
If xItem.BodyFormat <> olFormatHTML Then Exit Function
xCid = ""
xCid = Attach.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F")
If xCid <> "" Then
    xHtml = xItem.HTMLBody
    xID = "cid:" & xCid
    If InStr(xHtml, xID) > 0 Then
        IsEmbeddedAttachment = True
    End If
End If
End Function

Edit modo : fichier supprimé, code mis entre balises

Bonjour maverick59264

Je ne vois rien dans le code qui pourrait empêcher ça !

Vous avez bien plus de 500 mails avec pièce jointe dans le dossier sélectionné ?

A+

Bonjour BrunoM45,

Non j'ai moins de 500 mails mais je sélectionne mais 70 mails et dedans il y a mes PDF et l'ensemble des PDF fait 1241 et quand je lance la macro et bien cela rame un peu je pense c'est parce'que il y a beaucoup de PDF et quand je vais dans mon dossier et bien j'ai 500 élèments alors je devrais avoir 1241.

Cordialement,

Re,

Avez-vous pensé que certains éléments pouvaient avoir le même nom

Car votre fonction "Rename" n'est pas vraiment opérationnel, certes, elle semble récursive...
Je verrais plutôt quelque chose du style

Function FileRename(FilePath As String) As String
Dim xPath As String
Dim xFso As FileSystemObject
On Error Resume Next
Set xFso = CreateObject("Scripting.FileSystemObject")
xPath = FilePath
FileRename = xPath
' Tant que le fichier existe 
Do While xFso.FileExists(xPath)
    ' Incrémenter le numéro
    GCount = GCount + 1
    ' Définir le nouveaau nom
    xPath = xFso.GetParentFolderName(GFilepath) & "\" & xFso.GetBaseName(GFilepath) & " " & GCount & "." + xFso.GetExtensionName(GFilepath)
Loop
' Si sorti de boucle le nouveau nom est
FileRename = xPath
xFso = Nothing
End Function

A+

Bonjour,

Non les PJ ont des noms tous différents c'est pas grave ce que je fait c'est que je sélectionne les mails et je lance la macro ensuite d'autres mails et je relance

mais je dois le faire 4 ou 5 fois vu que j'ai 500 PDF qui s'affiche au max

Merci en tt cas pour ton aide