How do I align a UserForm next to the active cell?

The answer provided by J. Garth did a great job explaining things, however, as I mentioned in my comments, while it works for this specific situation, it fails on various other scenarios (e.g. zoom level changes, split/frozen panes with the target range outside the sheet's initial visible range), not to mention that it doesn't take into account the header row/column (that are also subject to zoom level changes) and the 3D "frame/border" around a form when setting the position.

I spent a few days looking for a complete answer to cover all possibilities, and the only one that set a form's position very close to the correct one in almost all scenarios was this one by nerv, written as a result of this discussion on MSDN forums - most of the credit goes to him, obviously. I "merged" it with other bits of information and code from various other sources in order to avoid hardcoded variables, make the code 32bit and 64bit compatible and cover the mysterious 3D frame around the form issue.

Sheet code

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    UserForm1.Show
End Sub

Userform code

Private Sub UserForm_Initialize()
  Dim pointcoordinates As pointcoordinatestype, horizontaloffsetinpoints As Double, verticaloffsetinpoints As Double
    With Me
        horizontaloffsetinpoints = (.Width - .InsideWidth) / 2
        verticaloffsetinpoints = 1 
        Call GetPointCoordinates(ActiveCell, pointcoordinates)
        .StartUpPosition = 0
        .Top = pointcoordinates.Top - verticaloffsetinpoints
        .Left = pointcoordinates.Left - horizontaloffsetinpoints
    End With
End Sub

Module code

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Public Type pointcoordinatestype
    Left As Double
    Top As Double
    Right As Double
    Bottom As Double
End Type
Private pixelsperinchx As Long, pixelsperinchy As Long, pointsperinch As Long, zoomratio As Double
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) 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
#Else
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    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
#End If

Private Sub ConvertUnits()
  Dim hdc As LongPtr
    hdc = GetDC(0)
    pixelsperinchx = GetDeviceCaps(hdc, LOGPIXELSX) ' Usually 96
    pixelsperinchy = GetDeviceCaps(hdc, LOGPIXELSY) ' Usually 96
    ReleaseDC 0, hdc
    pointsperinch = Application.InchesToPoints(1)   ' Usually 72
    zoomratio = ActiveWindow.Zoom / 100
End Sub

Private Function PixelsToPointsX(ByVal pixels As Long) As Double
    PixelsToPointsX = pixels / pixelsperinchx * pointsperinch
End Function

Private Function PixelsToPointsY(ByVal pixels As Long) As Double
    PixelsToPointsY = pixels / pixelsperinchy * pointsperinch
End Function

Private Function PointsToPixelsX(ByVal points As Double) As Long
    PointsToPixelsX = points / pointsperinch * pixelsperinchx
End Function

Private Function PointsToPixelsY(ByVal points As Double) As Long
    PointsToPixelsY = points / pointsperinch * pixelsperinchy
End Function

Public Sub GetPointCoordinates(ByVal cellrange As Range, ByRef pointcoordinates As pointcoordinatestype)
  Dim i As Long
    ConvertUnits
    Set cellrange = cellrange.MergeArea
    For i = 1 To ActiveWindow.Panes.Count
        If Not Intersect(cellrange, ActiveWindow.Panes(i).VisibleRange) Is Nothing Then
            pointcoordinates.Left = PixelsToPointsX(ActiveWindow.Panes(i).PointsToScreenPixelsX(cellrange.Left))
            pointcoordinates.Top = PixelsToPointsY(ActiveWindow.Panes(i).PointsToScreenPixelsY(cellrange.Top))
            pointcoordinates.Right = pointcoordinates.Left + cellrange.Width * zoomratio
            pointcoordinates.Bottom = pointcoordinates.Top + cellrange.Height * zoomratio
            Exit Sub
        End If
    Next
End Sub

Most of the things above are self-explanatory, and they work flawlessly - at least from what I've been able to test. The only thing that still bothers me a bit (yeah, I know, but I'm a perfectionist) is that for some reason the form frame isn't exactly on the desired cell gridline (i.e. it's 1px lower) for odd numbered rows (while it all goes smooth for even numbered ones). If anyone can figure out why, please share this mystery with me, as I doubt that it's a simple rounding issue...

EDIT: Today, while working with Timers, I figured out how to avoid the differences between odd and even numbered rows that occured above: it was just a matter of declaring point values and outputs (as well as the zoom ratio) As Double (i.e. floating-point numbers) instead of As Long (i.e. integers). Silly mistake from my part - I've properly edited the code to correct it. I've added a verticaloffsetinpoints variable to adjust the curious (but this time consistent) "1px lower than expected" vertical glitch that I couldn't find an explanation for (yet).


Question 1: I have the UserForm StartUpPosition property set to 0 - Manual - is this correct? Yes, it's correct. In the code below, I am setting this property in the code.

Question 2: When I click any cell in the specified range, for the first time after opening the workbook, the UserForm always opens in the far top left corner of the screen. Why? I think the answer to this is somewhat related to question #3. That would seem to be a default location for the form to open in. The way you have the code now, trying to set the form top and left coordinates in the Worksheet_SelectionChange event is not working because the coordinates are never actually getting set. The setting of the coordinates needs to be moved to the userform initialization event.

Question 3: When I click any cell in the specified range, for any clicks after the first, the UserForm opens relative to the previous cell that was active, instead of the one I just clicked. How do I get it to open relative to the cell just clicked, instead of relative to the previous active cell? This problem is also related to the code being in the wrong place. As noted above, the coordination setting needs to take place in the userform initialization event. As to why it's referencing the previous active cell, my guess would be that the active cell doesn't actually get changed until after the worksheet selection change event completes. So since you are trying to set the coordinates within this event (i.e. - before the event finishes), you are getting the previously active cell. Again, moving the code to the correct location fixes this issue.

Question 4: Why does it appear to align the bottom of the UserForm instead of the top? There appears to be a difference between the definition of "top" when it comes to cells (ranges) vs userforms. The top of the cell is measured from the first row whereas the top of the userform seems to be measured from the top of the Excel application. So in over words, if activecell.top and userform.top are both equal to 144, they will be different locations on the screen. This is because the top of activecell is 144 points down from the first row in the Excel spreadsheet while the top of the userform is 144 points down from the top of the Excel application (i.e. - the top of the Excel window), which is higher on the screen because the starting point (top of the Excel window) is higher than the starting point for activecell.top (first row in the spreadsheet). We can adjust for that by adding the height of the userform plus the height of the active cell to the top coordinate.

Sheet module code

Private Sub Worksheet_SelectionChange(ByVal target As Range)

    Dim oRange As Range

    Set oRange = Range("B3:C2000")
    If Not Intersect(target, oRange) Is Nothing Then
        frmCalendar.Show
    End If

End Sub

Userform code

Private Sub UserForm_Initialize()

    With Me
        .StartUpPosition = 0
        .Top = ActiveCell.Top + ActiveCell.Height + .Height
        .Left = ActiveCell.Offset(0, 1).Left
    End With

End Sub

Tags:

Excel

Vba