Discussion :

[kiki29]

Acrobat Reader Rotation d'une page

Salut, et merci
En reprenant une partie du code du Post 21 et en y rajoutant un Sendkeys et un vbModeless, cela fonctionnera de façon qq peu "aléatoire". A adapter à ton contexte.

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Option Explicit
 
Private Sub LoadPDF(ByVal sNomFichier As String, iNumPage As Long)
    .....
 
        .setZoom 58
    End With
 
    UserForm1.Show vbModeless
    SendKeys "+^{+}",True
 
    .....
End Sub

Sinon il te faudra Acrobat Pro, voir Rotation d'une Page

[kiki29]

Salut, @mimo13100 : Merci et désolé mais le terme de "revue partagée" n'évoque chez moi strictement rien.
Quant à l'interactivité d'un pdf il faut faire appel à du code JavaScript qui doit être inclus dans le fichier pdf lui-même et/ou des librairies : voir ici. C'est une autre paire de manches ..... et à mon avis le pdf n'est pas approprié.

[MIMO13100]

Salut, @mimo13100 : Merci et désolé mais le terme de "revue partagée" n'évoque chez moi strictement rien.
Quant à l'interactivité d'un pdf il faut faire appel à du code JavaScript qui doit être inclus dans le fichier pdf lui-même et/ou des librairies : voir ici. C'est une autre paire de manches ..... et à mon avis le pdf n'est pas approprié.

Salut kiki29,

Merci pour ta réponse, même si elle ne m'arrange pas

Concernant la revue partagée j'ai trouvé cette fonctionnalité dans mon Adobe Acrobat X pro


Mon but est de pouvoir envoyé en révision a de multiple valideurs mon fichier pdf, mais également permettre dans le même temps la validation du fichier par le remplissage d'un formulaire or lorsque j'utilise la fonction de revue partagée, les valideurs peuvent ouvir en même temps le fichier et le commenter ( un peu comme une e-room) mais ne peuvent ni remplir mon formulaire ni le signer electroniquement ... d'où mon interrogation concernant des lignes de codes pour piloter ce type de revue sans passer par Acrobat...

[davido84]

Bonjour,

en hommage au remarquable travail fourni par l'auteur de ce fil je joins un petit fichier permettant d'effectuer une recherche avancée dans Adobe Reader via l'utilisation d'API Windows.

Les temps de pause seront probablement à adapter en fonction de votre ordinateur (je les ai placés à 200 ms).
Tester cependant 2-3 fois avant de commencer à les modifier.

Vous pouvez compléter la liste des dossiers à sélectionner en complétant en colonne G les items du menu déroulant de la fenêtre de recherche avancée d'Adobe Reader (ouvrir Adobe>menu Edition>recherche avancée).

Si vous choisissez l'item "Parcourir..." le chemin vers lequel sera orienté la recherche doit être renseigné en B4.

Vous pouvez également choisir certaines options proposées (mots entiers, respect de la casse, etc.).

Fichier testé sous Windows 7 (Excel 2007 et 2010 64 bits) et Windows 8 (Excel 2007) avec Adobe Reader 10 et 11.

Merci de me faire remonter vos remarques éventuelles et les bugs constatés en n'oubliant pas de préciser votre système d'exploitation et votre version d'Excel.
A+

[kiki29]

