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 |
Partager