Sub Test()
    Dim ExistOLEObj As OLEObject
    With ThisWorkbook.ActiveSheet
        For Each ExistOLEObj In .OLEObjects
            Debug.Print ExistOLEObj.Name
        Next
    End With
End Sub

Option Explicit

Sub Proba()
    Dim RngVis As Range
    Dim PosLeftObj As Integer, PosTopObj As Integer, WDTHObj As Integer, HGHTObj As Integer
    
    'Определяем объект Range, представляющий видимый диапазон клиентской области книги Excel
    Set RngVis = Application.ActiveWindow.VisibleRange
    'Считываем из него необходимые координаты и размеры в пунктах для определения стартовых координат и размера UserForm, которая заполнит виlимую область клиентской части рабочей книги
    With RngVis
        PosLeftObj = .Cells(1, 1).Left
        PosTopObj = .Cells(1, 1).Top
        WDTHObj = .Cells(.Rows.Count, .Columns.Count).Left + .Cells(.Rows.Count, .Columns.Count).Width - PosLeftObj
        HGHTObj = .Cells(.Rows.Count, .Columns.Count).Top + .Cells(.Rows.Count, .Columns.Count).Height - PosTopObj
    End With
    MyForm.Left = PosLeftObj
    MyForm.Top = PosTopObj
    MyForm.Width = WDTHObj
    MyForm.Height = HGHTObj
    MyForm.Show
End Sub

Option Explicit

Sub Res()
    MsgBox "Макрос скопирован и работает"
End Sub

Option Explicit

Private Const OCR_NORMAL As Long = 32512
Private Const IDC_APPSTARTING As Long = 32650
Private Const IMAGE_CURSOR As Long = 2
Private Const PathCursor As String = "c:\Windows\Cursors\"
Private Const GenNameMacros As String = "Res"

#If VBA7 Then
    'Функция копирования текущего значка указателя курсора мыши
    Private Declare PtrSafe Function CopyCursor Lib "user32" Alias "CopyIcon" (ByVal hcur As LongPtr) As LongPtr
    'Функция создания значка указателя курсора мыши на основе данных из файла, к которому обращается функция
    Private Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As LongPtr
    'Функция извлечения дескриптора (ручки) текущего курсора
    Private Declare PtrSafe Function GetCursor Lib "user32" () As LongPtr
    'Функция настройки системного курсора. Заменяет содержимое системного курсора, определенного параметром ID содержимым курсора, определенным его дескриптором (ручкой)
    Private Declare PtrSafe Function SetSystemCursor Lib "user32" (ByVal hcur As LongPtr, ByVal id As Long) As Long
    'Функция считывания положения курсора в указанных координаты экрана (результат в пикселях)
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    'Функция извлечения дескриптора (ручки) интересуемого окна
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal ClassName As String, ByVal WindowName As String) As LongPtr
    'Функция считывания информации об интересуемом окне
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    'Функция изменения атрибутов интересуемого окна
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    'Функция регулирования прозрачности окна
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
    'Функция подавления визуализации окна стороннего задействуемого в коде приложения другого приложения
    Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As LongPtr) As Long
    
    'Переменные, используемые для преобразования вспомогательной формы в прозрачную
    Private hwnd As LongPtr
    Private lStyle As LongPtr
    'Объявляем 3 переменные
    Private NewCur As LongPtr, OldCursor As LongPtr, VBEHwnd As LongPtr
    'Определяем файл, соответствующий виду конечного курсора мыши
    Private Const NameFileCurEnd As String = "aero_arrow.cur"
    'Определяем файл, соответствующий виду промежуточного курсора мыши
    Private Const NameFileCurTMP As String = "lperson.cur"
#Else
    Private Declare Function CopyCursor Lib "user32" Alias "CopyIcon" (ByVal hcur As Long) As Long
    Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpMyFileName As String) As Long
    Private Declare Function GetCursor Lib "user32" () As Long
    Private Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal ClassName As String, ByVal WindowName As String) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
    Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
    
    Private hwnd As Long
    Private lStyle As Long
    Private NewCur As Long, OldCursor As Long, VBEHwnd As Long
    Private Const NameFileCurEnd As String = "arrow_l.cur"
    Private Const NameFileCurTMP As String = "handapst.ani"
    
