XL 2016 VBA - Comment détecter la changement de position d'une fenêtre ?

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion Dudu2
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Dudu2

Dudu2

XLDnaute Barbatruc
Bonjour,

En gestion des évènements d'une fenêtre on a ces options:
1734412001934.png

Il n'y a pas d'évènement WindowLayout() comme il y a un évènement UserForm_Layout() et donc on ne peut pas détecter de déplacement de la Window.

Y a-t-il une parade à part faire mouliner sans fin une macro pour surveiller le layout de la Window ?
 
Dernière édition:
Solution
Dudu2
Et donc après une bonne dizaine d'heures de tests pour trouver la cause et la parade !!!
Ça m'a épuisé ! 😰

La cause: Après une initialisation du projet dans le VBE et uniquement dans ce cas (faut quand même le faire Excel !!!) crash Excel à cause d'un conflit entre l'évènement Application WindowResize et l'évènement SetWinEventHook EVENT_SYSTEM_MOVESIZEEND.

La parade: Désactiver les évènements Application sur l'évènement SetWinEventHook EVENT_SYSTEM_MOVESIZESTART et les réactiver sur EVENT_SYSTEM_MOVESIZEEND pour empêcher l'évènement Application WindowResize de se produire car ce dernier arrive entre les 2.
Trier par date Trier par votes
C'est possible en créant un classeur éventuellement candidat pour un Add-In / Complément qui scrute en permanence l'active Window et qui appelle une Public Function du classeur surveillé.
Le problème c'est qu'à part un Applcation.OnTime dont la résolution est la seconde, c'est un peu lâche comme surveillance.
J'ai essayé avec l'API Timer mais pas terrible.
Si on boucle sur un Doevents ou un Sleep, le curseur n'est plus normal dans le classeur surveillé.
 

Pièces jointes

Vote positif 0 Vote négatif
Hello,
tu peux essayer avec un hook des événements moveSizeStart et moveSizeStop comme ceci par exemple :
VB: 
Option Explicit
Private Const EVENT_SYSTEM_MOVESIZESTART As Long = &HA
Private Const EVENT_SYSTEM_MOVESIZEEND = &HB
Private Const WINEVENT_OUTOFCONTEXT = 0
#If VBA7 Then
    Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal EventMin As Long, ByVal EventMax As Long, ByVal hmodWinEventProc As LongLong, ByVal lpfnWinEventProc As LongLong, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, lpdwProcessId As Long) As Long
    Private Declare PtrSafe Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As LongPtr) As Long
#Else
    Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal EventMin As Long, ByVal EventMax As Long, ByVal hmodWinEventProc As Long, ByVal lpfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As Long) As Long
#End If

Private pRunningHandles As Collection

