CreatePopupMenu Class with Multiple Screens

Hi all,
I have been using the PopUp Class below that was originally in Visual Basic 4 (16 Bit). I do not know who the original author was to give kudos.
The problem I have encounter is that, when working with multiple screens, it will only find the mouse location to hook the popup menu when the excel workbook is opened in the main screen.

I find using the popup menu in the ribbon and in userforms an excellent interactive control to populate worksheets.

ClsPopUp

Code:

---

Option Explicit
Option Compare Text
Private m_hMenu As Long
Private strValue As String
'//* The Caption proporty of a Sub-menu is the option displayed on the parent menu
Public Caption As String


Private Declare PtrSafe Function SetMenuDefaultItem Lib "USER32" (ByVal hMenu As LongPtr, ByVal uItem As Long, ByVal fByPos As LongPtr) As LongPtr
'xPrivate Declare Function SetMenuDefaultItem Lib "USER32" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPos As Long) As Long
Private Declare PtrSafe Function CreatePopupMenu Lib "USER32" () As Long
'xPrivate Declare Function CreatePopupMenu Lib "USER32" () As Long
Private Declare PtrSafe Function DestroyMenu Lib "USER32" (ByVal hMenu As LongPtr) As LongPtr
'xPrivate Declare Function DestroyMenu Lib "USER32" (ByVal hMenu As Long) As Long
Private Declare PtrSafe Function AppendMenu Lib "USER32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As LongPtr, ByVal wIDNewItem As LongPtr, lpNewItem As String) As LongPtr
'xPrivate Declare Function AppendMenu Lib "USER32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, lpNewItem As String) As Long
Private Declare PtrSafe Function EnableMenuItem Lib "USER32" (ByVal hMenu As LongPtr, ByVal wIDEnableItem As LongPtr, ByVal wEnable As LongPtr) As LongPtr
'xPrivate Declare Function EnableMenuItem Lib "USER32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
Private Declare PtrSafe Function RemoveMenu Lib "USER32" (ByVal hMenu As LongPtr, ByVal nPosition As LongPtr, ByVal wFlags As LongPtr) As LongPtr
'xPrivate Declare Function RemoveMenu Lib "USER32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Private ItemCount As Long

Private Const MF_STRING = &H0&
Private Const MF_SEPARATOR = &H800&
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_POPUP = &H10&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H2&
Private Const MF_ENABLED As Long = &H0&
Private Const MF_CHECKED = &H8&

Private Const MF_BYPOSITION = &H400&
Private Const MF_REMOVE = &H1000&

Private Const APIFALSE As Long = 0

Private Declare PtrSafe Function GetCursorPos Lib "USER32" (lpPoint As POINTL) As LongPtr
'xPrivate Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTL) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "USER32" () As Long
'xPrivate Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Declare PtrSafe Function TrackPopupMenu Lib "USER32" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hWnd As Long, ByVal lprc As Long) As Long
'xPrivate 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 Long) As Long
 
 Private Declare PtrSafe Function GetWindow Lib "USER32" (ByVal hWnd As LongPtr, ByVal wCmd As Long) As Long
'Private Declare        Function GetWindow Lib "USER32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long

Private Declare PtrSafe Function GetWindowThreadProcessId Lib "USER32" (ByVal hWnd As LongPtr, lpdwProcessId As Long) As LongPtr
'xPrivate Declare Function GetWindowThreadProcessId Lib "USER32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
 'xPrivate Declare Function GetCurrentProcessId Lib "kernel32" () As Long


Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2

Private Type POINTL
    x As Long
    y As Long
End Type

Private Const TPM_RETURNCMD = &H100&
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_LEFTBUTTON = &H0&

Private Declare PtrSafe Function GetWindowRect Lib "USER32" (ByVal hWnd As LongPtr, lpRect As RECT) As LongPtr
'x Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long

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

'Public Event AddCollection(objstr, objInd)
'Public Frm As Object

Private Sub Class_Initialize()
    m_hMenu = CreatePopupMenu()
End Sub

Private Sub Class_Terminate()
    DestroyMenu m_hMenu
End Sub

'//* Returns a reference to the menu

Friend Property Get hMenu() As Long
    hMenu = m_hMenu
End Property

Public Sub RemoveItem(ByVal nID As Long)
    RemoveMenu m_hMenu, 0, MF_REMOVE Or MF_BYPOSITION
End Sub

