' Функции управления буфером
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
     (ByVal uFormat As Integer) As Integer
Private Declare Function apiOpenClipboard Lib "user32" Alias "OpenClipboard" _
     (ByVal hWnd As Long) As Integer
Private Declare Function apiSetClipboardData Lib "user32" Alias "SetClipboardData" _
     (ByVal uFormat As Integer, _
      ByVal hData As Long) As Long
Private Declare Function apiGetClipboardData Lib "user32" Alias "GetClipboardData" _
     (ByVal uFormat As Integer) As Long
Private Declare Function apiCloseClipboard Lib "user32" Alias "CloseClipboard" _
     () As Integer
Private Declare Function apiEmptyClipboard Lib "user32" Alias "EmptyClipboard" _
     () As Integer

' Функции управления памятью
Private Declare Function apiGlobalAlloc Lib "kernel32" Alias "GlobalAlloc" _
     (ByVal uFlags As Integer, _
      ByVal dwBytes As Long) As Long
Private Declare Function apiGlobalSize Lib "kernel32" Alias "GlobalSize" _
     (ByVal hMem As Long) As Integer
Private Declare Function apiGlobalLock Lib "kernel32" Alias "GlobalLock" _
     (ByVal hMem As Long) As Long
Private Declare Sub apiMoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
     (ByVal strDest As Any, _
      ByVal lpSource As Any, _
      ByVal Length As Long)
Private Declare Function apiGlobalUnlock Lib "kernel32" Alias "GlobalUnlock" _
     (ByVal hMem As Long) As Integer
Private Declare Function apiGlobalFree Lib "kernel32" Alias "GlobalFree" _
     (ByVal hMem As Long) As Long

' api-Константы памяти
Private Const GMEM_FIXED = &H0
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_NOCOMPACT = &H10
Private Const GMEM_NODISCARD = &H20
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MODIFY = &H80
Private Const GMEM_DISCARDABLE = &H100
Private Const GMEM_NOT_BANKED = &H1000
Private Const GMEM_SHARE = &H2000
Private Const GMEM_DDESHARE = &H2000
Private Const GMEM_NOTIFY = &H4000
Private Const GMEM_LOWER = GMEM_NOT_BANKED
Private Const GMEM_VALID_FLAGS = &H7F72
Private Const GMEM_INVALID_HANDLE = &H8000
Private Const GMEM_TEXT = (GMEM_MOVEABLE Or GMEM_DDESHARE)

' api-Форматы буфера
Private Const CF_TEXT =  1 
Private Const CF_BITMAP =  2 
Private Const CF_METAFILEPICT =  3 
Private Const CF_SYLK =  4 
Private Const CF_DIF =  5 
Private Const CF_TIFF =  6 
Private Const CF_OEMTEXT =  7 
Private Const CF_DIB =  8 
Private Const CF_PALETTE =  9 
Private Const CF_PENDATA =  10 
Private Const CF_RIFF =  11 
Private Const CF_WAVE =  12 
Private Const CF_UNICODETEXT =  13 
Private Const CF_ENHMETAFILE =  14 

'==============================================================
'  Копируем текст в буфер
'
Function CopyText(strText As String) As Variant
Dim hMem As Long
Dim lpMem As Long
Dim l As Long

     ' Выделение памяти
     l = Len(strText) +  1  ' Длина строки с учетом символа \0 (c++)
     hMem = apiGlobalAlloc(GMEM_TEXT, l) ' Память для буфера
     
     ' Управление памятью
     lpMem = apiGlobalLock(hMem) ' Блокируем часть памяти
     Call apiMoveMemory(lpMem, strText, l) ' Копируем строку в память
     Call apiGlobalUnlock(hMem) ' Разблокируем память
     
     ' Управление буфером
     Call apiOpenClipboard( 0 &) ' Открываем буфер
     Call apiEmptyClipboard ' Очищаем буфер
     Call apiSetClipboardData(CF_TEXT, hMem) ' Загружаем текст
     Call apiCloseClipboard ' Закрываем буфер
     
     ' Освобождаем память
     Call apiGlobalFree(hMem)
End Function

'==============================================================
'  Получаем текст из буфера
'
Public Function GetText() As Variant
Dim hMem As Long
Dim lpMem As Long
Dim s As String
Dim l As Long

     ' Проверяем формат буфера
     If Not CBool(IsClipboardFormatAvailable(CF_TEXT)) Then
         Exit Function
     End If
    
     ' Работаем с буфером и памятью
     Call apiOpenClipboard( 0 &) ' Открываем буфер
     hMem = apiGetClipboardData(CF_TEXT) ' Получаем заголовок данных в буфере
     l = apiGlobalSize(hMem) ' Определяем размер строки
     s = Space$(l) ' Выделение памяти для строки
     lpMem = apiGlobalLock(hMem) ' Блокируем память
     Call apiMoveMemory(s, lpMem, l) ' Копируем информацию из буфера в строку
     Call apiGlobalUnlock(hMem) ' Разблокирование памяти
     Call apiCloseClipboard ' Закрываем буфер
     
     ' Возвращаем результат
     GetText = Left$(s, InStr( 1 , s, Chr$( 0 )) -  1 )
     
