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 |
Envoyé par kiki29
: ça peut servir aux autres 
Partager