скрыть

скрыть

  Форум  

Delphi FAQ - Часто задаваемые вопросы

| Базы данных | Графика и Игры | Интернет и Сети | Компоненты и Классы | Мультимедиа |
| ОС и Железо | Программа и Интерфейс | Рабочий стол | Синтаксис | Технологии | Файловая система |



Google  
 

Исправление иконок выключенных пунктов меню



Автор: 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 с "заплаткой":






Copyright © 2004-2016 "Delphi Sources". Delphi World FAQ




Группа ВКонтакте   Ссылка на Twitter   Группа на Facebook