Discussion :

[kiki29]

Le but de ce code est de pouvoir générer un fichier Pdf via Distiller en nommant le fichier comme on l'entend,
et en le sauvant dans un dossier de son choix : choix autre que celui assigné par défaut lors de l'installation de la suite Acrobat.

Testé sous Excel XP ( 2002 SP3 ) / Acrobat 6.0.6 Pro / Distiller 6.0.1
Early Binding
sous VBE Menu Outils | Références cocher Acrobat Distiller

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
 
Option Explicit
Dim sNomPortReseau As String
 
Sub Tst_Adobe_PDF_03()
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLOG As String
Dim PDFDist As PdfDistiller
Dim PrinterDefault As String
 
    '   Sur un PC "Personnel" : a priori choix libre du Nom
    '   et de l'emplacement du fichier de sortie, on est logué en 
    '   Administrateur sur son PC
    '
    '   Sur un PC "Entreprise" :
    '   Il faut être logué en Administrateur ou en
    '   Avoir les droits pour utiliser Distiller
    '   Les chemins PS PDF LOG devront être de la forme :
    '       "C:\Documents and Settings\UserName\.....\....."
 
    '   Si l'on a plusieurs imprimantes il faut :
    '       Sélectionner l'imprimante virtuelle Adobe PDF tout en conservant
    '           trace de l'imprimante utilisée par défaut
    '   Le N° de port réseau NeXY varie suivant le PC sur lequel la macro tourne
 
    PrinterDefault = Application.ActivePrinter
    If Imprimante_AdobePDF Then
        Application.ActivePrinter = sNomPortReseau
    Else
        MsgBox "Pas d'imprimante Adobe PDF sur NeXY ", vbOKOnly+vbCritical, "Achtung"
        Exit Sub
    End If
 
    ' Ici le cas d'un PC "Personnel"
    sNomFichierPS = ThisWorkbook.Path & "\" & "Essai_AdobbePDF.ps"
    sNomFichierPDF = ThisWorkbook.Path & "\" & "Essai_AdobbePDF.pdf"
    sNomFichierLOG = ThisWorkbook.Path & "\" & "Essai_AdobbePDF.log"
 
    '   Impression d'une zone nommée
    ActiveSheet.Range("Zone").PrintOut Copies:=1, Preview:=False, _
                                       ActivePrinter:=sNomPortReseau , PrintToFile:=True, _
                                       Collate:=True, PrToFilename:=sNomFichierPS
 
    Set PDFDist = New PdfDistiller
    PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
    Set PDFDist = Nothing
 
    Kill sNomFichierPS
    Kill sNomFichierLOG
 
    Application.ActivePrinter = PrinterDefault
End Sub
 
Private Function Imprimante_AdobePDF() As Boolean
Dim i As Long
    ' 11 imprimantes réseau
    Imprimante_AdobePDF = False
    For i = 0 To 10
        If i < 10 Then
            sNomPortReseau = "Adobe PDF sur Ne0" & i & ":"
        Else
            sNomPortReseau = "Adobe PDF sur Ne" & i & ":"
        End If
        On Error Resume Next
        Application.ActivePrinter = sNomPortReseau
        If ActivePrinter = sNomPortReseau Then
            Imprimante_AdobePDF = True
            Exit For
        End If
    Next i
End Function

Dans une configuration d'Entreprise avec de multiples utilisateurs et les droits attenants il peut être nécessaire de connaitre son nom de login ( qui n'a rien à voir avec Application.UserName de VBA )

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
...
Dim sUserName As String
    sUserName = Environ("USERNAME")
...

Ou si l'on préfère connaître le chemin "C:\Documents and Settings\UserName"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
...
Dim sUserProfile as string
    sUserProfile = Environ("USERPROFILE")
...

Dans ce cas l'exemple ci-dessus deviendra qqch comme :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
 
Option Explicit
 
Dim sNomPortReseau As String
 
Sub Tst_Adobe_PDF()
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLOG As String
Dim PDFDist As PdfDistiller
Dim PrinterDefault As String
Dim sUserProfile As String
 
    sUserProfile = Environ("USERPROFILE")
 
    PrinterDefault = Application.ActivePrinter
    If Imprimante_AdobePDF Then
        Application.ActivePrinter = sNomPortReseau
    Else
        MsgBox "Pas d'imprimante Adobe PDF sur NeXY ", vbOKOnly+vbCritical, "Achtung"
        Exit Sub
    End If
 
    ' Ici le cas d'un PC "Entreprise"
    sNomFichierPS = sUserProfile & "\" & "Essai_AdobbePDF.ps"
    sNomFichierPDF = sUserProfile & "\" & "Essai_AdobbePDF.pdf"
    sNomFichierLOG = sUserProfile & "\" & "Essai_AdobbePDF.log"
 
    ActiveSheet.Range("Zone").PrintOut Copies:=1, Preview:=False, _
                                       ActivePrinter:=sNomPortReseau , PrintToFile:=True, _
                                       Collate:=True, PrToFilename:=sNomFichierPS
 
    Set PDFDist = New PdfDistiller
    PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
    Set PDFDist = Nothing
 
    Kill sNomFichierPS
    Kill sNomFichierLOG
 
    Application.ActivePrinter = PrinterDefault
End Sub
 
