Hide userform title bar, and locking the userform into a relative position on the application.

S

superstan2310

New Member
Joined
Nov 3, 2024
Messages
8
Office Version
  1. 365
Platform
  1. Windows
Hi All,

Currently working on a project and I'm trying to get a button located in the bottom right of the application window at all times, and staying there, even if the sheet is scrolled up/down/left/right or if the application window is moved.

I have created a userform (which just contains a command button) and added the below code into it as of this moment, and functionally it is everything I need, except for that fact that the button appears with a title bar, a close button, and can be moved by the user when dragging the title bar. Qualities that I do not wish it to have.

I have seen videos and forum threads about hiding the title bar (and therefore the close button, and prevents people moving it), which clearly shows it is possible, however when I copy the code they use and incorporate it into mine one of three things happen:
1. It outright doesn't do anything.
2. It creates a white box (the size of the userform) in the middle of the screen that just blocks the view of anything beneath it.
3. It stops my code below from working.

There is a bit of code left out of the below, but that is just code in the "ThisWorkbook" section for creating a modeless userform on workbook open, and calling the SetPos macro when the window is resized.

Would anyone be able to help with keeping the functionality of the below code, while being able to remove the title bar? If the code has to be rewritten from scratch, I don't mind.

VBA Code: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hWnd As LongPtr) As Long
    Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Private hWndForm As LongPtr, WbHwnd As LongPtr
    
#Else
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As Long) As Long
    Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    Private hWndForm As Long, WbHwnd As Long
#End If


Private Sub UserForm_Activate()
    WbHwnd = Application.hWnd
    Call IUnknown_GetWindow(Me, hWndForm)
    Call SetParent(hWndForm, WbHwnd)
    Call SetPos
End Sub

Public Sub SetPos()
    Me.StartUpPosition = 0
    Me.Left = Application.Width - 150 - Application.Left
    Me.Top = Application.Height - 125
End Sub
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Sort by date Sort by votes
Hi. Two things spring immediately to mind. First, you will need to make sure that the userform's ShowModal property is set to False, and I suspect that the code above would then need to be placed not in the Activate event but the Initialise event, if that makes sense.

Making the UserForm modeless will then enable you to click on other things, like the worksheet and input data, etc. The consequence though is that the Activate event doesn't fire, I think. Not at a computer, but I feel the answer is something along those lines.
 
Upvote 0
Dan_W said:
Hi. Two things spring immediately to mind. First, you will need to make sure that the userform's ShowModal property is set to False, and I suspect that the code above would then need to be placed not in the Activate event but the Initialise event, if that makes sense.

Making the UserForm modeless will then enable you to click on other things, like the worksheet and input data, etc. The consequence though is that the Activate event doesn't fire, I think. Not at a computer, but I feel the answer is something along those lines.
Click to expand...
I have a workbook open event that creates the userform as vbModeless already (not sure if thats technically the same thing as ShowModal set to false), see below for the entire workbook vba section as it is currently, and the userform_activate sub still runs so unless any title bar related macro just doesn't work on activate (and requires initialise instead for some reason) I would assume it's unfortunately neither of those two things.

VBA Code: 
Private Sub WorkBook_Open()
UserForm1.show vbModeless
End Sub

Private Sub Workbook_WindowResize(ByVal Wn As Window)
Call UserForm1.SetPos
End Sub
 
Upvote 0
@superstan2310

Just seen this. Have you found a solution?

Besides Dan's suggestion regarding the userform needing to be modeless, you will need to manage the Initialize and activate events so they don't clash when removing the the userfom caption and setting its position.

I remember writing some vba code to make buttons float on the screen (over the worksheet) but I didn't plan to lock them in a relative position to the application.

I will see if I can achive this and post the code here.
 
Upvote 0
Jaafar Tribak said:
@superstan2310

Just seen this. Have you found a solution?

Besides Dan's suggestion regarding the userform needing to be modeless, you will need to manage the Initialize and activate events so they don't clash when removing the the userfom caption and setting its position.

