Excel / Word / PDF avec Adobe Acrobat Pro et PDFCreator 1.7.3 (obsolète)

**kiki29** · 16/10/2007, 10h41

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** · 16/04/2011, 18h59

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** · 18/04/2011, 07h58

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** · 21/06/2011, 12h06

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** · 07/12/2011, 13h01

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** · 04/01/2012, 07h02

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

**Flodu31** · 02/11/2015, 17h02

Bonjour Kiki,

Merci pour tes didacticiels explicites, et désolé de remonter un si vieux post.. mais je n'ai pas trouvé plus proche de mon problème.
Je cherche donc à partir d'une macro excel VBA à :
- trouver un mot dans un fichier pdf
- et à ouvrir ce pdf à la page correspondante au mot recherché.

En appliquant ton bout de code, j'obtiens bien à iTrouvé -1 si le mot est trouvé et 0 le cas échéant.
En revanche, le fichier pdf s'ouvre toujours à la première page.
Saurais tu m'aiguiller?

Merci par avance,

Bien à toi

Envoyé par 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
Option Explicit
 
Sub SelFichier()
Dim Fichier As Variant
Dim sMot As String
 
    ChDir ThisWorkbook.Path
 
    ' Mot à rechercher
    sMot = "Investments"
 
    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 oApp As Object
Dim oAvDoc As Object
Dim iTrouvé As Integer
 
    Set oApp = CreateObject("AcroExch.App")
    oApp.Hide
 
    Set oAvDoc = CreateObject("AcroExch.AVDoc")
 
    If oAvDoc.Open(sFichier, "") Then
        If Len(sRch) > 0 Then
            '   Parametres FindText
            '       StringToSearchFor ,
            '       caseSensitive (1 Or 0),
            '       WholeWords(1 Or 0),
            '       ResetSearchToBeginOfDocument (1 Or 0)
 
            '   Rencoie -1 si Trouvé, 0 autrement
            iTrouvé = oAvDoc.FindText(sRch, True, False, True)
        Else
            oAvDoc.Close (1)
            Set oAvDoc = Nothing
            Set oApp = Nothing
            Exit Sub
        End If
    End If
 
    oApp.Show
    oAvDoc.BringToFront
 
    Set oAvDoc = Nothing
    Set oApp = 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
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** · 03/11/2015, 02h11

Salut, désolé mais je ne rencontre aucun problème de ce genre ( ni autre d'ailleurs ) même avec ~~le Reader 11.0.13~~ Acrobat DC 15 sous W10.

Tu pourrais voir ici, une autre façon plus exhaustive de procéder.

il y a aussi cette Liste des contributions et téléchargements pour faciliter la navigation dans le bazar.

**Sardaukar82** · 16/02/2016, 15h49

Bonjour,

Je travaille sur un outil qui doit, à partir d'une liste Excel, rechercher si le texte de chaque cellule est présent dans le fichier PDF.
J'utilise la méthode citée mais j'aimerais que la recherche ne s'applique que sur les mots entiers.
Malgré l'argument WholeWords = 1 passé en paramètre, les résultats ne sont pas probants.
Je voulais savoir s'il s'agit d'une erreur de programmation (suis encore novice) et comment je puis régler le problème.
Je joins mes fichiers de travail

Merci d'avance

[QUOTE=kiki29;6072478]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
Option Explicit
 
Sub SelFichier()
Dim Fichier As Variant
Dim sMot As String
 
    ChDir ThisWorkbook.Path
 
    ' Mot à rechercher
    sMot = "Investments"
 
    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 oApp As Object
Dim oAvDoc As Object
Dim iTrouvé As Integer
 
    Set oApp = CreateObject("AcroExch.App")
    oApp.Hide
 
    Set oAvDoc = CreateObject("AcroExch.AVDoc")
 
    If oAvDoc.Open(sFichier, "") Then
        If Len(sRch) > 0 Then
            '   Parametres FindText
            '       StringToSearchFor ,
            '       caseSensitive (1 Or 0),
            '       WholeWords(1 Or 0),
            '       ResetSearchToBeginOfDocument (1 Or 0)
 
            '   Rencoie -1 si Trouvé, 0 autrement
            iTrouvé = oAvDoc.FindText(sRch, True, False, True)
        Else
            oAvDoc.Close (1)
            Set oAvDoc = Nothing
            Set oApp = Nothing
            Exit Sub
        End If
    End If
 
    oApp.Show
    oAvDoc.BringToFront
 
    Set oAvDoc = Nothing
    Set oApp = Nothing
End Sub

**kiki29** · 16/02/2016, 18h34

Salut, regarde Acrobat Reader : Recherche dans tous les PDFs d'un dossier via Acrobat Reader (via APIs) ou Adobe Acrobat Reader DC (version 15)

A adapter à ton contexte.

**léo_sic69** · 28/10/2019, 11h11

Envoyé par kiki29

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

Set oDO = New MSForms.DataObject

Bonjour,
merci kiki29 pour tes contributions, j'essaye d'utiliser le bout de code que tu as fait pour récupérer le texte d'un fichier PDF dans une feuille Excel.

Le problème c'est que je ne m'y connais pas énormément, je code des petits trucs mais je suis vite perdu dès que ça sort du basique.

Plus précisemment je cherche à pouvoir récupérer les commentaires fait dans un PDF et les mettre dans un fichier excel. Donc je voulais tester si les commentaires étaient récupérés par ta méthode.

Par contre je n'arrive pas à faire tourner ton code : "erreur de compilation: Type défini par l'utilisateur non défini" en renvoyant à la ligne que j'ai mise en citation.

Concernant : " ' Cocher Reference : Microsoft Forms 2.0 Object Library " => J'ai coché Micorsoft Office 14.0 Object Library car c'est que j'ai trouvé qui ressemblait le plus...

Quelqu'un saurait-il me dépanner ?

Merci d'avance,
Léo

**casefayere** · 02/04/2012, 08h13

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** · 02/04/2012, 18h10

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

**kiki29** · 02/04/2012, 21h24

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** · 03/04/2012, 03h43

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** · 04/04/2012, 01h27

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

**Mayen59** · 25/10/2018, 16h19

Envoyé par 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

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Merci Kiki29 pour ce code, il fonctionne encore très bien avec le pdf créator actuel.

Néanmoins, je souhaite spécifier le chemin du dossier sans passer par la boite de dialogue. La liste des dossiers et déjà dans la colonne 2 de ma feuille excel.

Je souhaite compiler les fichiers images du dossier cells(i+1, 2).

D'avance merci de vos retours.