Discussion :

[kiki29]

Salut, Acrobat Reader en est à la version 11.0.06 et il est gratuit.

[sachadee]

Salut et merci,

Je viens de tester avec la dernière version de acrobat reader et même problème :

Voici le message d'erreur :

[kiki29]

re, encore une police fantaisiste(?) et donc il n'y aurait pas à s'étonner. Par curiosité pourrais-tu poster ce fichier pdf, s'il ne contient rien de confidentiel ?

qqs pistes :
voir aussi ici
celà provient peut-être du logiciel qui a servi à créer le pdf, l'option incorporer les polices n'a pas du être cochée ?

Dans les options du reader Edition/préférences/affichage le rendu doit être coché en utilisant les polices locales.

[sachadee]

Je viens de faire un test avec d'autre pdf et ça marche c'est seulement ce pdf qui pose problème. Etonnement !
Et c'est avec ce fichier que je faisais mes tests (J'ai perdu au moins 3 heures à cause de ça....)

Donc on va laisser ça comme ça jusqu'à ce que j'arrive à reproduire l'erreur et là on n'en reparlera.

En tous cas merci pour ton aide.

[kiki29]

PDFCreator Modifier l'ordre dans la queue d'impression puis fusionner le tout en un seul PDF
Adapté d'un vbs fourni avec l'installation

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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
Option Explicit
 
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Private Sub CreateTextfileAndPrint(sFichier As String, sContenu As String)
Dim FSO As Object, F As Object
Dim PDFCreator2 As Object
 
    Set PDFCreator2 = CreateObject("PDFCreator.clsPDFCreator")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set F = FSO.CreateTextFile(sFichier, True)
 
    F.WriteLine (sContenu)
    F.Close
    PDFCreator2.cPrintfile (sFichier)
 
    Sleep 2000
    FSO.DeleteFile (sFichier)
 
    Set F = Nothing
    Set FSO = Nothing
    Set PDFCreator2 = Nothing
End Sub
 
Sub CombinaisonJobs()
Dim PDFCreator As Object
Dim sDefaultPrinter As String, c As Long, sOut As String
Dim FSO As Object, sDossierOut As String
Const maxTime = 30    ' s
Const sleepTime = 250    ' ms
Const sNomFichier = "Ordre impression"
 
    Set PDFCreator = CreateObject("PDFCreator.clsPDFCreator")
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
    sDossierOut = ThisWorkbook.Path & "\" & "Resultats PDF" & "\"
    If Not FSO.FolderExists(sDossierOut) Then FSO.CreateFolder (sDossierOut)
    Set FSO = Nothing
 
    PDFCreator.cStart "/NoProcessingAtStartup"
    With PDFCreator
        .cPrinterStop = True
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sDossierOut
        .cOption("AutosaveFilename") = sNomFichier
        sDefaultPrinter = .cDefaultprinter
        .cDefaultprinter = "PDFCreator"
        .cClearcache
 
        ' 1. page
        CreateTextfileAndPrint sDossierOut & "1.txt", "1"
        ' 2. page
        CreateTextfileAndPrint sDossierOut & "2.txt", "2"
        ' 3. page
        CreateTextfileAndPrint sDossierOut & "3.txt", "3"
        ' 4. page
        CreateTextfileAndPrint sDossierOut & "4.txt", "4"
 
        ' Attendre que tout soit dans la queue d'impression
        Sleep 2000
 
        ' Ordre des pages : 1 2 3 4
 
        .cMovePrintjobTop 3
        ' Ordre des pages : 3 1 2 4
 
        .cMovePrintjobBottom 2
        ' Ordre des pages : 3 2 4 1
 
        .cMovePrintjobDown 2
        ' Ordre des pages : 3 4 2 1
 
        .cMovePrintjobUp 2
        ' Ordre des pages : 4 3 2 1
 
        .cDeletePrintjob 1
        ' Ordre des pages : 3 2 1
 
        ' On fusionne le tout dans un seul pdf 
        .cCombineAll
 
        ' On démarre l'imprimante
        .cPrinterStop = False
 
        c = 0
        Do While (.cOutputFilename = "") And (c < (maxTime * 1000 / sleepTime))
            c = c + 1
            Sleep sleepTime
        Loop
        sOut = .cOutputFilename
    End With
 
    With PDFCreator
        .cDefaultprinter = sDefaultPrinter
        Sleep 200
        .cClose
    End With
 
    Set PDFCreator = Nothing
 
    If sOut = "" Then
        MsgBox "Création du fichier PDF." & vbCrLf & vbCrLf & _
                "Une erreur s'est produite : temps écoulé !", vbExclamation + vbSystemModal
    End If
End Sub

[kiki29]

Acrobat Extraction de pages d'un catalogue PDF et insertion de ces PDF en réduction sur une feuille Excel
Dans un classeur Excel
Créer sur une feuille en A2...Axy la liste des pages à extraire.
En B2 : une plage nommée NbPagesH qui détermine le nombre de PDF disposés horizontalement.
Affecter un bouton à la procédure SelFichier.

Dans ce code ShParam est le CodeName de la feuille : voir pour explications CodeName
Il en est de même pour ShRecap.

pour PDFCreator voir Post# 25

Dans un module standard insérer le code suivant :

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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
 
Option Explicit
 
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim sOut As String
Dim bFlag As Boolean
 
Private Sub DeleteAllSheets()
Dim Ws As Worksheet
    For Each Ws In ThisWorkbook.Worksheets
        If Ws.Name <> ShParam.Name And Ws.Name <> ShRecap.Name Then
            Application.DisplayAlerts = False
            Ws.Delete
            Application.DisplayAlerts = True
        End If
    Next Ws