I remember writing some vba code to make buttons float on the screen (over the worksheet) but I didn't plan to lock them in a relative position to the application.

I will see if I can achive this and post the code here.
Click to expand...

I have not found a solution yet. Admittedly I have been working on the rest of the project to move things along, in hopes that by the time I get back round to the title bar situation someone here might have found a solution.

The code I'm using works for everything functionality wise, It just doesn't want to work alongside what seems to be the most used methods of removing the userforms title bar. I honestly wouldn't be surprised if the IUnknown_GetWindow function is somehow clashing with the title bar code.

It already is modeless, and the activate event worked fine, although I have since changed to initialise to see if it would work with the title bar stuff, it did not work either, but otherwise continues to run my code the same as activate did.

I will say that I have now moved the declarations to a module and made them public instead of private so that multiple userforms can take advantage of them without having to re-write it out every time. In case that somehow affects things.
 
Upvote 0
@superstan2310

Ok- Here is a generic function that creates dynamic floating button(s) on the fly ... Below is the signature of the core\worker function:

Public Function AddFloatingButton( _
ByVal AnchorCell As Range, _
ByVal Width As Double, _
ByVal Height As Double, _
ByVal ParentWindow As Window, _
ByVal lpClickFunc As LongPtr, _
Optional ByVal PosRelativeToParentWnd As Boolean, _
Optional ByVal FloatAccrossAllSheets As Boolean _
) As MSForms.CommandButton

By default, the function doesn't lock the button in a relative position to the application window so, in your case, you want to set the PosRelativeToParentWnd optional parameter to TRUE (This is shown when running the Test2 Macro) ... When this optional parameter is set, the floating button will move along with the parent window each time the application\workbook window is resized.

Since the function returns a native MSForms.CommandButton object, you can set the button properties at will once it is created. This is very convinient and intuitive.

The floating buttons share the same CLICK event but you can use the Button argument to know which button was clicked.
'// Generic Callback Click function:
Sub Button_Click(ByVal Button As MSForms.CommandButton)
MsgBox "You Clicked: [" & Button.Name & "]"
End Sub

There is also a right_click popup menu to close each button individually.

Written and tested in Excel 2016 x64bit and Excel 2013 x32bit.

File Demo:
Floating_Buttons.xlsm








1- Userform Module : (CFloatingButton)
VBA Code: 
Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

Private Type RECT
    Left            As Long
    Top             As Long
    Right           As Long
    Bottom          As Long
End Type

Private Type POINTAPI
    X               As Long
    Y               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 Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, hwnd As Any, Optional ByVal Msg As Long, Optional ByVal wParam As LongPtr, Optional ByVal lParam As LongPtr) As LongPtr
    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 GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Any) As Long
    Private Declare PtrSafe Function SysMtr Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function IsZoomed Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As Any) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As Any) As Long
    Private Declare PtrSafe Function ShowWindowAsync Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    Private Declare PtrSafe Function IsRectEmpty Lib "user32" (lpRect As RECT) As Long
    Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) 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 GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Object, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function CoLockObjectExternal Lib "ole32.dll" (ByVal pUnk As IUnknown, ByVal fLock As Boolean, Optional ByVal fLastUnlockReleases As Boolean) As Long
    Private Declare PtrSafe Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal cc As Long, ByVal vtReturn As Integer, ByVal cActuals As Long, ByRef prgvt As Integer, ByRef prgpvarg As LongPtr, ByRef pvargResult As Variant) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    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.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare 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 Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, hwnd As Any, Optional ByVal Msg As Long, Optional ByVal wParam As LongPtr, Optional ByVal lParam As LongPtr) As LongPtr
    Private Declare 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 Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Any) As Long
    Private Declare Function SysMtr Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
    Private Declare Function IsZoomed Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As Any) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As Any) As Long
    Private Declare Function ShowWindowAsync Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    Private Declare Function IsRectEmpty Lib "user32" (lpRect As RECT) As Long
    Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) 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 LongPtr
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Object, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare Function CoLockObjectExternal Lib "ole32.dll" (ByVal pUnk As IUnknown, ByVal fLock As Boolean, Optional ByVal fLastUnlockReleases As Boolean) As Long
    Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal cc As Long, ByVal vtReturn As Integer, ByVal cActuals As Long, ByRef prgvt As Integer, ByRef prgpvarg As LongPtr, ByRef pvargResult As Variant) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As LongPtr) As Long