Salut David, chapeau et encore bravo pour cette contribution tout à fait remarquable, autrement plus stable que la mienne via des Sendkeys ( un peu à l'arrache ... ). Merci aussi de rompre ce monologue où je soliloquais depuis longtemps.

[davido84]

Bonsoir,
Merci Philippe.
Code très légèrement épuré. Modification faite dans le fichier du message 144.
A+

[davido84]

Bonjour,
suite à la version initiale du fichier placé dans le premier message il m'a paru également intéressant de pouvoir récupérer le chemin des fichiers issus d'une recherche avancée (ceux affichés dans la fenêtre des résultats).

Ci-joint une possibilité.
Celle-ci fonctionne mais n'est pas des plus directes.

J'ai tenté via les API Windows d'accéder directement au Treeview de la fenêtre des résultats et aux différents chemins de fichier qu'elle contient mais sans succès. Je ne sais pas si je m'y prends mal ou si le programme Adobe Reader empêche ce genre de chose.

J'ai donc utilisé un moyen détourné consistant à aller chercher dans la fenêtre de propriétés du document l'emplacement et le nom de chaque fichier.

Le fait de procéder de la sorte allonge le temps de traitement car Adobe lance alors ses procédures de sécurité et autres fonctionnalités (vérification de la signature éventuelle du fichier et autres procédures) lors de l'ouverture de celui-ci.

Si toutefois certain(e)s d'entre vous sont intéressé(e)s pour creuser la question de voir s'il n'est pas possible de récupérer directement le texte affiché dans la fenêtre des résultats je veux bien livrer les pistes que j'ai creusées et continuer d'étudier la question en ouvrant le cas échéant un fil de discussion.

Merci de me faire remonter les problèmes éventuels que vous avez notés.
A+

[franck1872]

PDFCreator Rotation d'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
30
31
32
33
34
35
36
37
38
39
40
41
Option Explicit
 
Sub RotationPages()
Dim pdf As Object
Dim sIn As String
Dim FSO As Object
Dim sDossierRotation As String
 
    '    Public Function CreatePDFTestDocument( _
         '        destinationFilename As String, _
         '        countOfPages As Integer, _
         '        additionalText As String, _
         '        addPagenumbers As Boolean _
         '    ) As Integer
 
    '    Public Function RotatePages( _
         '        sourceFilename As String, _
         '        destinationFilename As String, _
         '        fromPage As Integer, _
         '        toPage As Integer, _
         '        angle As Integer _
         '    ) As Integer
 
    sDossierRotation = ThisWorkbook.Path & "\" & "Rotation"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(sDossierRotation) Then FSO.CreateFolder (sDossierRotation)
 
    sIn = sDossierRotation & "\" & "Test Rotation de Pages.pdf"
 
    Set pdf = CreateObject("pdfforge.pdf.pdf")
 
    pdf.CreatePDFTestDocument sIn, 2, "Test Rotation de Pages", True
    pdf.RotatePages sIn, sDossierRotation & "\" & "test 0°.pdf", 1, 1, 0
    pdf.RotatePages sIn, sDossierRotation & "\" & "test 90°.pdf", 1, 2, 90
    pdf.RotatePages sIn, sDossierRotation & "\" & "test 180°.pdf", 1, 1, 180
    pdf.RotatePages sIn, sDossierRotation & "\" & "test 270°.pdf", 1, 2, 270
 
 
    Set FSO = Nothing
    Set pdf = Nothing
End Sub

Comment fait on pour intégrer les valeurs ?

En fait, je me sers de PDF Creator pour faire des fichier .tif et je dois leurs faire faire une rotation de 180°, et j'aurai aimé le faire de façon automatique.

par avance Merci.

Franck

[kiki29]

Salut, désolé mais la fonction RotatePages de PDFCreator ne permet de faire une rotation qu'à un fichier pdf, pas à un fichier tif ou autre.

Par contre PDFCreator permet effectivement de convertir des formats ( bmp emf gif jfif jpe jpeg jpg png tif tiff wmf ) en pdf : Post# 110.

[franck1872]

Merci.

Je vais faire mes documents en PDF. Par contre a quelle moment on rentre les valeurs de la rotation souhaité ?

par avance merci.

Franck

[kiki29]

Salut, allons quand même ..... il faut générer le pdf puis ensuite lui appliquer une rotation.

[kiki29]

Salut, j'avais totalement oublié ceci : Utiliser la librairie Windows Image Acquisition en VBA pour la manipulation d'images

[kiki29]

En relation avec Pdf2Xls

En retestant Pdf2Xls, une Modif Tempo à faire ( suivant système/PC ) sinon : La méthode 'Paste' de l'objet '_worksheet' a échoué
cela dans la procédure Pdf2Txt du module mPdf.

sous XP

Code :

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

1
2
3
4
5
            Shell sAcro & " " & sFichier, vbNormalFocus
            SendKeys "^a", True
            SendKeys "^c", True
            SendKeys "^q", True
            Sleep 250

sous W8.1

Code :

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

1
2
3
4
5
6
7
8
9
Const Tempo As Long = 300
 
            Shell sAcro & " " & sFichier, vbNormalFocus
            Sleep Tempo
            SendKeys "^a", True
            SendKeys "^c", True
            Sleep Tempo
            SendKeys "^q", True
            Sleep 1.5 * Tempo

Voir Pdf2Excel 2007+

[Invité]

Bonjour et merci pour votre travaille,

Je travaille actuellement sur une macro Excel qui me permet d'ouvrir un fichier PDF et de l'imprimer. Pour ce faire, j'ai utilisé une solution proposée dans le post suivant: http://www.developpez.net/forums/d11...pdf-via-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
 
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 Sub PrintFichier(sNomFichier As String)
Dim Rep As Integer
Dim hwnd As Long
    Rep = ShellExecute(hwnd, "Print", sNomFichier, 0&, 0&, 1)
End Sub
 
Sub Tst()
Dim sDossier As String
Dim sFichier As String
    sDossier = "lien vers le dossier"
    sFichier = "nom du fichier"
    PrintFichier sDossier & "\" & sFichier
End Sub

Une problématique se pose alors dans le format d’impression. Je souhaite que mon fichier sorte en format A3 et non A4, comme c'est le cas par défaut dans mon fichier. J'ai cherché du coté de ma configuration imprimante ou de Adobe Reader mais je n'ai rien trouvé... Je suis également limité dans les réglages par le fait que je travaille sur le réseau entreprise de mon client... Après des recherches sur internet, je n'ai encore rien trouvé qui puisse m'aider...

Auriez vous une solution pour inclure à la macro une ligne de code permettant de paramétrer l'impression?

En vous remerciant pour votre retour!

[kiki29]

Salut, menu Fichier/Imprimer
cliquer sur Propriétés
puis sur l'onglet Disposition
et enfin cliquer sur Avancé, ou peut-être via des SendKeys acrobatiques .....

[kiki29]

Acrobat Pro Nombre de pages d'une liste de fichiers pdf

Suite du post de QuestVba

Une autre solution via RegExp qui fonctionne : voir code initial Acrobat.

Pour cela : Modifier le code initial Acrobat
Dans le module mPages ajouter la procédure Comptage_RegExp ainsi que la fonction GetPageNum
Ajouter un bouton sur la feuille Param et l'affecter à Comptage_RegExp ou remplacer l'affectation du bouton "Nb Pages"

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 Comptage_RegExp()
Dim i As Long, LastRow As Long, sFichier As String
Dim iNbTotal As Long
Dim iNbPages As Long
 
    QueryPerformanceCounter Debut
    iNbTotal = 0
    LastRow = ShParam.Range("B" & Rows.Count).End(xlUp).Row
 
    For i = RDepart To LastRow
        sFichier = ShParam.Cells(1, 1) & "\" & ShParam.Cells(i, 2)
 
        iNbPages = GetPageNum(sFichier)
 
        With ShParam
            .Cells(i, 3) = iNbPages
            iNbTotal = iNbTotal + iNbPages
            .Cells(1, 5) = iNbTotal
        End With
 
        Application.StatusBar = i & " / " & LastRow
        DoEvents
    Next i
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = Format((Fin - Debut) / Freq, "0.00 s")
End Sub

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
Private Function GetPageNum(PDF_File As String) As Long
Dim FileNum As Long
Dim sStr As String
Dim RegExp As Object
 
    Set RegExp = CreateObject("VBscript.RegExp")
    RegExp.Global = True
    RegExp.Pattern = "/Type\s*/Page[^s]"
 
    FileNum = FreeFile
    Open PDF_File For Binary As #FileNum
        sStr = Space(LOF(FileNum))
        Get #FileNum, , sStr
    Close #FileNum
 
    GetPageNum = RegExp.Execute(sStr).Count
 
    Set RegExp = Nothing
End Function

[kiki29]

Acrobat Pro Lecture de formulaires PDF
Testé avec Acrobat Pro 15.6 / Distiller 15.6 / Reader 11.0.12

Suite de ce post

En reprenant le post 41
Source permettant le dépouillement de formulaires PDF

Créer un classeur avec 2 feuilles : Param et Extraction avec les CodeName : ShParam et ShExtraction

sur Param : créer 4 boutons : Liste Fichiers PDF, Lecture Formulaire, puis 2 boutons d'effacement Fichiers et Extractions, et une CheckBox "Recherche récursive" Voir le code pour les CodeName de ces boutons et autres.

un module standard baptisé mGlob avec le code suivant :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
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 RDepart = 6
 
Public Debut As Currency, Fin As Currency, Freq As Currency
Public sDossierDepart As String
Public NbC As Long

un module standard baptisé mMenus avec 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
Option Explicit
 
Public MenuPrincipal As CommandBarPopup
Public SousMenu1 As CommandBarControl
Public SousMenu2 As CommandBarControl
Public SousMenu3 As CommandBarControl
 
Sub EffacerMenus(Optional Dummy As String)
Dim Ctrl As CommandBarControl
    For Each Ctrl In Application.CommandBars("Cell").Controls
        If Ctrl.Caption = "PDF" Then Ctrl.Delete
    Next Ctrl
End Sub

un module standard baptisé mPDF avec 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
182
183
184
185
186
187
188
189
190
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Dim bFlag As Boolean, Cpt As Long
 
Private Sub DecompteA()
Dim LastRow As Long, i As Long
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Cpt = 0
    With ShParam
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        For i = LastRow To RDepart Step -1
            If FSO.fileExists(.Cells(1, 1) & "\" & .Cells(i, 2)) Then
                If UCase$(.Cells(i, 1)) = "X" Then Cpt = Cpt + 1
            Else
                .Cells(i, 1) = "o"
            End If
        Next i
    End With
    Set FSO = Nothing
End Sub
 
Private Sub EffacerExt()
    With ShExtraction
        .Activate
        .Cells.Delete Shift:=xlUp
        .Range("A1").Select
    End With
    ActiveWindow.FreezePanes = False
End Sub
 
Sub Extraction()
Dim sFichier As String
Dim LastRow As Long, i As Long
Dim iDep As Long, iFin As Long
Dim sDossier As String, sCol As String
 
    QueryPerformanceCounter Debut
    DecompteA
    If Cpt = 0 Then
        MsgBox "Taper dans la colonne A un x ou X en vis à vis" & vbCrLf & _
               "des fichiers  à traiter de la colonne B", vbInformation + vbOKOnly, "x ou X"
        Exit Sub
    End If
 
    Application.StatusBar = ""
    Application.ScreenUpdating = False
 
    sDossier = ShParam.Cells(1, 1)
    LastRow = ShParam.Range("B" & Rows.Count).End(xlUp).Row
    ShExtraction.Activate
 
    With ShExtraction
        .Activate
        .Cells.Delete Shift:=xlUp
        .Range("A1").Select
    End With
 
    iDep = 0: iFin = LastRow - RDepart + 1
    bFlag = False
 
    For i = RDepart To LastRow
        If UCase$(ShParam.Range("A" & i)) = "X" Then
            Init (sDossier & "\" & ShParam.Cells(i, 2))
            Exit For
        End If
    Next i
 
    For i = RDepart To LastRow
        If UCase$(ShParam.Range("A" & i)) = "X" Then
            bFlag = True
            iDep = iDep + 1
            sFichier = sDossier & "\" & ShParam.Range("B" & i)
 
            Lecture_ChampsFormulaire sFichier
 
            Application.StatusBar = "Lecture : " & iDep & " / " & Cpt
        End If
    Next i
 
    sCol = NumCol2Lettre(NbC + 1)
    With ShExtraction
        .Columns("A:" & sCol).Columns.AutoFit
        .Range("A1").Select
    End With
 
    With ActiveWindow
        .ScrollColumn = 1
        .ScrollRow = 1
    End With
 
    Application.ScreenUpdating = True
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = "Terminé : " & Format((Fin - Debut) / Freq, "0.00 s")
 
    KillAcrobat
End Sub
 
Private Sub Init(ByVal sNomFichier As String)
Dim AVDoc As Object
Dim Champ As Object
Dim Fields As Object
Dim AcroForm As Object
Dim i As Long, sCol As String
 
    Set AVDoc = CreateObject("AcroExch.AVDoc")
 
    If AVDoc.Open(sNomFichier, "") Then
 
        Set AcroForm = CreateObject("AFormAut.App")
        Set Fields = AcroForm.Fields
 
        i = 2: NbC = 0
        For Each Champ In Fields
            ShExtraction.Cells(1, i) = Champ.Name
            i = i + 1
            NbC = NbC + 1
        Next Champ
 
        sCol = NumCol2Lettre(NbC + 1)
        With ShExtraction
            .Range("A1:" & sCol & "1").Interior.ColorIndex = 40
            .Range("A1") = "Fichier"
            .Rows("2:2").Select
        End With
 
        ActiveWindow.FreezePanes = True
        Set Champ = Nothing
        Set Fields = Nothing
        Set AcroForm = Nothing
    End If
 
    Set AVDoc = Nothing
End Sub
 
Private Sub KillAcrobat()
Dim Rep As Variant
    Rep = Shell("Taskkill /im Acrobat.exe /f", 0)
End Sub
 
Private Sub Lecture_ChampsFormulaire(ByVal sNomFichier As String)
Dim AVDoc As Object
Dim Champ As Object
Dim Fields As Object
Dim AcroForm As Object
Dim i As Long, j As Long
Dim LastR As Long, sNom As String, Pos As Long
 
    Set AVDoc = CreateObject("AcroExch.AVDoc")
 
    If AVDoc.Open(sNomFichier, "") Then
 
        Set AcroForm = CreateObject("AFormAut.App")
        Set Fields = AcroForm.Fields
 
        LastR = ShExtraction.Range("A" & Rows.Count).End(xlUp).Row
 
        i = LastR + 1: j = 1
        Pos = InStrRev(sNomFichier, "\")
        sNom = Mid$(sNomFichier, Pos + 1, Len(sNomFichier))
        ShExtraction.Cells(i, 1) = sNom
 
        For Each Champ In Fields
            ShExtraction.Cells(i, j + 1) = Trim$(Champ.Value)
            If Trim$(Champ.Value) = "Off" Then ShExtraction.Cells(i, j + 1) = "No"
            j = j + 1
        Next Champ
 
        Set Champ = Nothing
        Set Fields = Nothing
        Set AcroForm = Nothing
    End If
 
    Set AVDoc = Nothing
End Sub
 
Private Function NumCol2Lettre(iNumCol As Long) As String
Dim i As Long, sStr As String
    i = iNumCol
    sStr = ""
    Do While i > 0
        sStr = Chr$(((i - 1) Mod 26) + 65) & sStr
        i = (i - 1) \ 26
    Loop
    NumCol2Lettre = sStr
End Function

un module standard baptisé mRch avec 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
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
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 iNbDossier As Long
 
Private Sub Effacer()
    With ShParam
        .Activate
        .Columns("B:B").ClearContents
        .Range("A1").ClearContents
        .Range("A3:A5").ClearContents
        .Range("A6:A" & .Rows.Count).ClearContents
        With .Range("A6:A" & .Rows.Count)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .Interior.ColorIndex = xlNone
        End With
        PosBoutons
        .Activate
        .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 Sub PosBoutons()
Dim T As Range
    Application.ScreenUpdating = False
    With ShParam
        .Activate
        .Rows(1).RowHeight = 12.75
 
        Set T = .Cells(1, 3)
        With .Buttons("btnListe")
            .Left = T.Left + 3
            .Top = T.Top + 15
            .Width = 100
            .Height = 2 * Rows(1).RowHeight - 5
        End With
 
        With .Buttons("btnExtraction")
            .Left = ShParam.Buttons("btnListe").Left + ShParam.Buttons("btnListe").Width + 5
            .Top = ShParam.Buttons("btnListe").Top
            .Width = ShParam.Buttons("btnListe").Width + 30
            .Height = ShParam.Buttons("btnListe").Height
        End With
 
        With .Buttons("btnEffacer")
            .Left = ShParam.Buttons("btnExtraction").Left + ShParam.Buttons("btnExtraction").Width + 5
            .Top = ShParam.Buttons("btnListe").Top
            .Width = ShParam.Buttons("btnListe").Width + 30
            .Height = ShParam.Buttons("btnListe").Height
        End With
 
        With .Buttons("btnEffacerExt")
            .Left = ShParam.Buttons("btnEffacer").Left
            .Top = ShParam.Buttons("btnEffacer").Top + ShParam.Buttons("btnEffacer").Height + 5
            .Width = ShParam.Buttons("btnListe").Width + 30
            .Height = ShParam.Buttons("btnListe").Height
        End With
 
        With .Shapes("chkRecur")
            .Left = ShParam.Shapes("btnListe").Left
            .Top = ShParam.Shapes("btnListe").Top + ShParam.Shapes("btnListe").Height + 5
            .Width = ShParam.Buttons("btnListe").Width
            .Height = ShParam.Buttons("btnListe").Height
        End With
        .Range("B2").Select
    End With
 
    Application.ScreenUpdating = False
End Sub
 
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 ShParam
        .Columns("A:B").ClearContents
        .Cells(1, 1) = sRacine
        .Cells(2, 1) = srch
        .Cells(3, 1) = ""
        .Cells(4, 1) = ""
        .Cells(5, 1) = ""
        .Range("B" & RDepart & ":B" & Rows.Count).Clear
    End With
 
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1
 
    Application.ScreenUpdating = False
    With FP
        .sFileRoot = QualifyPath(ShParam.Cells(1, 1))
        .sFileNameExt = ShParam.Cells(2, 1)
        .bRecurse = ShParam.CheckBoxes("chkRecur").Value = 1
        .nCount = 0
        .nSearched = 0
        iNbDossier = 0
        '   0=inclus tous les fichiers
        '   1=exclus sauf extension : ici pdf
        .bFindOrExclude = 1
    End With
 
    QueryPerformanceCounter Debut
    sDossierDepart = FP.sFileRoot
    SearchForFiles FP.sFileRoot
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
 
    With ShParam
        .Cells(3, 1) = iNbDossier & " Dossier(s)"
        .Cells(4, 1) = Format$(FP.nCount, "###,###,###,##0 Fichier(s)")
        .Cells(5, 1) = FormatNumber((Fin - Debut) / Freq, 3) & " s"
 
        .Range("A1:A5").HorizontalAlignment = xlLeft
        .Range("A2:A5").Columns.AutoFit
        PosBoutons
 
        .Activate
        .Range("B2").Select
    End With
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub SearchForFiles(sRoot As String)
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long, i As Long, sDoss As String
 
    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
                    iNbDossier = iNbDossier + 1
                    If FP.bRecurse Then SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackSlash
                End If
            Else
                If MatchSpec(WFD.cFileName, FP.sFileNameExt) Then
                    FP.nCount = FP.nCount + 1
                    i = Len(sDossierDepart)
                    sDoss = Right$(sRoot & TrimNull(WFD.cFileName), Len(sRoot & TrimNull(WFD.cFileName)) - i)
                    ShParam.Cells(FP.nCount + RDepart - 1, 2) = sDoss
                End If
            End If
        Loop While FindNextFile(hFile, WFD)
    End If
    Application.StatusBar = iNbDossier & " / " & FP.nCount
    FindClose hFile
End Sub
 
Sub SelDossierRacine(Optional Dummy As String)
Dim sChemin As String, sDossierDepart As String
Dim FSO As Object
 
    sChemin = ThisWorkbook.Path
    sDossierDepart = ShParam.Cells(1, 1)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(sDossierDepart) Then sChemin = sDossierDepart
    Set FSO = Nothing
 
    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
            ShParam.Activate
            Effacer
            ShParam.Range("B2").Select
            DoEvents
            Rch .SelectedItems(1)
        End If
    End With
End Sub
 
Private Function TrimNull(startStr As String) As String
    TrimNull = Left$(startStr, lstrlen(StrPtr(startStr)))
End Function
 
Sub Usf(Optional Dummy As String)
    UserForm1.Show vbModeless
End Sub

Une UserForm1 avec 2 boutons Sélection et Annuler et une TextBox contenant *.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
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
    ShParam.Activate
    ShParam.Range("B2").Select
End Sub
 
Private Sub UserForm_Initialize()
    If Len(ShParam.Range("A2")) = 0 Then ShParam.Range("A2") = "*.pdf"
    txtBox.Text = ShParam.Range("A2")
End Sub

Dans ThisWorkbook

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
Option Explicit
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.CutCopyMode = False
    Application.ErrorCheckingOptions.NumberAsText = True
End Sub
 
Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    Application.ErrorCheckingOptions.NumberAsText = False
    With ShParam
        .Activate
        .Range("B2").Select
    End With
    Application.ScreenUpdating = True
End Sub

Dans ShParam

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 Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    EffacerMenus
 
    Set MenuPrincipal = CommandBars("cell").Controls.Add(Type:=msoControlPopup, before:=1, temporary:=True)
    With MenuPrincipal
        .Caption = "PDF"
        .BeginGroup = True
    End With
 
    Set SousMenu1 = MenuPrincipal.Controls.Add(Type:=msoControlButton)
    With SousMenu1
        .Caption = "Liste Fichiers Pdf"
        .OnAction = "Usf"
        .FaceId = 25
    End With
 
    Set SousMenu2 = MenuPrincipal.Controls.Add(Type:=msoControlButton)
    With SousMenu2
        .Caption = "Lecture Formulaires"
        .OnAction = "Extraction"
        .FaceId = 237
    End With
End Sub
 
Private Sub Worksheet_Deactivate()
    EffacerMenus
End Sub

[kiki29]

Pour en revenir aux posts 49 et 153 qui concernaient Pdf2Xls et Pdf2Excel 2007+

Suite à une remarque pertinente de Davido84, une modif permet en fait de supprimer le module de Classe baptisé clsKeyBoard et apparemment de pallier le problème de désactivation des NumLock CapsLock ScrollLock PauseLock.

Dans la procédure Pdf2Txt du module mPDF

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Dim Wsh As Object  
 
            Set Wsh = CreateObject("WScript.Shell")
            With Wsh
                .SendKeys "^a", True
                .SendKeys "^c", True
                Sleep Tempo
                .SendKeys "^q", True
                Sleep 2 * Tempo
            End With
            Set Wsh = Nothing

[jeeerome]

Bonjour,

La liste des remerciements est déjà longue mais j'en ajoute encore un !
C'est vraiment très pratique et très complet ...

Je viens d'utiliser la fonction d'inclusion de fichier (qui fonctionne sans problème)
Je cherche à la compléter en permettant l'ajout d'un lien vers les pièces jointes directement dans le corps du texte du document PDF principal.
Le standard PDF l'autorise mais je ne trouve rien dans la documentation PDFCREATOR qui le permet.

Avez vous une idée ou une piste de solution ?

Encore merci !

[kiki29]

Salut, j'avais totalement oublié ceci : Acrobat : Exécution d'un code JavaScript

Dans le dernier script proposé ( extrait de la doc de référence d'Acrobat ), on recherche un mot dans un PDF, on l'encadre puis on crée un lien ( ici vers un site web )

Ce post 112 pourra servir de base à tes essais, ainsi que les docs disponibles ici : Acrobat DC SDK Documentation