Недавно добавленные исходники

•  TDictionary Custom Sort  535

•  Fast Watermark Sources  900

•  3D Designer  1 828

•  Sik Screen Capture  1 474

•  Patch Maker  1 482

•  Айболит (remote control)  1 406

•  ListBox Drag & Drop  1 175

•  Доска для игры Реверси  21 823

•  Графические эффекты  1 354

•  Рисование по маске  1 295

•  Перетаскивание изображений  1 096

•  Canvas Drawing  968

•  Рисование Луны  814

•  Поворот изображения  770

•  Рисование стержней  814

•  Paint on Shape  493

•  Генератор кроссвордов  762

•  Головоломка Paletto  667

•  Теорема Монжа об окружностях  855

•  Пазл Numbrix  617

•  Заборы и коммивояжеры  848

•  Игра HIP  557

•  Игра Go (Го)  527

•  Симулятор лифта  548

•  Программа укладки плитки  509

•  Генератор лабиринта  565

•  Проверка числового ввода  524

•  HEX View  600

•  Физический маятник  528

•  Задача коммивояжера  560

 
скрыть


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

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



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



Автор: 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-2022 "Delphi Sources" by BrokenByte Software. Delphi World FAQ

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