Attribute VB_Name = "PictureMenuModule"
'This library file written by Alex Vallat.  Contact me at my homepage at http://www.ByAlexV.co.uk
'
'This module is for putting bitmaps on menus.  See the procedures for details on how to
'use them.
'
Option Explicit
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSubMenu 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 GetMenuCheckMarkDimensions Lib "user32" () As Long
Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpItem As Long) As Long

Public Sub CheckMarkBitmapOnMenu(MenuForm As Form, MenuAddress As String, UsePicChecked As Variant, UsePicUnchecked As Variant)
    'MenuAddress as string of positions, separated by "\", for example the address for "Make .exe" would be "0\10".  If that had
    'two sub choices, such as ".DLL" and ".EXE" on a sub menu, the first choice's address would be "0\10\0".  Note that only sub-
    'menu items can have pictures. "0" is not a valid address"
    'UsePicChecked and UsePicUnchecked must be pictures, such as image1.picture, or a "Could not perform requested operation" (17)
    'error will occur.  To remove picture from a menu, set UsePic* to 0.
    Dim FormHwnd As Long, Counter As Integer, Buffer As String * 1, BNumber As String, DepthCounter As Integer
    Dim Position() As Integer, hMenu As Long, hSubMenu As Long, Result As Long, MenuID As Long
    For Counter = 1 To Len(MenuAddress) - 1
        If InStr(Counter, MenuAddress, "\") > 0 Then
            DepthCounter = DepthCounter + 1
        End If
    Next Counter
    If DepthCounter < 2 Then
        Err.Raise Number:=5, Description:="Address not long enough.  Cannot assign a picture to a Menu with Sub-Menus"
        Exit Sub
    End If
    ReDim Position(1 To DepthCounter) As Integer
    DepthCounter = 0
    FormHwnd = MenuForm.hwnd
    For Counter = 1 To Len(MenuAddress)
        Buffer = Mid$(MenuAddress, Counter, 1)
        BNumber = BNumber + Buffer
        If Buffer = "\" Or Counter = Len(MenuAddress) Then
            If Buffer = "\" Then BNumber = Left$(BNumber, Len(BNumber) - 1)
            DepthCounter = DepthCounter + 1
            Position(DepthCounter) = CInt(BNumber)
            BNumber = ""
        End If
    Next Counter
    hMenu = GetMenu(FormHwnd)
    hSubMenu = hMenu
    For Counter = 1 To DepthCounter - 1
        hSubMenu = GetSubMenu(hSubMenu, Position(Counter))
    Next Counter
    MenuID = GetMenuItemID(hSubMenu, Position(DepthCounter))
    If MenuID = -1 Then
        Err.Raise Number:=17, Description:="Menu does not exist, or has Sub-Menus."
        Exit Sub
    End If
    Result = SetMenuItemBitmaps(hMenu, MenuID, 0, CLng(UsePicChecked), CLng(UsePicUnchecked))
    If Result <> 1 Then
        Err.Clear
        Err.Raise 17
    End If
End Sub
Public Sub ItemBitmapOnMenu(MenuForm As Form, MenuAddress As String, UsePic As Variant)
    'MenuAddress as string of positions, separated by "\", for example the address for "Make .exe" would be "0\10".  If that had
    'two sub choices, such as ".DLL" and ".EXE" on a sub menu, the first choice's address would be "0\10\0".  Note that only sub-
    'menu items can have pictures. "0" is not a valid address"
    'UsePicChecked and UsePicUnchecked must be pictures, such as image1.picture, or a "Could not perform requested operation" (17)
    'error will occur.  To remove picture from a menu, set UsePic* to 0.
    Dim FormHwnd As Long, Counter As Integer, Buffer As String * 1, BNumber As String, DepthCounter As Integer
    Dim Position() As Integer, hMenu As Long, hSubMenu As Long, Result As Long, MenuID As Long
    For Counter = 1 To Len(MenuAddress) - 1
        If InStr(Counter, MenuAddress, "\") > 0 Then
            DepthCounter = DepthCounter + 1
        End If
    Next Counter
    If DepthCounter < 2 Then
        Err.Raise Number:=5, Description:="Address not long enough.  Cannot assign a picture to a Menu with Sub-Menus"
        Exit Sub
    End If
    ReDim Position(1 To DepthCounter) As Integer
    DepthCounter = 0
    FormHwnd = MenuForm.hwnd
    For Counter = 1 To Len(MenuAddress)
        Buffer = Mid$(MenuAddress, Counter, 1)
        BNumber = BNumber + Buffer
        If Buffer = "\" Or Counter = Len(MenuAddress) Then
            If Buffer = "\" Then BNumber = Left$(BNumber, Len(BNumber) - 1)
            DepthCounter = DepthCounter + 1
            Position(DepthCounter) = CInt(BNumber)
            BNumber = ""
        End If
    Next Counter
    hMenu = GetMenu(FormHwnd)
    hSubMenu = hMenu
    For Counter = 1 To DepthCounter - 1
        hSubMenu = GetSubMenu(hSubMenu, Position(Counter))
    Next Counter
    MenuID = GetMenuItemID(hSubMenu, Position(DepthCounter))
    If MenuID = -1 Then
        Err.Raise Number:=17, Description:="Menu does not exist, or has Sub-Menus."
        Exit Sub
    End If
    Result = ModifyMenu(hMenu, MenuID, 4, MenuID, UsePic)
    If Result <> 1 Then
        Err.Clear
      '  Err.Raise 17
    End If
End Sub
Public Function CheckMarkSize() As Integer
    'This will return the size of the check mark, as one side of a square, in pixels
    '(I think its pixels, anyway :-)
    Dim Buffer As Long
    Buffer = GetMenuCheckMarkDimensions
    Buffer = Buffer And &HFF
    CheckMarkSize = Buffer
End Function