#End If

Private Type BUTTON_INFO
    AnchorCell As Range
    Width As Double
    Height As Double
    ParentHwnd As LongPtr
    lpClickFunc As LongPtr
    RelativeToParentWnd As Boolean
    FloatAccrossAllSheets As Boolean
End Type

Private WithEvents CButton As MSForms.CommandButton
Private WithEvents Wb As Workbook

Private uBUTTON_INFO As BUTTON_INFO
Private hWndForm As LongPtr
Private lOffsetX As Long, lOffsetY As Long
Private bActivated As Boolean
   
   
Private Sub UserForm_Initialize()
    Me.StartUpPosition = 0&
    Call CoLockObjectExternal(Me, True)
    Call IUnknown_GetWindow(Me, hWndForm)
End Sub

Private Sub UserForm_Activate()
    Const WS_CAPTION = &HC00000: Const GWL_STYLE = (-16)
    If bActivated Then Exit Sub
    bActivated = True
    Call SetWindowLong(hWndForm, GWL_STYLE, _
         GetWindowLong(hWndForm, GWL_STYLE) And (Not WS_CAPTION))
    Call DrawMenuBar(hWndForm)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If bClosing = False Then Cancel = True:  Exit Sub
    Call CoLockObjectExternal(Me, False)
End Sub

Private Sub Wb_SheetActivate(ByVal Sh As Object)
    If uBUTTON_INFO.FloatAccrossAllSheets Then Exit Sub
    If uBUTTON_INFO.AnchorCell.Parent Is Sh Then
        Me.Show vbModeless
    Else
        Me.Hide
    End If
End Sub

Private Sub Wb_WindowResize(ByVal Wn As Window)
    If Wn.hwnd = uBUTTON_INFO.ParentHwnd Then
        Call SetWndDrawingRegion
    End If
End Sub

Private Sub Wb_BeforeClose(Cancel As Boolean)
    Unload Me
End Sub

Private Sub CButton_Click()
    Call CallFuncByPointer(uBUTTON_INFO.lpClickFunc, CButton)
    Call SetActiveWindow(uBUTTON_INFO.AnchorCell.Parent.Parent.Windows(1&).hwnd)
End Sub

Private Sub CButton_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2& Then
        Call DisplayMenuPopUp
    End If
End Sub