Public Sub AddItem(ByVal nID As Long, varItem As Variant, Optional bDefault As Boolean = False, Optional bChecked As Boolean = False, Optional bDisabled As Boolean = False, Optional bGrayed As Boolean = False, Optional bNewColumn As Boolean = False)
  ' RaiseEvent Frm.AddCollection(varItem, CStr(nID))
    If TypeName(varItem) = "String" Then
        If varItem = "-" Then
            AppendMenu m_hMenu, MF_STRING Or MF_SEPARATOR, nID, ByVal vbNullString
        Else
            AppendMenu m_hMenu, MF_STRING Or IIf(bNewColumn, MF_MENUBARBREAK, 0) Or IIf(bChecked, MF_CHECKED, 0), nID, ByVal varItem
        End If
    ElseIf TypeName(varItem) = "clsPopup" Then
        Dim cSubMenu As clsPopUp
        Set cSubMenu = varItem
        AppendMenu m_hMenu, MF_STRING Or MF_POPUP Or IIf(bNewColumn, MF_MENUBARBREAK, 0), cSubMenu.hMenu, ByVal cSubMenu.Caption
    End If
    If bDefault Then SetMenuDefaultItem m_hMenu, nID, APIFALSE
    If bGrayed Then EnableMenuItem m_hMenu, nID, MF_BYCOMMAND Or MF_GRAYED
    If bDisabled Then EnableMenuItem m_hMenu, nID, MF_BYCOMMAND Or MF_DISABLED
    ItemCount = ItemCount + 1
End Sub

'//* Returns the count of items

Public Property Get Items() As Long
    Items = ItemCount
End Property

'//* Enables/Disables a single item

Public Sub GreyItem(nID, Disabled As Boolean)
    On Error Resume Next
    EnableMenuItem m_hMenu, nID, MF_BYCOMMAND Or IIf(Disabled, MF_DISABLED, MF_ENABLED)
End Sub

'//* The main procedure to display the menu and return the selection

Public Function PopUpMnu(Optional ByVal hWnd As Long = -1, Optional ByVal PopX As Long = -1, Optional ByVal PopY As Long = -1, Optional ByVal hWndOfBeneathControl As Long = -1) As Long
    Dim h As Long
    Dim x As Long
    Dim y As Long
    If hWnd = -1 Or hWnd = 0 Then
     
      ' Find the top window of current process
        Dim hDesktop As Long
        hDesktop = GetDesktopWindow()
        Dim hChild As Long
             
        '//* Find the Active Child Window
        hChild = GetWindow(hDesktop, GW_CHILD)
       
        '//* Get the ProcessID
        Dim idCurrent As Long
        idCurrent = GetCurrentProcessId()
       
        Do While hChild
            Dim idChild As Long
            GetWindowThreadProcessId hChild, idChild
            If idChild = idCurrent Then Exit Do
            hChild = GetWindow(hChild, GW_HWNDNEXT)
        Loop
        If hChild = 0 Then Err.Raise -1, "cMenu.TrackPopup", "Cannot find top window of current process!"
        h = hChild
    Else
        h = hWnd
    End If
   
  '//* Passed a default control to use as a reference point?
    If hWndOfBeneathControl <> -1 Then
        Dim rt As RECT
        GetWindowRect hWndOfBeneathControl, rt
        x = rt.Left
        y = rt.Bottom
    Else
 
 '//* else get the current Mouse position
        Dim pt As POINTL
        GetCursorPos pt
        If PopX = -1 Then x = pt.x Else: x = PopX
        If PopY = -1 Then y = pt.y Else: y = PopY
    End If
   
      '//* Show the menu.
    PopUpMnu = TrackPopupMenu(m_hMenu, TPM_RETURNCMD + TPM_LEFTALIGN + TPM_LEFTBUTTON, x, y, 0, h, 0)
End Function

---

The Module Code

Code:

---

Option Explicit
Option Compare Text

Sub ShowUserForm()
UserForm1.Show
End Sub
Public Sub PopUp()


  Dim mnu              As clsPopUp
  Dim mnuSub          As clsPopUp


  On Error GoTo Catch


  Set mnu = New clsPopUp
  Set mnuSub = New clsPopUp


  mnuSub.Caption = "Test 4 (Sub menu)"


  With mnu


      .AddItem 0, "Test 1 (Disabled)", , , True
      .AddItem 1, "Test 2 (Default)", True
      .AddItem 2, "Test 3 (Checked)", , True
      .AddItem 3, mnuSub                              '// Can also have other settings like 'Default, Checked' etc
      .AddItem 5, "-"
      .AddItem 6, "Close Menu"
  End With


  With mnuSub
      .AddItem 10, "Submenu 1"
      .AddItem 11, "Submenu 2"
      .AddItem 12, "Submenu 3"
      .AddItem 13, "Submenu 4"
      .AddItem 14, "Submenu 5 (New Column)", , , , , True
      .AddItem 15, "Submenu 6"
      .AddItem 16, "Submenu 7"


  End With
 
  '// the return value will be the value defined after the .ADDITEM
  Debug.Print mnu.PopUpMnu()


  Set mnu = Nothing
  Set mnuSub = Nothing


