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

 

[kelly mort]

I get the error when I call this module. When I comment it out, I get the userform maximized with the control buttons but the multi page does not expand.

    Call StoreInitialControlMetrics

Yes I have all the code in the UserForm Module

 

[Jaafar Tribak]

I get the error when I call this module. When I comment it out, I get the userform maximized with the control buttons but the multi page does not expand.

    Call StoreInitialControlMetrics

Yes I have all the code in the UserForm Module

Hi Kelly,

the StoreInitialControlMetrics sub works for me fine.. Try dimming the oCtrl variable As Object instead of As Control in both the UserForm_Resize event and in the StoreInitialControlMetrics subs and see if the error stops .. like this :

Private Sub UserForm_Resize()
    Dim oCtrl As Object

Private Sub StoreInitialControlMetrics()
    Dim oCtrl As Object

 

[Jaafar Tribak]

Does this Workbook Demo works for you ?

 

[kelly mort]

Yes it did. I don't know why my own is failing.

 

[kelly mort]

Do you think there may be some unusual object I have on the form which is causing this?

Oh I just found the cause: I have image controls. I added one to your file and it proved to be the cause.
Is there a way around it?

 

[Jaafar Tribak]

Do you think there may be some unusual object I have on the form which is causing this?

So you are saying that the workbook demo worked for you - right ? If so there is probably a control on the form or some other code that is interfering.

By the way, did you replace oCtrl As Control with oCtrl as Object ?

Edit :
Try adding On Error Resume Next at the top of the UserForm_Resize and StoreInitialControlMetrics routines and see what happens.

 

[kelly mort]

After adding the error handler it expanded all controls except the image control and the listbox

 

[Jaafar Tribak]

After adding the error handler it expanded all controls except the image control and the listbox

Ok I see what is happening ... The error is coming from when trying to set the Font Size on te Image control which doesn't have a Font Property . I have missed that.

I am about to leave in a moment but I'll get back to this later so keep an eye on this thread.

 

[kelly mort]

Okay my eyes are widely opened

 

[Jaafar Tribak]

Fresh Workbook Demo

The following updated code should solve the image\Spin and Scrollbar controls Font issue

Code in Uerform module:

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 Single
Private dInitHeight As Single


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
                If HasFont(oCtrl) Then
                    .Font.Size = Split(.Tag, "*")(4) * (Me.InsideWidth) / dInitWidth
                End If
            End If
        End With
    Next
    Me.Repaint
End Sub

Private Sub StoreInitialControlMetrics()
    Dim oCtrl As Control
    Dim dFontSize As Currency

    dInitWidth = Me.InsideWidth
    dInitHeight = Me.InsideHeight
    For Each oCtrl In Me.Controls
        With oCtrl
            On Error Resume Next
                dFontSize = IIf(HasFont(oCtrl), .Font.Size, 0)
            On Error GoTo 0
            .Tag = .Width & "*" & .Left & "*" & .Height & "*" & .Top & "*" & dFontSize
        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

Private Function HasFont(ByVal oCtrl As Control) As Boolean
    Dim oFont As Object
    
    On Error Resume Next
    Set oFont = CallByName(oCtrl, "Font", VbGet)
    HasFont = Not oFont Is Nothing
End Function