VBA : repérer la prise et la perte de focus sur une Shape

mromain

XLDnaute Barbatruc
Bonjour le forum :),

Voici un petit code VBA qui permet de rajouter 2 évènements au classeur :
  • prise de focus sur une Shape
  • La perte de focus sur une Shape

Il faut rajouter au projet le module de classe Cls_ShapesEvents contenant le code suivant :
VB:
Option Explicit

Private memShp As Shape
Private WithEvents wbk As Workbook

Public Event GetFocus(shp As Shape)
Public Event LostFocus(shp As Shape)


Public Sub ShapeClic(shp As Shape)
    FreeShape
    Set memShp = shp
    RaiseEvent GetFocus(memShp)
End Sub

Private Sub FreeShape()
    If Not memShp Is Nothing Then RaiseEvent LostFocus(memShp)
    Set memShp = Nothing
End Sub

Private Sub Class_Initialize()
    Set wbk = ThisWorkbook
End Sub

Private Sub wbk_BeforeClose(Cancel As Boolean)
    FreeShape
End Sub

Private Sub wbk_Deactivate()
    FreeShape
End Sub

Private Sub wbk_SheetActivate(ByVal Sh As Object)
    FreeShape
End Sub

Private Sub wbk_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    FreeShape
End Sub
Ainsi que ce code dans ThisWorkbook :
VB:
Private WithEvents ShapesEvts As Cls_ShapesEvents

Public Sub ClickShape()
    On Error Resume Next
    If ShapesEvts Is Nothing Then Set ShapesEvts = New Cls_ShapesEvents
    ShapesEvts.ShapeClic ActiveSheet.Shapes(Application.Caller)
End Sub

Ensuite, associer la macro ThisWorkbook.ClicShape aux formes du classeur.


Il ne reste qu’à implémenter la gestion des évènements depuis ThisWorkbook :
VB:
Private Sub ShapesEvts_GetFocus(shp As Shape)

End Sub

Private Sub ShapesEvts_LostFocus(shp As Shape)

End Sub

Le fichier ci-joint montre un exemple d’utilisation.

A+
 

Pièces jointes

  • Exemple_ShapeFocus.xlsm
    92.7 KB · Affichages: 409

ebeaul12

XLDnaute Nouveau
Re : VBA : repérer la prise et la perte de focus sur une Shape

Salut Romain,

Ta méthode fonctionne parfaitement. Par contre j'ai une dérive par rapport à l'utilisation de zone de texte. Lors que je click sur une zone de texte j'active l'évènement getFocus :
Private Sub ShapesEvts_GetFocus(shp As Shape)
shp.TextFrame2.TextRange.Characters.Select
End Sub

test.jpg

Je sélectionne ainsi la zone de texte. Par contre lorsque je clique directement sur une seconde zone de texte, je rentre directement dans l'éditeur de texte sans déclencher de LostFocus.

Test 2.jpg

Le lostFocus se déclenche uniquement lorsque je click sur une cellule à côté ou un Shape n'ayant pas de texte. Y a t-il moyen d'ajouter un évènement qui détecte le changement de selection de TextFrame2 des zones de textes ??

Merci d'avance.
 

Pièces jointes

  • test.jpg
    test.jpg
    8.2 KB · Affichages: 188
  • test.jpg
    test.jpg
    8.2 KB · Affichages: 196
  • Test 2.jpg
    Test 2.jpg
    11 KB · Affichages: 196
  • Test 2.jpg
    Test 2.jpg
    11 KB · Affichages: 190

mromain

XLDnaute Barbatruc
Re : VBA : repérer la prise et la perte de focus sur une Shape

Bonjour ebeaul12 et bienvenue sur le forum,
Bonjour le forum,

Peux-tu mettre un petit fichier exemple, ce sera plus simple pour voir.

A+
 

ebeaul12

XLDnaute Nouveau
Re : VBA : repérer la prise et la perte de focus sur une Shape

Salut Romain,

J'ai joins un fichier qui reprend ta classe. Sur la feuille 1 j'ai placé deux textboxs et j'ai ajouté dans le code thisworkbook le code pour les évènement getfocus et lostfocus (renvoyant des messages selon le focus ou la perte de focus sur les shapes).

Lorsque tu sélectionnes l'une des texbox, le getfocus fonctionne et sélectionne directement le texte. Par contre lorsqu'on sélectionne directement le texte de la seconde textbox, le lostfocus ne se déclenche pas. Il faut clicker en dehors des texbox.

C'est problématique si je souhaite sauvegarde après un lostfocus les données alors qu'il est possible de modifier plusieurs zones de textes sans que je le détecte.
 

Pièces jointes

  • Classeur1.xlsm
    20.1 KB · Affichages: 153
  • Classeur1.xlsm
    20.1 KB · Affichages: 171
  • Classeur1.xlsm
    20.1 KB · Affichages: 177

mromain

XLDnaute Barbatruc
Re : VBA : repérer la prise et la perte de focus sur une Shape

Bonjour ebeaul12,

Je comprends mieux ton problème. Malheureusement, je ne vois pas de solution appropriée.

