powered by simpleCommunicator - 2.0.36     © 2025 Programmizd 02
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Изменение свойств Controls UserForm на экране при перемещении пользователем мыши по экрану
1 сообщений из 1, страница 1 из 1
Изменение свойств Controls UserForm на экране при перемещении пользователем мыши по экрану
    #40072116
Chula
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Здравствуйте!

Никак не могу найти ошибку в своем коде в силу недостаточности уровня знаний в понимании правил использования обратного вызова с использованием API функций.
Начнем по порядку.
Итак, есть задача - изменять для визуальной наглядности пользователю состояние свойств объектов (Controls) загруженной и выведенной на экран формы (UserForm) при перемещении пользователем мыши по экрану окна.
Возьмем для простоты простейшую форму, содержащую объект Image.
Желаемое:
Если пользователь навел курсор мыши на форму (курсор мыши внутри координат формы), то фон Image зеленый.
Если пользователь перевел курсор мыши за пределы координат формы , то фон Image становится красный.
Все это я пытаюсь реализовать в 64-bit операционной системе с установленной версией Office, использующего 64-разрядную версию VBA.
Создавая различного рода запросы в поисковике для решения своей задачи я выяснил, что в помощь мне функция API TRACKMOUSEEVENT.
И даже нашел практический пример по ссылке: http://rusproject.narod.ru/winapi/t/trackmouseevent.html
Изучив его, я понял, что мне его необходимо адаптировать в свою операционную среду.
И тут снова мне в помощь пришел найденный справочный материал: https://codekabinett.com/rdumps.php?Lang=2&targetDoc=windows-api-declaration-vba-64-bit
Изучив на его основании типы аргументов необходимых мне API функций, я адаптировал их декларацию под версию VBA 64-bit.
При проверке компиляции кода в среде VBA.Project все хорошо.
Однако результат выполнения кода не дает нужного результата.
Более того, при пошаговом выполнении наблюдается серьезный сбой, когда приложение Excel просто перезагружается или даже закрывается.
И это происходит именно на этапе обращения к функции обратного вызова.
Теперь конкретно о коде.

Вот код основного модуля
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
Option Explicit

Public Const WM_MOUSELEAVE As Long = &H2A3&
Public Declare PtrSafe Function TRACKMOUSEEVENT Lib "user32" Alias "TrackMouseEvent" ( _
          lpEventTrack As TRACKMOUSEEVENT) As Long

Public Type TRACKMOUSEEVENT
    cbSize As Long
    dwFlags As Long
    hwndTrack As LongPtr
    dwHoverTime As Long
End Type

Public Const TME_LEAVE As Long = &H2

Public Declare PtrSafe Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr

Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

Private Const GWLP_WNDPROC = (-4)
Dim PrevProc As LongPtr
Public Track As TRACKMOUSEEVENT
Public NoRecursForm As Boolean

Public Sub Hook(ByVal frmHWnd As LongPtr)
    PrevProc = SetWindowLong(frmHWnd, GWLP_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnHook(ByVal frmHWnd As LongPtr)
    SetWindowLong frmHWnd, GWLP_WNDPROC, PrevProc
End Sub

Public Function WindowProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    
    If uMsg = WM_MOUSELEAVE Then

        If UserForm1.Image1.BackColor = vbGreen Then
           UserForm1.Image1.BackColor = vbRed
        Else
           UserForm1.Image1.BackColor = vbGreen
        End If
        
    End If
    
    WindowProc = CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)
End Function

Sub Example()
    Load UserForm1
    UserForm1.Show
End Sub



В процедуре Hook основного модуля используется параметр дескриптора окна пользовательской формы frmHwnd .
Я знаю, что у UserForm и его Controls нет свойства hwnd , поэтому мне опять же в помощь пришел справочный материал: https://colinlegg.wordpress.com/2016/05/06/getting-a-handle-on-userforms-vba/, изучив который я научился считывать дескриптор пользовательской формы.

Соответственно, код класса оговоренной для примера формы приобрел следующий вид:
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
Private Sub UserForm_Initialize()
   StorehWnd
   Hook Me.hWnd
   With Track
       .cbSize = Len(Track)
       .dwFlags = TME_LEAVE
       .hwndTrack = Me.hWnd
       .dwHoverTime = 400
   End With
End Sub
 
Private Sub StorehWnd()
 
    Dim strCaption As String
    Dim strClass As String
 
    'class name changed in Office 2000
    If Val(Application.Version) >= 9 Then
        strClass = "ThunderDFrame"
    Else
        strClass = "ThunderXFrame"
    End If
 
    'remember the caption so we can
    'restore it when we're done
    strCaption = Me.Caption
 
    'give the userform a random
    'unique caption so we can reliably
    'get a handle to its window
    Randomize
    Me.Caption = CStr(Rnd)
 
    'store the handle so we can use
    'it for the userform's lifetime
    mlnghWnd = FindWindowA(strClass, Me.Caption)
 
    'set the caption back again
    Me.Caption = strCaption
 
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    TRACKMOUSEEVENT Track
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    UnHook Me.hWnd
End Sub


Однако, не работает(
При пошаговом исполнении при обращении к функции WindowProc , я заметил, что параметр uMsg вообще даже близко не сопоставляется с установленной константой WM_MOUSELEAVE .
При этом происходит рекурсивное обращение к указанной функции, параметр uMsg меняется каждый раз, а после раза 4-5 рекурсивного вызова, приложение просто перезапускается или выгружается.

Уважаемые знатоки темы, подскажите, где у меня ошибка и/или чего мне не хватает (кроме ума и знаний, тут понятно, шутки будут неуместны).
...
Рейтинг: 0 / 0
1 сообщений из 1, страница 1 из 1
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Изменение свойств Controls UserForm на экране при перемещении пользователем мыши по экрану
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]