Clic droit et sélection change s'éxécutent les 2

Le 28/01/2022 à 11:46

Bonjour,

Voilà je m'amuse à faire un petit démineur pour m'exercer. Le problème est que ma macro éxécute à la fois :

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

et

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Comment bloquer selection change quand beforerightclick a été activé ?

Voici mon code :

Public nbbb, decalv, decalh, th, tv As Integer

Sub grille()
nbbb = 15    'nb de bombes
decalh = 5  'début du tracé
decalv = 5
th = 8     'dimensions du tracé -1
tv = 12

Cells.Delete

With Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv))
   .Borders.Weight = xlThin
   .Borders(xlEdgeTop).Weight = xlMedium
   .Borders(xlEdgeBottom).Weight = xlMedium
   .Borders(xlEdgeLeft).Weight = xlMedium
   .Borders(xlEdgeRight).Weight = xlMedium
   .HorizontalAlignment = xlCenter
   '.Font.Color = vbWhite    'blanc sur blanc
End With

For i = 1 To nbbb
    'x = Int((th * Rnd) + 1)   'de 1 à nbbb
    x = Int((th + 1) * Rnd)
    y = Int((tv + 1) * Rnd)
    If Cells(decalh + x, decalv + y) = "X" Then i = i - 1
    If Cells(decalh + x, decalv + y) = "" Then Cells(decalh + x, decalv + y) = "X"
Next

For Each cell In Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv))
    If cell.Value <> "X" Then cell.Value = 0
    If cell.Offset(1, 1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(0, 1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(-1, 1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(-1, 0) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(-1, -1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(0, -1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(1, -1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(1, 0) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
Next
   '.Font.Color = vbBlack
Cells(decalh, decalv + tv + 2) = "Nombre de coups joué"
Cells(decalh + 1, decalv + tv + 2 + 1) = "sur"
Cells(decalh + 1, decalv + tv + 2) = 0
Cells(decalh + 1, decalv + tv + 2 + 2) = Application.WorksheetFunction.CountA(Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv)))

'fin de construction de la grille

End Sub
Sub alea()
Dim nb, nblign, nbtir As Integer

Range("A1", "A1000").ClearContents
Range("j10", "FF10").ClearContents

nb = Cells(4, 5)      '1 nb début tirage
nblign = Cells(4, 7)  '100 nb fin tirage
nbtir = Cells(5, 7)   '5 nb de tirage

i = nb

Do Until i > nblign
nb = Int((nblign * Rnd) + 1)
    Do While IsEmpty(Cells(nb, 1))
    Cells(nb, 1) = i
    i = i + 1
    If i = nbalign Then Exit Sub
    nb = Int((nblign * Rnd) + 1)
    Loop
Loop

Randomize
nblign = nblign - nbtir + 1
nb = Int((nblign * Rnd) + 1)

For i = 0 To nbtir - 1
    Cells(10, 10 + i) = Cells(nb + i, 1)
Next

End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Set KeyCells = Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv)) 'cette variable définit la zone sensible
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
    Cancel = True 'Annulation du clic droit
    ActiveCell.Interior.Color = RGB(0, 0, 0)
    'Cells(decalh + 1, decalv + tv + 2) = Cells(decalh + 1, decalv + tv + 2) + 1
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim couleur(8) As String
Set KeyCells = Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv)) 'cette variable définit la zone sensible
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then

If ActiveCell.Interior.Color = RGB(0, 0, 0) Then Stop

couleur(0) = RGB(174, 248, 200): couleur(1) = RGB(148, 246, 183)
couleur(2) = RGB(93, 241, 146): couleur(3) = RGB(55, 237, 120)
couleur(4) = RGB(20, 230, 95): couleur(5) = RGB(16, 188, 77)
couleur(6) = RGB(13, 151, 62): couleur(7) = RGB(10, 120, 49)
couleur(8) = RGB(8, 88, 37)
a = ActiveCell.Value
If a <> "X" And a <> "" Then ActiveCell.Interior.Color = couleur(a)
If a = "X" Then
    MsgBox "perdu"
    Call grille
End If