End Function

В модуле
Option Compare Database

Private Declare PtrSafe Function ActivateKeyboardLayout Lib "user32" _
                                        (ByVal HKL As LongPtr, ByVal flags As Long) As LongPtr
Private Declare PtrSafe Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" _
                                        (ByVal pwszKLID As String) As Long
                                        
Public KeyBoard As String

Dim X As LongPtr
Dim kb_lay_ru As LongPtr
Dim kb_lay_en As LongPtr

Public Sub SetRussianLayout()
    X = ActivateKeyboardLayout(kb_lay_ru,  0 )
End Sub

Public Sub SetEnglishLayout()
    X = ActivateKeyboardLayout(kb_lay_en,  0 )
End Sub
Public Sub KeyboardLayout()
 
    Dim KeybLayoutName As String
    Dim KeyboardLayout As String
    KeybLayoutName = String( 9 ,  0 )
    GetKeyboardLayoutName KeybLayoutName
        If CLng(Left$(KeybLayoutName, InStr( 1 , KeybLayoutName, Chr( 0 )) -  1 )) =  409  Then
            KeyBoard = "LAT"
        Else: KeyBoard = "RUS"
        End If

End Sub
Public Sub ChangeLayout()
    ActivateKeyboardLayout  0 ,  0 
End Sub

Вызов

Private Sub Form_Timer()
    Call KeyboardLayout
    Me![keyb].Caption = KeyBoard
End Sub

Private Sub keyb_Click()

    If Me![keyb].Caption = "LAT" Then
        Call SetRussianLayout
    End If
    
        If Me![keyb].Caption = "RUS" Then
            Call SetEnglishLayout
        End If
End Sub

