Donnez vie à vos documents numériques !
 

Répondre à : Un Script (petit)

abracadabraPDF Forums PDF – Général Un Script (petit) Répondre à : Un Script (petit)

#61765
Chnoirhomme
Participant

Merci Merlin pour le support,
J’ai trouvé et adapté un code qui a l’air de marcher.

Une petite contribution pour les autres, j’ai déjà eu énormément du site, merci :

Les pages doivent être incriminées dans le sens opposé la dernière en premier et la première en dernier.
Bonne soirée

Code:
Sub DeletePDFPages()
Dim strSourceFullPath As String, strDestinationFullPath As String
Dim iStartPage As Long, iNumPages As Long
Dim PDDocSource As Object, PDDocTarget As Object
Dim Cell As Range, Cell1 As Range, Rng As Range
Application.ScreenUpdating = False
    Set PDDocSource = CreateObject(“AcroExch.PDDoc”)
    Set PDDocTarget = CreateObject(“AcroExch.PDDoc”)

    Set Rng = Range(“a1”, ActiveSheet.Range(“a” & ActiveSheet.Rows.Count).End(xlUp)) ‘ Selection
 
    strSourceFullPath = Application.GetOpenFilename(“PDF Files (*.pdf), *.pdf”)
    strDestinationFullPath = StripFilename(strSourceFullPath) & InputBox(“Output FileName”) & “.pdf”
     
    ‘ Create a new PDDoc
  If PDDocTarget.Create True Then
        MsgBox “Unable to create a new PDF”
        Exit Sub
    End If
   
        ‘ Open the PDF source file (the file we are going to take pages from)
    If PDDocSource.Open(strSourceFullPath) True Then
        MsgBox “Unable to open the source PDF”
        Exit Sub
    End If
       
    For Each Cell In Rng

    ‘ Set the page range you wish to delete
    ‘ Don’t forget that this is zero based
    iStartPage = Cell – 1
 
    ‘ Set the number of pages you wish to delete
    iNumPages = 0
     
        ‘ Insert the pages from the source PDF file to the target PDF
  If PDDocSource.DeletePages(iStartPage, iStartPage) True Then
      MsgBox “Unable to Delete”
      Exit Sub
  End If
     
 

    Next Cell
   
        ‘ Save the new file
    If PDDocSource.Save(&H1, strDestinationFullPath) True Then
        MsgBox “Unable to save the pdf”
        Exit Sub
    End If
   
    ‘Close the PDF files
    PDDocSource.Close
    PDDocTarget.Close
   
    ‘ Clean up
    Set PDDocSource = Nothing
    Set PDDocTarget = Nothing
    Application.ScreenUpdating = True
  MsgBox “File Saved to ” & strDestinationFullPath
End Sub
Function StripFilename(sPathFile As String) As String
‘given a full path and file, strip the filename off the end and return the path
Dim filesystem As Object

Set filesystem = CreateObject(“Scripting.FilesystemObject”)

StripFilename = filesystem.GetParentFolderName(sPathFile) & “”

Exit Function

End Function