Private Function Imprimante_AdobePDF() As Boolean
Dim i As Long
    ' 11 imprimantes réseau
    Imprimante_AdobePDF = False
    For i = 0 To 10
        If i < 10 Then
            sNomPortReseau = "Adobe PDF sur Ne0" & i & ":"
        Else
            sNomPortReseau = "Adobe PDF sur Ne" & i & ":"
        End If
        On Error Resume Next
        Application.ActivePrinter = sNomPortReseau
        If ActivePrinter = sNomPortReseau Then
            Imprimante_AdobePDF = True
            Exit For
        End If
    Next i
End Function

Impression de certaines Feuilles d'un classeur via un tableau dans un seul Pdf résultant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
 
Option Explicit
Dim sNomPortReseau As String
 
Sub Tst4()
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLog As String
Dim PDFDist As PdfDistiller, PrinterDefault As String
Dim i As Long, Cpt As Long
Dim Ar() As String
 
    sNomFichierPS = ThisWorkbook.Path & "\" & "Tableau.ps"
    sNomFichierPDF = ThisWorkbook.Path & "\" & "Tableau.pdf"
    sNomFichierLog = ThisWorkbook.Path & "\" & "Tableau.log"
 
    Cpt = 0
    For i = 1 To ThisWorkbook.Sheets.Count
        If Left(Sheets(i).Name, 2) = "RF" Or Left(Sheets(i).Name, 2) = "RC" Then
            ReDim Preserve Ar(Cpt)
            Ar(Cpt) = Sheets(i).Name
            Cpt = Cpt + 1
        End If
    Next i
    If Cpt = 0 Then Exit Sub
 
    PrinterDefault = Application.ActivePrinter
    If Imprimante_AdobePDF Then
        Application.ActivePrinter = sNomPortReseau
    Else
        MsgBox "Pas d'imprimante Adobe PDF sur NeXY ", vbOKOnly + vbCritical, "Achtung"
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
    Sheets(Ar).PrintOut copies:=1, Preview:=False, _
                        ActivePrinter:=sNomPortReseau, PrintToFile:=True, _
                        PrToFileName:=sNomFichierPS
 
    Set PDFDist = New PdfDistiller
    PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
    Set PDFDist = Nothing
 
    Kill sNomFichierPS
    Kill sNomFichierLog
 
    Application.ScreenUpdating = True
    Application.ActivePrinter = PrinterDefault
    Sheets("Feuil1").Select
End Sub
 
Private Function Imprimante_AdobePDF() As Boolean
Dim i As Long
    ' 11 imprimantes réseau
    Imprimante_AdobePDF = False
    For i = 0 To 10
        If i < 10 Then
            sNomPortReseau = "Adobe PDF sur Ne0" & i & ":"
        Else
            sNomPortReseau = "Adobe PDF sur Ne" & i & ":"
        End If
        On Error Resume Next
        Application.ActivePrinter = sNomPortReseau
        If ActivePrinter = sNomPortReseau Then
            Imprimante_AdobePDF = True
            Exit For
        End If
    Next i
End Function

en Late Binding ( sans référence à cocher )

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Option Explicit

Dim sNomPortReseau As String

Sub Tst_Adobe_PDF()
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLOG As String
Dim PDFDist As Object
Dim PrinterDefault As String
Dim sUserProfile As String
 
    sUserProfile = Environ("USERPROFILE")
    
    PrinterDefault = Application.ActivePrinter
    If Imprimante_AdobePDF Then
        Application.ActivePrinter = sNomPortReseau
    Else
        MsgBox "Pas d'imprimante Adobe PDF sur NeXY ", vbOKOnly + vbCritical, "Achtung"
        Exit Sub
    End If
   
    sNomFichierPS = sUserProfile & "\" & "LateBinding_AdobePDF.ps"
    sNomFichierPDF = sUserProfile & "\" & "LateBinding_AdobePDF.pdf"
    sNomFichierLOG = sUserProfile & "\" & "LateBinding_AdobePDF.log"
 
    ActiveSheet.Range("Zone").PrintOut Copies:=1, Preview:=False, _
                                       ActivePrinter:=sNomPortReseau, PrintToFile:=True, _
                                       Collate:=True, PrToFilename:=sNomFichierPS
 
    Set PDFDist = CreateObject("PdfDistiller.PdfDistiller")
    PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
    Set PDFDist = Nothing
 
    Kill sNomFichierPS
    Kill sNomFichierLOG
 
    Application.ActivePrinter = PrinterDefault
End Sub

Private Function Imprimante_AdobePDF() As Boolean
Dim i As Long
    Imprimante_AdobePDF = False
    For i = 0 To 10
        If i < 10 Then
            sNomPortReseau = "Adobe PDF sur Ne0" & i & ":"
        Else
            sNomPortReseau = "Adobe PDF sur Ne" & i & ":"
        End If
        On Error Resume Next
        Application.ActivePrinter = sNomPortReseau
        If ActivePrinter = sNomPortReseau Then
            Imprimante_AdobePDF = True
            Exit For
        End If
    Next i
End Function

