Show UserForm near active cell - 64-bit version

[Artik]

I use the 32-bit version of Office on a daily basis. For many years I have been using the following code to display the UserForm close to the clicked cell. And it works properly.

Option Explicit

Private Declare PtrSafe Function FindWindowExA Lib "User32" _
        (ByVal Hwnd As LongPtr, _
         ByVal HChildAfter As LongPtr, _
         ByVal lpsz1 As String, _
         ByVal lpsz2 As Any) As LongPtr

Private Declare PtrSafe Function GetWindowRect Lib "User32" _
        (ByVal Hwnd As LongPtr, _
         ByRef lpRect As RECT) As LongPtr

Private Declare PtrSafe Function SendInput Lib "User32" _
        (ByVal nInputs As Long, _
         ByRef pInputs As GENERAL_INPUT, _
         ByVal cbSize As Long) As Long

Private Declare PtrSafe Sub RtlMoveMemory Lib "Kernel32" _
        (ByRef pDst As Any, _
         ByRef pSrc As Any, _
         ByVal ByteLen As LongPtr)

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

Private Type KEYBDINPUT
    wVk             As Integer
    wScan           As Integer
    dwFlags         As Long
    time            As Long
    dwExtraInfo     As Long
End Type

Private Type GENERAL_INPUT
    dwType          As Long
    dwData(23)      As Byte
End Type


Private Sub Worksheet_BeforeRightClick _
        (ByVal Target As Range, Cancel As Boolean)
    Dim Hwnd        As LongPtr
    Dim Rec         As RECT
    Dim pxWidth     As Long
    Dim Ratio       As Double
    Dim acc         As IAccessible

    Dim KInput      As KEYBDINPUT
    Dim GInput(3&)  As GENERAL_INPUT
    Dim b           As Boolean
    Dim i           As Long

    Cancel = True

    For i = 0 To UBound(GInput)
        GInput(i).dwType = 1&
    Next

    KInput.wVk = vbKeyF2
    KInput.dwFlags = 0&
    RtlMoveMemory GInput(0&).dwData(0&), KInput, Len(KInput)
    KInput.dwFlags = 2&
    RtlMoveMemory GInput(1&).dwData(0&), KInput, Len(KInput)

    KInput.wVk = vbKeyEscape
    KInput.dwFlags = 0&
    RtlMoveMemory GInput(2&).dwData(0&), KInput, Len(KInput)
    KInput.dwFlags = 2&
    RtlMoveMemory GInput(3&).dwData(0&), KInput, Len(KInput)

    With Application
        b = .EditDirectlyInCell
        .EditDirectlyInCell = True
    End With

    SendInput 4&, GInput(0&), Len(GInput(0&))
    DoEvents

    Application.EditDirectlyInCell = b

    Hwnd = FindWindowExA(Application.Hwnd, 0&, "XLDESK", 0&)
    Hwnd = FindWindowExA(Hwnd, 0&, "EXCEL6", 0&)
    GetWindowRect Hwnd, Rec

    Set acc = UserForm1
    Set acc = acc.accParent
    acc.accLocation 0&, 0&, pxWidth, 0&, 0&

    With UserForm1
        .StartUpPosition = 0&
        Ratio = .Width / pxWidth
        .Left = (Rec.Left - 1) * Ratio + Target(1).Width
        .Top = (Rec.Top - 1) * Ratio + Target(1).Height
        .Show 0&
    End With

End Sub

Recently, however, I have a need to use this code in the 64-bit version. It seems that after adjusting the API function declarations for the 64-bit version, the code should work the same as in the 32-bit version. Unfortunately, it doesn't.
I don't know much about Win API functions, but I understand roughly the operation of these two lines

    Hwnd = FindWindowExA(Hwnd, 0&, "EXCEL6", 0&)
    GetWindowRect Hwnd, Rec

The first line returns a handle to the window descendant of the "EXCEL6" class window (in this case, a programmatically edited cell for a while). This mechanism of operation I do not understand. How is the descendant, i.e. the edited cell, determined? The second line of code returns the dimensions and location of this cell (in pixels).
In the 64-bit version, this piece of code does not work properly. Left and Right always get a value of zero, while Top and Bottom get the same values (perhaps the height of the ribbon). I conclude that the dimensions of the programmatically edited cell were not read.

Could someone explain what the problem is? Alternatively, suggest another solution that works in the 64-bit version.

Best regards

Artik

 

[Micron]

ByRef lpRect As RECT) As LongPtr
Not every variable or return type needs to be converted. From what I see, that should be ByRef lpRect As RECT) As Long, which may be your issue.
See

Office Talk: Working with VBA in the 32-bit and 64-bit Versions of Office 2010

learn.microsoft.com

