Detecting the resizing of Excel's application window.

[Legacy 98055]

<table border="1" bgcolor="White"><caption ALIGN=left><font size="2" face=Courier New>Example VBA Code:</FONT></caption><tr><td><font size="2" face=Courier New>  <font color="#0000A0">Private</font> <font color="#0000A0">Sub</font> Workbook_WindowResize(ByVal Wn <font color="#0000A0">As</font> Window)
  
  <font color="#0000A0">End</font> <font color="#0000A0">Sub</font>
  
</FONT></td></tr></table>
works fine for workbook windows. Does anybody have any suggestions for the main application window.

Thanks a lot.

Tom

 

[XLGibbs]

Hi Tom,

While not exactly sure how to pull it off, I believe you can create a class module and refer the Application itself by declaring a public variable as "Application" and setting the object = Application.

If it is using Public WithEvents and using a class module to handle those events, I suppose it is possible. Again, not sure exactly how to pull it off, but will see if I can! Sounds like an interesting challenge to say the least.

 

[Legacy 98055]

Hi XLGibbs. I tried that with hope but no good. Only resizing workbook windows were firing the procedure.

Thanks though.

Tom

 

[XLGibbs]

Yeah, me too. Although everything I am readng keeps telling me that setting the class reference to the current instance of the Application will trap events.....I was also unsuccessful. Interestingly, any events set within the class fire for every workbook open during the active instance.

I know it is easier to trap this from a regular VB program than from the excel instance itself.

 

[Jaafar Tribak]

Sorry to raise this old thread back from the dead but i've been working on a project where i needed such functionality and here is what i've come up with so far.

Important! the code subclasses the excel application and for some obscure reason , the code works fine on some machines while it crashes on others. - If the machine where the code is run frezzes the application then, please go first to the VBE, click on the Stop button and then on the Reset button. I am not sure if this is a dcumented bug or what.

Here is a workbook demo that will prevent the user from increasing the width of the application window if the number of visible columns exceeds 9 columns and doesn't allow to increase the height of the excel window above the StartUp height.- Change these criteria in the event routines of the EventHandlersBas module as required.

http://www.datafilehost.com/download-0b439b99.html


1- Standard module : ( CallerBas)

Option Explicit
 
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Public Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
 
Public Declare Function FindWindow Lib _
    "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
 
Public lStartUpHeight As Long
Public lStartUpWidth  As Long
 
Sub Test()
 
    Dim tRect As RECT
    Dim lXLhwnd As Long
 
    lXLhwnd = FindWindow("XLMAIN", Application.Caption)
    GetWindowRect lXLhwnd, tRect
    With tRect
        lStartUpWidth = .Right - .Left
        lStartUpHeight = .Bottom - .Top
    End With
    Call InstalXLSubClass
 
End Sub
 
Sub StopTest()
 
    Call RemoveXLSubClass
 
End Sub

2-Standard Module (EventHandlersBas)

Option Explicit
 
'// set the maximum height of the excel window
' to the startup height//
 
Sub Application_WindowResizeVer(Cancel_WnSZ_Height As Boolean)
 
    Dim tRect As RECT
    Dim lCurrentAppHeight As Long
    Dim lXLhwnd As Long
 
    lXLhwnd = FindWindow("XLMAIN", Application.Caption)
    GetWindowRect lXLhwnd, tRect
    lCurrentAppHeight = tRect.Bottom - tRect.Top
    If lCurrentAppHeight > lStartUpHeight Then
        Cancel_WnSZ_Height = True
        MsgBox "Maximum height reached", vbExclamation
    End If
 
End Sub
 
'//stop increasing the width of the excel window
'if more than 8 columns become visible//
 
Sub Application_WindowResizeHor(Cancel_WnSZ_Width As Boolean)
 
    If ActiveWindow.VisibleRange.Columns.Count = 9 Then
        Cancel_WnSZ_Width = True
    End If
 
End Sub

3- Standard Module (WindowCallBackcBas)

Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type MINMAXINFO
    ptReserved As POINTAPI
    ptMaxSize As POINTAPI
    ptMaxPosition As POINTAPI
    ptMinTrackSize As POINTAPI
    ptMaxTrackSize As POINTAPI
End Type
 
Private Declare Function SystemParametersInfo _
Lib "user32" Alias "SystemParametersInfoA" _
                (ByVal uAction As Long, _
                ByVal uParam As Long, _
                lpvParam As Any, _
                ByVal fuWinIni As Long) As Long
 
Private Const SPI_GETDRAGFULLWINDOWS = 38
Private Const SPI_SETDRAGFULLWINDOWS = 37
Private Const SPIF_SENDWININICHANGE = &H2
Private bInitialFullWindowDragSettig As Boolean
 
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
 