Sous Excel 2007, moyennant le téléchargement d'un complément qui rend possible l'enregistrement en Pdf (ou Xps)
http://www.microsoft.com/downloads/d...displaylang=fr
Le SP2 intègre ce complément
Impression de certaines Feuilles d'un classeur via un tableau dans un seul Pdf résultant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
Sub Tst_2007()
Dim sNomFichierPDF As String
Dim i As Long, Cpt As Long
Dim Ar() As String
 
    sNomFichierPDF = ThisWorkbook.Path & "\" & "Tableau2007.pdf"
 
    Cpt = 0
    For i = 1 To ThisWorkbook.Sheets.Count
        If Left(Sheets(i).Name, 2) = "RF" Or Left(Sheets(i).Name, 2) = "RC" Then
            ReDim Preserve Ar(Cpt)
            Ar(Cpt) = Sheets(i).Name
            Cpt = Cpt + 1
        End If
    Next i
    If Cpt = 0 Then Exit Sub
 
    Application.ScreenUpdating = False
    Sheets(Ar).Select
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNomFichierPDF _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
 
    Sheets("Feuil1").Select
    Application.ScreenUpdating = True
End Sub

[kiki29]

Sauvegarder un fichier PDF au format TEXTE via VBA Excel

Ajouter un bouton et l'affecter à la procédure SelectionFichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
 
Option Explicit
 
'    com.adobe.acrobat.accesstext           txt
'    com.adobe.acrobat.doc                  doc
'    com.adobe.acrobat.eps                  eps
'    com.adobe.acrobat.html-3-20            html, htm
'    com.adobe.acrobat.html-4-01-css-1-00   html, htm
'    com.adobe.acrobat.jp2k                 jpf, jpx, jp2, j2k, j2c, jpc
'    com.adobe.acrobat.jpeg                 jpeg, jpg, jpe
'    com.adobe.acrobat.plain-text           txt
'    com.adobe.acrobat.png                  png
'    com.adobe.acrobat.ps                   ps
'    com.adobe.acrobat.RTF                  rft
'    com.adobe.acrobat.tiff                 tiff, tif
'    com.adobe.acrobat.xml-1-00             xml
 
Sub SelectionFichier()
Dim FD As FileDialog
 
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With
 
    If FD.Show = True Then Lire FD.SelectedItems(1)
 
    Set FD = Nothing
End Sub
 
Private Sub Lire(sFichier As String)
Dim AcroXApp As Object
Dim AcroXAVDoc As Object
Dim AcroXPDDoc As Object
Dim JSO As Object
Dim sCheminPDF As String, sChemin As String
 
    Set AcroXApp = CreateObject("AcroExch.App")
    AcroXApp.Hide
 
    sCheminPDF = sFichier
    sChemin = ThisWorkbook.Path & "\" & "Essai.txt"
 
    Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
    AcroXAVDoc.Open sCheminPDF, "Acrobat"
    AcroXAVDoc.BringToFront
 
    Set AcroXPDDoc = AcroXAVDoc.GetPDDoc
    Set JSO = AcroXPDDoc.GetJSObject
 
    JSO.SaveAs sChemin, "com.adobe.acrobat.accesstext"
 
    AcroXAVDoc.Close False
    AcroXApp.Exit
 
    Set JSO = Nothing
    Set AcroXPDDoc = Nothing
    Set AcroXAVDoc = Nothing
    Set AcroXApp = Nothing
End Sub

[kiki29]

Un autre exemple pour récupérer le texte d'un fichier PDF dans une feuille Excel

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Option Explicit

Sub SelectionFichier2()
Dim FD As FileDialog

    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF", "*.pdf", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier PDF"
    End With

    If FD.Show = True Then Lire2 FD.SelectedItems(1)

    Set FD = Nothing
End Sub

'   Cocher Reference : Microsoft Forms 2.0 Object Library
Sub Lire2(sFichier As String)
Dim PDDoc As Object
Dim PDPage As Object
Dim PDText As Object
Dim TextSelt As Object
Dim Rep As Long
Dim i As Long, j As Long
Dim wkPage As Long
Dim wkCnt As Long
Dim wkText As String
Dim FName As String
Dim oDO As Object

    FName = sFichier
    Set PDDoc = CreateObject("AcroExch.PDDoc")
    Rep = PDDoc.Open(FName)

    Set TextSelt = CreateObject("AcroExCh.HiliteList")
    TextSelt.Add 0, 32767

    wkPage = PDDoc.GetNumPages()
    For i = 0 To wkPage - 1
        Set PDPage = PDDoc.AcquirePage(i)
        Set PDText = PDPage.CreatePageHilite(TextSelt)
        wkCnt = PDText.GetNumText()
        For j = 0 To wkCnt - 1
            wkText = wkText & PDText.GetText(j)
        Next j
    Next i
    PDDoc.Close

    Set PDPage = Nothing
    Set PDText = Nothing

    Set oDO = New MSForms.DataObject
    oDO.Clear
    oDO.SetText wkText
    oDO.PutInClipboard

    Application.ScreenUpdating = False
    ShTest.Cells.Clear
    ShTest.Range("A1").PasteSpecial

    Set oDO = Nothing
    Set TextSelt = Nothing
    Set PDDoc = Nothing

    ShTest.Range("H1").Select
    Application.ScreenUpdating = True
End Sub

On peut également remplacer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

wkText = wkText & PDText.GetText(j)

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

wkText = wkText & vbTab & PDText.GetText(j)

[kiki29]

Rechercher un mot dans un fichier PDF via Acrobat

Ajouter un bouton et l'affecter à la procédure SelFichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Option Explicit
 
Sub SelFichier_Acrobat()
Dim Fichier As Variant
Dim sMot As String
 
    ChDir ThisWorkbook.Path
 
    ' Mot à rechercher
    sMot = "Système de refroidissement"
 
    Fichier = Application.GetOpenFilename("Fichier PDF (*.pdf), *.pdf")
    If Fichier <> False Then AcrobatFindText Fichier, sMot
