Disabling Excel Application Resizing

[derny1]

I have an Excel app for which I would like to specify the application window size when the screen resolution is greater than 1280 wide. Setting up the window is the easy part (see code below), but, I can't seem to figure out if it is possible to disable resizing of the window afterwards, whether it be through dragging the borders or minimize/maximize (I am talking about the application and not the workbook itself).

This is a 'dictator' application which uses a worksheet as the interface and not a form, so I cannot set a border property.

I have seen mention of an Api WM_SIZE message function but I am not sure if this can be utilized in VBA.

Here is the code that sets up the applications window size and center's it on the desktop:

'WHEN SM_CXSCREEN IS > 1280, otherwise use separate zoom function

hwnd = FindWindow("XLMAIN", Application.Caption)
Call SetWindowPos(hwnd, HWND_TOPMOST, (GetSystemMetrics(SM_CXSCREEN) - 1250) / 2, (GetSystemMetrics(SM_CYSCREEN) - 760) / 2, 1250, 760, 0)

Thx,
Dennis

 

[Kusaywa]

I'm getting an error here when pasting?

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long

 

[Kusaywa]

And Compile error

 

[Jaafar Tribak]

I don't see any errors in those API declararions .. Are you running this code on a 32bit machine or 64bit ?
Also, Are you running the code on Mac or on a PC ?

 

[Kusaywa]

Pc & 64

 

[Jaafar Tribak]

Pc & 64

Well, in that case, those two API declaration lines should be coloured in red which is ok but they shouldn't cause a compile error.

Are you sure you copied and pasted the whole code I posted in the ThisWorkbook Module ?

 

[Kusaywa]

Just tried it on a 32 bit PC and it works.
Can't resize window, can't full screen...
You also can't minimize or close excel from the window buttons but you can do it from the taskbar.
Mouse "busy" circle spins for about 2 minutes which is odd?
This is good for me since I was only looking to prevent the resize.
Others may find this helpful.

I will try it again on a 64 bit again later and let you know my results.

Jaafar Tribak, did you ever try the code posted by derny1 to center window on screen?
Where would that go?

 

[Jaafar Tribak]

Just tried it on a 32 bit PC and it works.
Can't resize window, can't full screen...
You also can't minimize or close excel from the window buttons but you can do it from the taskbar.
Mouse "busy" circle spins for about 2 minutes which is odd?
This is good for me since I was only looking to prevent the resize.
Others may find this helpful.

I will try it again on a 64 bit again later and let you know my results.

Jaafar Tribak, did you ever try the code posted by derny1 to center window on screen?
Where would that go?

Hi Kusaywa,

I'll be leaving shorltly .. I'll post back later on , maybe tomorrow.

 

[Kusaywa]

I found this that centers the workbook on the desktop.
These settings set the window rather small.
I changed appLeft, appTop, appWidth & appHeight to 6, 6, 1.5 & 1.5 respectively.
It makes the window a little bigger and still centers it on the desktop.

Private Sub Workbook_Open()
    Dim maxWidth As Integer
    Dim maxHeight As Integer
    Application.WindowState = xlMaximized
    maxWidth = Application.Width
    maxHeight = Application.Height
    Call CenterApp(maxWidth, maxHeight)
End Sub

Sub CenterApp(maxWidth As Integer, maxHeight As Integer)
    Dim appLeft As Integer
    Dim appTop As Integer
    Dim appWidth As Integer
    Dim appHeight As Integer
    Application.WindowState = xlNormal
    appLeft = maxWidth / 4
    appTop = maxHeight / 4
    appWidth = maxWidth / 2
    appHeight = maxHeight / 2
    Application.Left = appLeft
    Application.Top = appTop
    Application.Width = appWidth
    Application.Height = appHeight
End Sub

 

[Kusaywa]

Thanks Jaafar Tribak for all your help.
I was able to get the resize lock to work on both 32 & 64.
Problem I found was...
If your workbook had 2 sheets and you went to the other sheet, you couldn't go back to the other one.
I've decided to put the "center" code above and the zoom code (below) into Private Sub Worksheet_Change(ByVal Target As Range)
This way if the user moves or resizes the excel window, it reverts back every time they enter something.

