Binaryworld - Split menu into multiple columns if dont fit and Auto Mouse move/click ... [ VB -> Menu ]

This code is a combo of two great piece of code. From this example you will learn the following items

- How to generate various mouse events using mouse_event API
- How display shortcut menu created at runtime using CreatePopupMenu and TrackPopupMenu APIs
- How to use MF_MENUBARBREAK flag to split Menu into several columns if total height of menu exceeds than user defined limit.

The whole example is well documeted so I think you wont have any problem to understand it.

Step-By-Step Example

- Create a standard exe project
- Add one command button, one textbox (MultiLine=True and ScroolBar=Both) and one timer control on the form1
- Add the following code in form1

Click here to copy the following block

Option Explicit

Const MF_UNCHECKED = &H0&
Const MF_CHECKED = &H8&
Const MF_DISABLED = &H2&
Const MF_GRAYED = &H1&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const MF_POPUP = &H10&
Const MF_BYCOMMAND = &H0&
Const MF_MENUBARBREAK = &H20&
Const MF_BYPOSITION = &H400&

Const TPM_LEFTALIGN = &H0&
Const TPM_RETURNCMD = &H100& '//This flag will return menu item after popup item is clicked
Const TPM_NONOTIFY = &H80&

Private Declare Function GetCursorPos Lib "user32" ( _
    lpPoint As POINTAPI) As Long

Private Declare Function ClientToScreen Lib "user32" ( _
    ByVal hwnd As Long, _
    lpPoint As POINTAPI) As Long

Private Declare Sub mouse_event Lib "user32" ( _
    ByVal dwFlags As Long, _
    ByVal dx As Long, _
    ByVal dy As Long, _
    ByVal cButtons As Long, _
    ByVal dwExtraInfo As Long)

Private Declare Function CreatePopupMenu Lib "user32" () As Long

Private Declare Function TrackPopupMenu Lib "user32" ( _
    ByVal hMenu As Long, _
    ByVal wFlags As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nReserved As Long, _
    ByVal hwnd As Long, _
    ByVal lprc As Any) As Long

Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" ( _
    ByVal hMenu As Long, _
    ByVal wFlags As Long, _
    ByVal wIDNewItem As Long, _
    ByVal lpNewItem As Any) As Long

Private Declare Function DestroyMenu Lib "user32" ( _
    ByVal hMenu As Long) As Long

Private Declare Function GetMenuItemRect Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal hMenu As Long, _
    ByVal uItem As Long, _
    lprcItem As RECT) As Long

Private Declare Function GetSystemMetrics Lib "user32" ( _
    ByVal nIndex As Long) As Long

Const SM_CYMENU = 15     'Height of menu

Enum enumMouseEvents
  MOUSEEVENTF_MOVE = &H1 ' mouse move
  MOUSEEVENTF_LEFTDOWN = &H2  ' left button down
  MOUSEEVENTF_LEFTUP = &H4 ' left button up
  MOUSEEVENTF_RIGHTDOWN = &H8  ' right button down
  MOUSEEVENTF_RIGHTUP = &H10  ' right button up
  MOUSEEVENTF_MIDDLEDOWN = &H20  ' middle button down
  MOUSEEVENTF_MIDDLEUP = &H40  ' middle button up
  MOUSEEVENTF_WHEEL = &H800 ' wheel button rolled
  MOUSEEVENTF_ABSOLUTE = &H8000  ' absolute move
End Enum

Private Type POINTAPI
  x As Long
  y As Long
End Type

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

Const MAX_MENU_ITEMS = 50

Dim hMenu As Long, iCnt As Long

'//destX and destY are new mouse cordinate (Must be in pixel) where mouse pointer will be shifted
Sub FireMouseEvent(Optional EventFlag As enumMouseEvents = MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, _
    Optional destX = 0, Optional destY = 0, _
    Optional NumMoves = 200, Optional hWndClient As Long = 0)

  Dim pt As POINTAPI
  Dim cur_x As Single
  Dim cur_y As Single
  Dim dest_x As Single
  Dim dest_y As Single
  Dim dx As Single
  Dim dy As Single
  Dim i As Integer

  '//mouse_event moves in a coordinate system where
  '//(0, 0) is in the upper left corner and
  '//(65535,65535) is in the lower right corner.

  ' Get the current mouse coordinates and convert
  ' them into this new system.
  GetCursorPos pt

  cur_x = pt.x * 65535 / (Screen.Width / Screen.TwipsPerPixelX)
  cur_y = pt.y * 65535 / (Screen.Height / Screen.TwipsPerPixelY)

  '//Convert the coordinates of the center of the
  pt.x = destX
  pt.y = destY

  '//When user pass hWndClient means we have to map If user pass client crdinayte
  If hWndClient <> 0 Then ClientToScreen hWndClient, pt

  dest_x = pt.x * 65535 / (Screen.Width / Screen.TwipsPerPixelX)
  dest_y = pt.y * 65535 / (Screen.Height / Screen.TwipsPerPixelY)

  '//For smooth mouse move effect
  dx = (dest_x - cur_x) / NumMoves  '//X displacement (it can be +ve or -ve)
  dy = (dest_y - cur_y) / NumMoves  '//Y displacement (it can be +ve or -ve)

  '//Only move pointer if source and destination cordinates are different and mousemove flag is set
  If (dest_x = cur_x And dest_y = cur_y) = False And (EventFlag And MOUSEEVENTF_MOVE) = MOUSEEVENTF_MOVE Then
    For i = 1 To NumMoves - 1
      cur_x = cur_x + dx
      cur_y = cur_y + dy
      mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0
      DoEvents
    Next i
  End If

  '//Move the mouse to its final destination and click it.
  mouse_event EventFlag, dest_x, dest_y, 0, 0