Option Compare Database
Option Explicit

Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                            (ByVal hwnd As LongPtr, ByVal lpOperation As String, _
                            ByVal lpFile As String, ByVal lpParameters As String, _
                            ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr

Public Const SW_SHOWMAXIMIZED =  3 
Public Const SW_SHOWDEFAULT =  10 
Public Const SW_SHOWNOACTIVATE =  4 
Public Const SW_SHOWNORMAL =  1 


Function StartOfFile(strNameFile As String)
    Dim intResult As Boolean
    Dim vTaskID
    intResult = ShellExecute(Application.hWndAccessApp, "open", strNameFile,  0 ,  0 , SW_SHOWNORMAL)
        If intResult =  31  Then
'            Select Case MsgBox("     Файл с таким расширением не зарегистрирован!" _
'                    & Chr(13) & "Желаете открыть его выбрав самостоятельно программу?" _
'                    & vbCrLf & _
'                        "", vbYesNo + vbExclamation, "ВНИМАНИЕ")
'                    Case vbNo
'                        Exit Sub
'                    Case vbYes
'                        GoTo calc
'                    End Select
'calc:
            vTaskID = Shell("rundll32.exe shell32.dll, OpenAs_RunDLL strNameFile", vbNormalFocus) ' Вызов окна выбора программы для открытия файла с незарегистированным расширением
        End If
End Function

вызов

StartOfFile "Put'"

'Win API позволяющая задать прозрачность окна
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
                                (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long

Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
                                (ByVal hwnd As LongPtr, ByVal nIndex As Long, _
                                ByVal dwNewLong As Long) As Long

Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" _
                                (ByVal hwnd As Long, ByVal crKey As Long, _
                                ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
   


Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Private Const GWL_EXSTYLE = (- 20 )
Private Const WS_EX_LAYERED = &H80000

' Layered - степень прозрачности 0-255
' Примечание: форма должна быть всплывающей
Public Sub TransparentForm(hWnd As Long, Layered As Byte)
    Dim ret As Long
    ret = GetWindowLong(hWnd, GWL_EXSTYLE)
    ret = ret Or WS_EX_LAYERED
    SetWindowLong hWnd, GWL_EXSTYLE, ret
    SetLayeredWindowAttributes hWnd,  0 , Layered, LWA_ALPHA
End Sub

в модуле:

Option Compare Database
Option Explicit

Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
                                                       (ByVal lpFile As String, _
                                                        ByVal lpDirectory As String, _
                                                        ByVal lpResult As String) As Long

Public Sub OpenPDF(FileName As Variant, Optional GoToPage As Long =  1 )
' FileName - Полный путь к PDF файлу
' GoToPage - номер страницы на которую надо перейти

On Error GoTo ErrHandler
  
  Dim Error282Count As Integer  ' Количество ошибок "Can't open DDE channel"
  Dim AcroDDEFailed As Boolean  ' Кстанавливается в true если не удалось установить DDE соединение
  Dim strCmd As String          ' DDE команда
  Dim lStatus As Long           ' Ответ команды ShellExecute
  Const Max282Errors =  6         ' Количество попыток установить DDE соединение, перед тем как будет решено
                                ' что Acrobat Reader не удалось запустить.
                                ' Возможно, что число потребуется изменить для конкретного компьютера
  Dim strAcroPath As String     ' Путь к acrobat, определяемый FindExecutable
  Dim lngChanel As Long
  
  Error282Count = Max282Errors '' Количество повторов установить DDE канал
  AcroDDEFailed = False        '' ErrHandler will set to true if Acro is not running
  

'создаем DDE канал
lngChanel = DDEInitiate("acroview", "control")
  ' если возникла ошибка пробуем запустить Acrobat
  If AcroDDEFailed = True Then
   
    ' С помощью FindExecutable пробуем получить путь к программе работы с PDF.
    ' Это может быть Acrobat Reader или Acrobat
    
    strAcroPath = String( 128 ,  32 )
    lStatus = FindExecutable(FileName, vbNullString, strAcroPath)
    If lStatus <=  32  Then
      MsgBox "Не найден Acrobat Reader. Открытие файла отменено.", vbCritical, "Ошибка"
      Exit Sub
    End If

    lStatus = Shell(strAcroPath, vbNormalFocus)
    If (lStatus >=  0 ) And (lStatus <=  32 ) Then
      MsgBox "Ошибка при запуске Acrobat Reader. Открытие файла отменено", vbCritical, "Ошибка"
      Exit Sub
    End If
   
  End If
  
  PauseFor  2   '' Ждем пока загрузится Acrobat
  Error282Count =  0        'Счетчик ошибок в 0
  AcroDDEFailed = False   '' Acrobat запустился, но может быть еще занят загрузкой файла
 
 'создаем DDE канал
 lngChanel = DDEInitiate("acroview", "control")

  If AcroDDEFailed = True Then
    MsgBox "Ошибка соединения с Acrobat. Открытие файла Отменено", vbCritical, "Ошибка"
    Exit Sub
  End If
 strCmd = "[DocOpen(" & Chr( 34 ) & FileName & Chr( 34 ) & ")]"
 strCmd = strCmd & "[FileOpen(" & Chr( 34 ) & FileName & Chr( 34 ) & ")]"
 strCmd = strCmd & "[DocGoTo(" & Chr( 34 ) & FileName & Chr( 34 ) & "," & GoToPage -  1  & ")]"
' теоретически здесь вместо DocGoTo можно использовать DocGoToNameDest с указанием
' имени закладки, но практически не пробовал
 
DDEExecute lngChanel, strCmd
   
  'Закрываем все DDE
 DDETerminateAll
Exit Sub

ErrHandler:
  If Err.Number =  282  Then 'Невозможно открыть DDE канал
    ' Эта ошибка может возникать когда Acrobat загрузился не польностью
    ' делаем Max282Errors попыток перед тем как вернуть AcroDDEFailed = True
    Error282Count = Error282Count +  1 
    If Error282Count <= Max282Errors Then
      PauseFor  3 
      Resume
    Else
      AcroDDEFailed = True
      Resume Next
    End If
  End If
  
  MsgBox "Error in OpenPDF sub Error# " & Err.Number & " " & Err.Description & "."
End Sub

'вспомогательная функция
Private Sub PauseFor(iSeconds As Integer)
'Пауза iSecond секунд
  Dim sngTimer As Single
  
  sngTimer = Timer
  While Timer - sngTimer < iSeconds
    DoEvents
  Wend

End Sub

Вызов

    Call OpenPDF("N:\Ojournal\Задания\BCFESDE8.pdf",  7 )

Модуль modSubclsWndProc:

Option Explicit
Option Private Module


Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function GetProp Lib "user32" Alias "GetPropA" ( _
   ByVal hWnd As Long, ByVal lpString As String) As Long


Public Function SubclsWndPtrPropName() As String
 SubclsWndPtrPropName = "ISubclassedWindowPtr"
End Function

Public Function ISubclassedWindow(Wnd As Object) As ISubclassedWindow
 Set ISubclassedWindow = Wnd
End Function

Public Function SubclsWndProc( _
   ByVal hWnd As Long, ByVal uMessage As Long, _
   ByVal wParam As Long, ByVal lParam As Long) As Long
 Dim pSubclsWnd As Long
 Dim SubclsWnd As ISubclassedWindow
 pSubclsWnd = GetProp(hWnd, SubclsWndPtrPropName)
 CopyMemory SubclsWnd, pSubclsWnd,  4 
 SubclsWndProc = SubclsWnd.Procedure(hWnd, uMessage, wParam, lParam)
 CopyMemory SubclsWnd,  0 &,  4 
End Function

Класс CMouseWheelEventTracker:

Option Compare Database
Option Explicit


Implements ISubclassedWindow


Private Enum BOOL
   BOOL_FALSE =  0 
   BOOL_TRUE =  1 
End Enum

Private Declare Function SetProp Lib "user32" Alias "SetPropA" ( _
   ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As BOOL
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" ( _
   ByVal hWnd As Long, ByVal lpString As String) As Long

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
   ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, _
   ByVal wParam As Long, ByVal lParam As Long) As Long

Private Enum GetWindowLongIndex
   GWL_WNDPROC = - 4 &
   GWL_HINSTANCE = - 6 &
   GWL_HWNDPARENT = - 8 &
   GWL_ID = - 12 &
   GWL_STYLE = - 16 &
   GWL_EXSTYLE = - 20 &
   GWL_USERDATA = - 21 &
End Enum
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
   ByVal hWnd As Long, ByVal nIndex As GetWindowLongIndex) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
   ByVal hWnd As Long, ByVal nIndex As GetWindowLongIndex, _
   ByVal dwNewLong As Long) As Long