Private lCurAppWidth As Long
Private lCurAppHeight As Long
Private lCurAppLeft As Long
Private lCurAppTop As Long
Private lPrevAppWidth As Long
Private lPrevAppHeight As Long
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                                (ByVal lpClassName As String, _
                                ByVal lpWindowName As String) As Long
Private lXLhwnd As Long
 
Private Declare Function GetSystemMetrics Lib _
        "user32" (ByVal nIndex As Long) As Long
 
Const SM_CXSCREEN = 0 'X Size of screen
Const SM_CYSCREEN = 1 'Y Size of Screen
 
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 CallWindowProc Lib "user32" _
  Alias "CallWindowProcA" _
                         (ByVal lpPrevWndFunc As Long, _
                         ByVal hwnd As Long, _
                         ByVal uMsg As Long, _
                         ByVal wParam As Long, _
                         lParam As MINMAXINFO) As Long
 
Private Const GWL_WNDPROC = (-4)
Private ldefWindowProc As Long
Private Const WM_GETMINMAXINFO = &H24
 
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MAXIMIZE = &HF030&
Private Const SC_RESTORE = &HF120&
Private Const WM_EXITSIZEMOVE As Long = &H232&
Private Const WM_ENABLE = &HA
Private bXLAppDisabled As Boolean
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTTOP = 12
Private Const HTBOTTOM = 15
Private Const HTLEFT = 10
Private Const HTRIGHT = 11
Private Const HTTOPLEFT = 13
Private Const HTTOPRIGHT = 14
Private Const HTBOTTOMLEFT = 16
Private Const HTBOTTOMRIGHT = 17
Private b_LEFT_Edge_Sizing   As Boolean
Private b_RIGHT_Edge_Sizing   As Boolean
Private b_TOP_Edge_Sizing   As Boolean
Private b_BOTTOM_Edge_Sizing   As Boolean
 
 
Sub InstalXLSubClass()
 
Call Show_Windows_Contents_While_Dragging
 
lXLhwnd = FindWindow("XLMAIN", Application.Caption)
  'assign our own window message
  'procedure (WindowProc)
   On Error Resume Next
   If ldefWindowProc = 0 Then
   ldefWindowProc = SetWindowLong(lXLhwnd, _
                    GWL_WNDPROC, _
                    AddressOf WindowProc)
   End If
 
End Sub
 
Sub RemoveXLSubClass()
 
   Call ResetInitialFullWindowDragSetting
   If ldefWindowProc Then
      SetWindowLong lXLhwnd, GWL_WNDPROC, ldefWindowProc
      ldefWindowProc = 0
   End If
 
End Sub
 
Private Function WindowProc(ByVal hwnd As Long, _
                    ByVal uMsg As Long, _
                    ByVal wParam As Long, _
                    lParam As MINMAXINFO) As Long
 
Dim Cancel_WnSZ_Height As Boolean
Dim Cancel_WnSZ_Width As Boolean
Dim tRect As RECT
 
On Error Resume Next
GetWindowRect hwnd, tRect
With tRect
    lCurAppLeft = .Left
    lCurAppTop = .Top
    lCurAppWidth = .Right - .Left
    lCurAppHeight = .Bottom - .Top
End With
 