Private Sub UserForm_AddControl(ByVal Control As MSForms.Control)
    Const GWL_EXSTYLE = (-20&), WS_EX_DLGMODALFRAME = &H1&, WS_EX_NOACTIVATE = &H8000000, _
          SWP_SHOWWINDOW = &H40, SWP_HIDEWINDOW = &H80, SM_CXEDGE = 45&, SM_CXBORDER = 5&, SM_CXFRAME = 32&
    Dim tTargetRect As RECT, tWndRect As RECT, pt As POINTAPI
    Dim lX As Long, lY As Long, lW As Long, lH As Long, lOffset As Long, lShow As Long

    With uBUTTON_INFO
        Set .AnchorCell = Range(Split(Me.Tag, "|")(0&))
        .Width = CDbl(Split(Me.Tag, "|")(1&))
        .Height = CDbl(Split(Me.Tag, "|")(2&))
        .ParentHwnd = CLngPtr(Split(Me.Tag, "|")(3&))
        .lpClickFunc = CLngPtr(Split(Me.Tag, "|")(4&))
        .RelativeToParentWnd = CBool(Split(Me.Tag, "|")(5&))
        .FloatAccrossAllSheets = CBool(Split(Me.Tag, "|")(6&))
    End With
    Set CButton = Control
    With CButton
        .Left = 0&:                     .Top = 0&
        .Width = uBUTTON_INFO.Width:    .Height = uBUTTON_INFO.Height
    End With
    Call SetParent(hWndForm, uBUTTON_INFO.ParentHwnd)
    Call SetWindowLong(hWndForm, GWL_EXSTYLE, _
         GetWindowLong(hWndForm, GWL_EXSTYLE) And (Not WS_EX_DLGMODALFRAME) Or WS_EX_NOACTIVATE)
    Call GetWindowRect(uBUTTON_INFO.ParentHwnd, tWndRect)
    If IsZoomed(uBUTTON_INFO.ParentHwnd) Then
        lOffset = SysMtr(SM_CXBORDER) + SysMtr(SM_CXEDGE) + SysMtr(SM_CXFRAME)
    End If
    With uBUTTON_INFO.AnchorCell.Parent.Parent.Windows(1&).ActivePane
        lW = PTtoPX(uBUTTON_INFO.Width, False):  lH = PTtoPX(uBUTTON_INFO.Height, True)
    End With
    tTargetRect = GetRangeRect(uBUTTON_INFO.AnchorCell)
    With tTargetRect
        lX = .Left - tWndRect.Left - lOffset: lY = .Top - tWndRect.Top - lOffset
    End With
    If uBUTTON_INFO.FloatAccrossAllSheets = False And Not (ActiveSheet Is uBUTTON_INFO.AnchorCell.Parent) Then
        lShow = SWP_HIDEWINDOW
        Call ShowWindowAsync(hWndForm, 0&)
    Else
        lShow = SWP_SHOWWINDOW
    End If
    Call SetWindowPos(hWndForm, NULL_PTR, lX, lY, lW, lH, SWP_SHOWWINDOW)
    If uBUTTON_INFO.RelativeToParentWnd Then
        pt.X = lX:   pt.Y = lY
        Call ClientToScreen(uBUTTON_INFO.AnchorCell.Parent.Parent.Windows(1&).hwnd, pt)
        lOffsetX = tWndRect.Right - pt.X:  lOffsetY = tWndRect.Bottom - pt.Y
    End If
    Set Wb = ThisWorkbook
    DoEvents
    Call SetWndDrawingRegion
End Sub