Private Declare Function GetDC Lib "user32" ( _
   ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
   ByVal hWnd As Long, ByVal hDC As Long) As Long

Private Enum DeviceCapability
   LOGPIXELSX =  88         '  Logical pixels/inch in X
   LOGPIXELSY =  90         '  Logical pixels/inch in Y
End Enum
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nIndex As DeviceCapability) As Long

Private Type POINTAPI
   X As Long
   Y As Long
End Type
Private Declare Function ScreenToClient Lib "user32" ( _
   ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Private Declare Function GetKeyState Lib "user32" ( _
   ByVal vKey As Long) As Integer


Private Enum MouseKeys
   MK_LBUTTON = &H1
   MK_RBUTTON = &H2
   MK_SHIFT = &H4
   MK_CONTROL = &H8
   MK_MBUTTON = &H10
End Enum

Public Enum WheelDeltaConst
   WHEEL_DELTA =  120 
End Enum

Private Const WM_MOUSEWHEEL As Long = &H20A&


Public Event MouseWheel(ByVal Button As Integer, ByVal Shift As Integer, _
                        ByVal X As Single, ByVal Y As Single, _
                        ByVal Delta As Integer, Cancel As Boolean)


Private m_hWnd As Long
Private m_pfnOldWndProc As Long
Private m_SubclassHelper As CSubclassHelper

Private Type TLong
   Lng As Long
End Type

Private Type TDWord
   LowWord As Integer
   HighWord As Integer
End Type

Private Const TWIPS_PER_INCH =  1440 &


Private Sub Unsubclass()
 If m_hWnd Then
    SetWindowLong m_hWnd, GWL_WNDPROC, m_pfnOldWndProc
    RemoveProp m_hWnd, SubclsWndPtrPropName
    m_pfnOldWndProc =  0 
    Set m_SubclassHelper = Nothing
    m_hWnd =  0 
 End If
End Sub

Private Sub Subclass(ByVal hWnd As Long)
 Dim SubclassedMe As ISubclassedWindow
 Unsubclass
 If hWnd Then
    Set SubclassedMe = Me
    If SetProp(hWnd, SubclsWndPtrPropName, ObjPtr(SubclassedMe)) Then
       m_pfnOldWndProc = GetWindowLong(hWnd, GWL_WNDPROC)
       Set m_SubclassHelper = New CSubclassHelper
       With m_SubclassHelper
          .Add WM_MOUSEWHEEL, AddressOf SubclsWndProc
          .DefWndProcAddr = m_pfnOldWndProc
          SetWindowLong hWnd, GWL_WNDPROC, .WndProcAddr
       End With
       m_hWnd = hWnd
    End If
 End If
End Sub


Public Property Get hWnd() As Long
 hWnd = m_hWnd
End Property

Public Property Let hWnd(ByVal Handle As Long)
 If m_hWnd <> Handle Then Subclass Handle
End Property


Private Function LOWORD(ByVal dwParam As Long) As Integer
 'LOWORD = dwParam And &HFFFF& Or CLng(CBool(dwParam And &H8000&)) And &HFFFF0000
 Dim tmpL As TLong, tmpDW As TDWord
 tmpL.Lng = dwParam
 LSet tmpDW = tmpL
 LOWORD = tmpDW.LowWord
End Function

Private Function HIWORD(ByVal dwParam As Long) As Integer
 'HIWORD = dwParam \ &H10000
 Dim tmpL As TLong, tmpDW As TDWord
 tmpL.Lng = dwParam
 LSet tmpDW = tmpL
 HIWORD = tmpDW.HighWord
End Function

Private Function GET_X_LPARAM(ByVal lParam As Long) As Long
 GET_X_LPARAM = LOWORD(lParam)
End Function

Private Function GET_Y_LPARAM(ByVal lParam As Long) As Long
 GET_Y_LPARAM = HIWORD(lParam)
End Function


Private Function ISubclassedWindow_Procedure( _
   ByVal hWnd As Long, ByVal uMessage As Long, _
   ByVal wParam As Long, ByVal lParam As Long) As Long
 Dim hDC As Long
 Dim ptClient As POINTAPI
 Dim X As Single, Y As Single
 Dim Button As Integer
 Dim Shift As Integer
 Dim Cancel As Boolean
 
 ptClient.X = GET_X_LPARAM(lParam)
 ptClient.Y = GET_Y_LPARAM(lParam)
 ScreenToClient hWnd, ptClient
 hDC = GetDC(hWnd)
 X = ptClient.X * (TWIPS_PER_INCH \ GetDeviceCaps(hDC, LOGPIXELSX))
 Y = ptClient.Y * (TWIPS_PER_INCH \ GetDeviceCaps(hDC, LOGPIXELSY))
 ReleaseDC hWnd, hDC
 
 Shift = LOWORD(wParam)
 Button = acLeftButton And CBool(Shift And MK_LBUTTON) Or _
          acRightButton And CBool(Shift And MK_RBUTTON) Or _
          acMiddleButton And CBool(Shift And MK_MBUTTON)
 Shift = acShiftMask And CBool(Shift And MK_SHIFT) Or _
         acCtrlMask And CBool(Shift And MK_CONTROL) Or _
         acAltMask And CBool(GetKeyState(vbKeyMenu) And &H8000)
 'Debug.Print Hex$(hWnd), Hex$(uMessage), Hex$(wParam), Button, Shift, X, Y
 
 RaiseEvent MouseWheel(Button, Shift, X, Y, HIWORD(wParam), Cancel)
 
 If Cancel Then
    ISubclassedWindow_Procedure =  0 
 Else
    ISubclassedWindow_Procedure = CallWindowProc(m_pfnOldWndProc, hWnd, _
                                                 uMessage, wParam, lParam)
 End If
End Function


Private Sub Class_Terminate()
 Unsubclass
End Sub

Класс CSubclassHelper:

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function GetModuleHandle Lib "kernel32" _
   Alias "GetModuleHandleA" ( _
   ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
   ByVal hModule As Long, ByVal lpProcName As String) As Long


Private Type TMsgFilterData
   nCount As Long
   puMessages As Long
   ppfnHandlers As Long
   pfnCallWindowProc As Long
End Type

Private Type TThunk
   OpCodes( 0  To  127 ) As Byte
End Type

Private Type TLocalDataAndCode
   Data As TMsgFilterData
   Code As TThunk
End Type

Private Const COUNT_INIT =  16 
Private Const COUNT_ADD =  16 

Private m_uMessages() As Long
Private m_pfnHandlers() As Long
Private m_DnC As TLocalDataAndCode
Private m_pfnDefHandler As Long


Private Sub Class_Initialize()
 Dim i As Long, j As Long
 Const OFS_L1 =  5 
 Const OFS_L3 =  96 
 m_DnC.Data.pfnCallWindowProc = GetProcAddress(GetModuleHandle("USER32"), _
                                               "CallWindowProcA")
 With m_DnC.Code
    j = UBound(.OpCodes)
    For i =  0  To j
       .OpCodes(i) = &H90  'nop
    Next i
    
    .OpCodes( 0 ) = &HE8  'e8 60 00 00 00   call  GetEIP
    .OpCodes( 1 ) = OFS_L3 - OFS_L1
    .OpCodes( 2 ) = &H0
    .OpCodes( 3 ) = &H0
    .OpCodes( 4 ) = &H0

    .OpCodes(OFS_L1) = &H53  '53          push ebx
    
    .OpCodes( 6 ) = &H8D  '8d 58 f0         lea ebx, DWORD PTR [eax-16]
    .OpCodes( 7 ) = &H58
    .OpCodes( 8 ) =  256  - (VarPtr(m_DnC.Code) - VarPtr(m_DnC.Data))

    .OpCodes( 9 ) = &H8B  '8b 44 24 0c      mov eax, DWORD PTR [esp+12]   //uMsg
    .OpCodes( 10 ) = &H44
    .OpCodes( 11 ) = &H24
    .OpCodes( 12 ) = &HC

    .OpCodes( 13 ) = &H57 '57               push edi

    .OpCodes( 14 ) = &H8B '8b 7b 04         mov edi, DWORD PTR [ebx+4]   //pMsgList->puMsgs
    .OpCodes( 15 ) = &H7B
    .OpCodes( 16 ) = VarPtr(m_DnC.Data.puMessages) - VarPtr(m_DnC.Data)

    .OpCodes( 17 ) = &H56 '56               push esi

    .OpCodes( 18 ) = &H8B '8b f7            mov esi, edi
    .OpCodes( 19 ) = &HF7

    .OpCodes( 20 ) = &H8B '8b 0b            mov ecx, DWORD PTR [ebx]     //pMsgList->nCount
    .OpCodes( 21 ) = &HB
    
    .OpCodes( 22 ) = &H9C '9c               pushfd
    
    .OpCodes( 23 ) = &HFC 'fc               cld

    .OpCodes( 24 ) = &HF2 'f2 af            repne scasd
    .OpCodes( 25 ) = &HAF
    
    .OpCodes( 26 ) = &HB8 'b8 00 00 00 00   mov eax, 0
    .OpCodes( 27 ) = &H0
    .OpCodes( 28 ) = &H0
    .OpCodes( 29 ) = &H0
    .OpCodes( 30 ) = &H0
    
    .OpCodes( 31 ) = &HF  '0f 94 c0         sete al
    .OpCodes( 32 ) = &H94
    .OpCodes( 33 ) = &HC0
    
    .OpCodes( 34 ) = &H8D '8d 34 86         lea esi, DWORD PTR [esi+eax*4]
    .OpCodes( 35 ) = &H34
    .OpCodes( 36 ) = &H86
    
    .OpCodes( 37 ) = &H2B '2b fe            sub edi, esi
    .OpCodes( 38 ) = &HFE

    .OpCodes( 39 ) = &H9D '9d               popfd

    .OpCodes( 40 ) = &H5E '5e               pop esi

    .OpCodes( 41 ) = &H8B '8b 43 08         mov eax, DWORD PTR [ebx+8]   //pMsgList->ppfnHandlers
    .OpCodes( 42 ) = &H43
    .OpCodes( 43 ) = VarPtr(m_DnC.Data.ppfnHandlers) - VarPtr(m_DnC.Data)

    .OpCodes( 44 ) = &H8B '8b 04 38         mov eax, DWORD PTR [eax+edi]
    .OpCodes( 45 ) = &H4
    .OpCodes( 46 ) = &H38
    
    .OpCodes( 47 ) = &H5F '5f               pop edi
    
    .OpCodes( 48 ) = &H8B '8b 4b 0c         mov  ecx, DWORD PTR [ebx+12] //pMsgList->pfnCallWindowProc
    .OpCodes( 49 ) = &H4B
    .OpCodes( 50 ) = VarPtr(m_DnC.Data.pfnCallWindowProc) - VarPtr(m_DnC.Data)

    .OpCodes( 51 ) = &H5B '5b               pop ebx
    
    .OpCodes( 52 ) = &H8D '8d 64 24 ec      lea  esp, DWORD PTR [esp-20]
    .OpCodes( 53 ) = &H64
    .OpCodes( 54 ) = &H24
    .OpCodes( 55 ) = &HEC
    
    .OpCodes( 56 ) = &H89 '89 04 24         mov  DWORD PTR [esp], eax
    .OpCodes( 57 ) = &H4
    .OpCodes( 58 ) = &H24
    
    .OpCodes( 59 ) = &H8B '8b 44 24 24      mov  eax, DWORD PTR [esp+36] //lParam
    .OpCodes( 60 ) = &H44
    .OpCodes( 61 ) = &H24
    .OpCodes( 62 ) = &H24
    
    .OpCodes( 63 ) = &H89 '89 44 24 10      mov  DWORD PTR [esp+16], eax
    .OpCodes( 64 ) = &H44
    .OpCodes( 65 ) = &H24
    .OpCodes( 66 ) = &H10
    
    .OpCodes( 67 ) = &H8B '8b 44 24 20      mov  eax, DWORD PTR [esp+32] //wParam
    .OpCodes( 68 ) = &H44
    .OpCodes( 69 ) = &H24
    .OpCodes( 70 ) = &H20
    
    .OpCodes( 71 ) = &H89 '89 44 24 0c      mov  DWORD PTR [esp+12], eax
    .OpCodes( 72 ) = &H44
    .OpCodes( 73 ) = &H24
    .OpCodes( 74 ) = &HC
    
    .OpCodes( 75 ) = &H8B '8b 44 24 1c      mov  eax, DWORD PTR [esp+28] //uMsg
    .OpCodes( 76 ) = &H44
    .OpCodes( 77 ) = &H24
    .OpCodes( 78 ) = &H1C
    
    .OpCodes( 79 ) = &H89 '89 44 24 08      mov  DWORD PTR [esp+8], eax
    .OpCodes( 80 ) = &H44
    .OpCodes( 81 ) = &H24
    .OpCodes( 82 ) = &H8
    
    .OpCodes( 83 ) = &H8B '8b 44 24 18      mov  eax, DWORD PTR [esp+24] //hWnd
    .OpCodes( 84 ) = &H44
    .OpCodes( 85 ) = &H24
    .OpCodes( 86 ) = &H18
    
    .OpCodes( 87 ) = &H89 '89 44 24 04      mov  DWORD PTR [esp+4], eax
    .OpCodes( 88 ) = &H44
    .OpCodes( 89 ) = &H24
    .OpCodes( 90 ) = &H4
    
    .OpCodes( 91 ) = &HFF 'ff d1            call  ecx
    .OpCodes( 92 ) = &HD1
    
    .OpCodes( 93 ) = &HC2 'c2 14 00         ret  20
    .OpCodes( 94 ) = &H14
    .OpCodes( 95 ) = &H0
    
'GetEIP:
    .OpCodes(OFS_L3 +  0 ) = &H8B '8b 04 24  mov  eax, DWORD PTR [esp]
    .OpCodes(OFS_L3 +  1 ) = &H4
    .OpCodes(OFS_L3 +  2 ) = &H24

    .OpCodes(OFS_L3 +  3 ) = &H8D '8d 40 fb  lea  eax, DWORD PTR [eax-5]
    .OpCodes(OFS_L3 +  4 ) = &H40
    .OpCodes(OFS_L3 +  5 ) = &HFB

    .OpCodes(OFS_L3 +  6 ) = &HC3 'c3   ret  0
 End With
End Sub

Private Function Find(ByVal uMsg As Long) As Long
 Dim i As Long, j As Long
 j = m_DnC.Data.nCount -  1 
 For i =  0  To j
    If m_uMessages(i) = uMsg Then
       Find = i
       Exit Function
    End If
 Next i
 Find = - 1 
End Function

Public Function Add(ByVal uMsg As Long, ByVal pfnHandler As Long) As Long
 Dim i As Long
 With m_DnC.Data
    If .nCount =  0  Then
       If pfnHandler <>  0  Then
          ReDim m_uMessages( 0  To COUNT_INIT -  1 ) As Long
          ReDim m_pfnHandlers( 0  To COUNT_INIT) As Long
          m_uMessages( 0 ) = uMsg
          m_pfnHandlers( 0 ) = pfnHandler
          m_pfnHandlers( 1 ) = m_pfnDefHandler
          .puMessages = VarPtr(m_uMessages( 0 ))
          .ppfnHandlers = VarPtr(m_pfnHandlers( 0 ))
          .nCount =  1 
       '   Add = 1
       'Else
       '   Add = 0
       End If
    Else
       If pfnHandler <>  0  Then
          i = Find(uMsg)
          If i >=  0  Then
             m_pfnHandlers(i) = pfnHandler
          Else
             i = UBound(m_uMessages)
             If .nCount > i Then
                ReDim Preserve m_uMessages( 0  To i + COUNT_ADD) As Long
                ReDim Preserve m_pfnHandlers( 0  To i + COUNT_ADD +  1 ) As Long
                .puMessages = VarPtr(m_uMessages( 0 ))
                .ppfnHandlers = VarPtr(m_pfnHandlers( 0 ))
             End If
             m_uMessages(.nCount) = uMsg
             m_pfnHandlers(.nCount) = pfnHandler
             .nCount = .nCount +  1 
             m_pfnHandlers(.nCount) = m_pfnDefHandler
          End If
       'Else
       '   Add = 0
       End If
    End If
    Add = .nCount
 End With
End Function

Public Function Remove(ByVal uMsg As Long) As Long
 Dim i As Long, j As Long
 With m_DnC.Data
    If .nCount >  0  Then
       i = Find(uMsg)
       If i >=  0  Then
          If .nCount >  1  Then
             .nCount = .nCount -  1 
             j = (.nCount - i) *  4 
             CopyMemory m_uMessages(i), m_uMessages(i +  1 ), j
             m_uMessages(.nCount) =  0 
             CopyMemory m_pfnHandlers(i), m_pfnHandlers(i +  1 ), j +  4 
          Else
             Clear
          End If
       End If
    End If
    Remove = .nCount
 End With
End Function

Public Sub Clear()
 With m_DnC.Data
    If .nCount >  0  Then
       .nCount =  0 
       .puMessages =  0 
       .ppfnHandlers =  0 
       Erase m_uMessages
       Erase m_pfnHandlers
    End If
 End With
End Sub

Public Property Get WndProcAddr() As Long
 If m_pfnDefHandler And (m_DnC.Data.nCount >  0 ) Then _
    WndProcAddr = VarPtr(m_DnC.Code)
End Property

Public Property Get DefWndProcAddr() As Long
 DefWndProcAddr = m_pfnDefHandler
End Property

Public Property Let DefWndProcAddr(ByVal pfnDefHandler As Long)
 If pfnDefHandler Then
    With m_DnC.Data
       If .nCount >  0  Then m_pfnHandlers(.nCount) = pfnDefHandler
    End With
    m_pfnDefHandler = pfnDefHandler
 End If
End Property


Public Property Get Count() As Long
 Count = m_DnC.Data.nCount
End Property

Класс ISubclassedWindow:

Option Explicit

Public Function Procedure( _
   ByVal hWnd As Long, ByVal uMessage As Long, _
   ByVal wParam As Long, ByVal lParam As Long) As Long

End Function

В форме:

Option Compare Database
Option Explicit

Dim WithEvents mwet As CMouseWheelEventTracker

Private Sub CB_BlockWheel_Click()
 Set mwet = New CMouseWheelEventTracker
 mwet.hWnd = hWnd

 CB_UnblockWheel.Enabled = True
 CB_UnblockWheel.SetFocus
 CB_BlockWheel.Enabled = False
End Sub

Private Sub CB_UnblockWheel_Click()
 Set mwet = Nothing

 CB_BlockWheel.Enabled = True
 CB_BlockWheel.SetFocus
 CB_UnblockWheel.Enabled = False
End Sub

Private Sub mwet_MouseWheel(ByVal Button As Integer, ByVal Shift As Integer, _
                            ByVal X As Single, ByVal Y As Single, _
                            ByVal Delta As Integer, Cancel As Boolean)
 'Debug.Print Button, Shift, X, Y, Delta / WHEEL_DELTA, Cancel
 Cancel = True
End Sub

Option Compare Database

Private Declare PtrSafe Function ShowWindow Lib "user32" _
                    (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long

Const SW_HIDE =  0 
Const SW_SHOWNORMAL =  1 
Const SW_NORMAL =  1 
Const SW_SHOWMINIMIZED =  2 
Const SW_SHOWMAXIMIZED =  3 
Const SW_MAXIMIZE =  3 
Const SW_SHOWNOACTIVATE =  4 
Const SW_SHOW =  5 
Const SW_MINIMIZE =  6 
Const SW_SHOWMINNOACTIVE =  7 
Const SW_SHOWNA =  8 
Const SW_RESTORE =  9 
Const SW_SHOWDEFAULT =  10 
Const SW_MAX =  10 

Function min() ' Функция сворачивания
    Dim loX  As Long
    nCmdShow = SW_SHOWMINNOACTIVE
    loX = ShowWindow(hWndAccessApp, nCmdShow)
End Function

вызов:

call min

Создать модуль класса CloseCommand:

Option Compare Database
Option Explicit

Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, _
   ByVal bRevert As Long) As Long

Private Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As _
   Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long

Private Declare Function GetMenuItemInfo Lib "user32" Alias _
   "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As _
   Long, lpMenuItemInfo As MENUITEMINFO) As Long

Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