Public Function StartEventHook() As Long
  If pRunningHandles Is Nothing Then Set pRunningHandles = New Collection
  StartEventHook = SetWinEventHook(EVENT_SYSTEM_MOVESIZESTART, EVENT_SYSTEM_MOVESIZEEND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
  pRunningHandles.Add StartEventHook
End Function
#If VBA7 Then
   Public Sub StopEventHook(lHook As LongPtr)
#Else
    Public Sub StopEventHook(lHook As Long)
#End If
  Dim LRet As Long
  If lHook = 0 Then Exit Sub

  LRet = UnhookWinEvent(lHook)
End Sub
Public Sub StartHook()
    StartEventHook
End Sub
Public Sub StopAllEventHooks()
Dim vHook As Variant
#If VBA7 Then
    Dim lHook As LongPtr
#Else
    Dim lHook As Long
#End If
For Each vHook In pRunningHandles
    #If VBA7 Then
        lHook = CLngPtr(vHook)
    #Else
        lHook = CLng(vHook)
    #End If
    StopEventHook lHook
Next vHook
End Sub
#If VBA7 Then
    Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hWnd As LongPtr, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
#Else
    Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
#End If
  'This function is a callback passed to the win32 api
  'We CANNOT throw an error or break. Bad things will happen.
  On Error Resume Next
  Dim thePID As Long

  If LEvent = EVENT_SYSTEM_MOVESIZESTART Then
    GetWindowThreadProcessId Application.hWnd, thePID
    If thePID = GetCurrentProcessId Then
      Application.OnTime Now, "Event_MoveStart"
    End If
  ElseIf LEvent = EVENT_SYSTEM_MOVESIZEEND Then
    GetWindowThreadProcessId Application.hWnd, thePID
    If thePID = GetCurrentProcessId Then
      Application.OnTime Now, "Event_MoveEnd"
    End If 
  End If
  On Error GoTo 0
End Function
Public Sub Event_MoveStart()
Debug.Print "Event_MoveStart"
End Sub
Public Sub Event_MoveEnd()
Debug.Print "Event_MoveEnd"
End Sub

mais avec ce code je reçois les événements MoveSizeStart et MoveSizeEnd en même temps plutôt quand arrive le moveSizeEnd. Les événements se produisent aussi sur un resize. Ne pas oublier d'arrêter l'écoute des événements quand on a fini de faire joujou sinon risque de plantage.
Ami calmant, J.P
 
Vote positif 0 Vote négatif
re
@jurassic pork
mais je préfère quand même la solution du set timer car la fonction exécutée est en addressof
donc indépendante de la gestion proc/mémoire de de l'instance vba car tu utilise application.ontime qui elle s'inscrit dans stack(proc/mem) de l'instance de l'application

pour quoi a tu décidé de travailler comme ça?
 
Vote positif 0 Vote négatif
Hello patrick,
patricktoulon à dit:
@jurassic pork
mais je préfère quand même la solution du set timer car la fonction exécutée est en addressof
donc indépendante de la gestion proc/mémoire de de l'instance vba car tu utilise application.ontime qui elle s'inscrit dans stack(proc/mem) de l'instance de l'application
pour quoi a tu décidé de travailler comme ça?
Cliquez pour agrandir...
D'abord ce n'est pas mon code , j'ai seulement modifié les événements à écouter et ensuite je pense que celui qui a fait le code à utiliser un application.ontime pour avoir moins de chance de plantage car c'est indirect (cela se synchronise avec Excel) . Il me semble qu'en 64 bits j'ai pas mal de plantage quand j'utilise un settimer avec un AddressOf.
 
Vote positif 0 Vote négatif
Faut effacer la Collection au stop.
Code: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal EventMin As Long, ByVal EventMax As Long, ByVal hmodWinEventProc As LongLong, ByVal lpfnWinEventProc As LongLong, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, lpdwProcessId As Long) As Long
    Private Declare PtrSafe Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As LongPtr) As Long
#Else
    Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal EventMin As Long, ByVal EventMax As Long, ByVal hmodWinEventProc As Long, ByVal lpfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As Long) As Long
#End If

Private Const EVENT_SYSTEM_MOVESIZESTART As Long = &HA
Private Const EVENT_SYSTEM_MOVESIZEEND = &HB
Private Const WINEVENT_OUTOFCONTEXT = 0

Private pRunningHandles As Collection