End Sub

Sub CreateTestPopup()
  Dim i, mHeight As Long, fHeight As Long, sM As Long
  Dim R As RECT

  hMenu = CreatePopupMenu() '//Popup menu

  Me.ScaleMode = vbPixels

  mHeight = 0
  fHeight = Me.ScaleHeight

  '//Get Single menu item height
  '//Note: Actually you can use GetMenuItemRect to get single menu item area but
  '//it does not work before TrackPopupMenu so alternate function is GetSystemMetrics
  sM = GetSystemMetrics(SM_CYMENU)

  For i = 0 To MAX_MENU_ITEMS - 1
    '//If menu height exceeds than form height then split the menu
    If (mHeight > fHeight) Then
      mHeight = 0   '//Reset height variable
      '//maximum height of popup sud me height of form if it exceeds then break in a new column
      AppendMenu hMenu, MF_STRING Or MF_MENUBARBREAK Or MF_BYCOMMAND, ByVal i, "Item-" & CStr(i)
    Else
      AppendMenu hMenu, MF_STRING Or MF_BYCOMMAND, ByVal i, "Item-" & CStr(i)
    End If
    '//Update menu height variable
    mHeight = mHeight + sM
  Next

End Sub

Private Sub Command1_Click()
  Dim pt As POINTAPI, ClickedItem

  Me.ScaleMode = vbPixels '//We must use Pixel scale to use with Win32 API
  pt.x = Command1.Left
  pt.y = Command1.Top + Command1.Height  '//Left bottom of command button

  ClientToScreen Me.hwnd, pt  '//Convert this cordinates to screen cordinates

  CreateTestPopup

  '//Popup menu has modal behaviour so you cant execute next line after TrackPopupMenu
  '//until user select or cancel the popup menu

  Timer1.Interval = 300
  Timer1.Enabled = True
  iCnt = 0         '//Note: Menu item positions starts with 0 (i.e position of 1st item is 0)
  ClickedItem = TrackPopupMenu(hMenu, TPM_RETURNCMD Or TPM_LEFTALIGN, pt.x, pt.y, 0, Me.hwnd, ByVal 0&)
  If ClickedItem > 0 Then MsgBox "Clicked : Item #" & ClickedItem
  Timer1.Enabled = False
End Sub

'//Now we will do some automatic mouse events (i.e mouse move, click etc..)
Sub AutoMouseDemo(Optional PickMouseItem = 0, Optional DoClick As Boolean = False)
  Dim R As RECT, pt As POINTAPI, i As Integer
  'If PickMouseItem = 0 Then PickMouseItem = Rnd * MAX_MENU_ITEMS

  'ClientToScreen Me.hwnd, pt
  '//Get Rect bound of Menu item so we cam move mouse cursor on that item
  If (GetMenuItemRect(0, hMenu, PickMouseItem, R)) = 0 Then Exit Sub

  '//Get Center point of menu item
  pt.x = R.Left + (R.Right - R.Left) / 2
  pt.y = R.Top + (R.Bottom - R.Top) / 2

  '//Simulate mouse move/click event
  Dim EventFlag As enumMouseEvents

  If DoClick = True Then
    EventFlag = MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE + MOUSEEVENTF_LEFTDOWN + MOUSEEVENTF_LEFTUP
  Else
    EventFlag = MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE
  End If

  FireMouseEvent EventFlag, pt.x, pt.y, 1
  If DoClick = False Then
    LogEvent "Mouse Move >> Item-" & PickMouseItem & " (" & pt.x & "," & pt.y & ")"
  Else
    LogEvent "Mouse Click >> Item-" & PickMouseItem & " (" & pt.x & "," & pt.y & ")"
  End If
End Sub

Sub LogEvent(strMsg As String)
  Text1 = strMsg & vbCrLf & Text1
End Sub

Private Sub Form_Unload(Cancel As Integer)
  DestroyMenu hMenu
End Sub

Private Sub Timer1_Timer()
  If iCnt >= MAX_MENU_ITEMS Then Timer1.Enabled = False: iCnt = 0
  If iCnt = 10 Then
    AutoMouseDemo iCnt, True  '//Simulate click when its item #25
  Else
    AutoMouseDemo iCnt '//Simulate mouse move for all other items
  End If
  iCnt = iCnt + 1
End Sub

- Press F5 to run the project
- Click on the command1 and watch the automatic movement of mouse cursor.