Private Sub SetWndDrawingRegion()
    Const SWP_SHOWWINDOW = &H40, SWP_NOSIZE = &H1
    Const SM_CXVSCROLL = 2&, SM_CXBORDER = 5&, SM_CYDLGFRAME = 8&
    Dim tParentRect As RECT, tFormRect As RECT, tVisibleRect As RECT, tDesRect As RECT
    Dim tScrBarHRect As RECT
    Dim hScrollBarH As LongPtr, hScrollBarV As LongPtr
    Dim hIntersectRgn As LongPtr
    Dim lX As Long, lY As Long
   
    Call GetWindowRect(uBUTTON_INFO.ParentHwnd, tParentRect)
    If uBUTTON_INFO.RelativeToParentWnd Then
        With tParentRect
            lX = (.Right - .Left) - lOffsetX:   lY = (.Bottom - .Top) - lOffsetY
        End With
        Call SetWindowPos(hWndForm, NULL_PTR, lX, lY, 0&, 0&, SWP_SHOWWINDOW + SWP_NOSIZE)
    End If
    Call GetWindowRect(hWndForm, tFormRect)
    hScrollBarH = FindWindowEx(uBUTTON_INFO.ParentHwnd, NULL_PTR, "XLDESK", vbNullString)
    hScrollBarH = FindWindowEx(hScrollBarH, NULL_PTR, "EXCEL7", vbNullString)
    hScrollBarH = FindWindowEx(hScrollBarH, NULL_PTR, vbNullString, "Horizontal")
    Call GetWindowRect(hScrollBarH, tScrBarHRect)
    If IsRectEmpty(tScrBarHRect) Then
        hScrollBarH = FindWindowEx(GetParent(hScrollBarH), hScrollBarH, vbNullString, "Horizontal")
        Call GetWindowRect(hScrollBarH, tScrBarHRect)
    End If
    tVisibleRect = GetRangeRect(uBUTTON_INFO.AnchorCell.Parent.Parent.Windows(1&).VisibleRange)
    With tVisibleRect
        If uBUTTON_INFO.AnchorCell.Parent.Parent.Windows(1&).DisplayVerticalScrollBar Then
            .Right = tParentRect.Right - (SysMtr(SM_CXVSCROLL) + SysMtr(SM_CXBORDER) + 2& * SysMtr(SM_CYDLGFRAME))
        Else
            .Right = tParentRect.Right
        End If
        If uBUTTON_INFO.AnchorCell.Parent.Parent.Windows(1&).DisplayHorizontalScrollBar Then
            .Bottom = tScrBarHRect.Top - 7&
        Else
            If GetFootSheetTop Then
                .Bottom = GetFootSheetTop
            End If
        End If
    End With
    Call IntersectRect(tDesRect, tFormRect, tVisibleRect)
    With tDesRect
        Call ScreenToClient(hWndForm, .Left)
        Call ScreenToClient(hWndForm, .Right)
        hIntersectRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
    End With
    If SetWindowRgn(hWndForm, hIntersectRgn, True) = 0 Then
        Call DeleteObject(hIntersectRgn)
    End If
End Sub

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX As Long = 88&, LOGPIXELSY As Long = 90&
    Static lDPI(1) As Long, hdc As LongPtr
    If lDPI(0&) = 0& Then
        hdc = GetDC(NULL_PTR)
        lDPI(0&) = GetDeviceCaps(hdc, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(hdc, LOGPIXELSY)
        hdc = ReleaseDC(NULL_PTR, hdc)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(Points As Double, bVert As Boolean) As Long
    Const POINTS_PER_INCH = 72&
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function
 
Private Function GetRangeRect(ByVal Rng As Range) As RECT
    Dim oPane  As Pane
    Set oPane = Rng.Parent.Parent.Windows(1&).ActivePane
    With GetRangeRect
        .Left = oPane.PointsToScreenPixelsX(Rng.Left - 1&)
        .Top = oPane.PointsToScreenPixelsY(Rng.Top)
        .Right = oPane.PointsToScreenPixelsX(Rng.Left + Rng.Width)
        .Bottom = oPane.PointsToScreenPixelsY(Rng.Top + Rng.Height)
    End With
End Function

Private Function GetFootSheetTop() As Long
    Const S_OK = &H0&, OBJID_CLIENT = -4&
    Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
    Dim tGUID(0 To 3) As Long
    Dim oIAc As IAccessible
    Dim vTmp As Variant
    Dim hStatusBar As LongPtr, hExcel7 As LongPtr
    Dim lTop1 As Long, lTop2 As Long

    hStatusBar = FindWindowEx(uBUTTON_INFO.ParentHwnd, NULL_PTR, "EXCEL2", vbNullString)
    hStatusBar = FindWindowEx(hStatusBar, NULL_PTR, vbNullString, "Status Bar")
    If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0))) = S_OK Then
        If AccessibleObjectFromWindow(hStatusBar, OBJID_CLIENT, VarPtr(tGUID(0&)), oIAc) = S_OK Then
            oIAc.accLocation 0&, lTop1, 0&, 0&, 0&
        End If
    End If
    Set oIAc = Nothing
    hExcel7 = FindWindowEx(uBUTTON_INFO.ParentHwnd, NULL_PTR, "XLDESK", vbNullString)
    hExcel7 = FindWindowEx(hExcel7, NULL_PTR, "EXCEL7", vbNullString)
    If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0))) = S_OK Then
        If AccessibleObjectFromWindow(hExcel7, OBJID_CLIENT, VarPtr(tGUID(0&)), oIAc) = S_OK Then
            Set vTmp = oIAc
            If AccessibleChildren(vTmp, 5&, 1&, vTmp, 0&) = S_OK Then
                On Error Resume Next
                    vTmp.accLocation 0&, lTop2, 0&, 0&, 0&
                On Error GoTo 0
            End If
            Select Case True
                Case lTop1 <> 0& And lTop2 = 0&
                    GetFootSheetTop = lTop1
                Case lTop1 = 0& And lTop2 <> 0&
                    GetFootSheetTop = lTop2
                Case lTop1 <> 0& And lTop2 <> 0&
                    GetFootSheetTop = Application.Min(lTop1, lTop2)
            End Select
        End If
    End If
