modifying a fullscreen userform macro

[kelly mort]

I found this code here in this forum which maximizes the userform to cover the whole screen. It worked for me but I have a multi page form and the multi page did not expand. So I wanna know if it can also expand as well. Then what happens to the controls on it. Will they too expand?

Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]   VBA7 Then
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex 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 Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private hwnd As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]   
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex 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 Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private hwnd As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]   If

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Private Sub UserForm_Initialize()
    Call WindowFromAccessibleObject(Me, hwnd)
    If IsWindow(hwnd) Then
        SetWindowPos hwnd, 0, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN), 0
    End If
End Sub

And also on my pc the lines after the #Else are lighted red and was prompted to update them and mark them as PtrSafe. Somebody help me out.
Kelly

 

[Leith Ross]

Hello Kelly,


This is the code you need in your UserForm to correctly open and be shown as maximized.

' Written:  September 13, 2017
' Author:   Leith Ross
' Summary:  Open UserForm as Maximized


' Begin General Declarations Section
'-----------------------------------


Dim OldWidth    As Double
Dim OldHeight   As Double


Const ZoomMin   As Long = 10
Const ZoomMax   As Long = 400


Private Declare PtrSafe Function GetForegroundWindow Lib "User32.dll" () As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "User32.dll" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex 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


' End General Declarations Section
'---------------------------------




' Event Code
'-----------
Private Sub UserForm_Activate()


    Dim ret As Long
    
    Const SM_CXSCREEN As Long = 0
    Const SM_CYSCREEN As Long = 1


        ret = SetWindowPos(GetForegroundWindow, 0, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN), 0)
        
End Sub


Private Sub UserForm_Initialize()


        OldWidth = Me.Width
        OldHeight = Me.Height


End Sub


Private Sub UserForm_Resize()


    Dim CurStyle    As Long
    Dim tmpZoom     As Double
    
    Const WS_MAXIMIZE   As Long = &H1000000


        CurStyle = GetWindowLong(GetForegroundWindow, GWL_STYLE)
        
        tmpZoom = ((Me.Width / OldWidth) * 100) - 2.5
        If tmpZoom <= ZoomMin Then tmpZoom = ZoomMin
        If tmpZoom >= ZoomMax Then tmpZoom = ZoomMax
        
        If (CurStyle And WS_MAXIMIZE) = WS_MAXIMIZE Then
            Me.Width = (tmpZoom * OldWidth) / 100
            Me.Height = (Me.Width * OldHeight) / OldWidth
        End If
        
        Me.Zoom = tmpZoom


End Sub

 

[kelly mort]

Private Sub UserForm_Resize()


    Dim CurStyle    As Long
    Dim tmpZoom     As Double
    
    Const WS_MAXIMIZE   As Long = &H1000000


        CurStyle = GetWindowLong(GetForegroundWindow, GWL_STYLE)
        
        tmpZoom = ((Me.Width / OldWidth) * 100) - 2.5
        If tmpZoom <= ZoomMin Then tmpZoom = ZoomMin
        If tmpZoom >= ZoomMax Then tmpZoom = ZoomMax
        
        If (CurStyle And WS_MAXIMIZE) = WS_MAXIMIZE Then
            Me.Width = (tmpZoom * OldWidth) / 100
            Me.Height = (Me.Width * OldHeight) / OldWidth
        End If
        
        Me.Zoom = tmpZoom


End Sub

From the above I get the error : variable not defined and selects ;

GWL_STYLE

 

[Leith Ross]

Hello Kelly,

This event is the only one where the constant is used Replace the same event code in your UserForm this...

Private Sub UserForm_Resize()


    Dim Border      As Long
    Dim CurStyle    As Long
    Dim tmpZoom     As Long
    
    Const WS_MAXIMIZE   As Long = &H1000000
    Const GWL_STYLE     As Long = -16
    
        CurStyle = GetWindowLong(GetForegroundWindow, GWL_STYLE)
        
        tmpZoom = Fix(((Me.Width / OldWidth) * 100))
        If tmpZoom <= ZoomMin Then tmpZoom = ZoomMin
        If tmpZoom >= ZoomMax Then tmpZoom = ZoomMax
        
        If (CurStyle And WS_MAXIMIZE) = WS_MAXIMIZE Then
            Me.Width = (tmpZoom * OldWidth) / 100
            Me.Height = (Me.Width * OldHeight) / OldWidth
        End If
        
        Me.Zoom = tmpZoom


End Sub

 

[kelly mort]

Okay it has worked now. So can I toggle between maximize and restore?
Kelly

 

[Leith Ross]

Hello Kelly,

I going to take a guess you want the UserForm to show maximized but to behave like a Window, yes?

 

[kelly mort]

Yes exactly. Hope that is possible.

 

[Jaafar Tribak]

Hi Kelly,

In order to have the controls proportionally expand and reduce along with the userform, you will need some code like the one below :

Note that the following code adds Max,Min and Restore buttons to the userform plus it enables resizing it by mouse-dragging its edges just like a standard application window... In addition, it optionally maximize the form full-screen upon first showing.

Option Explicit 
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        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
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
    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 hwnd As LongPtr
    Private lStyle As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As Long) As Long
    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 hwnd As Long
    Private lStyle As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const GWL_STYLE = -16
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MAXIMIZE = &HF030&

Private dInitWidth As Double
Private dInitHeight As Double


Private Sub UserForm_Initialize()
    Call CreateMenu
    Call StoreInitialControlMetrics
    
    [B][COLOR=#008000]'OPTIONAL: maximize the form full-screen upon first showing.[/COLOR][/B]
    [B][COLOR=#008000]'========[/COLOR][/B]
    PostMessage hwnd, WM_SYSCOMMAND, SC_MAXIMIZE, 0
End Sub

Private Sub UserForm_Resize()
    Dim oCtrl As Control
    
    For Each oCtrl In Me.Controls
        With oCtrl
            If .Tag <> "" Then
                .Width = Split(.Tag, "*")(0) * ((Me.InsideWidth) / dInitWidth)
                .Left = Split(.Tag, "*")(1) * (Me.InsideWidth) / dInitWidth
                .Height = Split(.Tag, "*")(2) * (Me.InsideHeight) / dInitHeight
                .Top = Split(.Tag, "*")(3) * (Me.InsideHeight) / dInitHeight
                .Object.Font.Size = Split(.Tag, "*")(4) * (Me.InsideWidth) / dInitWidth
            End If
        End With
    Next
    Me.Repaint
End Sub

Private Sub StoreInitialControlMetrics()
    Dim oCtrl As Control

    dInitWidth = Me.InsideWidth
    dInitHeight = Me.InsideHeight
    For Each oCtrl In Me.Controls
        With oCtrl
            .Tag = .Width & "*" & .Left & "*" & .Height & "*" & .Top & "*" & .Object.Font.Size
        End With
    Next
End Sub
 
Private Sub CreateMenu()
    Call WindowFromAccessibleObject(Me, hwnd)
    lStyle = GetWindowLong(hwnd, GWL_STYLE)
    lStyle = lStyle Or WS_SYSMENU Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_THICKFRAME
    SetWindowLong hwnd, GWL_STYLE, lStyle
    DrawMenuBar hwnd
End Sub

 

[kelly mort]

Hello Jaafar,
I get the error 438
Object doesn't support this property or method.

 

[Jaafar Tribak]

Hello Jaafar,
I get the error 438
Object doesn't support this property or method.

On which line are you getting the error ? Also, I assume you are putting the whole code in the UserForm module not in a standard module .