#End If

'Тип данных - координаты курсора в пунктах
Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private pntPos As POINTAPI

'Значение константы пересчета значения в пунктах в значение в пикселях
Private Const PNTINPX As Single = 1.3281472327365
'Значение константы пересчета значения в пикселях в значение в пунктах
Private Const PXINPNT As Single = 0.75292857248934

'Константы, используемые для преобразования вспомогательной формы в прозрачную
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Const GWL_EXSTYLE = &HFFEC

Private Sub UserForm_Click()
    Dim ButtonOLEObj As OLEObject, LeftPos As Integer, TopPos As Integer
    Dim lLineNum As Long
    'Переменные значении смещения координат объектов клиентской области относительно координат окна приложения
    Dim SHFTX As Long, SHFTY As Long
    
    'Определяем координаты (в пикселях) смещения расположения первой ячейки клиентской области относительно координат окна приложения
    SHFTX = ActiveWindow.PointsToScreenPixelsX(0)
    SHFTY = ActiveWindow.PointsToScreenPixelsY(0)
    'Считываем координаты (в пикселях) текущего положения указателя мыши
    GetCursorPos pntPos
    'Определяем координаты (в пунктах) расположения добавляемого объекта ActiveX
    If Round((pntPos.X - SHFTX) * PXINPNT) - 20 <= 0 Then
        LeftPos = 0
    Else
        LeftPos = Round((pntPos.X - SHFTX) * PXINPNT) - 20
    End If
    If Round((pntPos.Y - SHFTY) * PXINPNT) - 20 <= 0 Then
        TopPos = 0
    Else
        TopPos = Round((pntPos.Y - SHFTY) * PXINPNT) - 20
    End If
    'Добавляем в лист дополнительный объект ActiveX (кнопку)
    Set ButtonOLEObj = ActiveWorkbook.ActiveSheet.OLEObjects.Add( _
        ClassType:="Forms.CommandButton.1", _
        DisplayAsIcon:=False, _
        Left:=LeftPos, _
        Top:=TopPos, _
        Width:=40, _
        Height:=40 _
    )
    With ButtonOLEObj
        .Object.Caption = ""
        'Вставляем в добавленный в активный лист объект ActiveX изображение и центрируем ее относительно размера объекта
        If Dir(ThisWorkbook.Path & "\Smiling face.jpg") <> "" Then .Object.Picture = LoadPicture(ThisWorkbook.Path & "\Smiling face.jpg")
        .Object.PicturePosition = fmPicturePositionCenter
    End With
    'Активируем ячейку активного листа, которая включает в свой размер левую и верхнюю координату добавленного объекта ActiveX
    ActiveWorkbook.ActiveSheet.Range(ButtonOLEObj.TopLeftCell.Address).Select
    'Отключаем переключение на окно VBAProject
    On Error GoTo ErrH:
    Application.VBE.MainWindow.Visible = False
    VBEHwnd = FindWindow("wndclass_desked_gsk", Application.VBE.MainWindow.Caption)
    If VBEHwnd Then
        LockWindowUpdate VBEHwnd
    End If
    'Вызываем функцию проверки наличия в активной книге необходимых модулей, требуемых для корректного срабатывания события Click добавленного объекта ActiveX ButtonOLEObj
    'и копирования этих модулей в активную книгу при их отсутствии
    Dim RunReplace As Boolean, Res As Integer, TextErr As String, NumbErr As Integer
    'Функции передан аргумент, определяющий, требуется ли замена содержимого модуля, предназначенного для вставки в активную книгу, при его обнаружении в активной книге
    RunReplace = False
    Res = CopyVBComponent("ModuleRun", "", ThisWorkbook, ActiveWorkbook, RunReplace)
    'Если необходимый модуль обнаружен в активной книге
    If Res = 0 Or Res = 1 Then
        'Определяем количество заполненных строк в интересуемом модуле
        lLineNum = ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.ActiveSheet.Name).CodeModule.CountOfLines + 1
        'Для нового добавленного объекта ActiveX создаем событие Click
        With ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.ActiveSheet.Name).CodeModule
            lLineNum = .CreateEventProc("Click", ButtonOLEObj.Name)
            lLineNum = lLineNum + 1
            .InsertLines lLineNum, GenNameMacros
        End With
    'Если в процессе выполнения функции произошла ошибка
    Else
        Select Case NumbErr
            Case 2
                TextErr = "Код ошибки 2: в книге исполняемого кода " & ThisWorkbook.Name & " не обнаружен проект VBA"
            Case 3
                TextErr = "Код ошибки 3: книга с исполняемым кодом " & ThisWorkbook.Name & " запаролирована"
            Case 4
                TextErr = "Код ошибки 4: Активная книга не содержит проект VBA"
            Case 5
                TextErr = "Код ошибки 5: проект VBA активной книги запаролирован"
            Case 6
                TextErr = "Код ошибки 6: не задано/неверно задано имя копируемого модуля"
            Case 7
                TextErr = "Код ошибки 7: в книге исполняемого кода не обнаружен заданный модуль"
            Case 8
                TextErr = "Код ошибки 8: ошибка удаления экспортированного файла модуля из временной папки"
            Case 9
                TextErr = "Код ошибки 9: неизвестная ошибка"
        End Select
        MsgBox "В процессе выполнения произошла ошибка на этапе модификации данных VBAProject" & Chr(13) & _
                TextErr, vbInformation + vbOKOnly, "Ошибка"
        'Удаляем добавленный объект ActiveX
        ButtonOLEObj.Delete
    End If
    Application.VBE.MainWindow.Visible = False
    'Устанавливаем форму стандартного системного курсора
    If Dir(PathCursor & NameFileCurEnd) <> "" Then
        NewCur = LoadCursorFromFile(PathCursor & NameFileCurEnd)
        SetSystemCursor NewCur, OCR_NORMAL
    End If