For those of you looking to use the "resize" code, here is what it does...
It locks your Excel window so you can't resize it.
You also can't close out Excel by the "X" button on the top right, or minimize or full screen.
You can minimize by clicking the "icon" on the taskbar and close Excel by right clicking and selecting Close Window.

My experience is it only works on a single sheet, it won't let you jump back and forth between sheets.

Zoom code:
I have mine set to the widest usable # in the row.
I found that if you use A1:D1, when you get to the bottom and type into row larger than A1, the sheet shifts.

ActiveSheet.Range("A4800:D4800").Select   'set range zoom
ActiveWindow.Zoom = True)

To prevent sheet from going to the last row (4800) when it opens, I use this code to make the sheet go to the next empty cell.
Only column B is unlocked on my sheet so adjust accordingly.

Dim rng As Range
    
    Set rng = ActiveSheet.Range("B2:B4800")
    For j = rng.Column To (rng.Column + rng.Columns.Count - 1)
        For i = rng.Row To (rng.Row + rng.Rows.Count - 1)
            If Cells(i, j).Locked = False And Len(Trim(Cells(i, j).Value)) = 0 Then
                Cells(i, j).Select
                Exit For
            End If
        Next i
    Next j

 

[Jaafar Tribak]

Hi, I have just finished fine-tuning the code .. This is the best I could do without resorting to window subclassing .. I hope it works with as little problems as possible.

If you incorporate any additional code, this will need to be worked around the API code in order to avoid potential conflicts.

As requested, the code is supposed to accomplish the following while the workbook is open :

1- Prevents resizing/moving the excel window.
2- Prevents Maximizing/Minimizing/Restoring Excel.
3- Centers the excel window on the screen. (Optional)
4- Makes the excel window TopMost. (Optional)

One limitation of the code is that it disables the Quick Access toolbar when the latter is displayed accross the top over the excel title bar .. You can move the toolbar down to the bottom of the ribbon to avoid this issue.

I tested the code and haven't noticed any issues when switching worksheets/workbooks or otherwise but I am not sure the code will work or be stable when tested on other machines.

Workbook Demo

Code goes in the ThisWorkbook Module:

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

#If VBA7 Then
    #If Win64 Then
        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 GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #End If
#Else
    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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
#End If

#If VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function RedrawWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal lprcUpdate As Long, ByVal hrgnUpdate As LongPtr, ByVal fuRedraw As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare PtrSafe Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function PtInRegion Lib "gdi32" (ByVal hRgn As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private hwndXLDESK As LongPtr, hRgn As LongPtr
    Private lStyle As LongPtr
#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private hwndXLDESK As Long, hRgn As Long
    Private lStyle As Long
#End If

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCLBUTTONDBLCLK = &HA3
Private Const WM_NCRBUTTONUP = &HA5
Private Const GWL_STYLE = (-16)
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CXSIZE = 30
Private Const SM_CYCAPTION = 4
Private Const SM_CYBORDER = 6
Private Const SM_CYDLGFRAME = 8
Private Const SPI_GETWORKAREA = 48
Private Const RDW_INTERNALPAINT = &H2

Private bCancel As Boolean
Private bMsgsBeingIntercepted As Boolean