Const MF_GRAYED = &H1&
Const MF_BYCOMMAND = &H0&
Const SC_CLOSE = &HF060&



Public Property Get Enabled() As Boolean
    Dim hwnd As Long
    Dim hMenu As Long
    Dim result As Long
    Dim MI As MENUITEMINFO
    
    MI.cbSize = Len(MI)
    MI.dwTypeData = String(80, 0)
    MI.cch = Len(MI.dwTypeData)
    MI.fMask = MF_GRAYED
    MI.wID = SC_CLOSE
    hwnd = Application.hWndAccessApp
    hMenu = GetSystemMenu(hwnd, 0)
    result = GetMenuItemInfo(hMenu, MI.wID, 0, MI)
    Enabled = (MI.fState And MF_GRAYED) = 0
End Property

Public Property Let Enabled(boolClose As Boolean)
    Dim hwnd As Long
    Dim wFlags As Long
    Dim hMenu As Long
    Dim result As Long
    
    hwnd = Application.hWndAccessApp
    hMenu = GetSystemMenu(hwnd, 0)
    If Not boolClose Then
        wFlags = MF_BYCOMMAND Or MF_GRAYED
    Else
        wFlags = MF_BYCOMMAND And Not MF_GRAYED
    End If
    result = EnableMenuItem(hMenu, SC_CLOSE, wFlags)
End Property


На открытие приложения запускать процедуру

Public Function fnCloseNo()
   Dim c As CloseCommand
   Set c = New CloseCommand
   
   c.Enabled = False   'передача значения модулю класса "CloseCommand"
   Exit Function
End Function