Dudu2
XLDnaute Barbatruc
| Ces fonctions personnalisées permettent de définir les propriétés d'une cellule ou d'une plage de cellules à partir d'une formule. |
Ces fonctions s'utilisent par concaténation dans les formules.
Il y a 3 fonctions personnalisées:
- CallerProperties
C'est celle qui sera le plus souvent utilisée dans une formule pour définir les propriétés de la cellule qui contient la formule.
Exemple: = "Bonjour" & CallerProperties(HEXDEC("FF");HEXDEC("FFFF"))
La cellule contenant la formule sera en caractères rouges ("FF") sur fond jaune ("FFFF").
- RangeProperties
Permet de définir les propriétés d'une plage de cellules désignée dans la formule qui n'est pas forcément liée à la cellule qui contient la formule.
Exemple en A3: = "Couleurs en B3" & RangeProperties(B3;HEXDEC("FF");HEXDEC("FFFF"))
La cellule B3 sera en caractères rouges ("FF") sur fond jaune ("FFFF").
- CellValue
Permet de définir la valeur d'une cellule désignée dans la formule qui n'est évidemment pas liée à la cellule qui contient la formule.
Exemple en A2: = "Valeur en B2" & CellValue(B2;"Bonjour")
La cellule B2 contiendra la valeur "Bonjour".
Les fonctions CellValue et RangeProperties sont bien sûr combinables:
VB:
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal nIDEvent As Long) As Long
#Else
Private Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
#End If
'
Private CallerCollection As New Collection
Private TimerId As Long
'--------------------------------------------------------------
'Propriétés de la cellule dont la formule concatène la fonction
'Exemple: ="Bonjour" & CallerProperties(HEXDEC("FF");HEXDEC("FFFF")) -> texte en rouge sur fond jaune sur la cellule "Caller"
'https://learn.microsoft.com/fr-fr/office/vba/language/reference/user-interface-help/color-constants
'--------------------------------------------------------------
Function CallerProperties(Optional ByVal FontColor As Long = xlNone, _
Optional ByVal InteriorColor As Long = xlNone, _
Optional ByVal FontName As Variant = xlNone, _
Optional ByVal FontSize As Double = xlNone, _
Optional ByVal FontBold As Variant = xlNone, _
Optional ByVal FontItalic As Variant = xlNone, _
Optional ByVal FontUnderline As Variant = xlNone, _
Optional ByVal FontStrikethrough As Variant = xlNone)
RangeProperties Application.Caller, FontColor, InteriorColor, FontName, FontSize, FontBold, FontItalic, FontUnderline, FontStrikethrough
End Function
'----------------------------------------------------------------------
'Valeur d'une cellule quelconque dont une formule concatène la fonction
'Exemple en A2: ="Valeur en B2" & CellValue(B2;"Bonjour") -> Valeur "Bonjour" en B2
'----------------------------------------------------------------------
Function CellValue(ByVal Target As Range, _
ByVal Value As Variant)
Dim TabCallerProperties(1 To 2) As Variant
'Store the Value into a Table
Set TabCallerProperties(1) = Target
TabCallerProperties(2) = Value
'Store the Table into a Collection
CallerCollection.Add TabCallerProperties
'Async run of the setting of the Properties
If TimerId = 0 Then
TimerId = SetTimer(0, 0, 100, AddressOf SetRangeProperties)
End If
End Function
'------------------------------------------------------------------------
'Propriétés d'une plage quelconque dont une formule concatène la fonction
'Exemple en A3: = "Couleurs en B3" & RangeProperties(B3;HEXDEC("FF");HEXDEC("FFFF")) -> couleurs texte en rouge sur fond jaune en B3
'https://learn.microsoft.com/fr-fr/office/vba/language/reference/user-interface-help/color-constants
'------------------------------------------------------------------------
Function RangeProperties(ByVal Target As Range, _
Optional ByVal FontColor As Long = xlNone, _
Optional ByVal InteriorColor As Long = xlNone, _
Optional ByVal FontName As Variant = xlNone, _
Optional ByVal FontSize As Double = xlNone, _
Optional ByVal FontBold As Variant = xlNone, _
Optional ByVal FontItalic As Variant = xlNone, _
Optional ByVal FontUnderline As Variant = xlNone, _
Optional ByVal FontStrikethrough As Variant = xlNone)
Dim TabCallerProperties(1 To 9) As Variant
'Store the Properties into a Table
Set TabCallerProperties(1) = Target
TabCallerProperties(2) = FontColor
TabCallerProperties(3) = InteriorColor
TabCallerProperties(4) = FontName
TabCallerProperties(5) = FontSize
TabCallerProperties(6) = FontBold
TabCallerProperties(7) = FontItalic
TabCallerProperties(8) = FontUnderline
TabCallerProperties(9) = FontStrikethrough
'Store the Table into a Collection
CallerCollection.Add TabCallerProperties
'Async run of the setting of the Properties
If TimerId = 0 Then
TimerId = SetTimer(0, 0, 100, AddressOf SetRangeProperties)
End If
End Function
Private Sub SetRangeProperties()
Dim TabCallerProperties() As Variant
Dim CalculationAtCallTime As Long
Dim CalculationChange As Boolean
KillTimer 0, TimerId
Do While Not Application.Ready
DoEvents
Loop
Do While CallerCollection.Count > 0
TabCallerProperties = CallerCollection(1)
With TabCallerProperties(1)
'Set the Cell Value
If UBound(TabCallerProperties) = 2 Then
If Not CalculationChange Then
CalculationAtCallTime = Application.Calculation
Application.Calculation = xlCalculationManual
CalculationChange = True
End If
'The Cell might not exist anymore if deleted
On Error Resume Next
.Value = TabCallerProperties(2)
On Error GoTo 0
'Set the Range Properties
Else
If Not TabCallerProperties(2) = xlNone Then .Font.Color = TabCallerProperties(2)
If Not TabCallerProperties(3) = xlNone Then .Interior.Color = TabCallerProperties(3)
If Not TabCallerProperties(4) = xlNone Then .Font.Name = TabCallerProperties(4)
If Not TabCallerProperties(5) = xlNone Then .Font.Size = TabCallerProperties(5)
If Not TabCallerProperties(6) = xlNone Then .Font.Bold = TabCallerProperties(6)
If Not TabCallerProperties(7) = xlNone Then .Font.Italic = TabCallerProperties(7)
If Not TabCallerProperties(8) = xlNone Then .Font.Underline = TabCallerProperties(8)
If Not TabCallerProperties(9) = xlNone Then .Font.Strikethrough = TabCallerProperties(9)
End If
End With
CallerCollection.Remove (1)
Loop
If CalculationChange Then Application.Calculation = CalculationAtCallTime
TimerId = 0
End Sub| Pour ne traiter QUE la couleur du texte de la cellule "Caller", une fonction personnalisée beaucoup plus simple peut être utilisée. |
VB:
'-----------------------------------------------------------------
'Couleur du texte en cellule dont la formule concatène la fonction
'Exemple: ="Bonjour" & TextColor(255;0;0) -> texte en rouge
'-----------------------------------------------------------------
Function TextColor(ByVal R As Integer, ByVal G As Integer, ByVal B As Integer)
Application.Caller.Font.Color = RGB(R, G, B)
End FunctionLe fichier joint contient les modules correspondants et des exemples.
Dernière édition:
