CODEWITHSUNDEEP
vbaexceluserform
Szybki
Szybki

Reputation: 1111

VBA How to display UserForm right under the cell?

I want to display UserForm right under the button that is placed in cell so it can simulate some popup window (just like dropdown list).

I tried many solutions over the net and none of them worked. The main problem is I'm not able to get the absolute screen location of cell or button on sheet.

Upvotes: 1

Views: 5202

Answers (3)

Yoghurt
Yoghurt

Reputation: 11

this modifaction makes it work with Panes if you freeze certain rows and columns :

Public Sub FormShow(ByVal objForm As Object, ByVal Rng As Range)
    Dim L As Single, T As Single

    If ActiveWindow.FreezePanes Then
       L = ActiveWindow.Panes(GetPanesIndex(Rng)).PointsToScreenPixelsX(Rng.Left)
       T = ActiveWindow.Panes(GetPanesIndex(Rng)).PointsToScreenPixelsY(Rng.Top + Rng.Height)
    Else
       L = ActiveWindow.ActivePane.PointsToScreenPixelsX(Rng.Left)
       T = ActiveWindow.ActivePane.PointsToScreenPixelsY(Rng.Top + Rng.Height)
    End If

    ConvertPixelsToPoints L, T

    With objForm
       .StartUpPosition = 0
       .Left = L
       .Top = T
       .Show
    End With

End Sub


Function GetPanesIndex(ByVal Rng As Range) As Integer
    Dim sr As Long:          sr = ActiveWindow.SplitRow
    Dim sc As Long:          sc = ActiveWindow.SplitColumn
    Dim r As Long:            r = Rng.Row
    Dim c As Long:            c = Rng.Column
    Dim Index As Integer: Index = 1

    Select Case True
    Case sr = 0 And sc = 0: Index = 1
    Case sr = 0 And sc > 0 And c > sc: Index = 2
    Case sr > 0 And sc = 0 And r > sr: Index = 2
    Case sr > 0 And sc > 0 And r > sr: If c > sc Then Index = 4 Else Index = 3
    Case sr > 0 And sc > 0 And c > sc: If r > sr Then Index = 4 Else Index = 2
    End Select

    GetPanesIndex = Index
End Function


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 FormShow UserForm1, Target

 SetForegroundWindow (Application.hWnd)  
 ' aktivates Application window
 ' so Cellselection by key is possible
 ' -> Userform moves with Arrow keys not only mouse selection
End Sub

Upvotes: 1

Fadi
Fadi

Reputation: 3322

Try this in new module:

Option Explicit

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 GetDeviceCaps Lib "gdi32" ( _
    ByVal hDC As Long, _
    ByVal nIndex As Long) As Long

Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Const TWIPSPERINCH = 1440

Sub ConvertPixelsToPoints(ByRef x As Single, ByRef y As Single)
    Dim hDC As Long
    Dim RetVal As Long
    Dim XPixelsPerInch As Long
    Dim YPixelsPerInch As Long

    hDC = GetDC(0)
    XPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
    YPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
    RetVal = ReleaseDC(0, hDC)
    x = x * TWIPSPERINCH / 20 / XPixelsPerInch
    y = y * TWIPSPERINCH / 20 / YPixelsPerInch
End Sub

Sub FormShow(ByVal objForm As Object, ByVal Rng As Range)    
    Dim L As Single, T As Single        

    L = ActiveWindow.ActivePane.PointsToScreenPixelsX(Rng.Left)
    T = ActiveWindow.ActivePane.PointsToScreenPixelsY(Rng.Top + Rng.Height)
    ConvertPixelsToPoints L, T

    With objForm
       .StartUpPosition = 0           
       .Left = L
       .Top = T  
       .Show          
    End With

End Sub

Sub test()
 FormShow UserForm1, ActiveCell
End Sub

To test it add BeforeRightClick event:

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 FormShow UserForm1, Target
 Cancel = True
End Sub

Now if you Right Click any cell in this worksheet the UserForm1 will show under this cell.

Notes:

  • This will not work on RightToLeft Worksheet and I failed to make it works.
  • I found ConvertPixelsToPoints here.

Upvotes: 2

SierraOscar
SierraOscar

Reputation: 17627

You would use something of this logic:

Sub SO()

With UserForm1
    .StartUpPosition = 0
    .Top = Application.Top + (ActiveSheet.Shapes(Application.Caller).Top + 170)
    .Left = Application.Left + (ActiveSheet.Shapes(Application.Caller).Left + 25)
    .Show
End With

End Sub

And your button would call the sub SO()

Upvotes: 2

Related Questions