End Sub
 
Sub DelOleRecapIns()
Dim oOle As OLEObject
    For Each oOle In Worksheets(ShRecap.Name).OLEObjects
        ShRecap.Shapes(oOle.Name).Delete
    Next oOle
End Sub
 
Private Sub ExtractionPDF(sNom As String, iNumPage As Long)
Dim PDDocSource As Object
Dim iNbPages As Long
 
    Set PDDocSource = CreateObject("AcroExch.PDDoc")
    PDDocSource.Open sNom
 
    iNbPages = PDDocSource.GetNumPages
    PDDocSource.Close
 
    If iNumPage > iNbPages Then
        bFlag = True
        Set PDDocSource = Nothing
        Exit Sub
    End If
 
    Split_Fichier sNom, iNumPage
 
    Set PDDocSource = Nothing
End Sub
 
Private Sub InsertionPDF(ByVal sNomFichier As String)
Dim LastRow As Long, i As Long
 
    ShParam.Range("A2:A" & Rows.Count).Interior.ColorIndex = xlNone
 
    DeleteAllSheets
    DelOleRecapIns
 
    Application.ScreenUpdating = False
    LastRow = ShParam.Range("A" & Rows.Count).End(xlUp).Row
 
    sOut = ThisWorkbook.Path & "\" & "Extraction.pdf"
    bFlag = False
    For i = 2 To LastRow
        ExtractionPDF sNomFichier, ShParam.Range("A" & i)
        If bFlag Then
            ShParam.Range("A" & i).Interior.ColorIndex = 36
            Exit For
        End If
 
        With ShRecap
            .Activate
            .Range("A1").Select
            .OLEObjects.Add Filename:=sOut
        End With
        Application.StatusBar = "Insertion : " & i - 1 & " / " & LastRow - 1
    Next i
 
    ShParam.Activate
    Kill sOut
    Application.ScreenUpdating = True
End Sub
 
Sub PosShapesIns()
Dim oOle As OLEObject
Dim i As Long
Dim L As Double, W As Double
Dim T As Double, H As Double, Pas As Double, PasDepart As Double
Dim Tablo() As String, sNomOle As String
Dim Nb As Long, Coeff As Double
 
    i = 0
    For Each oOle In Worksheets(ShRecap.Name).OLEObjects
        sNomOle = ShRecap.Shapes(oOle.Name).Name
        ReDim Preserve Tablo(i)
        Tablo(i) = sNomOle
        i = i + 1
    Next oOle
 
    If i = 0 Then Exit Sub
 
    With ShRecap.Shapes(Tablo(0))
        W = .Width
        H = .Height
        Coeff = H / W
    End With
 
    W = Application.CentimetersToPoints(6)
    H = W * Coeff
    Pas = Application.CentimetersToPoints(0.25)
    PasDepart = Application.CentimetersToPoints(0.25)
 
    Nb = ShParam.Range("NbPagesH")
    For i = LBound(Tablo) To UBound(Tablo)
        L = PasDepart + (i Mod Nb) * (W + Pas)
        T = PasDepart + (i \ Nb) * (H + Pas)
        With ShRecap.Shapes(Tablo(i))
            .Left = L
            .Top = T
            .Width = W
            .Height = H
        End With
    Next i
 
    With ShRecap
        .Activate
        .Range("A1").Select
    End With
End Sub
 
Sub SelFichier()
Dim Fichier As Variant
Dim s As Double
    ChDir ThisWorkbook.Path & "\"
    Fichier = Application.GetOpenFilename("Fichiers PDF (*.pdf), *.pdf", Title:="Sélection PDF pour Insertion Excel")
    If Fichier = False Then Exit Sub
    DoEvents
    QueryPerformanceCounter Dep
    Application.StatusBar = ""
 
    InsertionPDF Fichier
    PosShapesIns
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    s = (Fin - Dep) / Freq
    Application.StatusBar = Application.StatusBar & " : " & Format(s, "0.00 s")
End Sub
 
Private Sub Split_Fichier(sNomFichier As String, iNb As Long)
Dim PDDocSource As Object   
Dim PDDocDestination As Object    
Dim sNomPdf As String
 
    Set PDDocSource = CreateObject("AcroExch.PDDoc")
    PDDocSource.Open sNomFichier
 
    Set PDDocDestination = CreateObject("AcroExch.PDDoc")
    PDDocDestination.Create
    sNomPdf = sOut
 
    'nInsertPageAfter
    '   La page du document Destination après laquelle les pages du document Source seront insérées.
    '   La 1ere page d'un document est la page 0.
    'iPDDocSource
    '   Le document Source contenant les pages à insérer.
    'nStartPage
    '   La 1ere page a être insérée dans le document Destination.
    'nNumPages
    '   Le nombre de pages à insérer.
    'bBookmarks
    '   Si le nombre est positif alors les signets du document Source sont copiés.
    '   Si 0, alors non.
 
    With PDDocDestination
        .InsertPages -1, PDDocSource, iNb - 1, 1, 0
        .Save 1, sNomPdf
        .Close
    End With
 
    Set PDDocDestination = Nothing
    Set PDDocSource = Nothing
End Sub

[kiki29]

PDFCreator Affichage du log d'activité de PDFCreator
Adapté d'un vbs fourni avec l'installation

Ce log est généré si dans le menu Imprimante de PDFCreator.exe l'option Journal est cochée

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
Option Explicit
 
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_SHOWNORMAL = 1
Private Const HTMLFile = "PDFCreator_logfile.htm"
 
Private Sub CreateHTMLFile(sFilename As String, Content As String)
Dim F As Object, FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set F = FSO.CreateTextFile(sFilename, True)
        F.Write Content
        F.Close
    Set F = Nothing
    Set FSO = Nothing