End Sub
 
Private Sub AcrobatFindText(ByVal sFichier As String, ByVal sRch As String)
Dim AcroApp As Object
Dim AvDoc As Object
Dim iTrouvé As Integer
 
    Set AcroApp = CreateObject("AcroExch.App")
    AcroApp.Hide
 
    Set AvDoc = CreateObject("AcroExch.AVDoc")
    Application.StatusBar = ""
 
    If AvDoc.Open(sFichier, "") Then
        If Len(sRch) > 0 Then
            '   Parametres FindText
            '       StringToSearchFor ,
            '       caseSensitive (1 Or 0),
            '       WholeWords(1 Or 0),
            '       ResetSearchToBeginOfDocument (1 Or 0)
 
            '   Renvoie -1 si Trouvé, 0 autrement
 
            iTrouvé = AvDoc.FindText(sRch, True, True, True)
            If iTrouvé = True Then
                Application.StatusBar = sRch & " : Trouvé"
                AcroApp.Show
                AvDoc.BringToFront
            Else
                AvDoc.Close (1)
                Application.StatusBar = sRch & " : Introuvable"
            End If
        End If
    End If
 
    Set AvDoc = Nothing
    Set AcroApp = Nothing
End Sub

Rechercher un mot dans un fichier PDF via Internet Explorer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Option Explicit
 
 
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
 
Sub SelFichier()
Dim FD As FileDialog, sStr As String
 
 
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "PDF", "*.pdf", 1
.ButtonName = "Ouvrir fichier"
.Title = "Sélectionner un fichier PDF"
End With
 
 
If FD.Show = True Then
DoEvents
' Mot à rechercher
sStr = "Investments"
RchMot_PDF_IExplorer FD.SelectedItems(1), sStr
End If
 
 
 
Set FD = Nothing
End Sub
 
Private Sub RchMot_PDF_IExplorer(sFichier As String, sMot As String)
Dim IE As Object
 
Set IE = CreateObject("InternetExplorer.Application")
 
IE.Navigate sFichier
IE.Visible = True
 
' Attente de la fin du chargement
Do Until IE.ReadyState = 4
DoEvents
Loop
 
SendKeys "^f", True
Sleep 250
SendKeys sMot, True
Sleep 100
SendKeys "{ENTER}"
 
Set IE = Nothing
End Sub

[kiki29]

Fusion de fichiers PDF

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Option Explicit
 
