Question

我想在放置在单元格中的按钮下方显示UserForm，这样它就可以模拟一些弹出窗口（就像下拉列表一样）。

我在网上尝试了很多解决方案，但没有一个能够解决问题。主要问题是我无法在工作表上获得单元格或按钮的绝对屏幕位置。

Answer 1

你会使用这种逻辑：

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

您的按钮会调用子SO()

Answer 2

在新模块中尝试：

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

要测试它，请添加BeforeRightClick事件：

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

现在，如果您Right Click此工作表中的任何单元格，UserForm1将显示在此单元格下。

注意：

这不适用于RightToLeft工作表，但我无法使其正常工作。
我找到了ConvertPixelsToPoints here。

Answer 3

这种改进使其有效与Panes 如果你冻结某些行和列：

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

VBA如何在单元格下显示UserForm？

3 个答案: