fork download 
  1. Option Explicit
  2.  
  3.  
  4.  
  5. Private Type POINTAPI
  6.  
  7.     X As Long
  8.  
  9.     Y As Long
  10.  
  11. End Type
  12.  
  13. Private Type RECT
  14.  
  15.     Left As Long
  16.  
  17.     Top As Long
  18.  
  19.     Right As Long
  20.  
  21.     Bottom As Long
  22.  
  23. End Type
  24.  
  25. Private Type MOUSEHOOKSTRUCT
  26.  
  27.     pt As POINTAPI
  28.  
  29.     hwnd As Long
  30.  
  31.     wHitTestCode As Long
  32.  
  33.     dwExtraInfo As Long
  34.  
  35. End Type
  36.  
  37.  
  38.  
  39. Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
  40.  
  41. Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
  42.  
  43. Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
  44.  
  45. Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
  46.  
  47. Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  48.  
  49. Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  50.  
  51. Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
  52.  
  53. Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
  54.  
  55. Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  56.  
  57. Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As Long
  58.  
  59. Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  60.  
  61. Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
  62.  
  63.  
  64.  
  65. Private Const WH_MOUSE_LL As Long = 14
  66.  
  67. Private Const WM_MOUSEWHEEL As Long = &H20A
  68.  
  69. Private Const HC_ACTION As Long = 0
  70.  
  71. Private Const POINTSPERINCH As Long = 72
  72.  
  73. Private Const LOGPIXELSX As Long = 88
  74.  
  75. Private Const LOGPIXELSY As Long = 90
  76.  
  77. Private Const SCROLL_CHANGE As Long = 5
  78.  
  79.  
  80.  
  81. Private lMouseHook As Long
  82.  
  83. Private lFormHwnd As Long
  84.  
  85. Private bHookIsSet As Boolean
  86.  
  87. Private oScrollableObject As Object
  88.  
  89.  
  90.  
  91.  
  92.  
  93. Public Sub SetScrollHook(ByVal ScrollableObject As Object)
  94.  
  95.     If Not (IsObjectUserForm(ScrollableObject) Or TypeName(ScrollableObject) = "Frame") Then Exit Sub
  96.  
  97.     Set oScrollableObject = ScrollableObject
  98.  
  99.     lFormHwnd = GetActiveWindow
  100.  
  101.     With ScrollableObject
  102.  
  103.         .ScrollBars = fmScrollBarsBoth
  104.  
  105.         .KeepScrollBarsVisible = fmScrollBarsBoth
  106.  
  107.         .PictureAlignment = fmPictureAlignmentTopLeft
  108.  
  109.         ' Adjust the values of the scroll width and height properties as required
  110.  
  111.         .ScrollWidth = ScrollableObject.InsideWidth * 3
  112.  
  113.         .ScrollHeight = ScrollableObject.InsideHeight * 2
  114.  
  115.     End With
  116.  
  117.     If Not bHookIsSet Then
  118.  
  119.         lMouseHook = SetWindowsHookEx( _
  120.  
  121.         WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
  122.  
  123.         bHookIsSet = lMouseHook <> 0
  124.  
  125.     End If
  126.  
  127. End Sub
  128.  
  129.  
  130.  
  131. Public Sub RemoveScrollHook(Optional ByVal Dummy As Boolean)
  132.  
  133.     If bHookIsSet Then
  134.  
  135.         UnhookWindowsHookEx lMouseHook
  136.  
  137.         lMouseHook = 0
  138.  
  139.         bHookIsSet = False
  140.  
  141.     End If
  142.  
  143. End Sub
  144.  
  145.  
  146.  
  147. Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long
  148.  
  149.  
  150.  
  151.     Dim tTopLeft As POINTAPI
  152.  
  153.     Dim tBottomRight As POINTAPI
  154.  
  155.     Dim tRect As RECT
  156.  
  157.  
  158.  
  159.     GetClientRect lFormHwnd, tRect
  160.  
  161.     With oScrollableObject
  162.  
  163.         If IsObjectUserForm(oScrollableObject) Then
  164.  
  165.             tTopLeft.X = tRect.Left
  166.  
  167.             tTopLeft.Y = tRect.Top
  168.  
  169.             tBottomRight.X = tRect.Right
  170.  
  171.             tBottomRight.Y = tRect.Bottom
  172.  
  173.         Else
  174.  
  175.             tTopLeft.X = PTtoPX(.Left, False) + tRect.Left
  176.  
  177.             tTopLeft.Y = PTtoPX(.Top, True) + tRect.Top
  178.  
  179.             tBottomRight.X = PTtoPX(.Left + .Width, False) + tRect.Left
  180.  
  181.             tBottomRight.Y = PTtoPX(.Top + .Height, True) + tRect.Top
  182.  
  183.         End If
  184.  
  185.     End With
  186.  
  187.     ClientToScreen lFormHwnd, tTopLeft
  188.  
  189.     ClientToScreen lFormHwnd, tBottomRight
  190.  
  191.     SetRect tRect, tTopLeft.X, tTopLeft.Y, tBottomRight.X, tBottomRight.Y
  192.  
  193.     On Error GoTo errH
  194.  
  195.     If (nCode = HC_ACTION) And CBool(PtInRect(tRect, lParam.pt.X, lParam.pt.Y)) Then
  196.  
  197.         If wParam = WM_MOUSEWHEEL Then
  198.  
  199.             With oScrollableObject
  200.  
  201.                 Select Case GetAsyncKeyState(VBA.vbKeyControl)
  202.  
  203.                     Case Is = 0 'vertical scroll
  204.  
  205.                         If lParam.hwnd > 0 Then
  206.  
  207.                             .ScrollTop = Application.Max(0, .ScrollTop - SCROLL_CHANGE)
  208.  
  209.                         Else
  210.  
  211.                             .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE)
  212.  
  213.                         End If
  214.  
  215.                     Case Else ' horiz scroll when the Ctl key down
  216.  
  217.                         If lParam.hwnd > 0 Then
  218.  
  219.                             .ScrollLeft = Application.Max(0, .ScrollLeft - SCROLL_CHANGE)
  220.  
  221.                         Else
  222.  
  223.                             .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE)
  224.  
  225.                         End If
  226.  
  227.                 End Select
  228.  
  229.             End With
  230.  
  231.         End If
  232.  
  233.     End If
  234.  
  235.     MouseProc = CallNextHookEx( _
  236.  
  237.     lMouseHook, nCode, wParam, ByVal lParam)
  238.  
  239.     Exit Function
  240.  
  241. errH:
  242.  
  243.     RemoveScrollHook
  244.  
  245. End Function
  246.  
  247.  
  248.  
  249. Private Function ScreenDPI(bVert As Boolean) As Long
  250.  
  251.     Static lDPI(1), lDC
  252.  
  253.     If lDPI(0) = 0 Then
  254.  
  255.         lDC = GetDC(0)
  256.  
  257.         lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
  258.  
  259.         lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
  260.  
  261.         lDC = ReleaseDC(0, lDC)
  262.  
  263.     End If
  264.  
  265.     ScreenDPI = lDPI(Abs(bVert))
  266.  
  267. End Function
  268.  
  269.  
  270.  
  271. Private Function PTtoPX _
  272.  
  273. (Points As Single, bVert As Boolean) As Long
  274.  
  275.     PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
  276.  
  277. End Function
  278.  
  279.  
  280.  
  281. Private Function IsObjectUserForm(ByVal obj As Object) As Boolean
  282.  
  283.     Dim oTemp As Object
  284.  
  285.     On Error Resume Next
  286.  
  287.         Set oTemp = obj.Parent
  288.  
  289.         Set oTemp = Nothing
  290.  
  291.         IsObjectUserForm = Err.Number = 438
  292.  
  293.     On Error GoTo 0
  294.  
  295. End Function
  296.  
  297.  
Compilation error #stdin compilation error #stdout 0s 0KB
comments (?)
stdin 
Standard input is empty
compilation info 
Main.java:1: error: class, interface, or enum expected
Option Explicit
^
Main.java:109: error: unclosed character literal
        ' Adjust the values of the scroll width and height properties as required
        ^
Main.java:203: error: unclosed character literal
                    Case Is = 0 'vertical scroll
                                ^
Main.java:215: error: unclosed character literal
                    Case Else ' horiz scroll when the Ctl key down
                              ^
4 errors
stdout 
Standard output is empty
https://ideone.com/wbDBoR
language:
Java (HotSpot 12)
created:
2 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!