VBA - Renommage de fichiers PDF avec recherche dans le document

Question

Bonjour,

Je suis confronté à une colle et je sollicite votre aide... Mes compétences de jeune padawan en VBA se heurtent à un morceau trop gros pour moi.

Pour mon travail, je dois renommer environ 200 PDF afin de les mettre à disposition des collaborateurs de l'association. Pour pousser les PDF (qui sont nominatifs et confidentiels) sur la plateforme qui permettra aux collaborateurs de les récupérer, ces PDF doivent être nommés avec leur numéro AVS (pareil que le numéro de sécu). Le renommage se fait en cherchant le nom du collaborateur dans le PDF (dans le PDF lui-même, pas dans son titre). Pour ça, je dispose d'un fichier Excel qui sert à établir les correspondances.
En gros, la macro devrait ouvrir le premier PDF du dossier, tester dans le fichier Excel des correspondances pour chaque nom un par un (boucler sur la colonne des noms) pour voir si l'un d'entre eux est trouvable dans le PDF. Soit le nom est trouvé et le fichier est renommé, soit il n'est pas trouvé et c'est tant pis. Dans tous les cas, la macro ferme ensuite le PDF, ouvre le PDF suivant et reste tous les noms jsuqu'à trouve rune correspondance, etc.
Pour le renommage, une fois une correspondance établie, la macro décale de une colonne à gauche, récupère le numéro AVS, le combine au nom et renomme le PDF, par exemple: "N° AVS_Yvan-Desclous".

J'ai réussi à coder tout ça pour des fichier .docx, mais c'est pas du tout la même chose pour des PDF.

Quelques détails:
1) Les PDF font une seule page chacun
2) Je peut au besoin disposer d'un accès à Acrobat Pro
3) Dans le fichier Excel qui sert à établir des correspondances, deux colonnes sont pertinentes: E, qui contient les noms, et D, qui contient les numéros AVS.

J'espère que j'ai été clair dans ma demande et qu'un jedi confirmé pourra m'aider.

Merci d'avance et meilleures salutations!

PS : Je joins le code pour renommage des fichiers Word, des fois que ça serve à quelqu'un:

Option Explicit

' Fonction pour supprimer les accents
Function SupprimerAccents(Texte As String) As String
    Dim accents As String, sansAccents As String
    Dim i As Integer

    accents = "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝŸàáâãäåæçèéêëìíîïðñòóôõöøùúûüýÿ"
    sansAccents = "AAAAAAACEEEEIIIIDNOOOOOUUUUYYaaaaaaaceeeeiiiidnooooouuuuyy"

    SupprimerAccents = Texte
    For i = 1 To Len(accents)
        SupprimerAccents = Replace(SupprimerAccents, Mid(accents, i, 1), Mid(sansAccents, i, 1))
    Next i
End Function

