Userform.... Always on top

[mtheriault2000]

Hello

I need a userform to be always on top of any Windows applications. Is it possible.

I want to use it to reduce the amount of paper i print. At the moment, i make a printout of data that i need to enter in an applcation. Having my data on the screen will help me reducing my waste of paper and be more ecological.

Nice idea that i got, but i have no idea how to start it.

Any one could help me? Any hint hint greatly appreciated

Martin
P.S. As usual, please excuse my English

 

[John_w]

It turns out that Excel 2013 cannot open an Excel 2007 workbook with the above code.
Compile error:

The code in this project must be updated for use on 64-bit systems. Please review and update Declare statements and then mark them with the PtrSafe attribute.

Please update this thread with the full code as indicated by the compile error.

The issue isn't that Excel 2013 per se cannot open the workbook, but that your Excel 2013 is the 64-bit installation of Office and your Excel 2007 is the 32-bit installation of Office.

Try this code which completely replaces the previous version. I have changed the functions GetWindowLong and SetWindowLong to GetWindowLongPtr and SetGetWindowLongPtr respectively to use the declarations for both the 32-bit and 64-bit versions of Office. I have tested this on Windows 32-bit/Office 32-bit and Windows 64-bit/Office 32-bit. Not tested on Office 64-bit because my installation is Office 32-bit.

Put this code in a standard module:

Option Explicit

Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1

Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2

Public Const GWL_STYLE = -16

Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_SYSMENU = &H80000

'https://msdn.microsoft.com/en-us/library/office/gg264421.aspx
'64-Bit Visual Basic for Applications Overview

#If VBA7 Then

    'VBA version 7 compiler, therefore >= Office 2010
    'PtrSafe means function works in 32-bit and 64-bit Office
    'LongPtr type alias resolves to Long (32 bits) in 32-bit Office, or LongLong (64 bits) in 64-bit Office

    Public 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 uFlags As Long) As Long
    
    Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr
        
    #If Win64 Then
        '64-bit Office
        Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _
            (ByVal hWnd As LongPtr, _
            ByVal nIndex As Long) As LongPtr
    #Else
        '32-bit Office
        Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" _
            (ByVal hWnd As LongPtr, _
            ByVal nIndex As Long) As LongPtr
    #End If

    #If Win64 Then
        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _
            (ByVal hWnd As LongPtr, _
            ByVal nIndex As Long, _
            ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" _
            (ByVal hWnd As LongPtr, _
            ByVal nIndex As Long, _
            ByVal dwNewLong As LongPtr) As LongPtr
    #End If
    
    Public Declare PtrSafe Function DrawMenuBar Lib "user32" _
        (ByVal hwnd As LongPtr) As Long

#Else
    
    'VBA version 6 or earlier compiler, therefore <= Office 2007
    
    Public 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 uFlags As Long) As Long
    
    Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long

    Public Declare Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" _
        (ByVal hWnd As Long, _
        ByVal nIndex As Long) As Long
    
    Public Declare Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" _
        (ByVal hWnd As Long, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long

    Public Declare Function DrawMenuBar Lib "user32" _
        (ByVal hWnd As Long) As Long

#End If

Put this code in the UserForm module:

Option Explicit


Private Sub UserForm_Initialize()
    AlwaysOnTop Me.caption
    AddButtons Me.caption, WS_MINIMIZEBOX 'minimise box only
    'AddButtons Me.caption, WS_MINIMIZEBOX Or WS_MAXIMIZEBOX     'minimise and maximise boxes
End Sub


Private Sub AlwaysOnTop(caption As String)

    #If VBA7 Then
        Dim hWnd As LongPtr
    #Else
        Dim hWnd As Long
    #End If
    Dim lResult As Long
    
    If Val(Application.Version) >= 9 Then
        hWnd = FindWindow("ThunderDFrame", caption)
    Else
        hWnd = FindWindow("ThunderXFrame", caption)
    End If
    
    If hWnd <> 0 Then
    
        lResult = SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
        
    Else
    
        MsgBox "AlwaysOnTop: userform with caption '" & caption & "' not found"
        
    End If
    
End Sub


#If VBA7 Then
Private Sub AddButtons(caption As String, buttonStyle As LongPtr)
#Else
Private Sub AddButtons(caption As String, buttonStyle As Long)
#End If

    #If VBA7 Then
        Dim hWnd As LongPtr
        Dim lstyle As LongPtr
    #Else
        Dim hWnd As Long
        Dim lstyle As Long
    #End If
    Dim lResult As Long
    
    If Val(Application.Version) >= 9 Then
        hWnd = FindWindow("ThunderDFrame", caption)
    Else
        hWnd = FindWindow("ThunderXFrame", caption)
    End If
    
    If hWnd <> 0 Then
    
        lstyle = GetWindowLongPtr(hWnd, GWL_STYLE)
        lstyle = lstyle Or WS_SYSMENU Or buttonStyle
        
        'Add specified icons to userform
        
        lResult = SetWindowLongPtr(hWnd, GWL_STYLE, lstyle)
        If lResult = 0 Then
            Debug.Print "SetWindowLongPtr error:"; Err.LastDllError
        End If
        
        DrawMenuBar hWnd

    Else
    
        MsgBox "AddButtons: userform with caption '" & caption & "' not found"
    
    End If
    
End Sub

 

[gklewis83]

@John_w: Thank you for your code, and the annotations therein. This should prove to be a help guide if not the solution. Thanks again!