Sub Fusion_PDFs()
Dim oPDDoc1 As Object
Dim oPDDoc2 As Object
Dim oPDDoc3 As Object
Dim Num As Long
 
    Set oPDDoc1 = CreateObject("AcroExch.PDDoc")
    Set oPDDoc2 = CreateObject("AcroExch.PDDoc")
    Set oPDDoc3 = CreateObject("AcroExch.PDDoc")
 
    oPDDoc1.Open (ThisWorkbook.Path & "\" & "1.pdf")
    oPDDoc2.Open (ThisWorkbook.Path & "\" & "2.pdf")
    oPDDoc3.Open (ThisWorkbook.Path & "\" & "3.pdf")
 
    '   Pour connaitre le nombre de pages
    '       Num = oPDDoc1.GetNumPages()
 
    '  Paramètres :
    '   1 Page du document en cours après laquelle l'insertion sera faite. La 1ere page est 0.
    '   2 Document contenant les pages à insérer.
    '   3 La 1ere page à être insérée dans le document en cours à partir du Document contenant les pages à insérer.
    '   4 Le nombre de pages à insérer.
    '   5 Si nombre > 0 les bookmarks sont copiés, si 0 ils ne le sont pas.
 
    oPDDoc1.InsertPages 0, oPDDoc2, 0, 1, 0
    oPDDoc1.InsertPages 1, oPDDoc3, 0, 1, 0
 
    oPDDoc1.Save 1, ThisWorkbook.Path & "\" & "Fusion.pdf"
 
    oPDDoc3.Close
    oPDDoc2.Close
    oPDDoc1.Close
 
    Set oPDDoc3 = Nothing
    Set oPDDoc2 = Nothing
    Set oPDDoc1 = Nothing
End Sub

[kiki29]

Impression Document Word en PDF

Testé sous Excel XP ( 2002 SP3 ) / Acrobat 6.0.6 Pro / Distiller 6.0.1
Early Binding
sous VBE Menu Outils | Références cocher Acrobat Distiller

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Option Explicit
 
Sub Tst_WORD_Adobe_PDF()
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLOG As String
Dim PDFDist As PdfDistiller
Dim sPrinterDefault As String
 
    sPrinterDefault = Application.ActivePrinter
    Application.ActivePrinter = "Adobe PDF"
 
    sNomFichierPS = ThisDocument.Path & "\" & "Essai_Word_AdobePDF.ps"
    sNomFichierPDF = ThisDocument.Path & "\" & "Essai_Word_AdobePDF.pdf"
    sNomFichierLOG = ThisDocument.Path & "\" & "Essai_Word_AdobePDF.log"
 
    ThisDocument.PrintOut outputFilename:=sNomFichierPS, PrintToFile:=True, Background:=False, Range:=wdPrintAllDocument
 
    Set PDFDist = New PdfDistiller
    PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
    Set PDFDist = Nothing
 
    Kill sNomFichierPS
    Kill sNomFichierLOG
 
    Application.ActivePrinter = sPrinterDefault
End Sub

Pour n'imprimer qu'une page donnée d'un document

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
    ' Aller à la page 2 et l'imprimer
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="2"
    ThisDocument.PrintOut outputFilename:=sNomFichierPS, PrintToFile:=True, Background:=False, Range:=wdPrintCurrentPage

Pour imprimer de la Page x à la Page y

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
    ' Imprimer de la Page 3 à la Page 4
    ThisDocument.PrintOut outputFilename:=sNomFichierPS, PrintToFile:=True, Background:=False, Range:=wdPrintFromTo, From:="3", To:="4"

Pour imprimer des Pages non contiguës

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Dim sPages As String
 
    ' Imprimer les Pages 2 à 3 et la Page 5
    sPages = "2-3,5"
    ThisDocument.PrintOut outputFilename:=sNomFichierPS, PrintToFile:=True, Background:=False, Range:=wdPrintRangeOfPages, Pages:=sPages

[kiki29]

PDFCreator Envoi par Mail d'un fichier PDF protégé

Testé avec PDFCreator 1.2.3, Windows XP SP3, OExpress, Excel 2007

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
 
Option Explicit
 
Sub Mail()
Dim Destinataire As String
Dim objMessage As Object
Dim sNomPdf As String
Dim sDossier As String
Dim sNomCrypt As String
 
    sDossier = ThisWorkbook.Path
 
    Destinataire = "zzzzz@wwwww.fr"
    sNomPdf = sDossier & "\" & "Essai.pdf"
 
    Feuil1.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sNomPdf, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
 
    sNomCrypt = sDossier & "\" & "Tempo.pdf"
    EncryptPDFUsingPdfforgeDll sNomPdf, sNomCrypt
 
    Kill sNomPdf
    Name sNomCrypt As sNomPdf
 
    Set objMessage = CreateObject("CDO.Message")
 
    With objMessage
        .Subject = "Essai"
        .From = "xxxxx@yyyyy.fr"
        .To = Destinataire
        .TextBody = "Bonjour, ceci est un test"
        .AddAttachment sNomPdf
        .Send
    End With
 
    Set objMessage = Nothing
End Sub
 
Private Sub EncryptPDFUsingPdfforgeDll(sNomFichier As String, sOutputCrypt As String)
Dim Pdf As Object, Crypt As Object
 
    Set Crypt = CreateObject("pdfforge.pdf.PDFEncryptor")
 
    With Crypt
        .AllowAssembly = False
        .AllowCopy = False
        .AllowFillIn = False
        .AllowModifyAnnotations = False
        .AllowModifyContents = False
        .AllowPrinting = True
        .AllowPrintingHighResolution = True
        .AllowScreenReaders = False
        .EncryptionMethod = 2
 
        .OwnerPassword = "master"
        .UserPassword = ""
    End With
 
    Set Pdf = CreateObject("pdfforge.pdf.pdf")
    Pdf.EncryptPDFFile sNomFichier, sOutputCrypt, Crypt
    Set Pdf = Nothing
 
    Set Crypt = Nothing
End Sub

[kiki29]

PDFCreator Fusion de fichiers PDF

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Option Explicit
 
Sub Fusion()
Dim Pdf As Object, Fichiers(2)
    Set Pdf = CreateObject("pdfforge.pdf.pdf")
 
    Fichiers(0) = ThisWorkbook.Path & "\" & "1.pdf"
    Fichiers(1) = ThisWorkbook.Path & "\" & "2.pdf"
    Fichiers(2) = ThisWorkbook.Path & "\" & "3.pdf"
 
    Pdf.MergePDFFiles_2 Fichiers, ThisWorkbook.Path & "\" & "Fusion.pdf", True
 
    Set Pdf = Nothing
End Sub

Fusion des PDF d'un Dossier
Affecter un bouton à SelDossierFusion
Procédure récursive ou non

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Option Explicit
 
Dim Cpt As Long
Dim Tableau() As Variant
Const TypeFichier As String = "*.pdf"
 
Private Sub Fusion()
Dim Pdf As Object
    Set Pdf = CreateObject("pdfforge.pdf.pdf")
    Pdf.MergePDFFiles_2 Tableau, ThisWorkbook.Path & "\" & "Fusion Dossier.pdf", True
    Set Pdf = Nothing
End Sub
 
Private Sub ListeFichiers(ByVal sChemin As String, ByVal Recursif As Boolean)
Dim FSO As Object
Dim Dossier As Object
Dim SousDossier As Object
Dim Fichier As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    For Each Fichier In Dossier.Files
        If UCase(Fichier.Name) Like UCase(TypeFichier) Then
            ReDim Preserve Tableau(Cpt)
            Tableau(Cpt) = Fichier.Path
            Cpt = Cpt + 1
            Application.StatusBar = Cpt
        End If
    Next Fichier
 
    If Recursif Then
        For Each SousDossier In Dossier.SubFolders
            ListeFichiers SousDossier.Path, True
        Next SousDossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Sub SelDossierFusion()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Application.StatusBar = ""
            DoEvents
            Cpt = 0
            Erase Tableau
           '    ListeFichiers récursive ou non True/False
            ListeFichiers .SelectedItems(1), True
            Fusion
        End If
    End With
End Sub

[Invité]

Salut Kiki

Merci pour tous ces petits bouts de code très utiles, j'en ai utilisé un la semaine dernière

Et j'étais avec Acrobat 10

Philippe

[casefayere]

Bonjour le forum, Kiki,
Je n'ai pas le temps ni l'opportunité de teste tes propositions mais chapeau ! pour ton travail,
J'ai ajouté ta contribution à mes favoris et ne manquerai pas d'y revenir.

Encore bravo,
Bonne journée à toi et tout le forum.

Cordialement,

[louqui]

Super boulot !
Ca m'amène une question PDF===> Excel, possible?

[kiki29]

PDFCreator Découpage d'un fichier PDF en fichiers unitaires
Affecter un bouton à SelFichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Option Explicit
 
Private Sub DecoupagePDF(sNomFichier As String)
Dim pdf As Object
Dim sNom As String, Pos As Long
    Pos = InStrRev(sNomFichier, "\")
    sNom = Right$(sNomFichier, Len(sNomFichier) - Pos)
    Pos = InStr(sNom, ".")
    sNom = Left$(sNom, Pos - 1)
 
    Set pdf = CreateObject("pdfforge.pdf.pdf")
    pdf.SplitPDFFile sNomFichier, sNom & ".pdf"
    Set pdf = Nothing
End Sub
 
Sub SelFichier()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Sélectionner un Fichier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Fichier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            DecoupagePDF .SelectedItems(1)
        End If
    End With
End Sub

[kiki29]

PDFCreator Conversion d'images Tif Bmp Png Jpg Gif d'un dossier dans un seul PDF résultant

Affecter un bouton à SelDossierImages

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Option Explicit
 
Dim Cpt As Long
Dim Tableau() As Variant
Dim TypeFichier(4) As String
 
Private Sub Fusion()
Dim tools As Object, pdf As Object
    Set tools = CreateObject("pdfforge.tools")
    Set pdf = CreateObject("pdfforge.pdf.pdf")
 
    '0 La page Pdf s'adaptera à la taille de l'image
    '1 L'image s'adaptera au format A4
    pdf.Images2PDF_2 Tableau, "Images.pdf", 1
 
    Set pdf = Nothing
    Set tools = Nothing
End Sub
 
Private Sub ListeFichiers(ByVal sChemin As String, ByVal bRecursif As Boolean)
Dim FSO As Object
Dim Dossier As Object
Dim SousDossier As Object
Dim Fichier As Object
Dim i As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    For Each Fichier In Dossier.Files
        For i = LBound(TypeFichier) To UBound(TypeFichier)
            If UCase(Fichier.Name) Like UCase(TypeFichier(i)) Then
                ReDim Preserve Tableau(Cpt)
                Tableau(Cpt) = Fichier.Path
                Cpt = Cpt + 1
                Application.StatusBar = Cpt
            End If
        Next i
    Next Fichier
 
    If bRecursif Then
        For Each SousDossier In Dossier.SubFolders
            ListeFichiers SousDossier.Path, True
        Next SousDossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Sub SelDossierImages()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            TypeFichier(0) = "*.tif"
            TypeFichier(1) = "*.bmp"
            TypeFichier(2) = "*.png"
            TypeFichier(3) = "*.jpg"
            TypeFichier(4) = "*.gif"
            DoEvents
            Cpt = 0
            Erase Tableau
            ' Recherche récursive ou non True/False
            ListeFichiers .SelectedItems(1), True
            Fusion
        End If
    End With
End Sub

[kiki29]

PDFCreator Insertion Image de fond dans Document Pdf
Cette image se centre automatiquement et de sa définition dépendra la surface couverte sur le document
On n'a accès ni à son positionnement xy ni à un facteur d'échelle

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Option Explicit
 
Sub Tst_Filigrane()
Dim pdf As Object, SNomFichier As String
 
     'Public Function StampPDFFileWithImage( _
     '    sourceFilename As String, _
     '    destinationFilename As String, _
     '    imageFilename As String, _
     '    fromPage As Integer, _
     '    toPage As Integer, _
     '    overUnder As Boolean, _
     '    fillOpacity As Single, _
     '    blendMode As Integer _
     ') As Integer
 
    '	Blend mode
    '1 	Color burn
    '2 	Color dodge
    '3 	Color compatible
    '4 	Color darken
    '5 	Color difference
    '6 	Color exclusion
    '7 	Color hardlight
    '8 	Color lighten
    '9 	Color multiply
    '10 Color normal
    '11 Color overlay
    '12 Color screen
    '13 Color softlight
 
    SNomFichier = ThisWorkbook.Path & "\" & "Snoopy.jpg"
    Set pdf = CreateObject("pdfforge.pdf.pdf")
 
    ' L'image sera en arrière plan : overUnder = False
    pdf.StampPDFFileWithImage "Document.pdf", "Document Snoopy.pdf", SNomFichier, 1, 1, False, 0.5, 10
 
    Set pdf = Nothing
End Sub

[kiki29]

PDFCreator Ajout de Texte, Ligne et Hirondelles sur un Document Pdf

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Option Explicit
 
Sub Tst_AjoutTexteLigneHirondelles()
Dim pdf As Object, pdfText As Object, pdfLine As Object, pdfLine2 As Object
Dim sNomDoc As String
 
    Set pdf = CreateObject("pdfforge.pdf.pdf")
    Set pdfText = CreateObject("pdfforge.pdf.pdfText")
    Set pdfLine = CreateObject("pdfforge.pdf.pdfline")
    Set pdfLine2 = CreateObject("pdfforge.pdf.pdfline")
 
    sNomDoc = ThisWorkbook.Path & "\" & "Document.pdf"
 
    With pdfText
        .fillOpacity = 1
 
        .FontColorBlue = 62
        .FontColorGreen = 125
        .FontColorRed = 255
 
        .FontName = "comic.TTF"
        .FontSize = 55
        .Rotation = 45
        .Text = "Essai Essai Essai Essai Essai"
        .XPosition = 25
        .YPosition = 100
 
        'Public Function AddTextToPDFFile( _
         '    sourceFilename As String, _
         '    destinationFilename As String, _
         '    fromPage As Integer, _
         '    toPage As Integer, _
         '    ByRef textObject As pdfText _
         ') As Integer
 
        pdf.AddTextToPDFFile sNomDoc, "AddText.pdf", 1, 1, pdfText
    End With
 
    With pdfLine
        .FromX = 25
        .FromY = 95
        .ToX = .FromX + 180
        .ToY = .FromY + 180
 
        .LineColorRed = 60
        .LineColorGreen = 125
        .LineColorBlue = 255
 
        .LineThickness = 4
        .UnitsOn = 5
        .UnitsOff = 2.5
        .Phase = 5
 
        'Public Function AddLineToPDFFile( _
         '    sourceFilename As String, _
         '    destinationFilename As String, _
         '    fromPage As Integer, _
         '    toPage As Integer, _
         '    ByRef lineObject As pdfLine _
         ') As Integer
 
        pdf.AddLineToPDFFile "AddText.pdf", "AddTextLine.pdf", 1, 1, pdfLine
    End With
 
    With pdfLine2
        .UnitsOn = 5
        .UnitsOff = 0
 
        'Public Function AddCropMarksToPDFFile( _
         '    sourceFilename As String, _
         '    destinationFilename As String, _
         '    fromPage As Integer, _
         '    toPage As Integer, _
         '    borderTopMillimeter As Single, _
         '    borderBottomMillimeter As Single, _
         '    borderLeftMillimeter As Single, _
         '    borderRightMillimeter As Single, _
         '    ByRef lineObject As pdfLine _
         ') As Integer
 
        pdf.AddCropMarksToPDFFile "AddTextLine.pdf", "AddTextLineCrop.pdf", 1, 0, 5, 5, 5, 5, pdfLine2
    End With
 
    Set pdfLine2 = Nothing
    Set pdfLine = Nothing
    Set pdfText = Nothing
    Set pdf = Nothing
End Sub

[Pierre Fauconnier]

Salut Philippe,

Très chouette boulot. Si tu souhaites développer dans un tuto plus étoffé, tu sais que tu peux me contacter...

Cela étant, je cherche une solution (gratuite ou payante, mais si payante, je dois pouvoir distribuer mon code, éventuellement au sein d'un DLL COM que j'écrirais alors en VB6 sans obliger les utilisateurs à acquérir une version payante) pour pouvoir :

1. fusionner des pdf en choisissant les pages à fusionner;
2. splitter des pdf ;
3. ajouter un cartouche à un endroit déterminé d'une page ;
4. ajouter un entête ou un pied de page;
5. visionner un pdf dans un contrôle viewer;
6. ...

J'ai vu que tes codes permettaient presque tout ce que je demande, sauf peut-être le placement d'un cartouche (texte ou image) en pied ou "n'importe où" (=> à un endroit précis d'une page du document).

Mais tu utilises plusieurs technos (Acrobat et PDF Creator) or je souhaite, pour la facilité de mon client, n'utiliser qu'un seul logiciel, et je ne sais pas si Acrobat peut être redistribuable et si tu utilises la version Pro de PDF Creator et si cette version est différente de la version gratuite...

Au passage, c'est quoi une hirondelle?

Cordialement,

[kiki29]

PDFCreator Création d'une brochure

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Option Explicit
 
Sub Tst_Brochure()
Dim pdf As Object
 
    ' Nécessite idéalement une Imprimante Recto/Verso
 
    Set pdf = CreateObject("pdfforge.pdf.pdf")
 
    'Public Function CreatePDFTestDocument( _
     '    destinationFilename As String, _
     '    countOfPages As Integer, _
     '    additionalText As String, _
     '    addPagenumbers As Boolean _
     ') As Integer
 
    pdf.CreatePDFTestDocument "input.pdf", 8, "Essai", True
    pdf.Brochure "input.pdf", "Brochure.pdf"
 
    Kill "input.pdf"
    Set pdf = Nothing
End Sub

[kiki29]

PDFCreator Disposer un nombre de pages donné sur une page

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Option Explicit
 
Sub Tst_Disposition()
Dim pdf As Object, pdfLine As Object
 
    Set pdf = CreateObject("pdfforge.pdf.pdf")
    Set pdfLine = CreateObject("pdfforge.pdf.pdfline")
 
    pdf.CreatePDFTestDocument "input.pdf", 10, "Essai", True
 
    With pdfLine
        .UnitsOn = 5
        .UnitsOff = 0
        pdf.AddCropMarksToPDFFile "input.pdf", "Output.pdf", 1, 0, 5, 5, 5, 5, pdfLine
    End With
 
    'Public Function NUp( _
    '    sourceFilename As String, _
    '    destinationFilename As String, _
    '    pagesPerPage As Integer _
    ') As Integer
 
    pdf.NUp "Output.pdf", "Disposition.pdf", 4
 
    Kill "input.pdf"
    Kill "Output.pdf"
    Set pdfLine = Nothing
    Set pdf = Nothing
End Sub

[Pierre Fauconnier]

Salut Philippe,

Merci pour ces nouveaux exemples. Grâce à eux, j'entrevois la possibilité de réaliser ce que mon client souhaite.

Pour le viewer, il suffit d'avoir acrobat reader et on peut disposer d'un contrôle ocx de visualisation sur un userform en VBA.

C'est presque bingo sur toute la ligne.

Bonne journée

[kiki29]

PDFCreator Numérotation des Pages, En-Tête et Pied de page

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Option Explicit
 
Sub Tst_NumPages()
Dim pdf As Object, pdfText As Object, WshShell As Object, pdfText2 As Object
 
    Set WshShell = CreateObject("WScript.Shell")
    Set pdf = CreateObject("pdfforge.pdf.pdf")
 
    pdf.CreatePDFTestDocument "input.pdf", 5, "Essai", False
 
    Set pdfText = CreateObject("pdfforge.pdf.pdfText")
    With pdfText
        .Text = "[PAGE] / [PAGES]"
        .FontColorRed = 200
        .FontName = "comicbd.TTF"
        .FontPath = WshShell.SpecialFolders("Fonts")
        .FontSize = 12
    End With
 
    Set pdfText2 = CreateObject("pdfforge.pdf.pdfText")
    With pdfText2
        .Text = "Coucou"
        .FontColorBlue = 200
        .FontName = "timesbd.ttf"
        .FontPath = WshShell.SpecialFolders("Fonts")
        .FontSize = 16
    End With
 
    'Public Function AddPageNumberToPDFFile( _
     '    sourceFilename As String, _
     '    destinationFilename As String, _
     '    fromPage As Integer, _
     '    toPage As Integer, _
     '    startPageNumber As Integer, _
     '    NumberOfPages As Integer, _
     '    pageNumberPosition As Integer, _
     '    borderXMillimeter As Single, _
     '    borderYMillimeter As Single, _
     '    ByRef textObject As pdfText _
     ') As Integer
 
    'Page number position
    '1: Top Left
    '2: Top middle
    '3: Top Right
    '4: bottom Left
    '5: bottom middle
    '6: bottom Right
 
    pdf.AddPageNumberToPDFFile "input.pdf", "NumPages.pdf", 1, 5, 1, 5, 6, 15, 15, pdfText
    pdf.AddPageNumberToPDFFile "NumPages.pdf", "NumPages2.pdf", 1, 5, 1, 5, 2, 15, 15, pdfText2
 
    Kill "input.pdf"
    Kill "NumPages.pdf"
 
    Set pdfText2 = Nothing
    Set pdfText = Nothing
    Set pdf = Nothing
    Set WshShell = Nothing
End Sub

Insertion x Pages d'un pdf dans un autre Pdf

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Option Explicit
 
Sub InsertionPages()
Dim pdf As Object, pdfText As Object, WshShell As Object
Dim iNbPages As Long
 
    Set pdf = CreateObject("pdfforge.pdf.pdf")
    pdf.CreatePDFTestDocument "test1.pdf", 4, "Doc1 de 4 Pages", True
    pdf.CreatePDFTestDocument "test2.pdf", 12, "Doc2 de 12 Pages", True
 
    'Public Function ReplacePagesFromPDFFile( _
     '    sourceFilename1 As String, _
     '    sourceFilename2 As String, _
     '    destinationFilename As String, _
     '    source1FromPage As Integer, _
     '    source1ToPage As Integer, _
     '    source2FromPage As Integer, _
     '    source2ToPage As Integer _
     ') As Integer
 
    '  Remplacer sur Test1 les pages 2 à 3 par les pages 4 à 8 de Test2
    pdf.ReplacePagesFromPDFFile "test1.pdf", "test2.pdf", "output.pdf", 2, 3, 4, 8
 
    ' Suppression pages vides
    pdf.RemoveEmptyPagesFromPDFFile "output.pdf", "output2.pdf"
    iNbPages = pdf.NumberOfPages("output2.pdf")
 
    Set WshShell = CreateObject("WScript.Shell")
    Set pdfText = CreateObject("pdfforge.pdf.pdfText")
    With pdfText
        .Text = "[PAGE] / [PAGES]"
        .FontColorRed = 200
        .FontName = "comicbd.TTF"
        .FontPath = WshShell.SpecialFolders("Fonts")
        .FontSize = 12
    End With
 
    'Public Function AddPageNumberToPDFFile( _
     '    sourceFilename As String, _
     '    destinationFilename As String, _
     '    fromPage As Integer, _
     '    toPage As Integer, _
     '    startPageNumber As Integer, _
     '    NumberOfPages As Integer, _
     '    pageNumberPosition As Integer, _
     '    borderXMillimeter As Single, _
     '    borderYMillimeter As Single, _
     '    ByRef textObject As pdfText _
     ') As Integer
 
    pdf.AddPageNumberToPDFFile "output2.pdf", "InsertionPages.pdf", 1, iNbPages, 1, iNbPages, 6, 15, 15, pdfText
 
    Kill "output.pdf"
    Kill "output2.pdf"
    Kill "test2.pdf"
    Kill "test1.pdf"
 
    Set WshShell = Nothing
    Set pdfText = Nothing
    Set pdf = Nothing
End Sub