Visual Basic

XP Menu's

You've all seen them in applications like Office 2003 and Windows Movie Maker, but how do you make them so pretty with Visual Basic 6? Well, that's what I set out to do, and I succeeded! Keep reading to find out how...

First attempt: classes

Download

One of the first things I did, together with Jeroen, a good friend of mine, was completely optimize a project submitted on planet source code. It worked by loading a new form for each submenu you wanted to create.

You can have a look at a screenshot of the project in action, or you can download the VB6 project to look at it yourself. It's very good to learn from. I could go on and on about how we optimized the code, but there's no point really, as the second attempt proved to yield a much better result. The first attempt had too many shortcomings:

• The form loses focus when a menu is opened (because the menu is a form)
• The menu flickers sometimes (again, because it's a form)
• It's a lot of manual labour defining the menu structure and icons
• You have to make use of a fairly large select case to capture the click event

Second attempt: subclassing

Download

Research

I quickly found a tutorial on EliteVB that explained how to draw menu's yourself. Although I respect Garret Sever's work, the code sample he put on the net had too many annoyances for my liking. There was a memory leak I could not get rid of, and I wasn't the only one, it was caused by a faulty API. Also, there were a lot of routines that were simply not necessary.

I learned so much from Garret's code though, that I was able to write my own version. It is possible not to use the API causing the memory leak, and it's possible to use only a few routines for caching the menu's properties (like caption, submenu address, hotkeys, ...).

First I set down my goals:

• Office XP style, including all XP icons
• It should work for usercontrols too
• Auto selection of the appropriate menu icon

For those of you who don't already know what subclassing is, I'll try to explain it briefly. Subclassing is essentially just asking your program to pass all its 'messages' to your program instead of passing them straight to Windows. The messages can be anything from 'draw me' to 'type the letter X'. We want to intercept the messages coming from menu's that say 'draw me'.

Caching menu info

First we have to cache the menus properties (like the menu caption). The following sub is what we're looking for:

Private Sub GetSubs(hMenu As Long, Optional isPopup As Boolean = False)

    Dim SubMenu As Long
    Dim i       As Long
    Dim mID     As Long
    Dim sAcc    As String
    Dim sCap    As String

    For i = 0 To GetMenuItemCount(hMenu) - 1
        Dim Item As clsODMenuItem
        Set Item = New clsODMenuItem

        'gets the submenu address
        SubMenu = GetSubMenu(hMenu, i)

        'this gets the menu info
        Call GetCaption(hMenu, i, (hMenu = MenuBar), mID, sCap, sAcc)

        'put the menu info in an item that stores it
        With Item
            .Caption = sCap
            .Handle = mID
            .ParentHandle = hMenu
            .KeyAccel = sAcc
            .hasSubmenu = (Not SubMenu = 0)
        End With

        On Local Error Resume Next
        If isPopup Then
            'special temp collection for usercontrol popup menus
            ODPopup.Add Item, "id" & CStr(ParenthWnd) & "-" & CStr(Item.Handle)
            If SubMenu <> 0 Then Call GetSubs(SubMenu, True)
        Else
            'normally the menu item is saved in the collection ODMenu
            ODMenu.Add Item, "id" & CStr(ParenthWnd) & "-" & CStr(Item.Handle)
            'cache the menu info for the submenu aswel
            If SubMenu <> 0 Then Call GetSubs(SubMenu, False)
        End If
    Next i

End Sub

It looks long but it's very easy. It's a loop that says: Here is an address to a menu item, then the loop takes the address, gets the menu info for the address with 'GetCaption' and stores it in a collection.

After that it gets the address to the submenu of the menu item (if there is one) and does the same loop for that menu item too!

If you want you can have a look at the 'GetCaption' sub by downloading the project, but it's not really necessary, it just uses some API's to get the menu's info and returns them.

Subclassing

After caching the menus info in a collection, we need to start subclassing it.

Private Sub SubClass(hWnd As Long)
    Dim origProc As Long
    origProc = GetWindowLong(hWnd, GWL_WNDPROC)
    SetWindowLong hWnd, GWL_WNDPROC, AddressOf MenuProc
    SetProp hWnd, "ODMenuProc", origProc
End Sub

That's easy enough isn't it? Let's have a look at what it does. First it gets the address of the original process 'origProc', and it saves it in the Windows catalog under the column 'ODMenuProc'.

SetProp hWnd, "ODMenuProc", origProc

We're doing that because if we stop subclassing, then we need to tell the menu to send its messages back to Windows instead of our module. There's also one more line of code:

SetWindowLong hWnd, GWL_WNDPROC, AddressOf MenuProc

It says that the menu, which is 'hWnd', should send all its messages to the sub 'MenuProc'. MenuProc will then handle the messages and draw the menu itself. That's subclassing!

Measuring

Before we can start drawing, we need to know what size the menu is, right? The size of the menu depends on how long the menu caption is. For instance a menu with only 'Save' as a caption should be smaller than a menu with 'Save config file as...' as a caption.

The sub MenuProc is divided into 3 parts:

• Measuring
• Drawing
• Checking if the app wants to draw a usercontrol menu

Let's start with 'Measuring'.

Private Function MenuProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim mItem As clsODMenuItem
    Dim oFont As Long
    Dim mFont As Long
    Dim MeasureInfo As MEASUREITEMSTRUCT
    Dim oldProc As Long

    oldProc = GetProp(hWnd, "ODMenuProc")
    ParenthWnd = hWnd

    Select Case uMsg
    Case WM_MEASUREITEM
        Dim ParentDC As Long
        Dim ptDim    As POINTAPI

        'get info from memory
        CopyMemory MeasureInfo, ByVal lParam, Len(MeasureInfo)
        If MeasureInfo.CtlType = ODT_MENU Then

            'get the corresponding menuitem
            On Local Error Resume Next
            Set mItem = ODMenu("id" & CStr(hWnd) & "-" & CStr(MeasureInfo.itemID))
            If Err.Number <> 0 Then
                Set mItem = ODPopup("id" & CStr(hWnd) & "-" & CStr(MeasureInfo.itemID))
                Err.Clear
            Else
                isPopup = False
            End If

            'get estimate for textsize
            ParentDC = GetDC(hWnd)
            mFont = GetFont(ParentDC)
            oFont = SelectObject(ParentDC, mFont)
            GetTextExtentPoint32 ParentDC, mItem.Caption + mItem.KeyAccel, Len(mItem.Caption) + Len(mItem.KeyAccel), ptDim

            'cleanup
            Call SelectObject(ParentDC, oFont)
            Call ReleaseDC(hWnd, ParentDC)
            Call DeleteObject(mFont)
            Call DeleteDC(ParentDC)

            'recalculate dimensions
            ptDim.Y = ptDim.Y + (2 * cMarginText)
            ptDim.X = ptDim.X + cMarginLeft + _
            IIf((mItem.hasSubmenu) Or (Not mItem.KeyAccel = ""), (cMarginLeft), 0) + _
            IIf((Not mItem.KeyAccel = ""), (cMarginLeft), 0)
            If mItem.Caption = "" Then ptDim.Y = cMarginText

            'set dimensions in memory
            MeasureInfo.itemWidth = ptDim.X
            MeasureInfo.itemHeight = ptDim.Y
            CopyMemory ByVal lParam, MeasureInfo, Len(MeasureInfo)
            Exit Function

        End If
    Case ...
    Case ...
    End Select

    MenuProc = CallWindowProc(oldProc, hWnd, uMsg, wParam, lParam)

End Function

It should be readable for you (like a book). Only the first few lines might be confusing. What I'm doing is getting the menu item from the collection by giving it the keyword 'hWnd-itemID'. If it can't find it in the collection Err.Number will be different from 0, so if that's the case, it must be in the other collection 'ODPopup'.

Usercontrol popupmenu's

ODPopup is a temporary collection to store menu info in from menu's generated by usercontrols (for instance when you right click on a usercontrol). You see, the problem is, when you open a usercontrols popupmenu, a new menu is created in memory, with a new address etc. That makes storing them in 'ODMenu' impossible. Well, actually, you could continue to store the menu info in ODMenu, but then ODMenu would get bigger and bigger each time you open a new popup menu, which is what I consider, a memory leak.

Now you might be wondering, why should the menu item be in ODPopup if it's not in ODMenu? The answer is I store it there, I just haven't showed you where I do that yet.

Private Function MenuProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim mItem As clsODMenuItem
    Dim oFont As Long
    Dim mFont As Long
    Dim MeasureInfo As MEASUREITEMSTRUCT
    Dim oldProc As Long

    oldProc = GetProp(hWnd, "ODMenuProc")
    ParenthWnd = hWnd

    Select Case uMsg
    Case ...
    Case ...
    Case WM_INITMENUPOPUP
        Dim hSysMenu As Long
        Dim aForm As Form
        Dim isSysMenu As Boolean

        'if the last menu we opened was NOT a usercontrol right-click menu
        'then delete the contents of the temp popup collection
        If Not isPopup Then Set ODPopup = Nothing

        'dont EVER change the style of a systemmenu
        isSysMenu = False
        For Each aForm In Forms
            hSysMenu = GetSystemMenu(aForm.hWnd, False)
            isSysMenu = isSysMenu Or (wParam = hSysMenu)
        Next aForm
        If Not isSysMenu Then
            On Local Error Resume Next

            'an error is raised if the item is not already cached, which
            'means it's a usercontrol generated popup menu
            Set mItem = ODMenu("id" & CStr(hWnd) & "-" & wParam)
            If Err.Number <> 0 Then

                'subclass the menu temporarily
                Call GetSubs(wParam, True)

                'remember that the last thing we opened was a ucontrol menu
                isPopup = True
                Err.Clear

            End If
        End If
    End Select

    MenuProc = CallWindowProc(oldProc, hWnd, uMsg, wParam, lParam)

End Function

This case happens when a new popup menu is opened (WM_INITMENUPOPUP).

First it checks if the last menu opened was a usercontrol popup menu (isPopup), if so it deletes the temporary collection.

Then it checks to see if the opened menu is not a system menu (right click on the title bar of an app to see a system menu). I doubt system menu's get passed to this sub, but it's better to play safe and check if it's not a system menu anyway.

Finally it does the same check as before: if the item exists in ODMenu already, there's nothing more we need to do. If it's not found in ODMenu, we need to cache the menu in ODPopup and remember the last thing we opened was a usercontrol popupmenu (isPopup).

Drawing the menu

Now we're all ready to start drawing the menu.

Private Function MenuProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim mItem As clsODMenuItem
    Dim oFont As Long
    Dim mFont As Long
    Dim MeasureInfo As MEASUREITEMSTRUCT
    Dim oldProc As Long

    oldProc = GetProp(hWnd, "ODMenuProc")
    ParenthWnd = hWnd

    Select Case uMsg
    Case ...
    Case WM_DRAWITEM

        'copy necessary info from memory into DrawInfo
        Dim DrawInfo As DRAWITEMSTRUCT
        CopyMemory DrawInfo, ByVal lParam, Len(DrawInfo)

        ...

        '*************************************
        'BACKBUFFER
        '*************************************
        BackBufferRECT = DrawInfo.rcItem
        BackBufferRECT.bottom = BackBufferRECT.bottom - BackBufferRECT.top
        BackBufferRECT.right = BackBufferRECT.right - BackBufferRECT.left
        BackBufferRECT.left = 0
        BackBufferRECT.top = 0
        BackBufferDC = CreateCompatibleDC(DrawInfo.hDC)
        BackBufferBMP = CreateCompatibleBitmap(DrawInfo.hDC, BackBufferRECT.right, BackBufferRECT.bottom)
        oBMP = SelectObject(BackBufferDC, BackBufferBMP)
        aBrush = CreateSolidBrush(crBackground)
        oBrush = SelectObject(BackBufferDC, aBrush)
        FillRect BackBufferDC, BackBufferRECT, aBrush
        DeleteObject aBrush

        ...(draw on the backbuffer)...

        'blit the menu from the buffer to the menu dc
        Call BitBlt(DrawInfo.hDC, DrawInfo.rcItem.left, DrawInfo.rcItem.top, _
        BackBufferRECT.right, BackBufferRECT.bottom, BackBufferDC, 0, 0, vbSrcCopy)

        'cleanup
        ...

    Case ...
    End Select

    MenuProc = CallWindowProc(oldProc, hWnd, uMsg, wParam, lParam)

End Function

I cut out a few lines of code, but no worries, it all boils down to these couple of lines anyway. First we copy the necessary information out of the system memory into 'DrawInfo'. DrawInfo provides us with the information we need to make a backbuffer. If you are not familiar with GDI drawing techniques, I suggest you read this guide to using DC's by Mike D Sutton, it's worth the read and you should learn about them sooner or later.

Now you've got a backbuffer and I'm assuming you know how to draw on a DC, you can draw the whole menu yourself. Or you can download my source code and use that instead, it comes with 34 XP icons ripped straight from shell32.dll!

Content & Design © 2005