Apparition et disparition d'une croix au clic

Bonjour,

A ) Si une cellule est en mode édition (curseur clignotant dans une cellule)
les diagonales de la cellule ne seront pas visibles, il est impossible de
les afficher dans cette situation.

Exemple : Adapte A1:A10 pour la plage de cellules que tu veux.

'-------------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rg As Range

'Adapte la plage de cellules
Set Rg = Intersect(Range("A1:A10"), Target)

If Not Rg Is Nothing Then
For Each c In Rg
With c.Borders(xlDiagonalDown)
If .LineStyle = -4142 Then
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
Else
.LineStyle = -4142
End If
End With
With c.Borders(xlDiagonalUp)
If .LineStyle = -4142 Then
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
Else
.LineStyle = -4142
End If
End With
Next
End If
End Sub
'-------------------------------------------------------

MichD

Le vendredi 20 Avril 2018 à 09:51 par Krodilock : > Bonjour à toutes et à tous, > > Je suis à la recherche d'un VBA afin de faire apparaître et > disparaître une croix dans une cellule lorsque l'utilisateur clique > dessus. J'ai déjà trouvé de nombreuses solutions mais > aucune ne me convient. À titre d'exemple, voici ce que j'ai > trouvé sur ce forum : > > <code> > Private Sub Worksheet_SelectionChange(ByVal Target As Range) > If Intersect(Target, Range("E2:E9")) Is Nothing Then: Exit Sub > If ActiveCell = "" Then > ActiveCell = "X" > ActiveCell.Font.Bold = True > With Selection > .HorizontalAlignment = xlCenter > .VerticalAlignment = xlCenter > End With > Else > ActiveCell = "" > End If > End Sub > </code> > > Ce code fait apparaître et disparaître la croix X lorsque la > cellule en question (entre E2 et E9) devient active. Ce n'est pas vraiment ce > que je recherce. > > 1 - Je souhaiterai que la croix créée soit issue des diagonales > de la cellule en question > 2 - Je souhaiterai que la croix n'apparaisse et ne disparaisse que lorsque > l'utilisateur clique dessus, et non lorsque la cellule devient active (par le > biais du clavier par exemple) > > Merci d'avance pour votre aide ! Bonjour Michd, Merci beaucoup pour ta réponse. Le code fonctionne parfaitement. J'ai cependant une question : Existe-il une fonctionnalité qui permet d'afficher les croix uniquement quand on clique sur la cellule (et non lorsque la cellule est sélectionnée par le biais des flèches du clavier) ? Le cas échéant, j'utiliserai ton code qui correspond parfaitement à ce que je recherche ! Encore merci.

Existe-il une fonctionnalité qui permet d'afficher les croix
uniquement quand on clique sur la cellule (et non lorsque la cellule est
sélectionnée par le biais des flèches du clavier) ?

Les procédures événementielles ne peuvent pas répondre à ce que tu demandes.
Mais Excel peut faire beaucoup plus si tu es bon en programmation et connaît
les API.

À titre d'exemple, il est possible d'empêcher la saisie d'un chiffre dans
une plage définie de cellules. Pour ce faire, copie le code suivant dans un
module standard, et exécute une fois la procédure "TrackKeyPressInit".
Maintenant, essaie de saisir un chiffre dans la plage de cellules A1:D10 et
observe ce qui se passe.

Ce code est disponible à cette adresse :
https://stackoverflow.com/questions/11153995/is-there-any-event-that-fires-when-keys-are-pressed-when-editing-a-cell

Pour ce qui est de ta demande, je me contenterai de répondre "non".... ;-)


Private Type POINTAPI
x As Long
y As Long
End Type

Private Type MSG
hwnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type

Private Declare Function WaitMessage Lib "user32" () As Long

Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _
(ByRef lpMsg As MSG, ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long

Private Declare Function TranslateMessage Lib "user32" _
(ByRef lpMsg As MSG) As Long

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Const WM_KEYDOWN As Long = &H100
Private Const PM_REMOVE As Long = &H1
Private Const WM_CHAR As Long = &H102
Private bExitLoop As Boolean

'----------------------------------------------------------------
Sub TrackKeyPressInit()

Dim msgMessage As MSG
Dim bCancel As Boolean
Dim iKeyCode As Integer
Dim lXLhwnd As Long

On Error GoTo errHandler:
Application.EnableCancelKey = xlErrorHandler
'initialize this boolean flag.
bExitLoop = False
'get the app hwnd.
lXLhwnd = FindWindow("XLMAIN", Application.Caption)
Do
WaitMessage
'check for a key press and remove it from the msg queue.
If PeekMessage _
(msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
'strore the virtual key code for later use.
iKeyCode = msgMessage.wParam
'translate the virtual key code into a char msg.
TranslateMessage msgMessage
PeekMessage msgMessage, lXLhwnd, WM_CHAR, _
WM_CHAR, PM_REMOVE
'for some obscure reason, the following
'keys are not trapped inside the event handler
'so we handle them here.
If iKeyCode = vbKeyBack Then SendKeys "{BS}"
If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
'assume the cancel argument is False.
bCancel = False
'the VBA RaiseEvent statement does not seem to return ByRef
arguments
'so we call a KeyPress routine rather than a propper event
handler.
Sheet_KeyPress _
ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection,
bCancel
'if the key pressed is allowed post it to the application.
If bCancel = False Then
PostMessage _
lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
End If
End If
errHandler:
'allow the processing of other msgs.
DoEvents
Loop Until bExitLoop

End Sub
'----------------------------------------------------------------
Sub StopKeyWatch()

'set this boolean flag to exit the above loop.
bExitLoop = True

End Sub
'----------------------------------------------------------------

'\This example illustrates how to catch worksheet
'\Key strokes in order to prevent entering numeric
'\characters in the Range "A1:D10" .
Sub Sheet_KeyPress(ByVal KeyAscii As Integer, _
ByVal KeyCode As Integer, _
ByVal Target As Range, _
Cancel As Boolean)

Const MSG As String = _
"Numeric Characters are not allowed in" & _
vbNewLine & "the Range: """
Const TITLE As String = "Invalid Entry !"

If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
If Chr(KeyAscii) Like "[0-9]" Then
MsgBox MSG & Range("A1:D10").Address(False, False) _
& """ .", vbCritical, TITLE
Cancel = True
End If
End If

End Sub
'----------------------------------------------------------------

MichD