Search code examples
winapivb6

Using FillRect as a bitmap for a MenuItem draws a black square


I'm using VB6 (old legacy code... don't ask) and trying to draw colored squares inside menu items - but I'm getting black squares instead. What am I doing wrong?

Public Function AddMenuItem(hMenu As Long, _
                            lItemID As Long, _
                            Optional fExType As Long = 0, _
                            Optional fState As Long = 0, _
                            Optional pzsText As String = "", _
                            Optional hSubMenu As Long = 0, _
                            Optional dwData As Long = 0, _
                            Optional iconHandle As Long = 0, _
                            Optional ByRef hMenuResult As Long = 0, _
                            Optional ByVal colorSquare As OLE_COLOR = -1) As Boolean
    On Error GoTo errHandle
    
    Dim mii         As MENUITEMINFO
    Dim lItemCount  As Long
    
    With mii
        .cbSize = Len(mii)
        .fMask = MIIM_FTYPE
        If hSubMenu Then
            .fMask = .fMask Or MIIM_SUBMENU
            .hSubMenu = hSubMenu
        Else
            .hSubMenu = 0
        End If
        If dwData Then
            .fMask = .fMask Or MIIM_DATA
            .dwItemData = dwData
        End If
        .fType = fExType Or MFT_RightORDER Or MFT_RightJUSTIFY Or MFT_STRING
        .fState = fState
        .wID = lItemID
        .dwTypeData = pzsText
        .cch = Len(.dwTypeData)
        
        If colorSquare = -1 Then
            .fMask = .fMask Or MIIM_STATE Or MIIM_ID Or MIIM_FTYPE Or MIIM_STRING
        Else
            Dim hBrush As Long
            hBrush = CreateSolidBrush(TranslateColor(colorSquare))
            .hbmpItem = CreateSquareBitmap(hBrush, 16, 16)
            DeleteObject hBrush
            
            .fMask = .fMask Or MIIM_ID Or MIIM_BITMAP Or MIIM_STATE Or MIIM_FTYPE Or MIIM_STRING
        End If
        
        lItemCount = Menu_GetItemCount(hMenu)
        Menu_InsertItem 0&, hMenu, lItemCount + 1, 1&, mii
    End With
    
    hMenuResult = DrawMenuBar(0&)
    
    Exit Function
    
errHandle:
    AddMenuItem = True
    DrawMenuBar 0&
End Function

Private Function CreateSquareBitmap(ByVal hBrush As Long, ByVal width As Long, ByVal height As Long) As Long
    Dim hdc         As Long
    Dim hBitmap     As Long
    Dim hOldBitmap  As Long
    Dim rc          As RECT

    rc.top = 0
    rc.left = 0
    rc.right = width
    rc.bottom = height
    
    hdc = CreateCompatibleDC(0&)
    hBitmap = CreateCompatibleBitmap(hdc, width, height)
    hOldBitmap = SelectObject(hdc, hBitmap)
    FillRect hdc, rc, hBrush
   
    ' Restore the old bitmap and delete the device context
    SelectObject hdc, hOldBitmap
    DeleteDC hdc
    
    ' Return the handle of the new bitmap
    CreateSquareBitmap = hBitmap
End Function

Solution

  • As @IInspectable pointed out and the remarks section of the CreateCompatibleBitmap said,

    Note: When a memory device context is created, it initially has a 1-by-1 monochrome bitmap selected into it. If this memory device context is used in CreateCompatibleBitmap, the bitmap that is created is a monochrome bitmap. To create a color bitmap, use the HDC that was used to create the memory device context, as shown in the following code:

        HDC memDC = CreateCompatibleDC ( hDC );
        HBITMAP memBM = CreateCompatibleBitmap ( hDC, nWidth, nHeight );
        SelectObject ( memDC, memBM );
    

    A complete sample: Capturing an Image.