' Macro principale : Parcours et renomme tous les fichiers Word
Sub RenommerFichiersWord()
    Dim dossierCible As String, fichier As String, cheminFichier As String
    Dim appWord As Object, doc As Object
    Dim wbUsine As Workbook, ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim texteDoc As String, recherche As String, nouveauNom As String
    Dim trouve As Boolean
    Dim fichiersRenommes As Integer

    ' Désactiver l'affichage pour éviter les bugs visuels
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' Sélection du dossier cible
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Sélectionnez le dossier contenant les fichiers Word"
        If .Show = -1 Then
            dossierCible = .SelectedItems(1) & "\"
        Else
            Exit Sub ' Annulation de l'utilisateur
        End If
    End With

    ' Vérification du dossier
    If Dir(dossierCible, vbDirectory) = "" Then
        MsgBox "Le dossier sélectionné n'existe pas.", vbExclamation
        Exit Sub
    End If

    ' Ouverture du fichier usine
    On Error Resume Next
    Set wbUsine = Workbooks.Open("C:\Users\Utilisateur\Desktop\Renommage fichiers\usine a renommage.xlsm")
    On Error GoTo 0
    If wbUsine Is Nothing Then
        MsgBox "Impossible d'ouvrir le fichier 'usine a renommage.xlsm'.", vbCritical
        Exit Sub
    End If

    ' Sélection de la feuille "Données"
    Set ws = wbUsine.Sheets("Données")

    ' Dernière ligne remplie en colonne E
    lastRow = ws.Cells(ws.Rows.Count, 5).End(xlUp).Row
    If lastRow < 1 Then
        MsgBox "Le fichier 'usine' ne contient pas de données valides.", vbCritical
        wbUsine.Close False
        Exit Sub
    End If

    ' Création de l'objet Word
    On Error Resume Next
    Set appWord = GetObject(, "Word.Application") ' Vérifier si Word est ouvert
    If Err.Number <> 0 Then
        Err.Clear
        Set appWord = CreateObject("Word.Application") ' Ouvrir Word si besoin
    End If
    On Error GoTo 0

    appWord.Visible = False ' Garder Word en arrière-plan

    fichiersRenommes = 0 ' Compteur de fichiers renommés

    ' Boucle sur les fichiers .docx du dossier
    fichier = Dir(dossierCible & "*.docx")
    Do While fichier <> ""
        cheminFichier = dossierCible & fichier
        trouve = False ' Reset du statut de recherche

        ' Ouvrir le fichier Word
        Set doc = appWord.Documents.Open(cheminFichier, ReadOnly:=True)
        texteDoc = doc.Content.Text
        doc.Close False ' Fermer après extraction du texte

        ' Comparaison avec les données du fichier Excel
        For i = 1 To lastRow
            recherche = SupprimerAccents(ws.Cells(i, 5).Value) ' Supprime les accents
            If InStr(1, SupprimerAccents(texteDoc), recherche, vbTextCompare) > 0 Then
                ' Nouveau format : ColonneD_ColonneB_ColonneC
                nouveauNom = ws.Cells(i, 4).Value & "_" & ws.Cells(i, 2).Value & "_" & ws.Cells(i, 3).Value
                trouve = True
                Exit For
            End If
        Next i

        ' Renommage du fichier si une correspondance est trouvée
        If trouve Then
            Dim nouveauChemin As String
            nouveauChemin = dossierCible & nouveauNom & ".docx"
            On Error Resume Next
            Name cheminFichier As nouveauChemin
            If Err.Number = 0 Then
                fichiersRenommes = fichiersRenommes + 1
            Else
                MsgBox "Erreur lors du renommage de " & fichier, vbCritical
                Err.Clear
            End If
            On Error GoTo 0
        End If

        ' Passer au fichier suivant
        fichier = Dir
    Loop

    ' Fermeture propre de Word
    appWord.Quit
    Set appWord = Nothing

    ' Fermeture du fichier Excel
    wbUsine.Close False

    ' Rétablir l'affichage d'Excel et VBA
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    ' Message final avec le nombre de fichiers renommés
    MsgBox fichiersRenommes & " fichier(s) renommé(s) avec succès.", vbInformation, "Renommage terminé"
End Sub

h2so4 · Accepted Answer

Que contient feuil2 après exécution ? si la feuille reste vide, c'est qu'il ne trouve aucun fichier. si cible est un répertoire tu dois mettre un \ à la fin de la chaine: ainsi chemin = "C:\Users\Utilisateur\Desktop\Informatique\Développements\Renommage fichiers\Cible\" sinon cible sera considéré comme une partie du nom des fichiers à prendre en compte (cible*.pdf)...

Jurassic Pork · Accepted Answer

Tu es peut-être victime du message d'avertissement de conversion, tu devrais rendre visible Word pour voir ce qui se passe : Set objword = CreateObject("Word.Application") objword.Visible = True Si il y a le message d'avertissement cocher la case pour qu'il n'apparaisse plus. Ami calmant, J.P...

h2so4 · Answer

Word est capable d'ouvrir des fichiers PDF. Essaie en remplaçant tes instructions d'ouverture du fichier Docx par fichier = Dir(dossierCible & "*.pdf") Do While fichier &lt;&gt; "" cheminFichier = dossierCible & fichier trouve = False ' Reset du statut de recherche ' Ouvrir le fichier Word Set doc = appWord.Documents.Open(cheminFichier, Format:="PDF Files", ConfirmConversions:=False, ReadOnly:=True)...

h2so4 · Answer

Ceci fonctionne chez moi. avec tes fichiers, j'ai mis une liste des fichiers pdf trouvés dans le répertoire et le résultat du "renommage". Il te faudra adapter le répertoire où aller chercher les fichiers PDF à renommer...