End Function

Private Function CallFuncByPointer(ClickEventPtr As LongPtr, Button As MSForms.CommandButton) As Variant
    Const CC_STDCALL = 4&
    Dim vParams(0&) As Variant
    Dim vParamPtr(0& To 0&) As LongPtr
    Dim vParamType(0& To 0&) As Integer
       
    vParams(0&) = ObjPtr(Button)
    vParamPtr(0&) = VarPtr(vParams(0))
    vParamType(0&) = VarType(vParams(0))
    Call DispCallFunc(NULL_PTR, ClickEventPtr, _
         CC_STDCALL, vbEmpty, 1&, vParamType(0&), vParamPtr(0&), CallFuncByPointer)
End Function

Private Sub DisplayMenuPopUp()
    On Error Resume Next
        Application.CommandBars("MyPopUpMenu").Delete
    On Error GoTo 0
    With Application.CommandBars.Add(Name:="MyPopUpMenu", Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "&Remove Me"
            .BeginGroup = True
            .State = msoButtonDown
            .FaceId = 358&
            .OnAction = "'Unload_Macro " & Chr(34&) & ObjPtr(Me) & Chr(34&) & "'"
        End With
    End With
    Application.CommandBars("MyPopUpMenu").ShowPopup
End Sub


2- Standard Module: (Where the worker function is located):
VBA Code: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If

Public bClosing As Boolean

Public Function AddFloatingButton( _
    ByVal AnchorCell As Range, _
    ByVal Width As Double, _
    ByVal Height As Double, _
    ByVal ParentWindow As Window, _
    ByVal lpClickFunc As LongPtr, _
    Optional ByVal PosRelativeToParentWnd As Boolean, _
    Optional ByVal FloatAccrossAllSheets As Boolean _
) As MSForms.CommandButton
   
    Dim Frm As CFloatingButton
    Dim oTmpBut As MSForms.CommandButton
   
    If Not RangeVisible(AnchorCell) Then
        MsgBox "The anchor cell must be located within the visible range of the active worksheet.", vbExclamation
        Exit Function
    End If
    Set Frm = New CFloatingButton
    Frm.Tag = AnchorCell.Address(External:=True) & "|" & Width & "|" & Height & "|" & _
    ParentWindow.hwnd & "|" & lpClickFunc & "|" & PosRelativeToParentWnd & "|" & FloatAccrossAllSheets
    Set oTmpBut = Frm.Controls.Add("Forms.CommandButton.1")
    Set AddFloatingButton = oTmpBut
    Frm.Show vbModeless
End Function

Public Sub Unload_Macro(ByVal lPtr As LongPtr)
    #If Win64 Then
        Const PTR_SIZE = 8&
    #Else
        Const PTR_SIZE = 4&
    #End If
    Dim oTmp As Object
    Call CopyMemory(oTmp, lPtr, PTR_SIZE)
    bClosing = True
    Unload oTmp
    bClosing = False
    Call CopyMemory(oTmp, 0&, PTR_SIZE)
End Sub

Private Function RangeVisible(ByVal Rng As Range) As Boolean
    On Error Resume Next
    RangeVisible = Not CBool(Intersect(Rng.Application.ActiveWindow.VisibleRange, Rng) Is Nothing)
End Function


3- Code Usage Examples:
VBA Code: 
Option Explicit

Sub Test1()
    Dim oButton As MSForms.CommandButton
    Set oButton = AddFloatingButton(Sheet1.Range("B10"), _
    100, 50, ThisWorkbook.Windows(1&), AddressOf Button_Click, , True)
    If Not oButton Is Nothing Then
        With oButton
            .Caption = "CommandButton1" & vbLf & "Click me"
            .Name = "CommandButton1"
            .BackColor = RGB(255, 255, 153)
            .Font.Bold = True
            .ForeColor = vbRed
        End With
    End If
End Sub

Sub Test2()
    Dim oButton As MSForms.CommandButton
    Set oButton = AddFloatingButton(Sheet1.Range("H20"), _
    250, 50, ThisWorkbook.Windows(1&), AddressOf Button_Click, True)
    If Not oButton Is Nothing Then
        With oButton
            .Caption = "This button is locked in a relative position to the application." _
                & vbLf & "Resize the workbook window now to test it."
            .Name = "CommandButton2"
        End With
    End If
End Sub

Sub Test3()
    Dim oButton As MSForms.CommandButton
    Set oButton = AddFloatingButton(Sheet1.Range("k10"), _
    50, 50, ThisWorkbook.Windows(1&), AddressOf Button_Click)
    If Not oButton Is Nothing Then
        With oButton
            .Caption = "Floating" & vbLf & "Button A"
            .Name = "CommandButton3"
            .BackColor = RGB(0, 0, 0)
            .Font.Bold = True
            .ForeColor = vbWhite
        End With
    End If
   
    Set oButton = AddFloatingButton(Sheet1.Range("k15"), _
    80, 50, ThisWorkbook.Windows(1&), AddressOf Button_Click)
    If Not oButton Is Nothing Then
        With oButton
            .Caption = "Floating" & vbLf & "Button B"
            .Name = "CommandButton4"
            .BackColor = RGB(255, 255, 255)
            .Font.Name = "Bradley Hand ITC"
            .Font.Italic = True
            .Font.Bold = True
            .Font.SIZE = 14
        End With
    End If
End Sub

'// Generic Callback Click function:
Sub Button_Click(ByVal Button As MSForms.CommandButton)
    MsgBox "You Clicked: [" & Button.Name & "]"
End Sub
 
Upvote 0
Hi again Jaafar, thanks for the code, with it's help I have been able to work out the code at the very bottom of this reply to meet what I need.
The only issue I have encountered is this basically keeps the userform window the same size, and moves the contents of the window up and to the left to fill the gap. (see below for example)

Before After
1731338355441.png
1731338392940.png


While I can remove this area by adding in:

Me.Width = Me.Width - X
Me.Height = Me.Height - Y

After the "Call Declarations.RemoveTitle" line, and replacing X and Y with values that I find look good, and this works for other userform I currently have in the file, but the above example doesn't want to get narrower than it already is. (see below)

1731338857691.png


This seems to be due to some minimum required width or something. And the only way I could get around this was to make the button wider than the actual userform window in the vba designer. (see below)

Design Screen Spreadsheet
1731343281010.png
1731343315581.png


Would you happen to know if there is a way to make it so when the title bar is removed the remaining userform looks just like it would on the vba designer example below, but obviously without the blue window around it? This would save me having to manually change the width and height of each userform going forward, and allow anyone to visually redesign the userforms if they want to without having to interact with the code side of things.

1731343394118.png


Userform code
VBA Code: 
Private Sub UserForm_Initialize()
    WbHwnd = Application.hwnd
    Call IUnknown_GetWindow(Me, hWndForm)
    Call SetParent(hWndForm, WbHwnd)
    Call Module.RemoveTitle
    Call SetPos
End Sub

Public Sub SetPos()
    Me.StartUpPosition = 0
    Me.Left = Application.Width - 161 - Application.Left
    Me.Top = Application.Height - 125
End Sub

Module code
Code: 
Option Explicit

#If VBA7 Then
    Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    Public Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As LongPtr) As Long
    Public Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Public hWndForm As LongPtr, WbHwnd As Long
