SoftwareBundler win32/stallmonitz s'installe avec certains ( peut-être tous ? ) téléchargements de PDFCreator 1.7.3. Il est Signalé/Mis en quarantaine par Windows Defender. A supprimer.
Version imprimable
SoftwareBundler win32/stallmonitz s'installe avec certains ( peut-être tous ? ) téléchargements de PDFCreator 1.7.3. Il est Signalé/Mis en quarantaine par Windows Defender. A supprimer.
Bonjour KIKI,
très bon travail, mais j'aurais une question à te posé !
comment récupérer les données de cellules positionnés à différent endroit d'une feuille et les rentrés dans un formulaire pdf, au bon endroit ?
j'ai bien utilisé les codes de la page 3, mais comme je suis novice dans la programmation :calim2: j'aurais besoin d'aide :weird:
merci de ta participation et encore une fois très bon travail.
Salut, dans les Post#42 et 43 tu as la réponse à ton problème
Cela nécessite d'avoir Acrobat ( pas le Reader ) mais cela tu dois t'en être rendu compte.
Tu connais le nom et type de champ dans le pdf : Set X = JSO.getField("Adresse")
Tu lui affectes la valeur voulue X.Value = CStr(Feuil2.Range("Adresse"))
Ces manips sont à renouveler pour tous les champs.
Après il y a ceci qui permet le dépouillement de formulaires.
Merci kiki,
bon alors là je suis complètement perdu :calim2:
tu pourrais me donné le code ? :oops:
je suis vraiment trop nul :oops:
Tu as avec le post#41 Lecture des champs d'un formulaire PDF la possibilité de lire le nom des champs d'un formulaire et leur type.
Après avec les posts cités plus haut tu modifies et adaptes à ton contexte pour faire concorder les champs de ton formulaire et les données de ta/tes feuilles Excel.
Merci encore Kiki,
bon alors sa marche :ptdr:
comment tu copie pour chaque cellule ?:calim2:Code:
1
2
3
4
5
6
7
8 If AVDoc.Open(sChemin, "") Then Set PDDoc = AVDoc.GetPDDoc Set JSO = PDDoc.GetJSObject For i = 2 To LastRow Set X = JSO.getField("Adresse") X.Value = CStr(Feuil2.Range("C7")) Next i
Oupss 8O
Je suis vraiment trop nul :oops:
Merci j'ai trouvé dur dur ce matin
sa le fait pas de ce coucher tard.:ptdr:
Par-contre Kiki
comment tu fait pour enregistré le fichier PDF avec l'année du fichier excel ?
l'enregistré dans un nouveau dossier créer avec l'année toujours du fichier excel ? :aie:
le tout avec le même bouton :lol:
Merci. :oops:
Pour les fichiers/dossiers tu as Manipulation des fichiers en VBA
sinon Excel et l'enregistreur de macro
En espérant par cela clôturer les verbiages et autres jacasseries inutiles qui viennent polluer ce bazar.
Acrobat Découpage d'un fichier Pdf en fichiers de n pages
Affecter un bouton à SelFichier
Téléchargement : iciCode:
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 Option Explicit Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _ (ByVal hwnd As Long, _ ByVal pszPath As String, _ ByVal lngsec As Long) As Long Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean Dim sRacine As String, sDossierPDFs As String Private Function CreationDossier(sDossier) As Long Dim Rep As Long Rep = SHCreateDirectoryEx(0&, sDossier, 0&) End Function Private Sub DecoupagePDF(sFichier As String) Dim PDDoc As Object Dim oPDF As Object Dim iNumPage As Long, sNom As String Dim i As Long, sDossier As String Dim Deb As Currency, Fin As Currency, Freq As Currency Dim sNomfichier As String, FSO As Object, iNbPages As Long, iLast As Long QueryPerformanceCounter Deb Nettoyage sDossier = sRacine & "\" & sDossierPDFs Set PDDoc = CreateObject("AcroExch.pdDoc") If PDDoc.Open(sFichier) Then iNumPage = PDDoc.GetNumPages iNbPages = Feuil1.Range("NbPages") If iNbPages > iNumPage Then PDDoc.Close Set PDDoc = Nothing Feuil1.Range("NbPages").Select MsgBox "Nb de pages invalide", vbOKOnly + vbInformation Exit Sub End If iLast = iNumPage Mod iNbPages Set FSO = CreateObject("Scripting.FileSystemObject") sNomfichier = FSO.GetBaseName(sFichier) Set FSO = Nothing For i = 0 To iNumPage - 1 - iLast Step iNbPages Set oPDF = CreateObject("AcroExch.PDDoc") oPDF.Create sNom = sNomfichier & "_" & Format(i + 1, "000") & "_" & Format(i + iNbPages, "000") & ".pdf" With oPDF .InsertPages -1, PDDoc, i, iNbPages, 0 .Save 1, sDossier & "\" & sNom .Close End With Set oPDF = Nothing Application.StatusBar = i + 1 & " / " & iNumPage Next i If iLast > 0 Then Set oPDF = CreateObject("AcroExch.PDDoc") oPDF.Create i = iNumPage - iLast sNom = sNomfichier & "_" & Format(i + 1, "000") & "_" & Format(i + iLast, "000") & ".pdf" With oPDF .InsertPages -1, PDDoc, i, iLast, 0 .Save 1, sDossier & "\" & sNom .Close End With Set oPDF = Nothing Application.StatusBar = i + 1 & " / " & iNumPage End If End If Set PDDoc = Nothing QueryPerformanceCounter Fin QueryPerformanceFrequency Freq Application.StatusBar = "Terminé : " & Format((Fin - Deb) / Freq, "0.000 s") End Sub Private Sub Nettoyage() Dim FSO As Object sRacine = ThisWorkbook.Path sDossierPDFs = "Split" Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FolderExists(sRacine & "\" & sDossierPDFs) Then _ FSO.DeleteFolder sRacine & "\" & sDossierPDFs, True Set FSO = Nothing CreationDossier sRacine & "\" & sDossierPDFs End Sub Sub SelFichier() With Application.FileDialog(msoFileDialogFilePicker) .InitialFileName = ThisWorkbook.Path & "\" .Title = "Sélectionner un Fichier" .Filters.Clear .Filters.Add "PDF", "*.pdf", 1 .AllowMultiSelect = False .InitialView = msoFileDialogViewDetails .ButtonName = "Sélection Fichier" .Show If .SelectedItems.Count > 0 Then DoEvents DecoupagePDF .SelectedItems(1) End If End With End Sub
PowerPoint 2003 : Générer un PDF protégé via PDFCreator
Code:
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 Option Explicit Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Dim sChemin As String Private Sub Chemin() Dim JobPDF As Object Set JobPDF = CreateObject("PDFCreator.clsPDFCreator") With JobPDF If .cStart("/NoProcessingAtStartup") = False Then MsgBox "Initialisation PDFCreator impossible.", vbCritical + _ vbOKOnly, "PDFCreator" Exit Sub End If sChemin = .coption("AutosaveDirectory") End With Set JobPDF = Nothing Kill_PDFCreator End Sub Private Sub EncryptPDF(sNomFichier As String, sOutputCrypt As String) Dim Pdf As Object, Crypt As Object Set Crypt = CreateObject("pdfforge.pdf.PDFEncryptor") With Crypt .AllowAssembly = False .AllowCopy = False .AllowFillIn = False .AllowModifyAnnotations = False .AllowModifyContents = False .AllowPrinting = True .AllowPrintingHighResolution = True .AllowScreenReaders = False .EncryptionMethod = 2 .OwnerPassword = "master" .UserPassword = "" End With Set Pdf = CreateObject("pdfforge.pdf.pdf") Pdf.EncryptPDFFile sNomFichier, sOutputCrypt, Crypt Set Pdf = Nothing Set Crypt = Nothing End Sub Sub GénérerPDF() Dim sNomPdf As String, sPdf As String Dim sDossier As String Dim sNomCrypt As String Dim FSO As Object sDossier = ActivePresentation.Path Chemin Set FSO = CreateObject("Scripting.FileSystemObject") sNomPdf = FSO.GetBaseName(ActivePresentation.Name) & ".pdf" Set FSO = Nothing sPdf = sChemin & sNomPdf With ActivePresentation.PrintOptions .RangeType = ppPrintAll .NumberOfCopies = 1 .Collate = msoTrue .OutputType = ppPrintOutputSlides .PrintHiddenSlides = msoTrue .PrintColorType = ppPrintColor .FitToPage = msoTrue .FrameSlides = msoFalse .ActivePrinter = "PDFCreator" End With ActivePresentation.PrintOut ' A ajuster Sleep 2000 sNomCrypt = sDossier & "\" & "Tempo.pdf" EncryptPDF sPdf, sNomCrypt Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FileExists(sPdf) Then Kill sPdf If FSO.FileExists(sNomPdf) Then Kill sNomPdf Name sNomCrypt As sNomPdf Set FSO = Nothing End Sub Private Sub Kill_PDFCreator() Dim RetVal As Long RetVal = Shell("Taskkill /im PDFCreator.exe /f", 0) End Sub
PowerPoint 2007 : Générer un PDF protégé via PDFCreator
Code:
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 Option Explicit Private Sub EncryptPDF(sNomFichier As String, sOutputCrypt As String) Dim Pdf As Object, Crypt As Object Set Crypt = CreateObject("pdfforge.pdf.PDFEncryptor") With Crypt .AllowAssembly = False .AllowCopy = False .AllowFillIn = False .AllowModifyAnnotations = False .AllowModifyContents = False .AllowPrinting = True .AllowPrintingHighResolution = True .AllowScreenReaders = False .EncryptionMethod = 2 .OwnerPassword = "master" .UserPassword = "" End With Set Pdf = CreateObject("pdfforge.pdf.pdf") Pdf.EncryptPDFFile sNomFichier, sOutputCrypt, Crypt Set Pdf = Nothing Set Crypt = Nothing End Sub Sub GénérerPDF() Dim sNomPdf As String, sPdf As String Dim sDossier As String Dim sNomCrypt As String Dim FSO As Object sDossier = ActivePresentation.Path sNomPdf = Left$(ActivePresentation.Name, InStr(ActivePresentation.Name, ".") - 1) & ".pdf" sPdf = sDossier & "\" & sNomPdf ActivePresentation.ExportAsFixedFormat sPdf, ppFixedFormatTypePDF, ppFixedFormatIntentPrint sNomCrypt = sDossier & "\" & "Tempo.pdf" EncryptPDF sPdf, sNomCrypt Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FileExists(sPdf) Then Kill sPdf If FSO.FileExists(sNomPdf) Then Kill sNomPdf Name sNomCrypt As sNomPdf Set FSO = Nothing End Sub
Bonjour Kiki29,
Je souhaiterai créer à partir d'une feuille Excel, un PDF ne prenant en compte uniquement la sélection de cellules sur cette feuille Excel.
Sur Excel : Feuil1 A1:P15 rempli de données
Je désire créer un Pdf ne prenant que les données A1:O15.
actuellement, je fais fait une sélection A1 à O15 puis, fichier/imprimer : Imprimer la sélection - Centrer Horizontal - Sur une seule Feuille (adapter la sélection à la largeur A4) [Jusque là tout fonctionne]
Puis, je fais enregistrer au format Pdf [Sélection] / [une page en largeur] puis enregistrer.
Le pdf créé n'a pas pris en compte la sélection mais de A1 à P15
Je ne peux pas supprimer la colonne P car elle contient des adresses mails (Copie cachée) qui me servent dans ma macro Excel à envoyer le Pdf aux destinataires (leurs adresses se situent en Colonne O) ainsi qu'a ceux qui sont en colonne P et je ne veux pas que les adresses mails de la colonne P se mettent dans le Pdf.
Cordialement,
Graphikris.
Salut, il suffit de sélectionner ta zone A1:O15 puis de la définir comme zone d'impression, tout cela en ayant paramétré ta mise en page.
Bonjour j'ai regardé ta contribution sur la recherche de PDF. J'ai essayé de transposer sur Access et ça marche. Mon, problème maintenant c'est que je voudrais afficher le résultat dans une ListBox mais je rencontre des soucis. Dans mon cas le traitement des fichiers est réalisée mais ensuite rien n'est affiché dans la ListBox.
Pourras tu m'aider si tu t'y connais en VBA Access.
Salut, voir Utiliser les contrôles dans un UserForm, en VBA Excel, comme précisé dans l'autre post ( pourquoi en changer et venir polluer celui-ci ) je n'ai pas Access.
Salut kiki29,
tu trouveras peut-être des petites choses qui peuvent t'intéresser sur ce post : http://www.developpez.net/forums/d15...ns-phrase-pdf/.
Ce post donne une méthode pour construire un lien sur une phrase complète dans un PDF.
Tchô
Acrobat Reader : Sauver un PDF en Texte (accessible) via des SendKeys
Via Acrobat voir post# 2
- Affecter un bouton à la procédure SelectionFichier
- Cocher Microsoft Forms 2.0 Object Library
- Ajuster éventuellement la valeur de Sleep dans la procédure SaveAsText, par défaut est à 2500 ms.
En supprimant la partie presse-papier, donc plus de référence Microsoft Forms 2.0 Object Library à cocherCode:
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 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Function LocaliserAcroReader() As String Dim FSO As Object Dim Wsh As Object Dim sCheminReader As String Set FSO = CreateObject("Scripting.FileSystemObject") Set Wsh = CreateObject("WScript.Shell") sCheminReader = Wsh.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\AcroRd32.exe\") If Not IsNull(FSO.GetAbsolutePathName(sCheminReader)) Then LocaliserAcroReader = FSO.GetAbsolutePathName(sCheminReader) Else LocaliserAcroReader = "" End If Set Wsh = Nothing Set FSO = Nothing End Function Private Sub SaveAsText(sFichier As String) Dim sAcro As String Dim Clip As MSForms.DataObject, sNom As String sNom = "SaveAs_Essai.txt" Set Clip = New MSForms.DataObject Clip.Clear Clip.SetText sNom, 1 Clip.PutInClipboard sAcro = LocaliserAcroReader Shell sAcro & " " & sFichier, vbNormalFocus With CreateObject("WScript.Shell") .SendKeys "%h", True .SendKeys "s", True .SendKeys "x", True .SendKeys "^v", True .SendKeys "{ENTER}", True .SendKeys "o", True Sleep 2500 .SendKeys "^q", True End With Set Clip = Nothing End Sub Sub SelectionFichier() Dim FD As FileDialog Dim Debut As Currency, Fin As Currency, Freq As Currency 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 SaveAsText FD.SelectedItems(1) End If Set FD = Nothing End Sub
Le fichier PDF sélectionné sera sauvé sous le même nom mais avec l'extension TXT
La procédure SaveAsText devient :
On peut également s'affranchir de la référence à cocher Microsoft Forms 2.0 Object Library en passant tout en Late Binding.Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18 Private Sub SaveAsText(sFichier As String) Dim sAcro As String sAcro = LocaliserAcroReader Shell sAcro & " " & sFichier, vbNormalFocus With CreateObject("WScript.Shell") .SendKeys "%h", True .SendKeys "s", True .SendKeys "x", True .SendKeys "{ENTER}", True .SendKeys "o", True Sleep 2500 .SendKeys "^q", True End With End Sub
Téléchargeable iciCode:
1
2
3
4
5
6
7
8
9 Dim Clip As Object ..... ' Late Binding pour remplacer Set Clip = New MSForms.DataObject ' et supprimer référence à cocher : Microsoft Forms 2.0 Object Library Set Clip = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") Clip.Clear .....
Acrobat : Extraction du Texte d'une liste de PDF
En élaguant/combinant Liste des fichiers d'un dossier et le post#2
On aboutit à ceci
Pour le module mPDF
Code:
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 Option Base 1 Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _ (ByVal hwnd As Long, _ ByVal pszPath As String, _ ByVal lngsec As Long) As Long Dim Cpt As Long Private Function CreationDossier(sDossier) As Long Dim Rep As Long Rep = SHCreateDirectoryEx(0&, sDossier, 0&) End Function 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 Function ExistenceFichier(sFichier As String) As Boolean ExistenceFichier = Dir$(sFichier) <> "" End Function Private Function LocaliserAcroReader() As String Dim FSO As Object Dim Wsh As Object Dim sCheminReader As String Set FSO = CreateObject("Scripting.FileSystemObject") Set Wsh = CreateObject("WScript.Shell") sCheminReader = Wsh.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\AcroRd32.exe\") If Not IsNull(FSO.GetAbsolutePathName(sCheminReader)) Then LocaliserAcroReader = FSO.GetAbsolutePathName(sCheminReader) Else LocaliserAcroReader = "" End If Set FSO = Nothing Set Wsh = Nothing End Function Sub Pdf2Txt() Dim sFichier As String Dim sAcro As String Dim LastRow As Long, i As Long Dim iDep As Long Dim sDossier As String Dim sDossierTxt As String, sNom As String, sNomfichier As String, FSO As Object QueryPerformanceCounter Debut DoEvents 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 = "" sDossier = ShParam.Cells(1, 1) bDossier = ShParam.CheckBoxes("chkDossier").Value = 1 sDossierTxt = ThisWorkbook.Path & "\" & "Essais_Pdf_Txt" If bDossier Then Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FolderExists(sDossierTxt) Then _ FSO.DeleteFolder sDossierTxt, True Set FSO = Nothing ShParam.CheckBoxes("chkDoublons").Value = 0 End If bDoublons = ShParam.CheckBoxes("chkDoublons").Value = 1 CreationDossier sDossierTxt LastRow = ShParam.Range("A" & Rows.Count).End(xlUp).Row sAcro = LocaliserAcroReader If ExistenceFichier(sAcro) = False Then MsgBox "Le chemin d'Acrobat Reader est erroné ou" & vbCrLf & "Acrobat Reader n'est pas installé" & vbCrLf & vbCrLf & _ "Voir la procédure Pdf2Txt du module mPDF" & vbCrLf & "à sAcro = .....", vbInformation + vbOKOnly, "Chemin du Reader erroné" Debug.Print sAcro Exit Sub End If Application.StatusBar = "Démarrage extraction texte" iDep = 0 For i = RDepart To LastRow If UCase$(ShParam.Range("A" & i)) = "X" Then iDep = iDep + 1 sFichier = sDossier & "\" & ShParam.Range("B" & i) Set FSO = CreateObject("Scripting.FileSystemObject") sNomfichier = FSO.GetBaseName(sFichier) sNom = sDossierTxt & "\" & sNomfichier & ".txt" Set FSO = Nothing If bDoublons Then sNom = RenommerFichier(sDossierTxt, sNomfichier & ".txt") End If SavePDFasTxt sFichier, sNom Application.StatusBar = "Extraction : " & iDep & " / " & Cpt End If DoEvents Next i With ActiveWindow .ScrollColumn = 1 .ScrollRow = 1 End With DoEvents QueryPerformanceCounter Fin QueryPerformanceFrequency Freq Application.StatusBar = "Terminé : " & Format((Fin - Debut) / Freq, "0.00 s") End Sub Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String Dim sNouveauNom As String Dim sPre As String Dim sExt As String Dim iExt As Long Dim i As Long, Pos As Long Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FileExists(sDossier & "\" & sNomfichier) Then sNouveauNom = sNomfichier Pos = InStrRev(sNomfichier, ".") If Pos > 0 Then iExt = Len(sNomfichier) - Pos + 1 sExt = Right$(sNomfichier, iExt) sPre = Left$(sNomfichier, Len(sNomfichier) - iExt) Else sExt = "" sPre = sNomfichier End If i = 0 While FSO.FileExists(sDossier & "\" & sNouveauNom) i = i + 1 sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & sExt Wend sNomfichier = sNouveauNom End If Set FSO = Nothing RenommerFichier = sDossier & "\" & sNomfichier End Function Private Sub SavePDFasTxt(sFichier As String, sFichierTxt As String) Dim AcroXAVDoc As Object Dim AcroXPDDoc As Object Dim JSO As Object Set AcroXAVDoc = CreateObject("AcroExch.AVDoc") AcroXAVDoc.Open sFichier, "Acrobat" Set AcroXPDDoc = AcroXAVDoc.GetPDDoc Set JSO = AcroXPDDoc.GetJSObject JSO.SaveAs sFichierTxt, "com.adobe.acrobat.accesstext" AcroXAVDoc.Close False Set JSO = Nothing Set AcroXPDDoc = Nothing Set AcroXAVDoc = Nothing End Sub
Acrobat Reader : Extraction du Texte d'une liste de PDF via des SendKeys
Pour les masochistes ..... avec toutes les tracasseries associées, voir ici
Une version Acrobat existe ici ( 40 à 50% plus rapide que cette version )
Pour le module mPDF
Code:
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 Option Explicit Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _ (ByVal hwnd As Long, _ ByVal pszPath As String, _ ByVal lngsec As Long) As Long Dim Cpt As Long Private Function CreationDossier(sDossier) As Long Dim Rep As Long Rep = SHCreateDirectoryEx(0&, sDossier, 0&) End Function 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 Function ExistenceFichier(sFichier As String) As Boolean ExistenceFichier = Dir$(sFichier) <> "" End Function Private Function LocaliserAcroReader() As String Dim FSO As Object Dim Wsh As Object Dim sCheminReader As String Set FSO = CreateObject("Scripting.FileSystemObject") Set Wsh = CreateObject("WScript.Shell") sCheminReader = Wsh.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\AcroRd32.exe\") If Not IsNull(FSO.GetAbsolutePathName(sCheminReader)) Then LocaliserAcroReader = FSO.GetAbsolutePathName(sCheminReader) Else LocaliserAcroReader = "" End If Set FSO = Nothing Set Wsh = Nothing End Function Sub Pdf2Txt() Dim sFichier As String Dim sAcro As String, Clip As Object Dim LastRow As Long, i As Long Dim iDep As Long Dim sDossier As String Dim sDossierTxt As String, sNom As String, sNomfichier As String, FSO As Object QueryPerformanceCounter Debut DoEvents 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 = "" sDossier = ShParam.Cells(1, 1) bDossier = ShParam.CheckBoxes("chkDossier").Value = 1 sDossierTxt = ThisWorkbook.Path & "\" & "Essais_Pdf_Txt" If bDossier Then Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FolderExists(sDossierTxt) Then _ FSO.DeleteFolder sDossierTxt, True Set FSO = Nothing ShParam.CheckBoxes("chkDoublons").Value = 0 End If bDoublons = ShParam.CheckBoxes("chkDoublons").Value = 1 CreationDossier sDossierTxt sAcro = LocaliserAcroReader If ExistenceFichier(sAcro) = False Then MsgBox "Le chemin d'Acrobat Reader est erroné ou" & vbCrLf & "Acrobat Reader n'est pas installé" & vbCrLf & vbCrLf & _ "Voir la procédure Pdf2Txt du module mPDF" & vbCrLf & "à sAcro = .....", vbInformation + vbOKOnly, "Chemin du Reader erroné" Debug.Print sAcro Exit Sub End If LastRow = ShParam.Range("A" & Rows.Count).End(xlUp).Row iDep = 0 For i = RDepart To LastRow If UCase$(ShParam.Range("A" & i)) = "X" Then iDep = iDep + 1 sFichier = sDossier & "\" & ShParam.Range("B" & i) Set FSO = CreateObject("Scripting.FileSystemObject") sNomfichier = FSO.GetBaseName(sFichier) sNom = sDossierTxt & "\" & sNomfichier & ".txt" Set FSO = Nothing If bDoublons Then sNom = RenommerFichier(sDossierTxt, sNomfichier & ".txt") End If Set Clip = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") Clip.Clear Clip.SetText sNom, 1 Clip.PutInClipboard Shell sAcro & " " & sFichier, vbNormalFocus With CreateObject("WScript.Shell") .SendKeys "%h", True .SendKeys "s", True .SendKeys "x", True .SendKeys "^v", True Sleep 250 .SendKeys "{ENTER}", True .SendKeys "e", True .SendKeys "o", True Sleep 2500 .SendKeys "^q", True End With Sleep 5000 Set Clip = Nothing Application.StatusBar = "Extraction : " & iDep & " / " & Cpt End If DoEvents Next i With ActiveWindow .ScrollColumn = 1 .ScrollRow = 1 End With DoEvents QueryPerformanceCounter Fin QueryPerformanceFrequency Freq Application.StatusBar = "Terminé : " & Format((Fin - Debut) / Freq, "0.00 s") End Sub Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String Dim sNouveauNom As String Dim sPre As String Dim sExt As String Dim iExt As Long Dim i As Long, Pos As Long Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FileExists(sDossier & "\" & sNomfichier) Then sNouveauNom = sNomfichier Pos = InStrRev(sNomfichier, ".") If Pos > 0 Then iExt = Len(sNomfichier) - Pos + 1 sExt = Right$(sNomfichier, iExt) sPre = Left$(sNomfichier, Len(sNomfichier) - iExt) Else sExt = "" sPre = sNomfichier End If i = 0 While FSO.FileExists(sDossier & "\" & sNouveauNom) i = i + 1 sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & sExt Wend sNomfichier = sNouveauNom End If Set FSO = Nothing RenommerFichier = sDossier & "\" & sNomfichier End Function
bonjour,
je souhaitais utiliser le bout de code ci-dessous pour fusionner des PDF mais cela m'affiche erreur automation le fichier spécifié est introuvable sur la ligne Set Pdf = CreateObject("pdfforge.pdf.pdf")
si vous aviez une solution a mon petit souci, cela m'arrangerait bienCode:
1
2
3
4
5
6
7
8
9
10
11
12 Sub Fusion() Dim Pdf As Object, Fichiers(2) Set Pdf = CreateObject("pdfforge.pdf.pdf") Fichiers(0) = ThisWorkbook.Path & "\" & "1.pdf" Fichiers(1) = ThisWorkbook.Path & "\" & "2.pdf" Fichiers(2) = ThisWorkbook.Path & "\" & "3.pdf" Pdf.MergePDFFiles_2 Fichiers, ThisWorkbook.Path & "\" & "Fusion.pdf", True Set Pdf = Nothing End Sub
je vous remercie d'avance
Bonjour,
l'application n'est pas installée ou non référencée dans Windows …
_________________________________________________________________________________________________________Je suis Paris, Nice, Bruxelles, Charlie, …
Salut, même si l'on est en Late Binding ( pas de références à cocher ), il faut quand même avoir installé PDFCreator 1.7.3. Voir cette remarque concernant les versions > à la 1.7.3 : PDFcreator V 2.x et interface COM, ainsi que celle-ci.
Après tu as plus pratique : Fusion des PDF d'un Dossier, voir également ici toujours via PDFCreator 1.7.3. Te référer à cette liste des contributions pour naviguer dans le bazar, salmigondis ( au choix )
Bonjour,
Est-ce qu'on peut faire la même chose que "Fusion des fichiers PDF d'un dossier à partir d'une liste Excel" mais avec des fichiers words qui n'ont pas été convertit en pdf avant?
J'utilise Adobe Acrobat XI pour fusionner des documents Word. J'aimerai faire la même chose mais à partir d'une liste excel.
Merci!
Salut, tu as déjà Fusion des PDFs d'un dossier via Acrobat Pro / Excel à disposition.
Donc à adapter à ton contexte : dans la sélection remplacer *.pdf par *.doc* ce qui donnera la liste des doc à convertir.
Insérer une procédure de conversion Doc2Pdf des *.doc* en *.pdf dans un dossier à fixer, et cela à l'endroit idoine dans la procédure FusionPdf.
Depuis la version 2007 SP2 tu as le format pdf de dispo en natif dans Office, le macro recorder te fournira un code de base pour la conversion Doc2Pdf.
Bonjour,
je vous remercie pour votre retour. Mon problème réside dans le fait que je suis obligé d'avoir pdf creator 1-7-3 pour faire fonctionner votre outils.
n'est-il pas possible de l'utiliser avec des versions plus récentes type 2-1-2?
je vous remercie par avance
Julien
Concernant Acrobat : Extraction du Texte d'une liste de PDF
Le message suivant : "Microsoft Office Excel attend la fin de l'exécution d'une action OLE d'une autre application" peut apparaître quand une procédure s'éternise pour un fichier pdf conséquent, même si tout s'est bien passé.
Pour désactiver les warnings OLE dans ce cas dans la procédure Pdf2Txt
Voir réponse d'AlainTech ici
Déclaration à ajouter :
Encadrer la procédure Pdf2Txt de cette façon :Code:
1
2 Private Declare Function CoRegisterMessageFilter Lib "OLE32.DLL" (ByVal lFilterIn As Long, _ ByRef lPreviousFilter) As Long
Code:
1
2
3
4
5
6
7
8
9 Dim iMsgFilter As Long '..... CoRegisterMessageFilter 0&, iMsgFilter For i = RDepart To LastRow ' ..... Next i CoRegisterMessageFilter iMsgFilter, iMsgFilter
La génération de fichiers textes à partir de PDF est lente via Acrobat. Un euphémisme.....
Une autre approche suggérée par Jurassic Pork et PatrickToulon pallie ce problème.
Cela est possible via Xpdf
Télécharger dans "Precompiled binaries" la version Windows.
L'exécutable pdftotext.exe est copié dans le dossier de test : C:\Tests.
La contrainte principale dans l'usage d'Xpdf est que les noms/chemins des fichiers/exé ne doivent pas comporter d'espaces.
Codes adaptés de ceux de PatrickToulon
● Coller le texte du PDF sélectionné dans une feuille Excel
Affecter un bouton à la procédure SélectionPDF
● Générer un fichier texte à partir de la sélection d'un pdfCode:
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 Option Explicit Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean Private Debut As Currency, Fin As Currency, Freq As Currency Sub SélectionPDF() Dim Fichier As Variant ChDir ThisWorkbook.Path Fichier = Application.GetOpenFilename("Fichier PDF (*.pdf), *.pdf") If Fichier <> False Then Lecture Fichier End Sub Private Sub Lecture(ByVal sFichier) QueryPerformanceCounter Debut PDF2Text sFichier Application.ScreenUpdating = False With Feuil1 .Columns("A:A").ClearContents .Range("A1").PasteSpecial .Range("C1").Select End With Application.ScreenUpdating = True QueryPerformanceCounter Fin QueryPerformanceFrequency Freq Application.StatusBar = "Terminé : " & Format((Fin - Debut) / Freq, "0.00 s") End Sub Private Sub PDF2Text(ByVal sFichier) Dim Wsh As Object Set Wsh = CreateObject("WScript.Shell") Wsh.Run "cmd /c C:\Tests\pdftotext.exe " & sFichier & " -raw - | clip", vbHide, True Set Wsh = Nothing End Function
Affecter un bouton à la procédure SélectionPDF
On pourra y rajouter un module qui permet d'effacer tous les presse-papiers ( office et windows )Code:
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 Option Explicit Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean Private Debut As Currency, Fin As Currency, Freq As Currency Sub SélectionPDF() Dim Fichier As Variant ChDir ThisWorkbook.Path Fichier = Application.GetOpenFilename("Fichier PDF (*.pdf), *.pdf") If Fichier <> False Then PDF2Text Fichier End Sub Private Sub PDF2Text(ByVal sFichier) Dim Wsh As Object, FSO As Object Dim sNomfichier As String, sNomFinal As String QueryPerformanceCounter Debut Set FSO = CreateObject("Scripting.FileSystemObject") sNomfichier = FSO.GetBaseName(sFichier) sNomFinal = sNomfichier & "_Raw.txt" Set FSO = Nothing Set Wsh = CreateObject("WScript.Shell") Wsh.Run "cmd /c C:\Tests\pdftotext.exe " & sFichier & " -raw C:\Tests\" & sNomFinal, vbHide, True Set Wsh = Nothing QueryPerformanceCounter Fin QueryPerformanceFrequency Freq Application.StatusBar = "Terminé : " & Format((Fin - Debut) / Freq, "0.00 s") End Sub
Application Téléchargeable iciCode:
1
2
3
4
5
6
7
8
9
10
11 Option Explicit Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function CloseClipboard Lib "user32" () As Long Sub ClearClipboard() OpenClipboard (0&) EmptyClipboard CloseClipboard End Sub
re
salut kiki
tu savais que de (ce petit exe) il y en avais une vielle version dans le dossier de adobe reader 9.40 les autre je ne sais pas
sous le nom de "acrotextextractor.exe"
malheureusement pour des raisons que j'ignore il n'est pas décompilé dans le dossier il reste dans le cab du setupfile
Pièce jointe 221298
Salut, cet exe est toujours présent dans la version 15 d'Acrobat DC. Il se retrouve après installation dans C:\Program Files (x86)\Adobe\Acrobat 2015\Acrobat et C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader
a oui exact je ne l'ai pas vu la première fois
bon ben y a pas quelque chose a faire avec ca ??Citation:
"C:\Program Files (x86)\Adobe\Reader 9.0\Reader\AcroTextExtractor.exe"
j'ai essayé de chercher sur la toile mais j'ai rien trouvé de concluant en ligne de commande
peut être a tu des idées
si on arrivait a une extraction on pourrait se passer d'aller chercher un exe externe non??
J'oubliais dans ton post 271
tu a oublié un detail
a savoir la récupération du text du clipbord dans une variable a la place de ton paste
perso plutôt que d'utilise l'objectdata j'utilise un object beaucoup plus facile a manipuler
c'est l'object"htmlfile"
voilaCode:
1
2
3
4
5
6
7 Set clipB = CreateObject("htmlfile") clipB.parentWindow.clipboardData.clearData "Text"'on vide le clipboard 'appel a ta fonction ou code interne tavariable= clipB.parentWindow.clipboardData.GetData("text") 'on recupere le contenu text du clipboard .
re
c'est presque ca KIKI
tu peut supprimer aussi la création de l' htmlfile il ne te sert a rien!!
ou prevoir dans la fonction le retour en variable string ou pas dans ce cas la avec un 2d arguments
un peu comme suit
exemple d'utilisationCode:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15 Private Function PDF2Text(ByVal sFichier, Optional variable As Variant = False) As variant Dim Wsh As Object, Clip As Object Set Clip = CreateObject("htmlfile") Set Wsh = CreateObject("WScript.Shell") Wsh.Run "cmd /c C:\Tests\pdftotext.exe " & sFichier & " -raw - | clip", vbHide, True Select Case variable Case "string" Clip.parentWindow.clipboardData.clearData "Text" PDF2Text = Clip.parentWindow.clipboardData.GetData("text") Case "tableau" PDF2Text = Split(Clip.parentWindow.clipboardData.GetData("text"), vbCrLf) End Select Set Wsh = Nothing Set Clip = Nothing End Function
dans une variable de type string
dans une variable de type tableauCode:
1
2 'la variable "texte" contient tout le texte du pdf texte = PDF2Text(sFichier, "string")
sans le 2 d argument sa met juste le pdf en clipboardCode:
1
2
3 'la variable tableau est maintenant rempli des lignes du texte du pdf ' et donc c'est un tableau de x lignes sur 1 colonne tableau = PDF2Text(sFichier, "tableau")
voilaCode:
1
2 'met le texte du pdf dans clipboard par l'argument dans la ligne shell on peut se servir de la fonction paste apres PDF2Text sFichier
oupss mille excuse
change le type de sortie pour la fonction en variant
re
KIKI
pour normaliser ton principe jusqu'ici
on peut placer l'exécutable dans le dossier du reader et se servir de ta fonction localiser
comme ca c'est propreCode:
1
2
3
4
5
6
7
8
9
10
11
12 Private Function LocaliserAcroReader() As String Dim Wsh As Object, adobread As String Set Wsh = CreateObject("WScript.Shell") adobread = Wsh.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\AcroRd32.exe\") adobread = Replace(adobread, "AcroRd32.exe", "pdftotext.exe") If Dir(adobread) <> "" Then LocaliserAcroReader = adobread Else LocaliserAcroReader = "" End If Set Wsh = Nothing End Function
ca fait une sorte de complément
Bonjour, j'ai malheureusement effacé depuis longtemps la version 1.7.3 de PDFCreator, et je suis obligé d'utiliser la dernière version. J'avais déjà vu cet exemple dans les COM Scripts de PDFCreator, mais j'aurai besoin d'insérer du texte à différents endroits (X et Y) de l'image de fond, pour générer puis expédier automatiquement avec Outlook ( je sais je suis chez Excel ) en pièce jointe un fichier. Je ne sais pas par où ni comment procéder pour y insérer ces informations.
Merci de vos réponses, et bien sûr, je suis à votre disposition pour tout renseignement complémentaire.
Salut, il y a ceci : PDFCreator Insertion Image de fond dans Document Pdf
PDFCreator Ajout de Texte, Ligne et Hirondelles sur un Document Pdf
PDFCreator Génération PDF puis envoi par mail via CDO
Toutes les 3 fonctionnent avec PDFCreator 1.7.3
Désolé mais pour les versions 2.x : voir cette remarque qui donne cependant un exemple VB6 pour placer un texte, à toi de l'adapter à ton contexte. Quant à l'explorateur d'objets il est plus que succinct.