End Sub
 
Private Function Footer()
    Footer = "</body>" & vbCrLf & "</html>"
End Function
 
Private Function Header()
Dim sStr As String, sTitle As String, pdfcreator As Object
    Set pdfcreator = CreateObject("PDFCreator.clsPDFCreator")
    sTitle = "PDFCreator logfile"
    sStr = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01//EN"""
    sStr = sStr & vbCrLf & "<html>"
    sStr = sStr & vbCrLf & "<head>"
    sStr = sStr & vbCrLf & "<title>" & sTitle & "</title>"
    sStr = sStr & vbCrLf & "</head>"
    sStr = sStr & vbCrLf & "<body>"
    sStr = sStr & vbCrLf & "<h1>" & sTitle & "</h1>"
    sStr = sStr & vbCrLf & "<p>Windows version : " & pdfcreator.cWindowsversion & "</p>"
    sStr = sStr & vbCrLf & "<p>Program release : " & pdfcreator.cProgramRelease & "</p>"
    sStr = sStr & vbCrLf & "<p>Chemin application : " & pdfcreator.cPDFCreatorApplicationPath & "</p>"
    sStr = sStr & vbCrLf & "<p>Version Ghostscript : " & pdfcreator.cGhostscriptVersion & "</p>"
    sStr = sStr & vbCrLf & "<p>Imprimante par défaut : " & pdfcreator.cDefaultPrinter & "</p>"
 
    If pdfcreator.cInstalledAsServer Then
        sStr = sStr & vbCrLf & "<p>Installation mode : Server</p>"
    Else
        sStr = sStr & vbCrLf & "<p>Installation mode : Standard</p>"
    End If
    If pdfcreator.cOption("Logging") = 1 Then
        sStr = sStr & vbCrLf & "<p>Logging : Activé</p>"
    Else
        sStr = sStr & vbCrLf & "<p>Logging : Désactivé</p>"
    End If
    Header = sStr & vbCrLf & "<p>--------------------------------</p>" & vbCrLf
    Set pdfcreator = Nothing
End Function
 
Sub Log()
Dim pdfcreator As Object, ProgramIsRunning As Boolean
Dim hwnd As Long
 
    Set pdfcreator = CreateObject("PDFCreator.clsPDFCreator")
 
    ProgramIsRunning = pdfcreator.cProgramIsRunning
    pdfcreator.cVisible = False
    pdfcreator.cStart "/NoProcessingAtStartup", True
 
    CreateHTMLFile HTMLFile, Header & LogFile & Footer
 
    If ProgramIsRunning = False Then
        'Sleep 200
        pdfcreator.cClose
    End If
    Set pdfcreator = Nothing
 
    ShellExecute hwnd, "Open", HTMLFile, 0&, 0&, SW_SHOWNORMAL
End Sub
 
Private Function LogFile()
Dim pdfcreator As Object
    Set pdfcreator = CreateObject("PDFCreator.clsPDFCreator")
    LogFile = Replace(ReplaceForbiddenChars(CStr(pdfcreator.cGetLogfile)), vbCrLf, "<br>") & vbCrLf
    Set pdfcreator = Nothing
End Function
 