#Else
    Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Public Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hWnd As Long) As Long
    Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    Public hWndForm As Long, WbHwnd As Long
#End If

Public Sub RemoveTitle()
    Const WS_CAPTION = &HC00000
    Const GWL_STYLE = (-16)
    Call SetWindowLong(hWndForm, GWL_STYLE, GetWindowLong(hWndForm, GWL_STYLE) And (Not WS_CAPTION))
    Call DrawMenuBar(hWndForm)
End Sub
 
Upvote 0
Not sure why I can't edit my previous reply, but the "Before After" and "Design Screen Spreadsheet" bits for the photos should be "Before / After" and "Design Screen / Spreadsheet", I tried putting a bunch of spaces in to make them more spaced out rather than adding the /'s, but I guess this forum removes the excess spaces. And also doesn't let you edit your previous replies.
 
Upvote 0
Hi again, I've found something that should be good enough.

VBA Code: 
Private Sub UserForm_Initialize()
    WbHwnd = Application.hwnd
    Call IUnknown_GetWindow(Me, hWndForm)
    Call SetParent(hWndForm, WbHwnd)
    Call Module.RemoveTitle
    Dim h, w, h1, w1
    h = 0: w = 0: h1 = Me.Height: w1 = Me.Width
    For Each Control In Me.Controls
        If Control.Visible Then
            If Control.Top + Control.Height > h Then h = Control.Top + Control.Height
            If Control.Top < h1 Then h1 = Control.Top
            If Control.Left + Control.Width > w Then w = Control.Left + Control.Width
            If Control.Left < w1 Then w1 = Control.Left
        End If
    Next Control
    If h > 0 And w > 0 Then
        Me.Width = w + 2 * w1
        Me.Height = h + 2 * h1
    End If
    Call SetPos
