XL 2019 Saisi clavier dans une feuille de calcul

Cemalatowilo

XLDnaute Nouveau
Bonjour,
Est-il possible de détecter l'appuie sur n'importe qu'elle touche du clavier lorsque l'on est sur une feuille de calcul?
Je pense à utiliser Keypress, mais je ne sais pas comment m'y prendre.
Merci
 

Cemalatowilo

XLDnaute Nouveau
ben nous non plus, sans fichier :rolleyes:

👍🤭
Bonsoir,
Voici mon fichier.
J'ai désactiver la partie qui intercepte le message d'erreur.
J'ai créer 2 boutons pour démarrer et arréter le programme récursif en cas de problème
Depuis ce matin, j'ai longuement utiliser mon classeur. En réalité il ne fonctionne pas si bien que cela. Excel s'éteint subrepticement pour redémarrer tout seul!
Merci de ton temps
 

Pièces jointes

  • 21.03.06 Test segment.xlsm
    71.9 KB · Affichages: 16
Bonjour Cematowilo

Pas terrible, une boucle de test permanente, cela finit forcément par saturer les piles d'exécution.
Je te propose de passer plutôt par ontime
Comme tu n'avais pas de module installé, j'ai laissé l'intégralité du code dans la feuille concernée, il faut passer par le codename pour utiliser une proc de feuille avec ontime (sans module installé), cela fonctionne très bien. J'en ai profité pour modifier la macro pour qu'elle teste et ne modifie la position des shapes que si besoin avec un test pour bloquer la récursivité du ontime si la proc est déja en cours d'exécution.
J'ai laissé un appel par Thisworkbook.open pour lancer l'exécution si la feuille "Dépense 2021" est déja la feuille active par défaut au lancement du classeur
Dis moi si cela te convient, cela me semble pas mal !

Bien cordialement

code de la feuille "Dépense 2021"
VB:
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_en_Cours As Boolean

Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    If Not Test_en_Cours Then
        Test_en_Cours = True
        If SegmentShape1 Is Nothing Then
            Set SegmentShape1 = Me.Shapes("Ss type")
            Set SegmentShape2 = Me.Shapes("Bénéficiaire")
            Set SegmentShape3 = Me.Shapes("Type")
            Set SegmentShape4 = Me.Shapes("Où")
            Set SegmentShape5 = Me.Shapes("Désignation")
        End If
        With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
            premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
        End With
        If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
            SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
            SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
            SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
        End If
        If ActiveSheet.Name = "Dépense 2021" Then Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
        Test_en_Cours = False
    End If
End Sub
Private Sub Worksheet_Activate()
    Set SegmentShape1 = Me.Shapes("Ss type")
    Set SegmentShape2 = Me.Shapes("Bénéficiaire")
    Set SegmentShape3 = Me.Shapes("Type")
    Set SegmentShape4 = Me.Shapes("Où")
    Set SegmentShape5 = Me.Shapes("Désignation")
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub

Code pour Thisworkbook, pas indispensable
Code:
Private Sub Workbook_Open()
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub
 
Modif, j'ai enlevé les référencement à l'activation de la feuille, quand j'ai ajouté le référencement conditionnel pour Thisworkbook, je n'avais pas vu qu'il n'était plus nécessaire à l'activation de la feuille
Code:
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_en_Cours As Boolean

Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    If Not Test_en_Cours Then
        Test_en_Cours = True
        If SegmentShape1 Is Nothing Then
            Set SegmentShape1 = Me.Shapes("Ss type")
            Set SegmentShape2 = Me.Shapes("Bénéficiaire")
            Set SegmentShape3 = Me.Shapes("Type")
            Set SegmentShape4 = Me.Shapes("Où")
            Set SegmentShape5 = Me.Shapes("Désignation")
        End If
        With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
            premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
        End With
        If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
            SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
            SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
            SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
        End If
        If ActiveSheet.Name = "Dépense 2021" Then Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
        Test_en_Cours = False
    End If
End Sub
Private Sub Worksheet_Activate()
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub
 

Pièces jointes

  • Copie de 21.03.06 Test segment.xlsm
    70.8 KB · Affichages: 6

Cemalatowilo

XLDnaute Nouveau
Bonjour Cematowilo

Pas terrible, une boucle de test permanente, cela finit forcément par saturer les piles d'exécution.
Je te propose de passer plutôt par ontime
Comme tu n'avais pas de module installé, j'ai laissé l'intégralité du code dans la feuille concernée, il faut passer par le codename pour utiliser une proc de feuille avec ontime (sans module installé), cela fonctionne très bien. J'en ai profité pour modifier la macro pour qu'elle teste et ne modifie la position des shapes que si besoin avec un test pour bloquer la récursivité du ontime si la proc est déja en cours d'exécution.
J'ai laissé un appel par Thisworkbook.open pour lancer l'exécution si la feuille "Dépense 2021" est déja la feuille active par défaut au lancement du classeur
Dis moi si cela te convient, cela me semble pas mal !

Bien cordialement

code de la feuille "Dépense 2021"
VB:
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_en_Cours As Boolean

Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    If Not Test_en_Cours Then
        Test_en_Cours = True
        If SegmentShape1 Is Nothing Then
            Set SegmentShape1 = Me.Shapes("Ss type")
            Set SegmentShape2 = Me.Shapes("Bénéficiaire")
            Set SegmentShape3 = Me.Shapes("Type")
            Set SegmentShape4 = Me.Shapes("Où")
            Set SegmentShape5 = Me.Shapes("Désignation")
        End If
        With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
            premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
        End With
        If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
            SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
            SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
            SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
        End If
        If ActiveSheet.Name = "Dépense 2021" Then Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
        Test_en_Cours = False
    End If
