Icons on dynamic popup menu

[GrimmReaper]

Hello everyone.

I took a program over from someone.

This program is used to disable the normal popmenu in a textbox, so, subclassing is involved.
Now, we had to do 2 things to the new "textbox menu", add colors, or add icons to the menu items.
we have got the background colours sorted out, but we are unable to add icons to this dynamic popupmenu.

This is the code:

Option Explicit
Private Const MIM_BACKGROUND As Long = &H2
Private Const MIM_APPLYTOSUBMENUS As Long = &H80000000
Private Const MF_BITMAP = &H4&
Private Const MIIM_ID = &H2
Private Const MIIM_TYPE = &H10
Private Const MF_STRING = &H0&
Private Const MF_BYPOSITION = &H400&
'Private Const MF_USECHECKBITMAPS = 512
Private Const LR_LOADFROMFILE = &H10
Private Const IMAGE_BITMAP = 0
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H2&
Private Const TPM_RETURNCMD = &H100&
Private Const TPM_RIGHTBUTTON = &H2&
Private Const TPM_LEFTALIGN = &H0&
Private Const LR_CREATEDIBSECTION = 8192
Private Const MF_OWNERDRAW = &H100&

Private Type POINTAPI
        x As Long
        y As Long
End Type
Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal hWnd As Long, ByVal lptpm As Any) As Long

Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

Private Declare Function GetCursorPos Lib "user32" ( _
   lpPoint As POINTAPI) As Long
Private Declare Function CreatePopupMenu Lib "user32" () 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 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 Const MF_SEPARATOR = &H800&
Private Const TPM_NONOTIFY = &H80
'Private Const TPM_RETURNCMD = &H100

Private Type MENUINFO
    cbSize As Long
    fMask As Long
    dwStyle As Long
    cyMax As Long
    hbrBack As Long
    dwContextHelpID As Long
    dwMenuData As Long
End Type

Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

Private Declare Function DrawMenuBar Lib "user32" _
    (ByVal hWnd As Long) As Long

Private Declare Function GetSubMenu Lib "user32" _
    (ByVal hMenu As Long, ByVal nPos As Long) As Long

Private Declare Function GetMenu Lib "user32" _
    (ByVal hWnd As Long) As Long

Private Declare Function SetMenuInfo Lib "user32" _
    (ByVal hMenu As Long, _
     mi As MENUINFO) As Long