End Sub

Personally I would have preferred to just do Me.Width = Me.InsideWidth as well as Me.Height = Me.InsideHeight, as then if someone didn't want the userforms to have the same size blank areas on the top/bottom and left/right then they could, but it didn't seem to want to work as advertised, instead of setting the height and width to what is shown within the userform, it just seemed to remove the width/height of the right/bottom borders respectively. I.e. there was a sizeable blank area underneath that is the same size as the title bar, and a small blank area to the right that is the size of the left border.

I even confirmed this by writing a msgbox to pop up and tell me the height/width of both .Height/.Width and .InsideHeight/.InsideWidth, and the difference was 4.5 for all values, despite thinking that the heights should be more than that due to the title bar.

@Jaafar Tribak If you can somehow think of a way to get InsideWidth and InsideHeight to work, please let me know, otherwise, if by the end of the week there are no further responses, I will mark this thread as resolved and set Reply #6 as the resolution.
 
Upvote 0
@superstan2310
I am not sure I fully understand. It seems to me that you are adding the commandbutton @ design time while my code adds the commandbutton for you at runtime. You just need to specify the button location, size etc in the parameters of the AddFloatingButton and it should do all the work for you.

Did you download the file demo I provided in post#6 ? And if so, did it work for you as shown in the animated gif in post#6 ?

Edit:
@Dan_W
Did you test the code in post#6 ? Did it work as advertised?
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
860
Jaafar Tribak
Jaafar Tribak
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
368
Minh Tuan VN
M
J
  • Solved
Get IAccessible of UserForm control without reference
2
Replies
12
Views
1K
Jaafar Tribak
Jaafar Tribak
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
786
huiettcm
H
Jaafar Tribak
  • Question Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
825
Dan_W
D

Forum statistics

Threads
1,224,808
Messages
6,181,072
Members
453,020
Latest member
mattg2448

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top