ErrH:
    LockWindowUpdate 0&
    Unload Me
End Sub

Private Sub UserForm_Initialize()
'    'Запоминаем прежний курсор и загружаем свой
'    OldCursor = GetCursor()
'    OldCursor = CopyCursor(OldCursor)
    If Dir(PathCursor & NameFileCurTMP, vbNormal) <> "" Then
        NewCur = LoadCursorFromFile(PathCursor & NameFileCurTMP)
        SetSystemCursor NewCur, OCR_NORMAL
    End If
    'Устанавливаем окно формы полностью прозрачным
    hwnd = FindWindow(vbNullString, Me.Caption)
    lStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
    SetWindowLong hwnd, GWL_EXSTYLE, lStyle Or WS_EX_LAYERED
    SetLayeredWindowAttributes hwnd, 0, 2.55, LWA_ALPHA
End Sub

'Функция копирования компонента VBAProject из одной книги в другую
'Параметры функции:
'wbFromFrom - Книга, компонент из VBA-проекта которой необходимо копировать
'wbFromTo - Книга, в VBA-проект которой необходимо копировать компонент
'sModuleName - Имя модуля, который необходимо копировать
'sModuleToName - Имя модуля, в который необходимо копировать
'bOverwriteExistModule: Если True или 1, то при наличии в конечной книге компонента с именем sModuleName - он будет удален, а вместо него импортирован копируемый
                        'Если False, то при наличии в конечной книге компонента с именем sModuleName сам компонент не будет скопирован в VBAProject конечной книги
'Возвращаемые значения: 0 - Модуль успешно добавлен в VBAProject конечной (активной) книги;
                        '1 - интересуемый модуль обнаружен в конечной книге и его принудительная замена не требуется
                        'Ошибки, выявленные в ходе выполнения функции, не позволяющие дальнейшее ее корректное выполнение
                        '2 - в книге, из которой копируем, нет проекта VBA
                        '3 - в книге, из которой копируем, для проекта VBA установлен пароль
                        '4 - в книге, в которую копируем, нет проекта VBA
                        '5 - в книге, в которую копируем, для проекта VBA установлен пароль
                        '6 - не задано/неверно задано имя копируемого модуля
                        '7 - в книге, из которой копируем, не найден заданный модуль
                        '8 - ошибка удаления экспортированного файла модуля из временной папки
                        '9 - неизвестная ошибка
