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
| Option Explicit
Option Base 1
Dim objFeuilCible As Worksheet
Sub ImpressSpecial()
'code Didier Gonard
'Attention à HPageBreaks, ou VPageBreaks.Location ou .Count, il y a des bugs officiels !
'Remarque Une feuille ne peut pas contenir plus de 1 000 sauts de page horizontaux et Verticaux (aide vba - limites et spécifications).
'on ne considère ici que les feuilles de calcul - worksheets - pas testé en dehors.
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim intIndexPage As Integer
Dim intNbSautsVer As Integer
Dim intNbSautsHor As Integer
Dim lngNumDerLigne As Long 'penser 2007
Dim intNumDerCol As Integer
Dim intTotalPgeImp As Integer
Dim objShapeLimiteVer As Range
Dim objShapeLimiteHor As Range
Dim intMemoryHor As Integer
Dim intMemoryVer As Integer
Dim tabvarSautsV() As Variant
Dim tabvarSautsH() As Variant
Dim tabvarPrintArea() As Variant
Set objFeuilCible = Worksheets(1)
ActiveWindow.View = xlNormalView 'affichage normal par défaut
' Initialisation des paramètres utiles
With objFeuilCible
.PageSetup.PrintArea = "" 'par défaut annule zone d'impression
.Cells(Rows.Count, Columns.Count).Select 'Anti buggage selon support Microsoft
lngNumDerLigne = .Cells(Rows.Count, 1).End(xlUp).Row
intNumDerCol = .Cells(1, Columns.Count).End(xlToLeft).Column
intNbSautsVer = .VPageBreaks.Count
intNbSautsHor = .HPageBreaks.Count
End With
intTotalPgeImp = ExecuteExcel4Macro("Get.Document(50)") 'on utilise une macro Excel4.
'Recherche et définition de la limite verticale, on ajoute des données à partir de
'la dernière cellule, quand un saut de page sup est généré, c'est qu'on a atteint la limite de notre surface utile
'on utilise la macro Excel4.
While intTotalPgeImp >= ExecuteExcel4Macro("Get.Document(50)")
Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "zzzzz"
Wend
Set objShapeLimiteVer = Cells(1, Columns.Count).End(xlToLeft).Offset(0, -1)
'on fait le ménage
Range(Cells(1, intNumDerCol + 1), Cells(1, Columns.Count).End(xlToLeft)).ClearContents
'Recherche et définition de la limite horizontale
While intTotalPgeImp >= ExecuteExcel4Macro("Get.Document(50)")
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = "zzzzz"
Wend
Set objShapeLimiteHor = Cells(Rows.Count, 1).End(xlUp).Offset(-1, 0)
Range(Cells(lngNumDerLigne + 1, 1), Cells(Rows.Count, 1).End(xlUp)).ClearContents
'Mise en tableau des cellules corner de sauts de page Verticaux
ReDim tabvarSautsV(intNbSautsVer)
For I = 1 To intNbSautsVer
Set tabvarSautsV(I) = ActiveSheet.VPageBreaks(I).Location.Offset(0, -1)
Next I
'Si le dernier saut ne coïncide pas avec la limite(cas ou la dernière donnée est en limite=>saut vide généré), on ajoute un item
If tabvarSautsV(intNbSautsVer).Address <> objShapeLimiteVer.Address Then ReDim Preserve tabvarSautsV(intNbSautsVer + 1): Set tabvarSautsV(intNbSautsVer + 1) = objShapeLimiteVer
'Mise en tableau des cellules corner de sauts de page Horizontaux
ReDim tabvarSautsH(intNbSautsHor)
For J = 1 To intNbSautsHor
Set tabvarSautsH(J) = ActiveSheet.HPageBreaks(J).Location.Offset(-1, 0)
Next J
'Si le dernier saut ne coïncide pas avec la limite(cas ou la dernière donnée est en limite=>saut vide généré), on ajoute un item
If tabvarSautsH(intNbSautsHor) <> objShapeLimiteHor Then ReDim Preserve tabvarSautsH(intNbSautsHor + 1): Set tabvarSautsH(intNbSautsHor + 1) = objShapeLimiteHor
'par défaut, pour simplifier, on prend un nombre de feuilles imprimées maxi, ce qui génère des feuilles vierges, ce que fait excel de façon variable selon les cas
ReDim tabvarPrintArea(UBound(tabvarSautsV) * UBound(tabvarSautsH))
'on met les Print area en tableau, et on traite ensuite = souplesse pour ajouts possibles
K = 1
For J = 1 To UBound(tabvarSautsV)
intMemoryHor = 0
For I = 1 To UBound(tabvarSautsH)
tabvarPrintArea(K) = Cells(tabvarSautsH(I).Row, tabvarSautsH(I).Column + intMemoryVer).Address & ":" & Cells(tabvarSautsV(J).Row + intMemoryHor, tabvarSautsV(J).Column).Address
K = K + 1
intMemoryHor = tabvarSautsH(I).Row
Next I
intMemoryVer = tabvarSautsV(J).Column
Next J
With objFeuilCible
For I = 1 To UBound(tabvarPrintArea)
.PageSetup.PrintArea = ""
.PageSetup.PrintArea = tabvarPrintArea(I)
If PageVierge(I, tabvarPrintArea) = False Then 'on peut faire sauter l'appel à la fonction qui évite l'impression des pages vierges si voulu
intIndexPage = intIndexPage + 1 'ici on choisi de gérer les Nos de page en ne tenant compte que des non vierges
.PageSetup.CenterHeader = Worksheets(2).Cells(intIndexPage, 1) ' on fait ce que l'on veut au niveau de en-tête & pieds de page
.PageSetup.CenterFooter = Worksheets(2).Cells(intIndexPage, 2) 'ici, on agit sur les center Header-Footer stockés en feuille 2
.PrintPreview 'on fait juste un preview ici, cliquer sur fermer pour avancer page par page à l'affichage
' .PrintOut ''ou bien ceci pour imprimer sur l'imprimante par défaut...En imp virtuelle pdf => 1 fichier par page...
End If
Next I
.Cells(1, 1).Select
.PageSetup.PrintArea = "" 'on annule la zone d'impression
End With
Set objFeuilCible = Nothing
End Sub
Function PageVierge(I As Integer, tabvarPrintArea As Variant) As Boolean
Dim objShape As Shape
With objFeuilCible
'avec countA, on vérifie l'absence de données et du coup on teste si le feuille comporte des Shapes...
If Application.CountA(.Range(tabvarPrintArea(I))) = 0 Then
'Si pas de données et pas de shapes...la page est déclarée vierge
If objFeuilCible.Shapes.Count = 0 Then PageVierge = True: Exit Function
'si pas de données mais des Shapes, on vérifie que tout ou partie d'une shape ne se trouve pas sur la zone d'impression
For Each objShape In .Shapes '
If Not Intersect(Range(objShape.TopLeftCell.Address & ":" & objShape.BottomRightCell.Address), .Range(tabvarPrintArea(I))) Is Nothing Then
Exit Function 'si c'est le cas, on sort
End If
Next objShape
PageVierge = True 'sinon la page est déclarée vierge
End If
End With
End Function |