Private Function ReplaceForbiddenChars(value)
Dim sStr As String
    sStr = Replace(value, "&", "&amp;")
    sStr = Replace(sStr, "<", "&lt;")
    sStr = Replace(sStr, ">", "&gt;")
    sStr = Replace(sStr, """", "&quot;")
    ReplaceForbiddenChars = sStr
End Function

[kiki29]

PDFCreator Fusion des fichiers PDF d'un dossier avec recherche récursive ou non de ces fichiers

Le code de recherche des fichiers ( ici *.pdf ) utilise les APIs.

Créer 3 boutons et une case à cocher sur la feuille 1.
● Le 1er baptisé btnListe avec intitulé "Liste Fichiers PDF" sera affecté à la procédure Usf du module mRch.
● Le 2eme baptisé btnFusion avec intitulé "Fusion Liste Fichiers PDF" sera affecté à la procédure FusionPdf du module mFusion.
● Le 3eme baptisé btnEffacer avec intitulé "Effacer" sera affecté à la procédure Effacer du module mRch.
● La case à cocher avec intitulé "Recherche Récursive ?" baptisée chkRecur.

Créer une UserForm avec 2 boutons et une TextBox
● Le 1er bouton avec intitulé "Sélection Dossier Racine" sera affecté à la procédure CommandButton1_Click du code de l'UserForm.
● Le 2eme bouton avec intitulé "Annuler" sera affecté à la procédure CommandButton2_Click du code de l'UserForm.
● La TextBox avec sa propriété value = *.pdf sera baptisée txtBox

Dans ces codes ShDatas est le CodeName de la feuille 1 : voir pour explications CodeName.

Code de l'UserForm

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
Option Explicit
 
Private Sub CommandButton1_Click()
    sRch = txtBox.Text
    If Len(sRch) = 0 Then
        Me.Hide
        Exit Sub
    End If
    Me.Hide
    SelDossierRacine
End Sub
 
Private Sub CommandButton2_Click()
    Me.Hide
    ShDatas.Range("B2").Select
End Sub
 
Private Sub UserForm_Initialize()
    If Len(ShDatas.Range("A2")) = 0 Then ShDatas.Range("A2") = "*.pdf"
    txtBox.Text = ShDatas.Range("A2")
End Sub

dans module standard baptisé mRch

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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
Option Explicit
 
Private Const vbDot = 46
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const vbBackSlash = "\"
Private Const ALL_FILES = "*.*"
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
 
Private Type FILE_PARAMS
    bRecurse As Boolean
    bFindOrExclude As Long
    nCount As Long
    nSearched As Long
    sFileNameExt As String
    sFileRoot As String
End Type
 
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" _
        Alias "FindFirstFileA" _
        (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
        Alias "FindNextFileA" _
        (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function PathMatchSpec Lib "shlwapi" _
        Alias "PathMatchSpecW" _
        (ByVal pszFileParam As Long, ByVal pszSpec As Long) As Long
 
Private FP As FILE_PARAMS
Private iNbDossiers As Long
 
Sub Effacer()
    With ShDatas
        .Activate
        .Columns("B:B").ClearContents
        .Range("A1").ClearContents
        .Range("A3:A5").ClearContents
        PosBoutons
        .Range("B2").Select
    End With
End Sub
 
Private Function MatchSpec(sFile As String, sSpec As String) As Boolean
    MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec)) = FP.bFindOrExclude
End Function
 
Private Function QualifyPath(sPath As String) As String
    If Right$(sPath, 1) <> vbBackSlash Then
        QualifyPath = sPath & vbBackSlash
    Else
        QualifyPath = sPath
    End If
End Function
 
Private Sub Rch(sRacine As String)
Dim Debut As Currency, Fin As Currency, Freq As Currency
 
    With ShDatas
        .Columns("A:B").ClearContents
        .Cells(1, 1) = sRacine
        .Cells(2, 1) = sRch
        .Cells(3, 1) = ""
        .Cells(4, 1) = ""
        .Cells(5, 1) = ""
        .Range("B:B").Clear
    End With
 
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1
 
    Application.ScreenUpdating = False
    With FP
        .sFileRoot = QualifyPath(ShDatas.Cells(1, 1))
        .sFileNameExt = ShDatas.Cells(2, 1)
        .bRecurse = ShDatas.CheckBoxes("chkRecur").Value = 1
        .nCount = 0
        .nSearched = 0
        iNbDossiers = 0
        '   0=inclus tous les fichiers
        '   1=exclus sauf extension : ici pdf
        .bFindOrExclude = 1
    End With
 
    QueryPerformanceCounter Debut
    SearchForFiles FP.sFileRoot
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
 
    With ShDatas
        '.Cells(3, 1) = Format$(FP.nSearched, "###,###,###,##0")
        .Cells(3, 1) = iNbDossiers & " Dossiers"
        .Cells(4, 1) = Format$(FP.nCount, "###,###,###,##0 Fichiers")
        .Cells(5, 1) = FormatNumber((Fin - Debut) / Freq, 3) & " s"
 
        .Range("A1:A5").HorizontalAlignment = xlLeft
        .Range("A2:A5").Columns.AutoFit
        PosBoutons
    End With
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub SearchForFiles(sRoot As String)
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
    hFile = FindFirstFile(sRoot & ALL_FILES, WFD)
    If hFile <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And vbDirectory) Then
                If Asc(WFD.cFileName) <> vbDot Then
                    iNbDossiers = iNbDossiers + 1
                    If FP.bRecurse Then SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackSlash
                End If
            Else
                If TrimNull(WFD.cFileName) <> sNomFichierFusion Then
                    If MatchSpec(WFD.cFileName, FP.sFileNameExt) Then
                        FP.nCount = FP.nCount + 1
                        ShDatas.Cells(FP.nCount + RDepart - 1, 2) = sRoot & TrimNull(WFD.cFileName)
                    End If
                End If
            End If
            FP.nSearched = FP.nSearched + 1
            'Application.StatusBar = FP.nSearched & " / " & FP.nCount
        Loop While FindNextFile(hFile, WFD)
    End If
    FindClose hFile
End Sub
 
Sub SelDossierRacine()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier Racine"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            ShDatas.Range("B2").Select
            DoEvents
            Rch .SelectedItems(1)
            'Tri
        End If
    End With
End Sub
 
Private Sub Tri()
Dim LastRow As Long
    LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row
    ShDatas.Range("B6:B" & LastRow).Sort Key1:=ShDatas.Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    ShDatas.Range("B2").Select
End Sub
 
Private Function TrimNull(startStr As String) As String
    TrimNull = Left$(startStr, lstrlen(StrPtr(startStr)))
End Function
 
Sub Usf()
    UserForm1.Show vbModeless
End Sub

dans un module standard baptisé mFusion

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
Option Explicit
 
Sub FusionPdf()
Dim LastRow As Long, i As Long
Dim Fichiers() As Variant
Dim sFichier As String
Dim pdf As Object
Dim Debut As Currency, Fin As Currency, Freq As Currency
 
    Application.StatusBar = ""
    QueryPerformanceCounter Debut
    LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row
    If LastRow < RDepart Then Exit Sub
 
    Set pdf = CreateObject("pdfforge.Pdf.Pdf")
    For i = RDepart To LastRow
        sFichier = ShDatas.Range("B" & i)
        ReDim Preserve Fichiers(i - RDepart)
        Fichiers(i - RDepart) = sFichier
    Next i
 
    '        Public Sub MergePDFFiles ( _
    '            ByRef sourceFilenames As Object(), _
    '            destinationFilename As String, _
    '            FilenamesAsBookmarks As Boolean _
    '        )
 
    pdf.MergePDFFiles_2 Fichiers, ThisWorkbook.Path & "\" & sNomFichierFusion, True
    PosBoutons
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = FormatNumber((Fin - Debut) / Freq, 2) & " s"
 
    Erase Fichiers
    Set pdf = Nothing
End Sub
 
Sub PosBoutons(Optional Dummy As String)
Dim T As Range
    With ShDatas
        .Activate
        .Rows(1).RowHeight = 12.75
 
        Set T = .Cells(1, 3)
        With .Buttons("btnListe")
            .Left = T.Left + 3
            .Top = T.Top + ShDatas.Rows(1).RowHeight + 2
            .Width = 100
            .Height = 2 * Rows(1).RowHeight - 5
        End With
 
        With .Buttons("btnFusion")
            .Left = ShDatas.Buttons("btnListe").Left + ShDatas.Buttons("btnListe").Width + 5
            .Top = ShDatas.Buttons("btnListe").Top
            .Width = ShDatas.Buttons("btnListe").Width + 30
            .Height = ShDatas.Buttons("btnListe").Height
        End With
 
        With .Buttons("btnEffacer")
            .Left = ShDatas.Buttons("btnFusion").Left + ShDatas.Buttons("btnFusion").Width + 20
            .Top = ShDatas.Buttons("btnFusion").Top
            .Width = 50
            .Height = ShDatas.Buttons("btnFusion").Height
        End With
 
        With .Shapes("chkRecur")
            .Left = ShDatas.Shapes("btnListe").Left
            .Top = ShDatas.Shapes("btnListe").Top + ShDatas.Shapes("btnListe").Height + 5
            .Width = ShDatas.Buttons("btnListe").Width
            .Height = ShDatas.Buttons("btnListe").Height
        End With
    End With
End Sub

dans module standard baptisé mGlob

Code :

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

1
2
3
4
5
6
7
8
Option Explicit
 
Public Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
 
Public sRch As String
Public Const sNomFichierFusion As String = "Liste Excel Fusion PDFs.Pdf"
Public Const RDepart = 6

[kiki29]

Acrobat Fusion des fichiers PDF d'un dossier avec recherche récursive ou non des fichiers
On reprend le code PDFCreator précédent
en remplaçant la procédure FusionPdf du module mFusion par le code suivant :

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
Sub FusionPdf()
Dim LastRow As Long, i As Long
Dim Fichiers() As Variant
Dim sFichier As String
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim PDDocDestination As Object  
Dim PDDocSource As Object        
 
    Application.StatusBar = ""
    QueryPerformanceCounter Debut
    LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row
    If LastRow < RDepart Then Exit Sub
 
    For i = RDepart To LastRow
        sFichier = ShDatas.Range("B" & i)
        ReDim Preserve Fichiers(i - RDepart)
        Fichiers(i - RDepart) = sFichier
    Next i
 
    Set PDDocDestination = CreateObject("AcroExch.PDDoc")
    Set PDDocSource = CreateObject("AcroExch.PDDoc")
 
    With PDDocDestination
        .Create
        .Open (ThisWorkbook.Path & "\" & sNomFichierFusion)
    End With
 
    For i = LBound(Fichiers) To UBound(Fichiers)
        PDDocSource.Open (Fichiers(i))
 
        '  Paramètres :
        '   1 : Page du Document Destination après laquelle l'insertion sera faite.
		'			La 1ere page est 0.
        '   2 : Document Source contenant les pages à insérer.
        '   3 : La 1ere page à être insérée dans le Document Destination 
		'			à partir du Document Source
        '   4 : Le nombre de pages à insérer.
        '   5 : Si nombre > 0 les bookmarks sont copiés, si 0 ils ne le sont pas.
 
        PDDocDestination.InsertPages PDDocDestination.GetNumPages - 1, _
                PDDocSource, _
                0, _
                PDDocSource.GetNumPages, _
                1
 
    With PDDocDestination
        .Save 1, ThisWorkbook.Path & "\" & sNomFichierFusion
        .Close
    End With
 
    Set PDDocSource = Nothing
    Set PDDocDestination = Nothing
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = FormatNumber((Fin - Debut) / Freq, 2) & " s"
 
    Erase Fichiers
    PosBoutons
    ShDatas.Range("B2").Select
End Sub

[kiki29]

Une liste des contributions à jour pour Excel / Word / PDF avec Adobe Acrobat Pro et PDFCreator au 23 Avril 2014 au format xls avec les liens et intitulés des différents posts

PS : Les colonnes D et E sont masquées ( pour encombrement visuel ... ) et contiennent les infos nécessaires pour créer les liens dans la colonne B.

[kiki29]

VBA Excel Dans le code de PDFCreator Fusion des fichiers PDF d'un dossier avec recherche récursive ou non de ces fichiers.

On peut rajouter la possibilité de copier/coller dans la TextBox de l'UserForm via le menu contextuel ( clic droit ).

Pour cela ajouter dans un module standard que l'on baptisera mPopupMenu.

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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
Option Explicit
 
'   http://word.mvps.org/faqs/userforms/AddRightClickMenu.htm
 
' Required API declarations
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
 
' Type required by TrackPopupMenu although this is ignored !!
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
' Type required by InsertMenuItem
Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type
 
' Type required by GetCursorPos
Private Type POINTAPI
    X As Long
    Y As Long
End Type
 
' Constants required by TrackPopupMenu
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_TOPALIGN = &H0
Private Const TPM_RETURNCMD = &H100
Private Const TPM_RIGHTBUTTON = &H2&
 
' Constants required by MENUITEMINFO type
Private Const MIIM_STATE = &H1
Private Const MIIM_ID = &H2
Private Const MIIM_TYPE = &H10
Private Const MFT_STRING = &H0
Private Const MFT_SEPARATOR = &H800
Private Const MFS_DEFAULT = &H1000
Private Const MFS_ENABLED = &H0
Private Const MFS_GRAYED = &H1
 
' Contants defined by me for menu item IDs
Private Const ID_Cut = 101
Private Const ID_Copy = 102
Private Const ID_Paste = 103
Private Const ID_Delete = 104
Private Const ID_SelectAll = 105
 
' Variables declared at module level
Private FormCaption As String
Private Cut_Enabled As Long
Private Copy_Enabled As Long
Private Paste_Enabled As Long
Private Delete_Enabled As Long
Private SelectAll_Enabled As Long
 
Public Sub ShowPopup(oForm As UserForm, strCaption As String, X As Single, Y As Single)
Dim oControl As MSForms.TextBox
Static click_flag As Long
 
    ' The following is required because the MouseDown event
    ' fires twice when right-clicked !!
    click_flag = click_flag + 1
 
    ' Do nothing on first firing of MouseDown event
    If (click_flag Mod 2 <> 0) Then Exit Sub
 
    ' Set object reference to the textboxthat was clicked
    Set oControl = oForm.ActiveControl
 
    ' If click is outside the textbox, do nothing
    If X > oControl.Width Or Y > oControl.Height Or X < 0 Or Y < 0 Then Exit Sub
 
    ' Retrieve caption of UserForm for use in FindWindow API
    FormCaption = strCaption
 
    ' Call routine that sets menu items as enabled/disabled
    EnableMenuItems oForm
 
    ' Call function that shows the menu and return the ID
    ' of the selected menu item. Subsequent action depends
    ' on the returned ID.
    Select Case GetSelection()
        Case ID_Cut
            oControl.Cut
        Case ID_Copy
            oControl.Copy
        Case ID_Paste
            oControl.Paste
        Case ID_Delete
            oControl.SelText = ""
        Case ID_SelectAll
            With oControl
                .SelStart = 0
                .SelLength = Len(oControl.Text)
            End With
    End Select
End Sub
 
Private Sub EnableMenuItems(oForm As UserForm)
Dim oControl As MSForms.TextBox
Dim oData As DataObject
Dim testClipBoard As String
 
    On Error Resume Next
 
    ' Set object variable to clicked textbox
    Set oControl = oForm.ActiveControl
 
    ' Create DataObject to access the clipboard
    Set oData = New DataObject
 
    ' Enable Cut/Copy/Delete menu items if text selected
    ' in textbox
    If oControl.SelLength > 0 Then
        Cut_Enabled = MFS_ENABLED
        Copy_Enabled = MFS_ENABLED
        Delete_Enabled = MFS_ENABLED
    Else
        Cut_Enabled = MFS_GRAYED
        Copy_Enabled = MFS_GRAYED
        Delete_Enabled = MFS_GRAYED
    End If
 
    ' Enable SelectAll menu item if there is any text in textbox
    If Len(oControl.Text) > 0 Then
        SelectAll_Enabled = MFS_ENABLED
    Else
        SelectAll_Enabled = MFS_GRAYED
    End If
 
    ' Get data from clipbaord
    oData.GetFromClipboard
 
    ' Following line generates an error if there
    ' is no text in clipboard
    testClipBoard = oData.GetText
 
    ' If NO error (ie there is text in clipboard) then
    ' enable Paste menu item. Otherwise, diable it.
    If Err.Number = 0 Then
        Paste_Enabled = MFS_ENABLED
    Else
        Paste_Enabled = MFS_GRAYED
    End If
 
    ' Clear the error object
    Err.Clear
 
    ' Clean up object references
    Set oControl = Nothing
    Set oData = Nothing
End Sub
 
Private Function GetSelection() As Long
Dim menu_hwnd As Long
Dim form_hwnd As Long
Dim oMenuItemInfo1 As MENUITEMINFO
Dim oMenuItemInfo2 As MENUITEMINFO
Dim oMenuItemInfo3 As MENUITEMINFO
Dim oMenuItemInfo4 As MENUITEMINFO
Dim oMenuItemInfo5 As MENUITEMINFO
Dim oMenuItemInfo6 As MENUITEMINFO
Dim oRect As RECT
Dim oPointAPI As POINTAPI
 
    ' Find hwnd of UserForm - note different classname
    ' 97 vs 2007
    #If VBA6 Then
        form_hwnd = FindWindow("ThunderDFrame", FormCaption)
    #Else
        form_hwnd = FindWindow("ThunderXFrame", FormCaption)
    #End If
 
    ' Get current cursor position
    ' Menu will be drawn at this location
    GetCursorPos oPointAPI
 
    ' Create new popup menu
    menu_hwnd = CreatePopupMenu
 
    ' Intitialize MenuItemInfo structures for the 6
    ' menu items to be added
 
    ' Cut
    With oMenuItemInfo1
        .cbSize = Len(oMenuItemInfo1)
        .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
        .fType = MFT_STRING
        .fState = Cut_Enabled
        .wID = ID_Cut
        .dwTypeData = "Couper"
        .cch = Len(.dwTypeData)
    End With
 
    ' Copy
    With oMenuItemInfo2
        .cbSize = Len(oMenuItemInfo2)
        .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
        .fType = MFT_STRING
        .fState = Copy_Enabled
        .wID = ID_Copy
        .dwTypeData = "Copier"
        .cch = Len(.dwTypeData)
    End With
 
    ' Paste
    With oMenuItemInfo3
        .cbSize = Len(oMenuItemInfo3)
        .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
        .fType = MFT_STRING
        .fState = Paste_Enabled
        .wID = ID_Paste
        .dwTypeData = "Coller"
        .cch = Len(.dwTypeData)
    End With
 
    ' Separator
    With oMenuItemInfo4
        .cbSize = Len(oMenuItemInfo4)
        .fMask = MIIM_TYPE
        .fType = MFT_SEPARATOR
    End With
 
    ' Delete
    With oMenuItemInfo5
        .cbSize = Len(oMenuItemInfo5)
        .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
        .fType = MFT_STRING
        .fState = Delete_Enabled
        .wID = ID_Delete
        .dwTypeData = "Supprimer"
        .cch = Len(.dwTypeData)
    End With
 
    ' SelectAll
    With oMenuItemInfo6
        .cbSize = Len(oMenuItemInfo6)
        .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
        .fType = MFT_STRING
        .fState = SelectAll_Enabled
        .wID = ID_SelectAll
        .dwTypeData = "Tout Sélectionner"
        .cch = Len(.dwTypeData)
    End With
 
    ' Add the 6 menu items
    InsertMenuItem menu_hwnd, 1, True, oMenuItemInfo1
    InsertMenuItem menu_hwnd, 2, True, oMenuItemInfo2
    InsertMenuItem menu_hwnd, 3, True, oMenuItemInfo3
    InsertMenuItem menu_hwnd, 4, True, oMenuItemInfo4
    InsertMenuItem menu_hwnd, 5, True, oMenuItemInfo5
    InsertMenuItem menu_hwnd, 6, True, oMenuItemInfo6
 
    ' Return the ID of the item selected by the user
    ' and set it the return value of the function
    GetSelection = TrackPopupMenu _
            (menu_hwnd, _
            TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
            oPointAPI.X, oPointAPI.Y, _
            0, form_hwnd, oRect)
 
    ' Destroy the menu
    DestroyMenu menu_hwnd
End Function

on rajoutera dans le code de l'UserForm.

Code :

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

1
2
3
4
5
6
7
Private Sub txtBox_MouseDown(ByVal Button As Integer, _
        ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    ' If right-button clicked
    If Button = 2 Then
        ShowPopup Me, Me.Caption, X, Y
    End If
End Sub

[kiki29]

Remarque Problèmes lors de l'usage des SendKeys si Acrobat Reader 10 et +

l'usage des Sendkeys pose des problèmes à partir du Reader 10 et +

Copier/Coller le texte d'un PDF dans une feuille Excel via des SendKeys

pour le Reader :
Dans le menu Edition/Préférences catégories : Protection (renforcée)
Décocher "Activer le mode protégé au démarrage".

pour Acrobat il en est de même via le menu idoine.

[kiki29]

Acrobat Reader Retrouver le chemin du Reader via la base de registre
Adapté d'un code initial de John de Kraft

dans un module standard baptisé mAcro

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
 
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
        (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
        pType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
        (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
        ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
 
Private Const SYNCHRONIZE As Long = &H100000
Private Const STANDARD_RIGHTS_ALL As Long = &H1F0000
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_SET_VALUE As Long = &H2
Private Const KEY_CREATE_SUB_KEY As Long = &H4
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const KEY_CREATE_LINK As Long = &H20
Private Const KEY_ALL_ACCESS As Long = ((STANDARD_RIGHTS_ALL Or _
        KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or _
        KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const ERROR_SUCCESS As Long = 0
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
 
Private Function GetRegistryString(lngKey As Long, strSubKey As String, strValue As String) As String
Dim lngDataType As Long
Dim lngDataLength As Long
Dim strDataString As String
Dim lngResult As Long
Dim lngHandle As Long
Const StringLength = 150
 
    strDataString = Space(StringLength)
    lngDataType = 0
    lngDataLength = CLng(StringLength)
    lngResult = RegOpenKeyEx(lngKey, strSubKey, 0, KEY_ALL_ACCESS, lngHandle)
    If lngResult < ERROR_SUCCESS Then
        GetRegistryString = "Error"
        Exit Function
    End If
    lngResult = RegQueryValueEx(lngHandle, strValue, 0, lngDataType, ByVal strDataString, lngDataLength)
    If lngResult < ERROR_SUCCESS Then
        GetRegistryString = "Error"
        lngResult = RegCloseKey(lngHandle)
        Exit Function
    End If
    strDataString = Left$(strDataString, lngDataLength)
 
    If Len(strDataString) > 0 Then
        If Left$(strDataString, 1) = Chr(34) Then strDataString = Right$(strDataString, Len(strDataString) - 1)
    End If
 
    If Right$(strDataString, 3) < "exe" And Len(strDataString) > 0 Then
        strDataString = Left$(strDataString, Len(strDataString) - 1)
        If Len(strDataString) > 0 Then
            If Right$(strDataString, 1) = Chr(34) Then strDataString = Left$(strDataString, Len(strDataString) - 1)
        End If
        If Right$(strDataString, 3) = "exe" Then
            GetRegistryString = Left$(strDataString, lngDataLength)
        Else
            GetRegistryString = "Error"
        End If
        lngResult = RegCloseKey(lngHandle)
    End If
End Function
 
Function GetAcrobatReaderShellPath() As String
    GetAcrobatReaderShellPath = GetRegistryString(HKEY_CLASSES_ROOT, "Software\Adobe\Acrobat\Exe", "")
End Function

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
.....
    sAcro = GetAcrobatReaderShellPath
 
    If ExistenceFichier(sAcro) = False Then
        MsgBox "Le chemin d'Acrobat Reader est erroné : il faudra le corriger manuellement" & vbCrLf & vbCrLf & _
                "dans la procédure xxxxx" & vbCrLf & "à sAcro = .....", vbInformation + vbOKOnly, "Chemin du Reader erroné"
        Exit Sub
    End If
.....
 
Private Function ExistenceFichier(sFichier As String) As Boolean
    ExistenceFichier = Dir$(sFichier) <> ""
End Function

pour XP et le Reader 11.x : GetAcrobatReaderShellPath retourne "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe"

[kiki29]

Remarque : Sauvegarde en Texte avec Acrobat et Acrobat Reader

Sous Acrobat il existe 2 options de sauvegarde en Texte ( Plain ) et ( Accessible )
avec le Reader une seule ( Accessible ), dans tous les cas opter pour Accessible.

Un doc pdf comporte des tags qui permettent de connaitre l'ordre de lecture du texte.
"Accessible" seront des documents incluants ces tags contrairement à "Plain".

Concernant Sauvegarder un fichier PDF au format TEXTE via VBA Excel opter pour l"option com.adobe.acrobat.accesstext.

[kiki29]

Remarque Utilisation de Sleep si usage de SendKeys

Acrobat Reader Copier/Coller le texte d'un PDF dans une feuille Excel via des SendKeys

Code :

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

1
2
3
4
5
6
7
8
9
10
11
  .....
            Clavier
            Sleep 250
 
            Shell sAcro & " " & sFichier, vbNormalFocus
 
            SendKeys "^a", True
            SendKeys "^c", True
            SendKeys "^q", True
            Sleep 250
	    .....

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
  .....
	    Clavier
            Sleep 250
 
            Shell sAcro & " " & sFichier, vbNormalFocus
            Sleep 5000
 
            SendKeys "^a", True
            Sleep 5000
            SendKeys "^c", True
            Sleep 5000
            SendKeys "^q", True
            Sleep 5000
            .....

Ces valeurs sont à ajuster suivant la config, cela permet d'éviter des messages du style "la méthode Paste de l'objet _Worksheet a échoué".

[jeremy64]

Bonjour KIKI29 et les autres ,

je viens de voir tout tes codes mais je n'ai malheureusement pas réussi à en adapter un pour ce que je dois faire.
Mon chef me demande un fichier excel avec differents boutons qui sont chacun reliés à des pages précis d'un fichier PDF. Par exemple, le bouton "Traca 1" imprime les pages 3 à 5 de mon fichier PDF, le bouton "Traca 2" imprime les pages 8 à 13" etc.
J'arrive à relier un bouton avec mon pdf mais impossible d'imprimer les pages souhaitées.
Quelqu'un aurait-il une idée afin de me débloquer? mon chef commence à s'impatienter :s

Merci beaucoup à tous ceux qui pourront m'aider

[kiki29]

Acrobat Imprimer un PDF de la page x à y

Infos tirées de la doc : AVDoc.PrintPages firstPage , lastPage , psLevel , binaryOK , ShrinkToFit

firstPage The first page to print. The first page in a PDDoc is page 0.
lastPage The last page to print.
psLevel if 1, PostScript Level 1 operators are used. If 2, PostScript Level 2 operators are also used.
binaryOK If true, binary data may be included in the PostScript program.If false, all data is encoded as 7-bit ASCII.
ShrinkToFit If true, the page is shrunk (if necessary) to fit within the imageable area of the printed page.If false, it is not.

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
Option Explicit
 
Sub Tst()
Dim AcroApp As Object
Dim AVDoc As Object
 
    Set AcroApp = CreateObject("AcroExch.App")
    Set AVDoc = CreateObject("AcroExch.AVDoc")
 
    AVDoc.Open "C:\Essai.pdf", ""
    AVDoc.PrintPages 1, 2, 2, True, True
    AVDoc.Close True
 
    AcroApp.Exit
 
    Set AVDoc = Nothing
    Set AcroApp = Nothing
End Sub

[jeremy64]

Merci beaucoup, c'est juste parfait, je l'ai essayé sur mon ordi perso hier soir il est nickel. Par contre au boulot je n'ai pas Acrobat Pro. Je vais voir avec le service info si ils possedent les licences. Il n'y a pas d'autre possibilité en ayant juste excel?
En tout cas merci pour ta réactivité

[kiki29]

Acrobat Reader Imprimer un PDF de la page x à y via des SendKeys

Ajouter une UserForm puis la supprimer pour référencer Microsoft Forms 2.0 Object Library

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
Option Explicit
 
Sub Tst()
Dim sAcro As String, sFichier As String
Dim Clip As MSForms.DataObject, sPages As String
 
    sPages = "1;3-4"
 
    Set Clip = New MSForms.DataObject
    Clip.Clear
    Clip.SetText sPages, 1
    Clip.PutInClipboard
 
    sAcro = "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe"
    sFichier = "C:\Essai.pdf"
 
    Shell sAcro & " " & sFichier, vbNormalFocus
    'Sleep 500
 
    SendKeys "^p", True
    SendKeys "%g", True
    SendKeys "{TAB}", True
    SendKeys "^v", True
    SendKeys "{ENTER}", True
    'Sleep 500
 
    KillAcrobatReader
    Set Clip = Nothing
End Sub
 
Private Sub KillAcrobatReader()
    Shell "Taskkill /im Acrobat.exe /f", 0
End Sub

Il est probable que l'utilisation de Sleep soit nécessaire, et donc l'ajout de la déclaration :

Code :

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

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

[illight]

Bonjour,


Je viens de lire ces posts ici et ici : ces 2 points de cféation de signets dans Excel m'intéresse au plus haut point.

Seulement, par rapport à ce que j'ai pu lire, j'ai l'impression qu'il faut une version particulière d'Excel, et Adobe Reader ne suffit pas.
Pouvez-vous me confirmer ou m'infirmer (ce qui m'arrangerai ) ?

J'ai un énorme fichier Excel, avec plusieurs onglets, qui correspondraient aux différents signets de mon fichier PDF final, mais je ne sais pas si c'est possible avec les macros présentées, et seulement Adobe Reader (et PDFCreator mais bon..).

En vous remerciant par avance pour vos réponses