Public Function StartEventHook() As Long
    If pRunningHandles Is Nothing Then Set pRunningHandles = New Collection
    StartEventHook = SetWinEventHook(EVENT_SYSTEM_MOVESIZESTART, EVENT_SYSTEM_MOVESIZEEND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
    pRunningHandles.Add StartEventHook
End Function

Public Sub StopEventHook(lHook As Variant)
  Dim LRet As Long
  If lHook = 0 Then Exit Sub

  LRet = UnhookWinEvent(lHook)
End Sub

Public Sub StartHook()
    StartEventHook
End Sub

Public Sub StopAllEventHooks()
    Dim vHook As Variant

    For Each vHook In pRunningHandles
        StopEventHook vHook
    Next vHook
    
    Set pRunningHandles = Nothing
End Sub

#If VBA7 Then
    Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hWnd As LongPtr, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
#Else
    Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
#End If
    Dim thePID As Long
    
    'This function is a callback passed to the win32 api
    'We CANNOT throw an error or break. Bad things will happen.
    On Error Resume Next
    
    If LEvent = EVENT_SYSTEM_MOVESIZESTART Then
        GetWindowThreadProcessId Application.hWnd, thePID
        If thePID = GetCurrentProcessId Then
            'Application.OnTime Now, "Event_MoveStart"
            Call Event_MoveStart
        End If
    ElseIf LEvent = EVENT_SYSTEM_MOVESIZEEND Then
        GetWindowThreadProcessId Application.hWnd, thePID
        If thePID = GetCurrentProcessId Then
            'Application.OnTime Now, "Event_MoveEnd"
            Call Event_MoveEnd
        End If
    End If
    
    On Error GoTo 0
End Function

Public Sub Event_MoveStart()
    Debug.Print pRunningHandles.Count & " Event_MoveStart"
End Sub

Public Sub Event_MoveEnd()
    Debug.Print pRunningHandles.Count & " Event_MoveEnd"
End Sub
 
Vote positif 0 Vote négatif
patricktoulon à dit:
@jurassic pork
les déclarations vb7 ne fonctionnent pas chez moi il y a donc un bloc #if win64 a ajouter dans le #if vba7
Cliquez pour agrandir...
A mon avis c'est les LongLong dans SetWinEventHook qui ne sont pas bon.
J'ai modifié le code de Dudu2 qui m'a l'air sympathique ( les start end fonctionnent) pour prendre en compte cette modification :
VB: 
Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal EventMin As Long, ByVal EventMax As Long, ByVal hmodWinEventProc As LongPtr, ByVal lpfnWinEventProc As LongPtr, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, lpdwProcessId As Long) As Long
    Private Declare PtrSafe Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As LongPtr) As Long
#Else
    Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal EventMin As Long, ByVal EventMax As Long, ByVal hmodWinEventProc As Long, ByVal lpfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As Long) As Long
#End If

Private Const EVENT_SYSTEM_MOVESIZESTART As Long = &HA
Private Const EVENT_SYSTEM_MOVESIZEEND = &HB
Private Const WINEVENT_OUTOFCONTEXT = 0

Private pRunningHandles As Collection