Cells(decalh + 1, decalv + tv + 2) = Cells(decalh + 1, decalv + tv + 2) + 1
If a = 0 Then
'    If cell.Offset(1, 1) = "0" Then cell.Offset(1, 1).Interior.Color = couleur(0)
'    If cell.Offset(0, 1) = "0" Then cell.Offset(0, 1).Interior.Color = couleur(0)
'    If cell.Offset(-1, 1) = "0" Then cell.Offset(-1, 1).Interior.Color = couleur(0)
'    If cell.Offset(-1, 0) = "0" Then cell.Offset(-1, 0).Interior.Color = couleur(0)
'    If cell.Offset(-1, -1) = "0" Then cell.Offset(-1, -1).Interior.Color = couleur(0)
'    If cell.Offset(0, -1) = "0" Then cell.Offset(0, 1).Interior.Color = couleur(0)
'    If cell.Offset(1, -1) = "0" Then cell.Offset(1, -1).Interior.Color = couleur(0)
'    If cell.Offset(1, 0) = "0" Then cell.Offset(1, 0).Interior.Color = couleur(0)
End If

If Cells(decalh + 1, decalv + tv + 2) = Cells(decalh + 1, decalv + tv + 2 + 2) - nbbb Then MsgBox "bravo!!!"

End If
End Sub

J'aurai aussi bien d'aider pour les "0" qui se découvre en fractal mais ca c'est une autre histoire :p

merci

Le 28/01/2022 à 12:08

Bonjour,

un simple test montre que l'événement Change se produit avant RightClic.
Il faut donc mémoriser que cet événement a eu lieu et le tester :

Public cellChange As Boolean

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If cellChange Then
        ' il y a eu SelectionChange
        Stop
    Else
        ' il n'y a pas eu de SelectionChange
        Stop
    End If
    cellChange = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    cellChange = True
    Stop
End Sub

eric

Le 28/01/2022 à 15:18

oui c'est ca, change se produit avant

comment faire en sorte qu'il ne se produise pas ou filtrer à l'intérieur que c'est un bouton de droite ?

Le 28/01/2022 à 15:24

Salut Yoyovento,
Salut Eriiic,

c'est bien ça le problème : un clic droit est avant tout... un clic !
La procédure 'Selection_Change' s'exécutera AVANT toute autre : il faut y penser quand on code !

Explique-nous ce que tu veux faire et nous trouverons peut-être une astuce.


A+

Le 28/01/2022 à 15:42

je veux noircir la case avec le clic doit donc :

je veux dire "perdu" quand on clique gauche et qu'il y a un X dans la case

mais je ne veux pas avoir "perdu" quand on clique droit et qu'il y a un X dans la case

Le 28/01/2022 à 15:48

Salut Yoyovento,

la réponse la plus facile est d'utiliser le Clic-droit dans un cas et le Double-clic dans l'autre, ainsi en supprimant 'Selection_Change', tu règles ton souci.


A+

Le 28/01/2022 à 16:07

Je suis d'accord avec toi curulis57 mais ca fait faire beaucoup de double clic alors :(

Sinon il faudrait alors toujours faire avec le gauche mais cliquer dans une autre case juste avant pour choisir la couleur noire...

Ca change un peu les règles mais simplifie la macro LOL

Le 28/01/2022 à 16:55

J'ai fait ce code du coup :

Public nbbb, decalv, decalh, th, tv, noireok As Integer

Sub grille()
nbbb = 15    'nb de bombes
decalh = 5  'début du tracé
decalv = 5
th = 8     'dimensions du tracé -1
tv = 12

Cells.Delete

With Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv))
   .Borders.Weight = xlThin
   .Borders(xlEdgeTop).Weight = xlMedium
   .Borders(xlEdgeBottom).Weight = xlMedium
   .Borders(xlEdgeLeft).Weight = xlMedium
   .Borders(xlEdgeRight).Weight = xlMedium
   .HorizontalAlignment = xlCenter
   .Font.Color = vbWhite    'blanc sur blanc
End With

For i = 1 To nbbb
    'x = Int((th * Rnd) + 1)   'de 1 à nbbb
    x = Int((th + 1) * Rnd)
    y = Int((tv + 1) * Rnd)
    If Cells(decalh + x, decalv + y) = "X" Then i = i - 1
    If Cells(decalh + x, decalv + y) = "" Then Cells(decalh + x, decalv + y) = "X"
