Prevent Extreme Zoom Out. Mouse Wheel Event?

[ryguy7272]

I posted this question a couple of days ago. I didn’t get a response, and
wanted to put this question back at the 'top of the list'. Basically, I am
trying to come up with a way of preventing a user from zooming out too far.
Is there a way to limit the user to say 30% of zoom. I have this:


If ActiveWindow.Zoom <= 30 Then
ActiveWindow.Zoom = 40
MsgBox("Already Zoomed Out as Far as Possible", _
vbOKCancel, "Max. Zoom")
End If

Somehow, the event has to be fired by a mouse wheel event (I believe that’s
what it is called). I’ve done quite a bit of research on this and all I can
come up with is some ways of doing this in Access, but not in Excel. Does
anyone know of a way to control the mouse wheel event in Excel?

Thanks,
Ryan---

 

[dmoney]

I found this info on another site - hth

http://www.andreavb.com/tip060008.html

dmoney

 

[ryguy7272]

Thanks dmoney; looks like a good resource, but seems to be much more focused
on VB than VBA for Excel. I modified the code slightly, and am now working
with this:

Option Explicit

'API
Private Declare Function CallWindowProc Lib "user32.dll" Alias
"CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias
"SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

'Constants
Public Const MK_CONTROL = &H8
Public Const MK_LBUTTON = &H1
Public Const MK_RBUTTON = &H2
Public Const MK_MBUTTON = &H10
Public Const MK_SHIFT = &H4
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A

'Variables
Private hControl As Long
Private lPrevWndProc As Long

Private Function WindowProc(ByVal lWnd As Long, ByVal lMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

If lMsg = WM_MOUSEWHEEL Then
Screen.ActiveSheet.MouseWheelRolled
End If

If lMsg <> WM_MOUSEWHEEL Then
WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam, lParam)
End If
End Function

Public Sub Hook(ByVal hControl_ As Long)
hControl = hControl_
lPrevWndProc = SetWindowLong(hControl, GWL_WNDPROC, AddrOf("WindowProc"))
End Sub

Public Sub UnHook()
Call SetWindowLong(hControl, GWL_WNDPROC, lPrevWndProc)
End Sub

Public Sub MouseWheelRolled()
Call Worksheet_Change
End Sub

In Sheet1 Module I have this:
Private Sub Worksheet_Change(ByVal Target As Range)
If ActiveWindow.Zoom <= 30 Then
ActiveWindow.Zoom = 40
MsgBox "Already Zoomed Out as Far as Possible", _
vbOKCancel, "Max. Zoom"
End If
End Sub


The macro does not fire when I hold the Ctrl key and move the mouse wheel to
zoom out. What am I doing wrong?

Thanks,
Ryan---