Private Declare Function CreateSolidBrush Lib "gdi32" _
    (ByVal crColor As Long) As Long
    
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, _
  ByVal nPos As Long) As Long
    
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, _
  ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, _
  ByVal hBitmapChecked As Long) As Long
  
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
  (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

Private Declare Function GetMenuItemCount Lib "user32" _
  (ByVal hMenu As Long) As Long
  
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" _
  (ByVal hMenu As Long, ByVal un As Long, ByVal b As Boolean, lpMenuItemInfo As _
  MENUITEMINFO) As Boolean
   Dim NewMenu As Long, nMenuId As Long, Pt As POINTAPI
   Private Colour As Byte
   
Friend Function WindowProc(ByVal sHwnd As Long, ByVal uMsg As Long, _
       ByVal wParam As Long, ByVal lParam As Long) As Long
    
   Select Case uMsg
   Case WM_RBUTTONUP
'Catch message before the window catches it!

      Exit Function
   End Select
        
   WindowProc = CallWindowProc(mWndProc, sHwnd, uMsg, wParam, _
                ByVal lParam)
    
End Function

Private Sub UnSubClass()
   If mWndProc Then
      SetWindowLong Me.hWnd, GWL_WNDPROC, mWndProc
   End If
End Sub

Private Sub Command1_Click()

Colour = 1
End Sub

Private Sub Command2_Click()
  Dim hMenu As Long
  Dim hSubMenu As Long
  Dim hID As Long
  Dim nPosition As Long
  Dim i As Long
  Dim x As Long

  hMenu = GetMenu(Me.hWnd)
  hSubMenu = GetSubMenu(hMenu, 0)
  For i = 0 To 2
    nPosition = GetMenuItemID(hSubMenu, i)
    x = SetMenuItemBitmaps(hMenu, nPosition, 0, CLng(Picture1(i).Picture), CLng(Picture1(i).Picture))
  Next

 hMenu = GetMenu(Me.hWnd)

'Get handle of first submenu
    hSubMenu& = GetSubMenu(NewMenu, 0)

'Get menuId of first entry
   hID& = GetMenuItemID(hSubMenu, 0)

'Add the bitmap
SetMenuItemBitmaps NewMenu, hID&, MF_BITMAP, _
Picture1(0).Picture, _
Picture1(0).Picture
Colour = 2
End Sub

Private Sub Form_Load()
   ' Subclass Textbox
   SubClass Text1.hWnd
   
End Sub

Private Sub SubClass(sHwnd)
   Dim lngResult As Long
   UnSubClass
   mWndProc = SetWindowLong(sHwnd, GWL_WNDPROC, AddressOf WndProc)
   If mWndProc Then
      lngResult = SetWindowLong(sHwnd, GWL_USERDATA, ObjPtr(Me))
   End If
End Sub

Private Sub Form_Unload(Cancel As Integer)

   UnSubClass
End Sub

Private Sub mnuTest1_Click()
MsgBox "Hello"
End Sub

Private Sub mnuTest2_Click()
MsgBox "Bye!"
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Button = vbRightButton Then

         Select Case Colour
         
         Case 1
                  NewMenu = CreatePopupMenu()
      If NewMenu Then
         Call AppendMenu(NewMenu, MF_STRING, 1, "menu 1")
         Call AppendMenu(NewMenu, MF_STRING, 2, "menu 2")
         Call AppendMenu(NewMenu, MF_SEPARATOR, 1, 0&)
         Call AppendMenu(NewMenu, MF_STRING, 3, "menu 3")
         Call GetCursorPos(Pt)
   Dim mi As MENUINFO
   
    With mi
        .cbSize = Len(mi)
        
        .fMask = MIM_BACKGROUND
        .hbrBack = CreateSolidBrush(vbYellow)
        SetMenuInfo NewMenu, mi
         .fMask = MIM_BACKGROUND Or MIM_APPLYTOSUBMENUS
               
      End With
         nMenuId = TrackPopupMenu(NewMenu, TPM_NONOTIFY Or TPM_RETURNCMD, Pt.x, Pt.y, 0, Me.hWnd, 0)
      End If
Case 2

 Dim hMenu As Long
  Dim hSubMenu As Long
  Dim hID As Long
  Dim nPosition As Long
  Dim i As Long
  Dim j As Long

  hMenu = GetMenu(Me.mnuCustomPopUp)
  hSubMenu = GetSubMenu(hMenu, 0)
  For i = 0 To 2
    nPosition = GetMenuItemID(hSubMenu, i)
    j = SetMenuItemBitmaps(hMenu, nPosition, 0, CLng(Picture1(i).Picture), CLng(Picture1(i).Picture))
  Next

 hMenu = GetMenu(Me.hWnd)

'Get handle of first submenu
    hSubMenu& = GetSubMenu(NewMenu, 0)

'Get menuId of first entry
   hID& = GetMenuItemID(hSubMenu, 0)

'Add the bitmap
SetMenuItemBitmaps NewMenu, hID&, MF_BITMAP, _
Picture1(0).Picture, _
Picture2.Picture
    End Select
End If
End Sub

if you were to add 2 pictureboxes, one textbox and 2 commandbuttons to the form, you'll see that the normal textbox menu is disabled when you right click in it, when you click button1, you'll be able to see the background colour of the menu, but when you click the second button, you'll see that not even a menu appears now.
All i want to do is to add icons to this dynamic popmenu.

can anyone help?

[MartinLiss]

You don't need to subclass. Just do something like this.

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Button = vbRightButton Then
        Text1.Enabled = False
        Text1.Enabled = True
        PopupMenu mnuPopup
    End If

End Sub

[GrimmReaper]

Thanx for your input sir. I took it away now. Any ideas on how to get pictures on a popupmenu?