Attribute VB_Name = "basMenu"
Option Compare Binary
Option Explicit

Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo WindowProc_Err

    Dim lpfn As Long
    Dim hDC As Long
    Dim mis As MEASUREITEMSTRUCT
    Dim dis As DRAWITEMSTRUCT
    Dim rgbyt() As Byte
    Dim cch As Long
    Dim hFontOld As Long
    Dim siz As SIZEL
    Dim pm As PopupMenu
    Dim ppm As Long
    Dim mii As MENUITEMINFO
    Dim clrPrevText As Long
    Dim clrPrevBkgnd As Long
    Dim X As Long
    Dim Y As Long
    
    Select Case uMsg
        Case WM_MEASUREITEM
            If wParam = 0 Then
                RtlMoveMemory mis, ByVal lParam, Len(mis)
                
                ppm = GetProp(hWnd, prp_pObj)
                RtlMoveMemory pm, ppm, 4
                With pm.MenuItems(mis.itemID)
                    hDC = GetDC(0&)
                    hFontOld = SelectObject(hDC, .iFont.hFont)
                    Call GetTextExtentPoint32(hDC, .Caption, Len(.Caption), siz)
                    Call SelectObject(hDC, hFontOld)
                    mis.itemWidth = siz.cx
                    mis.itemHeight = siz.cy
                End With
                RtlMoveMemory ByVal lParam, mis, Len(mis)
                RtlMoveMemory pm, &H0&, 4
            End If
            WindowProc = &H1&
        Case WM_DRAWITEM
            If wParam = 0 Then
                RtlMoveMemory dis, ByVal lParam, Len(dis)
                
                ppm = GetProp(hWnd, prp_pObj)
                RtlMoveMemory pm, ppm, 4
                
                With pm.MenuItems(dis.itemID)
    

                   ' Set the appropriate foreground and background colors.
                    If (dis.itemState And ODS_SELECTED) = ODS_SELECTED Then
                        clrPrevText = SetTextColor(dis.hDC, GetSysColor(COLOR_HIGHLIGHTTEXT))
                        clrPrevBkgnd = SetBkColor(dis.hDC, GetSysColor(COLOR_HIGHLIGHT))
                    Else
                        clrPrevText = SetTextColor(dis.hDC, GetSysColor(COLOR_MENUTEXT))
                       clrPrevBkgnd = SetBkColor(dis.hDC, GetSysColor(COLOR_MENU))
                    End If
                
                    ' Determine where to draw and leave space for a check mark.
                    X = dis.rcItem.Left
                    Y = dis.rcItem.Top
                    X = X + GetSystemMetrics(SM_CXMENUCHECK)
                
                    ' Select the font and draw the text.
                    Call SetMenuItemInfo(pm.hMenu, dis.itemID, &H1&, mii)
                    hFontOld = SelectObject(dis.hDC, .iFont.hFont)
                    Call ExtTextOut(dis.hDC, X, Y, ETO_OPAQUE, dis.rcItem, StrPtr(.Caption), Len(.Caption), ByVal 0&)
                    
                    ' Restore the original font and colors.
                    Call SelectObject(dis.hDC, hFontOld)
                    Call SetTextColor(dis.hDC, clrPrevText)
                    Call SetBkColor(dis.hDC, clrPrevBkgnd)
                    
                    ' Fix up that dis pointer, in case anything changed?
                    RtlMoveMemory ByVal lParam, dis, Len(dis)
                End With
                
                ' Clear out our illegal pointer before we do something dangerous and
                ' crash with it.
                RtlMoveMemory pm, &H0&, 4
            End If
            WindowProc = &H1&
        Case Else
            ' Lets get the previous wndproc. We hide so many items in the property list so that this
            ' procedure can be considered safe for any number of controls on the form.
            lpfn = GetProp(hWnd, prp_PrevWndProc)
        
            ' Forward all messages to previous window procedure
            WindowProc = CallWindowProc(lpfn, hWnd, uMsg, wParam, lParam)
    End Select
    
WindowProc_Exit:
    Exit Function
    
WindowProc_Err:
    Resume WindowProc_Exit

End Function