En protégeant la feuille, il est possible de verrouiller/déverrouiller les autres formes au moment des GetFocus et LostFocus, mais l’utilisation est moins intuitive. Il faut alors quitter le mode d’édition (avec la touche Echap, ou en sélectionnant une cellule de la feuille) avant de pouvoir cliquer sur une autre forme.
VB:
Private Sub ShapesEvts_GetFocus(shp As Shape)
Dim curShp As Shape
    'verrouiller toutes les autres formes de la feuilles
     For Each curShp In shp.Parent.Shapes
        If (Not curShp Is shp) And (curShp.OnAction = shp.OnAction) Then curShp.Locked = True
    Next curShp
    
    MsgBox "focus sur la zone de texte : " & shp.Name
    shp.TextFrame2.TextRange.Characters.Select
End Sub

Private Sub ShapesEvts_LostFocus(shp As Shape)
Dim curShp As Shape
    'déverrouiller toutes les autres formes de la feuilles
     For Each curShp In shp.Parent.Shapes
        If (Not curShp Is shp) And (curShp.OnAction = shp.OnAction) Then curShp.Locked = False
    Next curShp
    
    MsgBox "Lostfocus sur la zone de texte : " & shp.Name
End Sub
Sinon, vu ce que tu sembles vouloir faire, pourquoi ne pas utiliser des TextBoxs ?

A+
 

ebeaul12

XLDnaute Nouveau
Re : VBA : repérer la prise et la perte de focus sur une Shape

Bonjour,

Oui je penses que je vais utiliser des label dans ma feuille pour ensuite faire appel à un Userform à partir de l'évènement Label1_click().
Par contre vu que j'aurais plusieurs lignes, j'essaye de mutualiser mes évènements à l'aide d'une classe mais pour l'instant je fais face à des erreurs que je ne comprends pas.

J'ai crée ma classe LabelClass :
Public WithEvents LabelGroup As MSForms.Label
Private Sub LabelGroup_Click()
MsgBox "le label clické est : " & LabelGroup.Name & " et son parent est : " & LabelGroup.Parent
End Sub

Je crée ensuite dans ma feuille :

Private Lbs() As LabelClass

et j'utilise la procédure suivante pour crée des labels pendant le runtime :

Public Sub AjoutLigne(pos As Range, numLigne As Integer)
Me.Activate
pos.Select
Dim ole As OLEObject
Set ole = Me.OLEObjects.Add("Forms.Label.1")
With ole
.TopLeftCell = pos
.Height = TextHeight
.Width = TextWidth
.Placement = XlPlacement.xlMoveAndSize
.Name = nb_champs_observation & "_Lb_" & numLigne
End With

' Set Lbs(numLigne).LabelGroup = ole.Object
end Sub

Le problème c'est que lorsque je décommente le code Set Lbs(numLigne).LabelGroup = ole.Object, la fonction me renvoie un message d'erreur d'exécution 91 au niveau de la méthode Add comme quoi mon objet n'est pas défini. Dès lors que j'enlève le Set Lbs(numLigne).LabelGroup = ole.Object, la méthode fonctionne.
 

mromain

XLDnaute Barbatruc
Re : VBA : repérer la prise et la perte de focus sur une Shape

Bonjour ebeaul12, le forum,

Difficile de tester sans exemple...
Peux-tu en fournir un stp ?

A+
 

ebeaul12

XLDnaute Nouveau
Re : VBA : repérer la prise et la perte de focus sur une Shape

Bonjour,

J'ai résolu le problème en initialisant tous mes objets dans une méthode à l'ouverture de mon classeur. Merci à toi.

A+
 

Staple1600

XLDnaute Barbatruc
Re : VBA : repérer la prise et la perte de focus sur une Shape

Bonjour à tous

ebeaul12
J'ai résolu le problème en initialisant tous mes objets dans une méthode à l'ouverture de mon classeur.
Tu peux diffuser cette méthode sur le forum pour rester dans l'esprit de partage des connaissances qui caractérise tout bon forum d'entraide, stp ?
 

ebeaul12

XLDnaute Nouveau
Re : VBA : repérer la prise et la perte de focus sur une Shape

J'ai codé dans la feuille ThisWorkbook :
LabelCollection as Collection

Private Sub Workbook_Open()
Set LabelCollection= new Collection
dim feuille as Worksheet
dim ole as OLEObject
dim obj as LabelClass
set obj=new LabelClass
for each feuille in Me.sheets
for each ole in feuille.OLEObjects
set obj=ole.object
LabelCollection.Add obj
next
next

end sub.


Comme cela tous mes labels sont ajoutés à la collection à l'ouverture du fichier et je peux utiliser le code dans l'évènement LabelGroup_Click () pour tous les labels.





End Sub
 

patricktoulon

XLDnaute Barbatruc
bonjour
trouvant l'idée intéressante et n'ayant pas pu la faire fonctionner
j'utilise une variable public dans le module thisworkbook

VB:
Option Explicit
Public oldshape As Object
Public Sub ClickShape()
    With ActiveSheet
        If Not oldshape Is Nothing Then
            If oldshape.Name <> Application.Caller Then
                ShapesEvts_LostFocus oldshape
            End If
        End If
        ShapesEvts_GetFocus .Shapes(Application.Caller)
        Set oldshape = .Shapes(Application.Caller)
    End With
End Sub
Public Sub ShapesEvts_GetFocus(shp)
    MsgBox "SHAPE ACTIF" & vbCrLf & shp.Name
End Sub

Public Sub ShapesEvts_LostFocus(shp)
    MsgBox "PECEDENT SHAPE" & vbCrLf & shp.Name
End Sub

et pareillement associer la thisworlbook.ClickShape aux formes
 

Discussions similaires