Probably better to have one code version as shown there, rather than maintain 2 versions.

 

[Jaafar Tribak]

Forcing excel into Edit mode with SendInput in order to fetch the location of the EXCEL6 and then setting the form's position accordingly is not nice and may not yield consistent results and is unecessarly over complicating what can be achieved more easily simply by getting the screen position of the Target range.

Use this much simpler and consistent code :

Option Explicit

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

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

#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    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
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    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
#End If


Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

    Const SWP_NOSIZE = &H1, SWP_NOACTIVATE = &H10, SWP_SHOWWINDOW = &H40
    Dim hForm As LongPtr, tTargetRect As RECT
   
    Cancel = True
    Call IUnknown_GetWindow(UserForm1, VarPtr(hForm))
    tTargetRect = GetRangeRect(Target)
    With tTargetRect
        Call SetWindowPos( _
             hForm, NULL_PTR, .Left, .Top, _
             0&, 0&, SWP_SHOWWINDOW + SWP_NOSIZE _
        )
    End With
   
End Sub

Private Function GetRangeRect(ByVal obj As Object) As RECT
    Dim oPane  As Pane
    Set oPane = ThisWorkbook.Windows(1&).ActivePane

    With GetRangeRect
        .Left = oPane.PointsToScreenPixelsX(obj.Left - 1&)
        .Top = oPane.PointsToScreenPixelsY(obj.Top)
        .Right = oPane.PointsToScreenPixelsX(obj.Left + obj.Width)
        .Bottom = oPane.PointsToScreenPixelsY(obj.Top + obj.Height)
    End With
End Function

 

[Artik]

From what I see, that should be ByRef lpRect As RECT) As Long, which may be your issue.

You are right that the declaration was wrong (Ah that iniquitous ChatGPT). Nevertheless, the corrected version did not make the code work properly.

Artik

 

[Artik]

Hi Jaafar, I was waiting for you.

I was aware of the imperfections of the previous code. You know, when a person doesn't have any knowledge of something, he sits quietly and is happy to have something that works for him at all.
In the past, I spent many hours looking for a better solution, but I didn't come across anything close to your proposal. So I had to settle for what I found. Until the needs changed.
Your solution works won-der-fully! I took the liberty of modifying the GetRangeRect function a little to make it easier to control where the form is displayed.

Private Function GetRangeRect(ByVal obj As Object, Optional OffsetX, Optional OffsetY) As RECT
    Dim oPane       As Pane
    Dim OfstX As Single, OfstY As Single

    OfstX = IIf(IsMissing(OffsetX), 0, OffsetX)
    OfstY = IIf(IsMissing(OffsetY), 0, OffsetY)

    Set oPane = ThisWorkbook.Windows(1&).ActivePane

    With GetRangeRect
        .Left = oPane.PointsToScreenPixelsX(obj.Left - 1& + OfstX)
        .Top = oPane.PointsToScreenPixelsY(obj.Top + OfstY)
        .Right = oPane.PointsToScreenPixelsX(obj.Left + obj.Width)
        .Bottom = oPane.PointsToScreenPixelsY(obj.Top + obj.Height)
    End With
End Function

Various suggestions for calling the function:

    tTargetRect = GetRangeRect(Target)
    tTargetRect = GetRangeRect(Target, Target.Width, Target.Height)
    tTargetRect = GetRangeRect(Target, , Target.Height)
    tTargetRect = GetRangeRect(Target, 25, 30)

Thank you very much for this code.
Regards

Artik

 

[Jaafar Tribak]

@Artik

I took the liberty of modifying the GetRangeRect function a little to make it easier to control where the form is displayed.

I like the idea but I would declare the Optional arguments as Long (Not Variant). It is quicker, more efficient and requires less code as you don't need to use IsMissing.

Also, I think, PointsToScreenPixels converts its arguments to Long, so no need to use Single either.

Private Function GetRangeRect(ByVal obj As Object, Optional OffsetX As Long, Optional OffsetY As Long) As RECT
    Dim oPane As Pane

    Set oPane = ThisWorkbook.Windows(1&).ActivePane
    With GetRangeRect
        .Left = oPane.PointsToScreenPixelsX(obj.Left - 1& + OffsetX)
        .Top = oPane.PointsToScreenPixelsY(obj.Top + OffsetY)
        .Right = oPane.PointsToScreenPixelsX(obj.Left + obj.Width)
        .Bottom = oPane.PointsToScreenPixelsY(obj.Top + obj.Height)
    End With
End Function

 

[Artik]

Now that I look at it, I come to the conclusion that I overdid it with these Variants. Actually, in this case a numeric type would be better, but Single because we will be passing values in points, not pixels.
..::Edit
I didn't see your post edit.
::..

Artik