Delphi World - Исправление иконок выключенных пунктов меню
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Исправление иконок выключенных пунктов меню

Автор: VS

При использовании ListImage, в недоступных пунктах Menu пиктограммы отображаются некорректно. Это можно видеть на рисунке:


Ошибка связана с получением монохромного изображения в процедуре TCustomImageList.DoDraw. Однако ее можно исправить, если воспользоваться небольшой "заплаткой" - ScrambleBitmap.


procedure TCustomImageList.DoDraw(Index: Integer; Canvas: TCanvas;
  X, Y: Integer; Style: Cardinal; Enabled: Boolean);

  procedure ScrambleBitmap(var BMP: TBitmap);
  const
    RMask = $0000FF;
    RAMask = $FFFF00;
    GMask = $00FF00;
    GAMask = $FF00FF;
    BMask = $FF0000;
    BAMask = $00FFFF;
  var
    R, C: integer;
    Color: LongWord;
  begin
    with Bmp.Canvas do
    begin
      for C := 0 to Bmp.Height - 1 do
        for R := 0 to Bmp.Width - 1 do
        begin
          Color := Pixels[R, C];
          if ((Color = 0) or (Color = $FFFFFF)) then
            Continue;
          if (((Color and RMask > $7F) and (Color and RAMask > $0)) or
            ((Color and GMask > $7F00) and (Color and GAMask > $0)) or
            ((Color and BMask > $7F000) and (Color and BAMask > $0))) then
            Pixels[R, C] := $FFFFFF
          else
            Pixels[R, C] := 0;
        end;
    end;
  end;

const
  ROP_DSPDxax = $00E20746;

var
  R: TRect;
  DestDC, SrcDC: HDC;

begin
  if HandleAllocated then
  begin
    if Enabled then
      ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0,
        GetRGBColor(BkColor), GetRGBColor(BlendColor), Style)
    else
    begin
      if FMonoBitmap = nil then
      begin
        FMonoBitmap := TBitmap.Create;
        with FMonoBitmap do
        begin
          // Monochrome:= True; закомментировать!!!

          Width := Self.Width;
          Height := Self.Height;
        end;
      end;
      { Store masked version of image temporarily in FBitmap }
      FMonoBitmap.Canvas.Brush.Color := clWhite;
      FMonoBitmap.Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));
      ImageList_DrawEx(Handle, Index, FMonoBitmap.Canvas.Handle, 0, 0, 0, 0,
        CLR_DEFAULT, 0, ILD_NORMAL);
      ScrambleBitmap(FMonoBitmap); // заплатка
      R := Rect(X, Y, X + Width, Y + Height);
      SrcDC := FMonoBitmap.Canvas.Handle;
      BitBlt(SrcDC, 0, 0, Width, Height, SrcDC, 0, 0, DSTINVERT); // добавить!!!
      { Convert Black to clBtnHighlight }
      Canvas.Brush.Color := clBtnHighlight;
      DestDC := Canvas.Handle;
      Windows.SetTextColor(DestDC, clWhite);
      Windows.SetBkColor(DestDC, clBlack);
      BitBlt(DestDC, X + 1, Y + 1, Width, Height, SrcDC, 0, 0, ROP_DSPDxax);
      { Convert Black to clBtnShadow }
      Canvas.Brush.Color := clBtnShadow;
      DestDC := Canvas.Handle;
      Windows.SetTextColor(DestDC, clWhite);
      Windows.SetBkColor(DestDC, clBlack);
      BitBlt(DestDC, X, Y, Width, Height, SrcDC, 0, 0, ROP_DSPDxax);
    end;
  end;
end;

Теперь пиктограммы в Menu будут отображаться как на приведенном рисунке:

"Заплатку" можно использовать и в ToolBar, где ошибка аналогична. ToolBar без "заплатки":

ToolBar с "заплаткой":

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования