CODEWITHSUNDEEP
excelvba
Tomasz
Tomasz

Reputation: 426

Userform.show on cursor position

i wish to create code that will open form at any form object by mouse hover. For now i have form.show and unload form on mousemove event.

example

I can add some variable to each object to recognize their position on window and define top left like on example

Private Sub UserForm_Initialize()
If par_hoverForm = uf_Generator.com_MaxQty.Name Then
    Me.Top = Application.Top + uf_Generator.Top + uf_Generator.fr_settings.Top + uf_Generator.com_MaxQty.Top + uf_Generator.com_MaxQty.Height + 30
    Me.Left = uf_Generator.Left + uf_Generator.fr_settings.Left + uf_Generator.com_MaxQty.Left + 10
End If
End Sub

but is it possible to form.show at cursor position + some offset? this code getting cursor coordinates but i dont know how to convert it to top/left.

#If VBA7 Then
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
' Create custom variable that holds two integers
Type POINTAPI
   Xcoord As Long
   Ycoord As Long
End Type

Sub GetCursorPosDemo()
Dim llCoord As POINTAPI
' Get the cursor positions
GetCursorPos llCoord
' Display the cursor position coordinates
MsgBox "X Position: " & llCoord.Xcoord & vbNewLine & "Y Position: " & llCoord.Ycoord
End Sub

any advice are welcome

Upvotes: 1

Views: 3574

Answers (1)

Christofer Weber
Christofer Weber

Reputation: 1474

I will show you one way to do it, which should allow you to customize it to your needs.

First, this is the base code to convert the pixels to point and move an object to the pointer. I've set it to be called with another object, but obviously you can code a specific object in there:

Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Public Sub position(this As Object)

    Dim lngCurPos As POINTAPI
    Dim DocZero As POINTAPI
    Dim PointsPerPixelY As Double
    Dim PointsPerPixelX As Double
    Dim hdc As Long
        
    hdc = GetDC(0)
    PointsPerPixelY = 72 / GetDeviceCaps(hdc, 90)
    PointsPerPixelX = 72 / GetDeviceCaps(hdc, 88)
    ReleaseDC 0, hdc
    
    DocZero.Y = ActiveWindow.PointsToScreenPixelsY(0)
    DocZero.X = ActiveWindow.PointsToScreenPixelsX(0)
    
    GetCursorPos lngCurPos

    this.Top = (lngCurPos.Y - DocZero.Y) * PointsPerPixelY
    this.Left = (lngCurPos.X - DocZero.X) * PointsPerPixelX

End Sub

This worked well for my little test object, but not quite for my form. For my form, I changed the last two rows to: (Your Mileage May Vary)

this.Top = (lngCurPos.Y - DocZero.Y) * PointsPerPixelY + this.Height * 2.2
this.Left = (lngCurPos.X - DocZero.X) * PointsPerPixelX - this.Width / 2.5

Then, in my Form1 TextBox, I use Call position(UserForm2) in the MouseMove event to update the position of UserForm2 constantly.

One problem I had, was that I was also calling UserForm2.show, which kept resetting the position, making it jump around.
To get around this, I added another function:

Public Function IsLoaded(formName As String) As Boolean
Dim frm As Object
For Each frm In VBA.UserForms
    If frm.Name = formName Then
        IsLoaded = True
        Exit Function
    End If
Next frm
IsLoaded = False
End Function

And then my UserForm1 Code looks like this:

Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Not IsLoaded("UserForm2") Then UserForm2.show
Call position(UserForm2)
End Sub

I did not add any code to remove Form2 again, since you have that already. This was my result:

enter image description here

Upvotes: 1

Related Questions