Select Case uMsg
    Case Is = WM_ENABLE
        If Not wParam Then
            bXLAppDisabled = True
        End If
    Case Is = WM_EXITSIZEMOVE
        bXLAppDisabled = False
    Case WM_SYSCOMMAND
 
        Select Case wParam And &HFFF0
            Case Is = SC_MAXIMIZE
                Exit Function
        End Select
    Case Is = WM_NCLBUTTONDOWN
 
        Select Case wParam
            Case Is = HTTOP
                b_TOP_Edge_Sizing = True
                b_LEFT_Edge_Sizing = False
                b_RIGHT_Edge_Sizing = False
            Case Is = HTBOTTOM
                b_BOTTOM_Edge_Sizing = True
                b_LEFT_Edge_Sizing = False
                b_RIGHT_Edge_Sizing = False
            Case Is = HTLEFT
                b_LEFT_Edge_Sizing = True
                b_TOP_Edge_Sizing = False
                b_BOTTOM_Edge_Sizing = False
            Case Is = HTRIGHT
                b_RIGHT_Edge_Sizing = True
                b_TOP_Edge_Sizing = False
                b_BOTTOM_Edge_Sizing = False
            Case Is = HTTOPLEFT, HTTOPRIGHT, _
            HTBOTTOMLEFT, HTBOTTOMRIGHT
                Exit Function
        End Select
 
    Case WM_GETMINMAXINFO
 
        With lParam
 
            If bXLAppDisabled Then
                .ptMinTrackSize.y = lCurAppHeight
                .ptMaxTrackSize.y = lCurAppHeight
                .ptMinTrackSize.x = lCurAppWidth
                .ptMaxTrackSize.x = lCurAppWidth
                Exit Function
            End If
 
            If (b_TOP_Edge_Sizing Or b_BOTTOM_Edge_Sizing) Then
 
                Call Application_WindowResizeVer(Cancel_WnSZ_Height)
 
 
                If Cancel_WnSZ_Height Then
 
                    If lPrevAppHeight < lCurAppHeight And _
                    lPrevAppHeight <> 0 Then
 
                        .ptMinTrackSize.y = 0
                        If bXLAppDisabled Then
                            .ptMaxTrackSize.y = lCurAppHeight - 10
                        Else
                            .ptMaxTrackSize.y = lCurAppHeight
                        End If
                        Exit Function
 
                    ElseIf lPrevAppHeight > lCurAppHeight Then
 
                        If bXLAppDisabled Then
                            .ptMinTrackSize.y = lCurAppHeight + 10
                        Else
                            .ptMinTrackSize.y = lCurAppHeight
                        End If
                        .ptMaxTrackSize.y = GetSystemMetrics(SM_CYSCREEN)
                        Exit Function
                    End If
 
               End If
               lPrevAppHeight = lCurAppHeight
 
 
            End If
 
 
            If (b_LEFT_Edge_Sizing Or b_RIGHT_Edge_Sizing) Then
                Call Application_WindowResizeHor(Cancel_WnSZ_Width)
                If Cancel_WnSZ_Width Then
                    If lPrevAppWidth < lCurAppWidth And _
                    lPrevAppWidth <> 0 Then
 
                        .ptMinTrackSize.x = 0
                        If bXLAppDisabled Then
                            .ptMaxTrackSize.x = lCurAppWidth - 10
                        Else
                            .ptMaxTrackSize.x = lCurAppWidth
                        End If
                        Exit Function
 
                    ElseIf lPrevAppWidth > lCurAppWidth Then
 
                        If bXLAppDisabled Then
                            .ptMinTrackSize.x = lCurAppWidth + 10
                        Else
                            .ptMinTrackSize.x = lCurAppWidth
                        End If
                        .ptMaxTrackSize.x = GetSystemMetrics(SM_CXSCREEN)
                        Exit Function
                   End If
               End If
                lPrevAppWidth = lCurAppWidth
            End If
 
        End With
 
End Select
 
WindowProc = CallWindowProc(ldefWindowProc, _
                                    hwnd, _
                                    uMsg, _
                                    wParam, _
                                    lParam)
 
End Function
 
Private Function IsFullWindowDragOn() As Boolean
 
    Dim lresult As Long
    'Call API and check for successful call.
    If SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0&, lresult, 0&) _
    <> 0 Then
        'Feature supported now check value of result.
        If lresult = 0 Then
            IsFullWindowDragOn = False
        Else
            IsFullWindowDragOn = True
        End If
        'Call failed, feature not supported.
    Else
        IsFullWindowDragOn = False
    End If
 
End Function
 
Private Sub Show_Windows_Contents_While_Dragging()
 
    Dim lresult As Long
    bInitialFullWindowDragSettig = True
    If Not IsFullWindowDragOn Then
        lresult = SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, 1&, _
        ByVal vbNullString, SPIF_SENDWININICHANGE)
        bInitialFullWindowDragSettig = Not bInitialFullWindowDragSettig
    End If
 
End Sub
 
Private Sub ResetInitialFullWindowDragSetting()
 
    Dim lresult As Long
    If Not bInitialFullWindowDragSettig Then
        lresult = SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, 0&, _
        ByVal vbNullString, SPIF_SENDWININICHANGE)
    End If
 
End Sub

As usual with subclassing, please save your work before trying the code.

I hope this will be useful and can be improved on.

Regards.

 

[paffy]

Sorry to bring up such an old thread, but I have needed this to work for one of my sheets and found a much simpler solution that works quite well.

Rather than trying to detect the event directly, I ran a timed event every second to check if the window size has changed since the last event. Upon change of application width the zoom script is run. my code looks like this:

Private Sub RefreshWindowZoom()    
    'this timer will make sure the zoom is set correctly at any time
    If (Application.Width < WindowWidth * 0.9) Or (Application.Width > WindowWidth * 1.1) Then
        Call Module1.WindowResize
        WindowWidth = Application.Width
    End If
    
    Application.OnTime Now + TimeValue("00:00:01"), "Sheet2.RefreshWindowZoom"
    
End Sub

This is called on the workbook.open event, and runs continually. Checking with windows resource monitor it does not seem to take any noticeable memory or cpu load.

For reference my zoom code:

Function WindowResize()
'this function resizes the window to suit the current resolution or size.
Dim FullWidth As Long
FullWidth = 1453.5


Dim ZoomRange As Range
Set ZoomRange = Range("A1:Z1")


ZoomRange.Select


With ActiveWorkbook.Windows(1)
    If .Width < FullWidth Then
    .Zoom = True
    Else
    .Zoom = True
    End If
End With


'return to default selection
Range("A1").Select


End Function

Cheers