XL 2013 Fusionner des pdf en vba

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long

Option Explicit

Dim Fichiers() As Variant
Dim Cpt As Long
Const sRch As String = "pdf"

Private Function CreationDossier(sDossier As String) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function

Private Sub Liste(ByVal sChemin As String, ByVal bSousDossier As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)

    Fichier = Dir$(sChemin & "\*.*")

    Do While Len(Fichier) > 0
        If UCase$(FSO.GetExtensionName(Fichier)) Like (UCase$(sRch)) Then
            ReDim Preserve Fichiers(Cpt)
            Fichiers(Cpt) = sChemin & "\" & Fichier
            Cpt = Cpt + 1
        End If
        Fichier = Dir$()
    Loop

    If bSousDossier Then
        For Each Dossier In Dossier.SubFolders
            Liste Dossier.Path, True
        Next Dossier
    End If

    Set FSO = Nothing
End Sub

Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Dir(sDossier & "\" & sNomfichier, vbNormal) <> vbNullString Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)

        i = 0
        While Dir(sDossier & "\" & sNouveauNom, vbNormal) <> vbNullString
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing

    RenommerFichier = sDossier & "\" & sNomfichier
End Function

Sub Tst_Fusion_PDF()
Dim pdf As Object
Dim sDossierIn As String, sDossierOut As String
Dim sNomDossierPdf As String, sNomDossierFusion As String, sNomFichierFusion As String, sNom As String

    Set pdf = CreateObject("pdfforge.Pdf.Pdf")

    sNomDossierPdf = "Test PDF"
    sNomDossierFusion = "Fusion PDF"
    sNomFichierFusion = "Fusion.Pdf"

    sDossierIn = ThisWorkbook.Path & "\" & sNomDossierPdf
    sDossierOut = ThisWorkbook.Path & "\" & sNomDossierFusion

    CreationDossier sDossierOut
    Cpt = 0
    Liste sDossierIn, False

    sNom = RenommerFichier(sDossierOut, sNomFichierFusion)
    If Cpt > 0 Then pdf.MergePDFFiles_2 Fichiers, sNom, True

    Erase Fichiers
    Set pdf = Nothing
End Sub