Next

For Each cell In Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv))
    If cell.Value <> "X" Then cell.Value = 0
    If cell.Offset(1, 1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(0, 1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(-1, 1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(-1, 0) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(-1, -1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(0, -1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(1, -1) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
    If cell.Offset(1, 0) = "X" And cell.Value <> "X" Then cell.Value = cell.Value + 1
Next
   '.Font.Color = vbBlack
Cells(decalh, decalv + tv + 2) = "Nombre de coups joué"
Range(Cells(decalh, decalv + tv + 2), Cells(decalh, decalv + tv + 8)).Merge

Cells(decalh + 1, decalv + tv + 2 + 1) = "sur"
Cells(decalh + 1, decalv + tv + 2) = 0
Cells(decalh + 1, decalv + tv + 2 + 2) = Application.WorksheetFunction.CountA(Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv)))
Columns(decalv + tv + 2 + 2).EntireColumn.AutoFit

Cells(decalh + 3, decalv + tv + 2).Interior.Color = RGB(0, 0, 0)
'fin de construction de la grille

End Sub
Sub alea()
Dim nb, nblign, nbtir As Integer

Range("A1", "A1000").ClearContents
Range("j10", "FF10").ClearContents

nb = Cells(4, 5)      '1 nb début tirage
nblign = Cells(4, 7)  '100 nb fin tirage
nbtir = Cells(5, 7)   '5 nb de tirage

i = nb

Do Until i > nblign
nb = Int((nblign * Rnd) + 1)
    Do While IsEmpty(Cells(nb, 1))
    Cells(nb, 1) = i
    i = i + 1
    If i = nbalign Then Exit Sub
    nb = Int((nblign * Rnd) + 1)
    Loop
Loop

Randomize
nblign = nblign - nbtir + 1
nb = Int((nblign * Rnd) + 1)

For i = 0 To nbtir - 1
    Cells(10, 10 + i) = Cells(nb + i, 1)
Next

End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim couleur(8) As String

Set KeyCells1 = Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv)) 'cette variable définit la zone sensible
Set KeyCells2 = Cells(decalh + 3, decalv + tv + 2)

If Not Application.Intersect(KeyCells1, Range(Target.Address)) Is Nothing Then

couleur(0) = RGB(174, 248, 200): couleur(1) = RGB(148, 246, 183)
couleur(2) = RGB(93, 241, 146): couleur(3) = RGB(55, 237, 120)
couleur(4) = RGB(20, 230, 95): couleur(5) = RGB(16, 188, 77)
couleur(6) = RGB(13, 151, 62): couleur(7) = RGB(10, 120, 49)
couleur(8) = RGB(8, 88, 37)

a = ActiveCell.Value

If ActiveCell.Interior.Color = 16777215 Then Cells(decalh + 1, decalv + tv + 2) = Cells(decalh + 1, decalv + tv + 2) + 1

If a <> "X" And a <> "" And noireok = 0 Then ActiveCell.Interior.Color = couleur(a)
'stop

If a = "X" And noireok = 0 Then
    ActiveCell.Font.Color = RGB(0, 0, 0)
    MsgBox "perdu"
    Call grille
End If

If noireok = 1 Then
    ActiveCell.Interior.Color = RGB(0, 0, 0)
    ActiveCell.Font.Color = RGB(0, 0, 0)
    noireok = 0
End If

If a = 0 Then
'    If cell.Offset(1, 1) = "0" Then cell.Offset(1, 1).Interior.Color = couleur(0)
'    If cell.Offset(0, 1) = "0" Then cell.Offset(0, 1).Interior.Color = couleur(0)
'    If cell.Offset(-1, 1) = "0" Then cell.Offset(-1, 1).Interior.Color = couleur(0)
'    If cell.Offset(-1, 0) = "0" Then cell.Offset(-1, 0).Interior.Color = couleur(0)
'    If cell.Offset(-1, -1) = "0" Then cell.Offset(-1, -1).Interior.Color = couleur(0)
'    If cell.Offset(0, -1) = "0" Then cell.Offset(0, 1).Interior.Color = couleur(0)
'    If cell.Offset(1, -1) = "0" Then cell.Offset(1, -1).Interior.Color = couleur(0)
'    If cell.Offset(1, 0) = "0" Then cell.Offset(1, 0).Interior.Color = couleur(0)
End If

If Cells(decalh + 1, decalv + tv + 2) = Cells(decalh + 1, decalv + tv + 2 + 2) - nbbb Then
MsgBox "bravo!!!"
Range(Cells(decalh, decalv), Cells(decalh + th, decalv + tv)).Font.Color = vbBlack    'affiche les bombes
End If

End If

Columns(decalv + tv + 2).EntireColumn.AutoFit

On Error Resume Next

Set KeyCells2 = Cells(decalh + 3, decalv + tv + 2)

If Not Application.Intersect(KeyCells2, Range(Target.Address)) Is Nothing Then noireok = 1

End Sub

Ca ne me déplait pas tant que ca LOL

Je pourrais même voir pour une autre couleur du coup (comme dans le jeu original)

Le 28/01/2022 à 17:19

Salut Yoyovento,

pas lu mais si tu pouvais envoyer ton fichier et si tu es d'accord, j'y jetterai un oeil pour y mettre ma patte...


A+

Le 28/01/2022 à 17:48

J'ai collé tout mon code au dessus

Le 28/01/2022 à 18:25

Si tu testais ma proposition et me disais ce que tu en penses ?

Le 28/01/2022 à 18:39

Désolé Éric mais j'ai pas compris 🙏

Le 28/01/2022 à 18:52

Bah, teste le code que j'ai mis dans mon post tout au début.
Il faut tout lire dans une réponse...

Le 29/01/2022 à 17:30

Désolé Eric mais j'avais lu ca, c'est pas une solution, c'est le problème je crois

Le 29/01/2022 à 22:55

Oui, bonjour aussi,

Heuuu, comment dire... Tu as vraiment testé ?
Même sans tester, en lisant le code tu vois qu'il y a un test dans DoubleClick qui permet de savoir s'il y a eu un Selection juste avant ou pas.
Ce n'était la question originale ?
J'ai mis des Stop pour que tu vois quel chemin était pris selon les cas.
eric

Le 29/01/2022 à 23:44

Bonsoir,

ensemble de procédures utilisées dans mon application "le chasseur de bombe" que j'ai repris ci dessous pour Magic-Draw où le clic gauche est utilisé pour faire tourner les couleurs dans un sens et le clic droit dans l'autre sens, le principe on instaure une temporisation sur le change afin de laisser le temps à VBA de gérer le clic droit : si pas de gestion alors clic gauche dans les deux cas on lance la procédure de coloriage :

Option Explicit

Dim Droite As Boolean

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, R) Is Nothing And En_Cours Then
        Droite = True
        Cancel = True
        Call Coloriage(ActiveCell)
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If En_Cours Then
        Droite = False
        Application.OnTime 1, Me.CodeName & ".Action"
    End If
End Sub

Sub Action()
    ' si le clic droit a été géré, alors on sort de l'action due au "SelectionChange"
    If Droite Then Droite = False: Exit Sub
    ' s'il n'y a pas eu de gestion clic droit on exécute la gestion du clic gauche
    Call Coloriage(ActiveCell)
End Sub

Coloriage est la procédure de coloriage, Action remplace l'exécution "direct" du clic gauche...

@ bientôt

LouReeD

Le 29/01/2022 à 23:52

Le fichier "pas fini" pour l'exemple, le but est de cliquer sur les cellules du dessin de droite pour reconstituer l'image de gauche. Clic gauche la palette de couleur va dans un sens, clic droit elle va dans l'autre.

Que ce soit pour Magic-Draw ou le chasseur de bombe, après un clic gauche il faut dé sélectionner la cellule cliquée, sinon plus d'action car le clic gauche est géré par le sélection change !

Le fichier :

19md2.xlsm (301.36 Ko)

Attention ! il ne restera pas longtemps !

@ bientôt

LouReeD

Rechercher des sujets similaires à "clic droit selection change executent"