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
|
Option Explicit
Sub Test()
Dim DocEnCours As Document
Dim I As Integer, J As Integer, ColonneEncours As Integer, CouleurTitre As Integer, NouvelleCouleurDeFond As Integer
Dim TableEnCours As Table
Set DocEnCours = ActiveDocument
With DocEnCours
CouleurTitre = wdGray25
NouvelleCouleurDeFond = wdRed
For I = 1 To .Tables.Count
Set TableEnCours = .Tables(I)
With TableEnCours.Range
Select Case TableauPartiel(TableEnCours, CouleurTitre)
Case True
For J = 1 To .Cells.Count
With .Cells(J)
ColonneEncours = .ColumnIndex
If .Shading.BackgroundPatternColorIndex = CouleurTitre Then
.Shading.BackgroundPatternColorIndex = NouvelleCouleurDeFond
TableEnCours.Columns(ColonneEncours).Select
MiseEnFormeDesBordures Selection
End If
End With
Next J
Case Else
TableEnCours.Rows(1).Cells.Shading.BackgroundPatternColorIndex = NouvelleCouleurDeFond
TableEnCours.Select
MiseEnFormeDesBordures Selection
MefBorduresInterieuresVerticales Selection
End Select
End With
Set TableEnCours = Nothing
Next I
End With
Set DocEnCours = Nothing
End Sub
Function TableauPartiel(ByVal TableEnCours2 As Table, ByVal CouleurIndexTitre As Integer) As Boolean
Dim I As Integer, J As Integer, ColonneTitre As Integer, NbColonnes As Integer
TableauPartiel = False
With TableEnCours2.Rows(1).Range
NbColonnes = .Cells.Count
ColonneTitre = 0
For J = 1 To NbColonnes
If .Cells(J).Range.Shading.BackgroundPatternColorIndex = CouleurIndexTitre Then ColonneTitre = ColonneTitre + 1
Next J
End With
If ColonneTitre < NbColonnes Then TableauPartiel = True
End Function
Sub MiseEnFormeDesBordures(ByVal SelectionTableau As Selection)
Dim BorduresExterieures As Variant, BorduresInterieures As Variant
Dim K As Integer
BorduresExterieures = Array(-2, -4, -1, -3)
BorduresInterieures = Array(-5) ' Bordure horizontale
With SelectionTableau
For K = LBound(BorduresExterieures) To UBound(BorduresExterieures)
With .Borders(BorduresExterieures(K))
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = RGB(146, 208, 80)
End With
Next K
For K = LBound(BorduresInterieures) To UBound(BorduresInterieures)
With .Borders(BorduresInterieures(K))
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = RGB(255, 192, 0)
End With
Next K
End With
End Sub
Sub MefBorduresInterieuresVerticales(ByVal SelectionTableau As Selection)
Dim J As Integer
With SelectionTableau
For J = 1 To .Columns.Count - 1
With .Columns(J).Cells
With .Borders(wdBorderRight)
If .LineStyle <> wdLineStyleNone Then
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = RGB(255, 192, 0)
End If
End With
End With
Next J
End With
End Sub |
Partager