Private Function CopyVBComponent(sModuleName As String, ByVal sModuleToName As String, wbFromFrom As Workbook, wbFromTo As Workbook, bOverwriteExistModule As Boolean) As Integer

    Dim objVBProjFrom As Object, objVBProjTo As Object
    Dim objVBComp As Object, objTmpVBComp As Object
    Dim sTmpFolderPath As String, sVBCompName As String, sModuleCode As String
    
    'Проверяем корректность указанных параметров
    On Error Resume Next
    Set objVBProjFrom = wbFromFrom.VBProject
    Set objVBProjTo = wbFromTo.VBProject
    
    'если в книге, из которой копируем, нет проекта VBA
    If objVBProjFrom Is Nothing Then
        CopyVBComponent = 2: Exit Function
    End If
    'если в книге, из которой копируем, для проекта VBA установлен пароль
    If objVBProjFrom.Protection = 1 Then
        CopyVBComponent = 3: Exit Function
    End If
    
    'если в книге, в которую копируем, нет проекта VBA
    If objVBProjTo Is Nothing Then
        CopyVBComponent = 4: Exit Function
    End If
    'если в книге, в которую копируем, для проекта VBA установлен пароль
    If objVBProjTo.Protection = 1 Then
        CopyVBComponent = 5: Exit Function
    End If
    
    'если не задано имя копируемого модуля
    If Trim(sModuleName) = "" Then
        CopyVBComponent = 6: Exit Function
    End If
    'если не задано имя модуля для вставки кода, используем имя копируемого
    If Trim(sModuleToName) = "" Then
        sModuleToName = sModuleName
    End If
    
    'проверяем, существует ли в книге, из которой копируем, заданный модуль
    Set objVBComp = objVBProjFrom.VBComponents(sModuleName)
    'модуля нет, выходим из функции
    If objVBComp Is Nothing Then
        CopyVBComponent = 7: Exit Function
    End If
    
    'полный путь для экспорта/импорта модуля. К папке должен быть доступ на запись/чтение
    sTmpFolderPath = Environ("Temp") & "\" & sModuleToName & ".bas" '"
    'Если bOverwriteExistModule = True (принудительная замена модуля в конечной книге на новую версию), удаляем из временной папки и из конечного проекта модуль с указанным именем
    If bOverwriteExistModule Then
        'удаляем файл модуля из временной папки
        If Dir(sTmpFolderPath, 6) <> "" Then
            Err.Clear
            Kill sTmpFolderPath
            'удалить не удалось, модуль не сохранен. Выход из функции
            If Err.Number <> 0 Then
                CopyVBComponent = 8: Exit Function
            End If
        End If
        'удаляем модуль из конечной книги
        With objVBProjTo.VBComponents
            Set objVBComp = Nothing
            Set objVBComp = .Item(sModuleToName)
            'только если это не модуль листа или книги(их можно только очистить, но не удалять)
            If objVBComp.Type <> 100 Then
                .Remove .Item(sModuleToName)
            End If
        End With
    'Если установлен параметр bOverwriteExistModule, обозначающий, что принудительное обновление содержимого интересуемого модуля не требуется
    Else
        Err.Clear
        Set objVBComp = objVBProjTo.VBComponents(sModuleToName)
        'Если интересуемого модуля в конечной книге не обнаружено
        If Err.Number <> 0 Then
            'Err.Number 9 - отсутствие указанного компонента, что нам не мешает.
            'Если ошибка другая - выход из функции
            If Err.Number <> 9 Then
                CopyVBComponent = 9: Exit Function
            End If
        'если интересуемый модуль в конечной книге обнаружен
        Else
            CopyVBComponent = 1: Exit Function
        End If
    End If
    
    'Экспорт/Импорт компонента во временную директорию
    objVBProjFrom.VBComponents(sModuleName).Export sTmpFolderPath
    'копируем
    Set objVBComp = Nothing
    Set objVBComp = objVBProjTo.VBComponents(sModuleToName)
    If objVBComp Is Nothing Then
        objVBProjTo.VBComponents.Import sTmpFolderPath
    Else
        'Если компонент - модуль листа или книги, его нельзя удалить. Поэтому удаляем из него весь код и добавляем код из копируемого компонента
        If objVBComp.Type = 100 Then
            'для простоты обращения в коде делаем ссылку на копируемый модуль
            Set objTmpVBComp = objVBProjFrom.VBComponents(sModuleName)
            'копируем из него код
             With objVBComp.CodeModule
                .DeleteLines 1, .CountOfLines
                sModuleCode = objTmpVBComp.CodeModule.Lines(1, objTmpVBComp.CodeModule.CountOfLines)
                .InsertLines 1, sModuleCode
            End With
        End If
    End If
    'удаляем временный файл компонента
    Kill sTmpFolderPath
    CopyVBComponent = 0
