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
| 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
Application.StatusBar = ""
End Sub
Private 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 Pdf As Object
Dim iNbPages As Long
Set Pdf = CreateObject("pdfforge.pdf.pdf")
iNbPages = Pdf.NumberOfPages(sNom)
If iNumPage > iNbPages Then
bFlag = True
Set Pdf = Nothing
Exit Sub
End If
Pdf.CopyPDFFile sNom, sOut, iNumPage, iNumPage
Set Pdf = 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
Private 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
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 ' Si A4 Coeff=1.414
Pas = Application.CentimetersToPoints(0.25)
For i = LBound(Tablo) To UBound(Tablo)
With ShRecap.Shapes(Tablo(i))
.Width = W
.Height = H
End With
Next i
Nb = ShParam.Range("NbPagesH")
For i = LBound(Tablo) To UBound(Tablo)
L = (i Mod Nb) * (W + Pas)
T = (i \ Nb) * (H + Pas)
With ShRecap.Shapes(Tablo(i))
.Left = L
.Top = T
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 |
..quand c'est le cas !
Envoyé par kiki29
Partager