Catch:


End Sub

---

I have been trying to work the current monitor code into the class but to no avail.

Code:

---

Function CurrentActiveMonitor()
    Dim Monitor As String
    Monitor = Monitor & "Name:- " & Replace(Replace(Screen("DisplayName"), "\", ""), ".", "") & vbCrLf
    Monitor = Monitor & "Primary:- " & Screen("IsPrimary") & vbCrLf
    Monitor = Monitor & "Pixels X:- " & Screen("pixelsX") & vbCrLf
    Monitor = Monitor & "Pixels Y:- " & Screen("pixelsy") & vbCrLf
    Monitor = Monitor & "inches X:- " & Round(Screen("inchesX"), 2) & vbCrLf
    Monitor = Monitor & "inches Y:- " & Round(Screen("inchesY"), 2) & vbCrLf
    Monitor = Monitor & "inches Diagonal:- " & Round(Screen("inchesDiag"), 2) & vbCrLf
    Monitor = Monitor & "ppi X:- " & Round(Screen("ppiX"), 2) & vbCrLf
    Monitor = Monitor & "ppi Y:- " & Round(Screen("ppiY"), 2) & vbCrLf
    Monitor = Monitor & "dpi X:- " & Screen("dpiX") & vbCrLf
    Monitor = Monitor & "dpi Y:- " & Screen("dpiY") & vbCrLf
    Monitor = Monitor & "dpi Window:- " & Screen("dpiWin") & vbCrLf
    Monitor = Monitor & "Zoom Factor:- " & Round(Screen("zoomFac"), 2) * 100 & "%" & vbCrLf
    MsgBox Monitor, vbInformation, "Active Monitor Record Set"
End Function
Public Function Screen(Item As String)
    Dim xHSizeSq As Double, xVSizeSq As Double, xPix As Double, xDot As Double
    Dim hWnd As LongPtr, hDC As LongPtr, hMonitor As LongPtr
    Dim tMonitorInfo As MONITORINFOEX
    Dim nMonitors As Integer
    Dim vResult As Variant
    Dim sItem As String
    nMonitors = GetSystemMetrics(SM_CMONITORS)
    If nMonitors < 2 Then
        nMonitors = 1
        hWnd = 0
    Else
        hWnd = GetActiveWindow()
        hMonitor = MonitorFromWindow(hWnd, MONITOR_DEFAULTTONULL)
        If hMonitor = 0 Then
            hWnd = 0
        Else
            tMonitorInfo.cbSize = Len(tMonitorInfo)
            If GetMonitorInfo(hMonitor, tMonitorInfo) = False Then
                Debug.Print "GetMonitorInfo failed"
                hWnd = 0
            Else
                hDC = CreateDC(tMonitorInfo.szDevice, 0, 0, 0)
                If hDC = 0 Then
                    hWnd = 0
                End If
            End If
        End If
    End If
    If hWnd = 0 Then
        hDC = GetDC(hWnd)
        tMonitorInfo.dwFlags = MONITOR_PRIMARY
        tMonitorInfo.szDevice = "PRIMARY" & vbNullChar
    End If
    sItem = Trim(LCase(Item))
    Select Case sItem
    Case "horizontalresolution", "pixelsx"
        vResult = GetDeviceCaps(hDC, DevCap.HORZRES)
    Case "verticalresolution", "pixelsy"
        vResult = GetDeviceCaps(hDC, DevCap.VERTRES)
    Case "widthinches", "inchesx"
        vResult = GetDeviceCaps(hDC, DevCap.HORZSIZE) / 25.4
    Case "heightinches", "inchesy"
        vResult = GetDeviceCaps(hDC, DevCap.VERTSIZE) / 25.4
    Case "diagonalinches", "inchesdiag"
        vResult = Sqr(GetDeviceCaps(hDC, DevCap.HORZSIZE) ^ 2 + GetDeviceCaps(hDC, DevCap.VERTSIZE) ^ 2) / 25.4
    Case "pixelsperinchx", "ppix"
        vResult = 25.4 * GetDeviceCaps(hDC, DevCap.HORZRES) / GetDeviceCaps(hDC, DevCap.HORZSIZE)
    Case "pixelsperinchy", "ppiy"
        vResult = 25.4 * GetDeviceCaps(hDC, DevCap.VERTRES) / GetDeviceCaps(hDC, DevCap.VERTSIZE)
    Case "pixelsperinch", "ppidiag"
        xHSizeSq = GetDeviceCaps(hDC, DevCap.HORZSIZE) ^ 2
        xVSizeSq = GetDeviceCaps(hDC, DevCap.VERTSIZE) ^ 2
        xPix = GetDeviceCaps(hDC, DevCap.HORZRES) ^ 2 + GetDeviceCaps(hDC, DevCap.VERTRES) ^ 2
        vResult = 25.4 * Sqr(xPix / (xHSizeSq + xVSizeSq))
    Case "windotsperinchx", "dpix"
        vResult = GetDeviceCaps(hDC, DevCap.LOGPIXELSX)
    Case "windotsperinchy", "dpiy"
        vResult = GetDeviceCaps(hDC, DevCap.LOGPIXELSY)
    Case "windotsperinch", "dpiwin"
        xHSizeSq = GetDeviceCaps(hDC, DevCap.HORZSIZE) ^ 2
        xVSizeSq = GetDeviceCaps(hDC, DevCap.VERTSIZE) ^ 2
        xDot = GetDeviceCaps(hDC, DevCap.LOGPIXELSX) ^ 2 * xHSizeSq + GetDeviceCaps(hDC, DevCap.LOGPIXELSY) ^ 2 * xVSizeSq
        vResult = Sqr(xDot / (xHSizeSq + xVSizeSq))
    Case "adjustmentfactor", "zoomfac"
        xHSizeSq = GetDeviceCaps(hDC, DevCap.HORZSIZE) ^ 2
        xVSizeSq = GetDeviceCaps(hDC, DevCap.VERTSIZE) ^ 2
        xPix = GetDeviceCaps(hDC, DevCap.HORZRES) ^ 2 + GetDeviceCaps(hDC, DevCap.VERTRES) ^ 2
        xDot = GetDeviceCaps(hDC, DevCap.LOGPIXELSX) ^ 2 * xHSizeSq + GetDeviceCaps(hDC, DevCap.LOGPIXELSY) ^ 2 * xVSizeSq
        vResult = 25.4 * Sqr(xPix / xDot)
    Case "isprimary"
        vResult = CBool(tMonitorInfo.dwFlags And MONITOR_PRIMARY)
    Case "displayname"
        vResult = tMonitorInfo.szDevice & vbNullChar
        vResult = Left(vResult, (InStr(1, vResult, vbNullChar) - 1))
    Case Else
        vResult = CVErr(xlErrValue)
    End Select
    If hWnd = 0 Then
        ReleaseDC hWnd, hDC
    Else
        DeleteDC hDC
    End If
    Screen = vResult
End Function
Function MonitorCount()
    Dim indAdapter As Long, indDisplay As Long, NullCharPos As Long
    Dim ddAdapters As DISPLAY_DEVICE, ddDisplays As DISPLAY_DEVICE, dmode As DEVMODE
    Dim Monitor As String, CurDeviceName As String
    ddAdapters.cb = Len(ddAdapters)
    ddDisplays.cb = Len(ddDisplays)
    indAdapter = 0
    Do Until EnumDisplayDevices(vbNullString, indAdapter, ddAdapters, 0) = 0
        If (ddAdapters.StateFlags And DISPLAY_DEVICE_ATTACHED_TO_DESKTOP) = DISPLAY_DEVICE_ATTACHED_TO_DESKTOP Then
            NullCharPos = InStr(ddAdapters.DeviceName, vbNullChar)
            If NullCharPos > 0 Then
                CurDeviceName = Left$(ddAdapters.DeviceName, NullCharPos - 1)
            Else
                CurDeviceName = ddAdapters.DeviceName
            End If
            dmode.dmSize = Len(dmode)
            EnumDisplaySettings CurDeviceName, ENUM_CURRENT_SETTINGS, dmode
            Monitor = Monitor & "Name:- " & Replace(Replace(CurDeviceName, "\", ""), ".", "") & vbCrLf
            Monitor = Monitor & "DPI X:- " & dmode.dmPelsWidth & vbCrLf
            Monitor = Monitor & "DPI Y:- " & dmode.dmPelsHeight & vbCrLf & vbCrLf
        End If
        indAdapter = indAdapter + 1
    Loop
    MsgBox Monitor, vbInformation, "Display Devices Record Set"
End Function

---

Any help or direction appreciated

hmmm...very unsual .. after making any change to the syntax in the VBA Editor and the createpopupmenu code works .. the mouse will scroll the list of items when the workbook is in the third screen

link to Ozgrid