End Function

Sub Proba()
    Dim I As Integer, EistOLEObj As OLEObject
    I = 1
    'Определяем количество имеющихся на активном листе объектов ActiveX
    With ThisWorkbook.ActiveSheet
        For Each EistOLEObj In .OLEObjects
            I = I + 1
        Next
        'Добавляем на лист дополнительный объект ActiveX Image
        .OLEObjects.Add ClassType:="Forms.Image.1", _
                        DisplayAsIcon:=False, _
                        Left:=0, _
                        Top:=0, _
                        Width:=175, _
                        Height:=320
        'Переопределяем имя добавленного объекта для последующего удобства обращения к нему
        .OLEObjects(I).Name = "TempImage"
        'Устанавливаем свойства объекту, чтобы он был невиден пользвателю
        With .OLEObjects("TempImage")
            .Object.BackStyle = fmBackStyleTransparent
            .Object.BorderStyle = fmBorderStyleNone
        End With
    End With
End Sub

Option Explicit

Private Const OCR_NORMAL As Long = 32512
#If VBA7 Then
    'Загружаем функции для просмотра курсора
    Private Declare PtrSafe Function CopyCursor Lib "user32" Alias "CopyIcon" (ByVal hcur As LongPtr) As LongPtr
    Private Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As LongPtr
    Private Declare PtrSafe Function GetCursor Lib "user32" () As LongPtr
    Private Declare PtrSafe Function SetSystemCursor Lib "user32" (ByVal hcur As LongPtr, ByVal id As Long) As Long
    Public Declare PtrSafe Function DestroyCursor Lib "user32" (ByVal hcur As LongPtr) As Long
#Else
    'Загружаем функции для просмотра курсора
    Private Declare Function CopyCursor Lib "user32" Alias "CopyIcon" (ByVal hcur As Long) As Long
    Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpMyFileName As String) As Long
    Private Declare Function GetCursor Lib "user32" () As Long
    Private Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long
    Public Declare PtrSafe Function DestroyCursor Lib "user32" (ByVal hcur As Long) As Long

#End If
'Объявляем 2 переменные
Public NewCur As LongPtr, OldCursor As LongPtr



Sub Солнце1_Щелчок()
'Пишем откуда мы берем новый курсор
NewCur = LoadCursorFromFile(ActiveWorkbook.Path & "\Cursor.cur")
'Запоминаем прежний курсор и загружаем свой
'OldCursor = GetCursor()
'OldCursor = CopyCursor(OldCursor)
SetSystemCursor NewCur, OCR_NORMAL
End Sub

Sub Улыбающеесялицо3_Щелчок()
'Пишем откуда мы берем новый курсор
NewCur = LoadCursorFromFile(ActiveWorkbook.Path & "\check.cur")
'Запоминаем прежний курсор и загружаем свой
'OldCursor = GetCursor()
'OldCursor = CopyCursor(OldCursor)
SetSystemCursor NewCur, OCR_NORMAL
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    DestroyCursor NewCur
End Sub

Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As LongPtr
Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As LongPtr) As LongPtr

Sub proba()
Dim hCursor As LongPtr

hCursor = LoadCursorFromFile("C:\WINDOWS\Cursors\aero_link_il.cur")
If hCursor = 0 Then End
SetCursor hCursor
End Sub 

Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As LongPtr) As Long

Sub proba()
Dim hCursor As Long

hCursor = LoadCursorFromFile("C:\WINDOWS\Cursors\aero_link_il.cur")
If hCursor = 0 Then End
SetCursor hCursor
End Sub 

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

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

Option Explicit

Private Declare PtrSafe Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
 
Private mlnghWnd As LongPtr
 
Public Property Get hWnd() As LongPtr
    hWnd = mlnghWnd
End Property
 

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