Public Function StartEventHook() As Variant
    If pRunningHandles Is Nothing Then Set pRunningHandles = New Collection
    StartEventHook = SetWinEventHook(EVENT_SYSTEM_MOVESIZESTART, EVENT_SYSTEM_MOVESIZEEND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
    pRunningHandles.Add StartEventHook
End Function

Public Sub StopEventHook(lHook As Variant)
  Dim LRet As Long
  If lHook = 0 Then Exit Sub
  LRet = UnhookWinEvent(lHook)
End Sub

Public Sub StartHook()
    StartEventHook
End Sub

Public Sub StopAllEventHooks()
    Dim vHook As Variant

    For Each vHook In pRunningHandles
        StopEventHook vHook
    Next vHook
   
    Set pRunningHandles = Nothing
End Sub

#If VBA7 Then
    Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hWnd As LongPtr, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
#Else
    Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
#End If
    Dim thePID As Long   
    'This function is a callback passed to the win32 api
    'We CANNOT throw an error or break. Bad things will happen.
    On Error Resume Next   
    If LEvent = EVENT_SYSTEM_MOVESIZESTART Then
        GetWindowThreadProcessId Application.hWnd, thePID
        If thePID = GetCurrentProcessId Then
            'Application.OnTime Now, "Event_MoveStart"
            Call Event_MoveStart
        End If
    ElseIf LEvent = EVENT_SYSTEM_MOVESIZEEND Then
        GetWindowThreadProcessId Application.hWnd, thePID
        If thePID = GetCurrentProcessId Then
            'Application.OnTime Now, "Event_MoveEnd"
            Call Event_MoveEnd
        End If
    End If
   
    On Error GoTo 0
End Function

Public Sub Event_MoveStart()
    Debug.Print pRunningHandles.Count & " Event_MoveStart"
End Sub

Public Sub Event_MoveEnd()
    Debug.Print pRunningHandles.Count & " Event_MoveEnd"
End Sub
Cela fonctionne chez moi en 64 bits à voir si c'est OK en 32 bits
 
Vote positif 0 Vote négatif
re
j'ai une autre solution à vous proposer
en général on déplace une fenêtre à la main avec la souris appuyé sur sa barre de titre
j'ai repris mon hook pour le scroll des controls liste et adapté à la circonstance
avec cette fois si l'utilisation de 3 messages de la souris
  1. le mouse down
  2. le mousemove
  3. le mouseup
on a ainsi deux pseudo event manuallayout et stomanuallayout

j'ai mis deux bouton pour démarrer et arrêter l’écoute
je fourni le fichier


demo1.gif


c'est vite fait comme ca a peaufiner bien sur
 

Pièces jointes

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Dudu2
  • Résolu(e)
XL 2016 VBA - Comment savoir si un Handle de Window est celui d'une Window Excel
Réponses
10
Affichages
166
Dudu2
Dudu2
Dudu2
VBA - Obtenir les coordonnées exactes de la plage visible d'une fenêtre Excel
Réponses
0
Affichages
51
Dudu2
Dudu2
Dudu2
  • Résolu(e)
XL 2016 VBA - Question complexe ! Activer la Feuille ou le UserForm selon la position du curseur de la souris
Réponses
5
Affichages
891
Dranreb
Dranreb
L
  • Résolu(e)
XL 2016 Comment détecter si mail envoyé
2
Réponses
26
Affichages
2 K
Staple1600
Staple1600
Dudu2
  • Résolu(e)
XL 2016 VBA - Comment passer une structure Private en argument d'une fonction ?
2 3 4
Réponses
55
Affichages
1 K
Dudu2
Dudu2
C
  • Question Question
XL 2016 VBA Détecter la suppression de la dernière ligne d'un Tableau
Réponses
9
Affichages
511
crocrocro
C
C
Clin d’œil de fin d’année : Palme d’Or du Festival XLD
Réponses
2
Affichages
259
jurassic pork
jurassic pork
G
  • Question Question
XL 2016 Demande de conseils VBA : de la fenêtre unique (XL 2010) au multifenêtres (XL 2016)
Réponses
0
Affichages
532
Guy_M
G
A
  • Question Question
XL 2021 Automatiser la génération de documents Word à partir d’Excel avec VBA
Réponses
12
Affichages
269
ali591
A
Dudu2
  • Question Question
XL 2016 VBA - Une manière rapide de trouver les cellules verrouillées ?
9 10 11
Réponses
152
Affichages
5 K
Dudu2
Dudu2
PHV.FSM
  • Question Question
XL 2016 Calculer la position sur l'écran d'une position sur la grille (XL 2003)
2
Réponses
27
Affichages
3 K
Nicolas JACQUIN
Nicolas JACQUIN
T
  • Résolu(e)
Microsoft 365 Chercher si dans une plage de cellule la valeur d'une autre cellule est présente
Réponses
4
Affichages
332
TomJoad
T
I
  • Question Question
XL 2019 (RESOLU) Date de dernière modification d'une plage de cellule
Réponses
3
Affichages
1 K
patricktoulon
patricktoulon
O
  • Question Question
XL 2019 Code VBA pour automatiser la programmation des rotations des ouvriers qui travaillent à temps partiel et se relaient par période de temps constante.
2 3
Réponses
35
Affichages
2 K
olivier1984
O
N
  • Question Question
Microsoft 365 Liste déroulante (combobox) en fonction d'une séquence de valeurs
Réponses
13
Affichages
574
Neofalken
N
RyuAutodidacte
  • Résolu(e)
Microsoft 365 Obtenir par formule/champs nommés … ? la valeur d'une cellule de la feuille active que récupère une feuille non active … possible ? (sans vba)
2
Réponses
18
Affichages
1 K
RyuAutodidacte
RyuAutodidacte
Etoto
  • Résolu(e)
Microsoft 365 Code VBA qui renvoie une matrice à partir d'un liste à cocher au lieu d'une cellule
Réponses
5
Affichages
892
yal
Y
S
  • Résolu(e)
XL 2019 code vba changement de couleur si modification de la cellule
Réponses
7
Affichages
2 K
syriak
S
S
  • Question Question
XL 2016 Cellule change de couleur si la valeur existe dans une autre cellule d'un autre onglet
Réponses
12
Affichages
1 K
sum01
S
E
  • Résolu(e)
Microsoft 365 Conception d'un outils alliant faciliter d'utilisation et optimisation de la RAM/Processeur/Espace Disque
Réponses
6
Affichages
709
elgringo123456
E
Retour