Move a UserForm over a specific worksheet cell

Question

I'm trying to move a userform partially off screen to reveal data in the activesheet below. A SpinButton click on the form then scrolls through a short list, highlighting cells needing attention).

I want to place the Userform.Top & .Left over a computed Cell.Top & .Left, to make the necessary data visible by moving the form

The UserForm.Move method seems NOT to be the correct method, despite its name and the fact that all its arguments are in Points, the same as Cell.Left and Cell.Top

I have looked at earlier S.O. answers (here and, more hopefully, the last answer here)

My existing code calls UserForm_Activate() only when needed to reveal the worksheet table and to return to the normal default presentation. [Edit] I should have mentioned, the Activewindow can be offset both horizontally & vertically. Here is my code:

Private Sub UserForm_Activate()

Dim AppXCenter As Long, AppYCenter As Long

    AppXCenter = Application.Left + (Application.Width / 2)
    AppYCenter = Application.Top + (Application.Height / 2)

    With Me
        .StartUpPosition = 0    'mode 1 not suitable when extending VBE to a 2nd monitor

        .Top = AppYCenter - (Me.Height / 2)
        .Left = AppXCenter - (Me.Width / 2)
        If .Top < 0 Then .Top = 0
        If .Left < 0 Then .Left = 0

        If UserForm_Needs_To_Move Then
            VBA.beep  'in lieu of a frustrated smiley

            'I have tried many ways to calculate the offset to the desired column
            'This is the simplest

            Me.Move [y1].Left - Me.Left

            'NONE of them work!!!                

        End If
    End With
End Sub

Private Sub UserForm_Initialize()

    'UserForm_Activate 'is presently commented out

    'the form currently appears on screen at first Activate event
    'I have tried uncommenting, but it has not helped

End Sub

I can get close to what I describe, but not properly accurately.

Does one have to use API GetDeviceCaps in Lib GDI32 etc, as per ref 2 ?

I want the code to work on different devices and resolutions etc as others will use the app.

Answer 1

@Matthieu - Thank you for the helpful comment, and the web reference.

As a result of your help, I now understand everything much better. I've now got something that works, and can post an answer to my own question.

The code below repositions a UserForm accurately on or near any worksheet range in the ActiveWindow. It adjusts to the user's display settings (as it should). I've seen other posts searching for this kind of thing, so here is an offering.

To test it, add a UserForm and a standard Module to a new project The UserForm needs Label1 and CommandButton1. When the form is loaded, keep pressing Enter - until you're bored.

Userform code

 Option Explicit

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


Private Sub CommandButton1_Click()

Dim R As Long, C As Long
Dim X As Long, Y As Long
Dim i As Long, Cell As Range

'H and W are > 1 for test purposes only
Const H As Long = 3
Const W As Long = 5

    'test Randomizing starts
    'move the ActiveWindow around
    R = Int((5 * Rnd) + 1)    ' Generate random value between arg2 and arg1.
    C = Int((20 * Rnd) + 1)
    Set Cell = Cells(R, C)

    ActiveWindow.ScrollRow = R:    ActiveWindow.ScrollColumn = C

    'activate a random cell in the window
    X = Int((6 * Rnd) + 8): Y = Int((6 * Rnd) + 1)
    Cell.Offset(X, Y).Activate

    Me.Label1 = "Window at " & Cell.Address(False, False, xlA1) & ", " _
                             & Cell.Address(True, True, xlR1C1) _
               & vbLf _
               & "ActiveCell @ Window Offset " _
               & Cell.Offset(X, Y).Address(False, False, xlR1C1, , Cell)
    'randomizing ends
    ActiveCell.Resize(H, W).Select


    '====================================
    'Move the UserForm near to ActiveCell
Dim rc As RECT
    On Error GoTo done
    Call GetRangeRect(ActiveCell.Resize(H, W), rc)
done:
    Me.Top = PXtoPT(rc.Top, True)       'place form at offset(0,1)
    Me.Left = PXtoPT(rc.Right, False)
    '====================================

End Sub


Private Sub UserForm_Activate()

    Dim AppXCenter As Long, AppYCenter As Long
    AppXCenter = Application.Left + (Application.Width / 2)
    AppYCenter = Application.Top + (Application.Height / 2)

    With Me
        .StartUpPosition = 0    '- necessary if extending the VBE to a 2nd monitor
        .Top = AppYCenter - (Me.Height / 2)
        .Left = AppXCenter - (Me.Width / 2)
        If .Top < 0 Then .Top = 0
        If .Left < 0 Then .Left = 0

    End With

End Sub

Private Sub UserForm_Initialize()
    With Me.Label1
        .WordWrap = False
        .AutoSize = True
        .Left = 6
    End With
    Randomize    ' Initialize the generator.
End Sub

Module code

Option Explicit
'Moves a UserForm accurately onto or near a Worksheet Range
'Adapts to the host hardware and settings

'Original code at MrExcel.COM question 765416 
'https://www.mrexcel.com/forum/excel-questions/765416-how-get-x-y-screen-coordinates-excel-cell-range.html
'added new Function PXtoPT, returning Points as Single (similar style to PTtoPX)
'NB x64 PtrSafe options NOT coded


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

Private Declare Function GetDC Lib "user32" ( _
  ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
  ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
  ByVal nIndex As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
  ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" ( _
  ) As Long


Private Function ScreenDPI(bVert As Boolean) As Long
  'in most cases this simply returns 96
  Static lDPI&(1), lDC&
  If lDPI(0) = 0 Then
    lDC = GetDC(0)
    lDPI(0) = GetDeviceCaps(lDC, 88&)    'horz
    lDPI(1) = GetDeviceCaps(lDC, 90&)    'vert
    lDC = ReleaseDC(0, lDC)
  End If
  ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
  PTtoPX = Points * ScreenDPI(bVert) / 72
End Function

Function PXtoPT(Pixels As Long, bVert As Boolean) As Single
'new function added
  PXtoPT = Pixels / ScreenDPI(bVert) * 72
End Function

Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
  Dim wnd               As Window

  'requires additional code to verify the range is visible
  'etc.

  Set wnd = rng.Parent.Parent.Windows(1)
  With rng
    rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) _
              + wnd.PointsToScreenPixelsX(0)
    rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) _
             + wnd.PointsToScreenPixelsY(0)
    rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) _
               + rc.Left
    rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) _
                + rc.Top
  End With
End Sub

Sub GetCoordinateXY()
Dim rc As RECT

Dim X, Y                            'PIXELS, not points
Dim Xpt As Single, Ypt As Single    'POINTS, not pixels
    On Error GoTo done
    Call GetRangeRect(ActiveCell, rc)
    X = rc.Left
    Y = rc.Top
    'ADDED
    Xpt = PXtoPT(rc.Left, False)
    Ypt = PXtoPT(rc.Top, True)

done:
End Sub

I just hope this helps others, just as guys like Matthieu have helped me.