End Sub
Private Sub Worksheet_Activate()
    Set SegmentShape1 = Me.Shapes("Ss type")
    Set SegmentShape2 = Me.Shapes("Bénéficiaire")
    Set SegmentShape3 = Me.Shapes("Type")
    Set SegmentShape4 = Me.Shapes("Où")
    Set SegmentShape5 = Me.Shapes("Désignation")
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub

Code pour Thisworkbook, pas indispensable
Code:
Private Sub Workbook_Open()
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub
merci pour tout Yeahou, j'étudierai cela ce soir.
 
Bonjour Cematowilo

j'ai re activé tes boutons pour stopper et redémarrer la proc, je ne l'avais pas fait dans la version précédente.

@+
VB:
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_en_Cours As Boolean
Private Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    If Not Test_en_Cours Then
        Test_en_Cours = True
        If SegmentShape1 Is Nothing Then
            Set SegmentShape1 = Me.Shapes("Ss type")
            Set SegmentShape2 = Me.Shapes("Bénéficiaire")
            Set SegmentShape3 = Me.Shapes("Type")
            Set SegmentShape4 = Me.Shapes("Où")
            Set SegmentShape5 = Me.Shapes("Désignation")
        End If
        With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
            premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
        End With
        If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
            SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
            SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
            SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
        End If
        If ActiveSheet.Name = "Dépense 2021" Then Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
        Test_en_Cours = False
    End If
End Sub
Private Sub Worksheet_Activate()
    Test_en_Cours = False
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub
Private Sub Stop_FixeSegement()
    Test_en_Cours = True
End Sub
Private Sub Redemarre_FixeSegement()
    Test_en_Cours = False
    FixeSegment
End Sub
 

Pièces jointes

  • Copie de 21.03.06 Test segment.xlsm
    70.6 KB · Affichages: 2
Re
et si tu veux garder ta première version, j'ai modifié quelques trucs qui devrait l'améliorer, à tester
Référencement des shapes si besoin
Repositionnement des shapes si besoin
la procédure récursive ne lance FixeSegment que s'il n'est pas déja en cours d'exécution
Tu pourras modifier tes objets mais je pense que la pile d'exécution finira quand même par saturer
Cordialement
VB:
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_FixeSegment As Boolean

Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    Test_FixeSegment = True
    If SegmentShape1 Is Nothing Then
        Set SegmentShape1 = Me.Shapes("Ss type")
        Set SegmentShape2 = Me.Shapes("Bénéficiaire")
        Set SegmentShape3 = Me.Shapes("Type")
        Set SegmentShape4 = Me.Shapes("Où")
        Set SegmentShape5 = Me.Shapes("Désignation")
    End If
    With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
        premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
    End With
    If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
        SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
        SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
        SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
        SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
        SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
    End If
    Test_FixeSegment = False
End Sub
Sub Lanceur()
    'Procédure récursive qui permet d'appeler FiweSegment tous les Delta seconde
    'On Error GoTo ErreurClavier
    'Application.EnableCancelKey = xlErrorHandler 'Permet de contrôler l'erreur qui m'indique que je ne peux pas utiliser
                                                 'quand je modifie une cellule
   
    Delta = 0.01
    StopLanceur = False 'Par défaut Lanceur est actif
    While True
        Depart = Timer
        While Timer <= Depart + Delta
            DoEvents 'Rend la main à l'utilisateur et au système
            If StopLanceur = True Then Exit Sub 'Arrète la procédure récursive
        Wend
        If Not Test_FixeSegment Then FixeSegment 'exécute FixeSegment
        Lanceur 'Relance la procédure récursive
    Wend
   
ErreurClavier:
    If Err = 18 Then
        StopperLanceur
    End If
End Sub
Sub StopperLanceur()
    StopLanceur = True
End Sub
 
Dernière édition:

Cemalatowilo

XLDnaute Nouveau
J'ai étudié ta procédure avec application.ontime. Elle fonctionne bien, mais le mouvement des segments est moins lissé, c'est pourquoi j'avais essayé avec Timer qui permet de descendre l'incrément de temps en-dessous de la seconde.
Comme tu l'as suggéré, j'ai mis le code dans un module. Il est plus clair ainsi. je te joins le fichier modifié

je vais maintenant regardé le fichier avec Timer que tu as modifié.
Merci
 

Pièces jointes

  • 21.03.06 Test segment corrigé.xlsm
    67.4 KB · Affichages: 3

Cemalatowilo

XLDnaute Nouveau
Re bonsoir,
J'ai repris ton code modifié avec Timer.
Effectivement il y a un toujours un dépassement de la capacité de la pile.
J'essaye de la contourner en gérant l'erreur de la manière suivante:
VB:
Sub Lanceur()
    On Error GoTo ErreurPile
...
...
ErreurPile:
    If Err.Number = 28 Then
        Err.Clear
        Feuil7.Lanceur
    End If
End Sub
Mais cela ne fonctionne pas!
Une idée?
 

Discussions similaires

Réponses
7
Affichages
288