[B][COLOR=#008000]'Private routines.
'=================[/COLOR][/B]
Public Sub Start()
    Call Prevent_Resizing_Moving_Excel(CenterExcelWindow:=True, MakeExcelTopMost:=True)
End Sub


Public Sub Finish()
    Call Restore_Excel_Default
End Sub


[B][COLOR=#008000]'Private routines.
'=================[/COLOR][/B]
Private Sub Prevent_Resizing_Moving_Excel( _
    Optional ByVal CenterExcelWindow As Boolean, _
    Optional ByVal MakeExcelTopMost As Boolean _
)

    Dim tMSG As MSG
    Dim tIniWinRect As RECT
    Dim tCurWinRect As RECT
    Dim tWorkAreaRect As RECT
    Dim lCYOffset As Long
    Dim bFirstLoop As Boolean
    
    If bMsgsBeingIntercepted Then Exit Sub
    bMsgsBeingIntercepted = True
    
    GetWindowRect Application.hwnd, tIniWinRect
    Call SystemParametersInfo(SPI_GETWORKAREA, 0, tWorkAreaRect, 0)
    lCYOffset = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYBORDER) + GetSystemMetrics(SM_CYDLGFRAME) + 2
    
    With tIniWinRect
        Call SetWindowPos(Application.hwnd, IIf(MakeExcelTopMost, HWND_TOPMOST, HWND_NOTOPMOST), _
        (GetSystemMetrics(SM_CXSCREEN) - (.Right - .Left)) / 2, _
        ((tWorkAreaRect.Bottom - tWorkAreaRect.Top) - (.Bottom - .Top)) / 2, _
        0, 0, SWP_NOSIZE Or IIf(CenterExcelWindow, 0, SWP_NOMOVE))
        
        GetWindowRect Application.hwnd, tIniWinRect
        hRgn = CreateRectRgn(.Left, .Top, .Right - GetSystemMetrics(SM_CXSIZE), .Top + lCYOffset)
    End With
     
    lStyle = GetWindowLong(Application.hwnd, GWL_STYLE)
    lStyle = lStyle And Not (WS_THICKFRAME Or WS_MAXIMIZEBOX Or WS_MINIMIZEBOX)
    Call SetWindowLong(Application.hwnd, GWL_STYLE, lStyle)
    
    hwndXLDESK = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    
    On Error GoTo errHandler
    Application.EnableCancelKey = xlErrorHandler
    
    bCancel = False
    
    Do While GetMessage(tMSG, 0, 0, 0) <> 0
    
      RedrawWindow Application.hwnd, ByVal 0, ByVal 0, RDW_INTERNALPAINT
        If bCancel Then Exit Do
                If bFirstLoop = False Then
            Application.SendKeys "{ESC}", True
            DoEvents
            Application.SendKeys "{ESC}", True
            DoEvents
        End If
        bFirstLoop = True
        
        Call GetWindowRect(Application.hwnd, tCurWinRect)
        If EqualRect(tIniWinRect, tCurWinRect) = 0 Then
            With tIniWinRect
                Call SetWindowPos(Application.hwnd, 0, (GetSystemMetrics(SM_CXSCREEN) - (.Right - .Left)) / 2, _
                ((tWorkAreaRect.Bottom - tWorkAreaRect.Top) - (.Bottom - .Top)) / 2, .Right - .Left, .Bottom - .Top, 0)
            End With
        End If
        
        With tMSG
            If WM_NCLBUTTONDOWN Or .message = WM_NCLBUTTONDBLCLK Or .message = WM_NCRBUTTONUP Then
                If GetParent(.hwnd) <> hwndXLDESK Then
                    If PtInRegion(hRgn, tMSG.pt.X, tMSG.pt.Y) Then
                        GoTo NxtLoop
                    End If
                End If
            End If
            PostMessage .hwnd, .message, .wParam, .lParam
            DoEvents
        End With
        
NxtLoop:

    Loop
    
    Application.EnableCancelKey = xlInterrupt
    DeleteObject hRgn
    Exit Sub
    
errHandler:
    Resume
End Sub

Private Sub Restore_Excel_Default()
    bCancel = True
    bMsgsBeingIntercepted = False
    lStyle = GetWindowLong(Application.hwnd, GWL_STYLE)
    lStyle = lStyle Or (WS_THICKFRAME Or WS_MAXIMIZEBOX Or WS_MINIMIZEBOX)
    Call SetWindowLong(Application.hwnd, GWL_STYLE, lStyle)
    Call SetWindowPos(Application.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
End Sub


[B][COLOR=#008000]'Workbook event routines.
'====================[/COLOR][/B]
Private Sub Workbook_Open()
    'Any exixting code goes here before calling the 'Restore_Excel_Default' routine   !!!
    Application.OnTime Now, Me.CodeName & ".Start"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call Finish
End Sub