Пользовательский стиль пера. Часть II: Бегущие муравьи

Это продолжение разговора, начатого в первой части, про эффект рамки «бегущие муравьи». Было также сказано, что лучше этого не делать в GDI. Поэтому сейчас сделаем бегущих муравьёв в GDI и GDI+, и сравним.

Содержание скрыть

Класс бегущих муравьёв

Бегущие муравьи в GDI

Как использовать

Бегущие муравьи в GDI+

Чем GDI+ отличается от GDI?

Бегущие муравьи в GDI+ по другому

Практическое использование

Дополнительно в класс

Действия с выбранной областью

Копирование выбранной области

Бегущие муравьи: Листинг

Скачать

Бегущие муравьи: Рисование в GDI, GDI+

Бегущие муравьи: Использование

Класс бегущих муравьёв

Давайте вынесем отрисовку насекомых в отдельный модуль и отдельный класс. Пусть в классе будет собственный таймер, который будет инкрементировать внутренний счетчик и генерировать событие OnPaint: TNotifyEvent — отрисуй меня.

procedure TRunningAnts.DoPaint;
begin
  if Assigned(FOnPaint) then FOnPaint(Self);
end;

procedure TRunningAnts.TimerEvent(Sender: TObject);
begin
  if Sender <> FTimer then exit;
  Inc(FTickTimer);
  DoPaint;
end;

procedure TRunningAnts.DoPaint;

begin

if Assigned(FOnPaint) then FOnPaint(Self);

end;

procedure TRunningAnts.TimerEvent(Sender: TObject);

begin

if Sender <> FTimer then exit;

Inc(FTickTimer);

DoPaint;

end;

Предусмотрим возможность хранить относительные координаты, значения X и Y которых находятся в интервале (0..1). Это нужно для масштабирования. Поэтому в конструкторе сразу указываем параметр ASingleRange. Он сообщает классу, что при формировании координат необходимо учитывать размеры текущей области рисования.

constructor TRunningAnts.Create(ASingleRange: Boolean);
begin
  FSingleRange := ASingleRange;
  FList := TList<TPointF>.Create;
end;

constructor TRunningAnts.Create(ASingleRange: Boolean);

begin

FSingleRange := ASingleRange;

FList := TList<TPointF>.Create;

end;

Чтобы получить координаты для отображаемой линии, предусмотрим метод GetPoints, куда параметром передаём текущий прямоугольник отрисовки и на выходе получаем посчитанный массив координат.

function TRunningAnts.GetPoints(const ARect: TRect): TArray<TPoint>;
var
  w,h: Integer; // Высота и ширина
  l,t: Integer; // Смещения слева и сверху
  p: TPointF;   // Хранимая координата
  v: TPoint;    // Расчётная координата
  i: Integer;
begin
  // Если размеры не совпадут, кэш сбросится
  SetRect(ARect);
  // Если массив точек уже посчитан - выходим
  if Length(FPoints) <> 0 then exit(FPoints);
  // Делаем размер массива равным количеству хранимых координат
  SetLength(FPoints, FList.Count);
  if not FSingleRange then
  begin
    // Если хранимые координаты абсолютные,
    // размер и смещения не важны
    w := 1; h := 1;
    l := 0; t := 0;
  end
  else
  begin
    // Если хранимые координаты относительные,
    // размер и смещения важны
    w := ARect.Width; h := ARect.Height;
    l := ARect.Left; t := ARect.Top;
  end;
  // Пробег по хранимым координатам и расчёт точек линии
  for i := 0 to High(FPoints) do
  begin
    p := FList[i];
    v.X := l + Round(p.X*w);
    v.Y := t + Round(p.Y*h);
    FPoints[i] := v;
  end;
  Result := FPoints;
end;

procedure TRunningAnts.SetRect(const Value: TRect);
begin
  if FCachedRect <> Value then
    ClearCache;
  FCachedRect := Value;
end;

procedure TRunningAnts.ClearCache;
begin
  // Сброс массива
  SetLength(FPoints, 0);
end;

function TRunningAnts.GetPoints(const ARect: TRect): TArray<TPoint>;

var

w,h: Integer; // Высота и ширина

l,t: Integer; // Смещения слева и сверху

p: TPointF; // Хранимая координата

v: TPoint; // Расчётная координата

i: Integer;

begin

// Если размеры не совпадут, кэш сбросится

SetRect(ARect);

// Если массив точек уже посчитан - выходим

if Length(FPoints) <> 0 then exit(FPoints);

// Делаем размер массива равным количеству хранимых координат

SetLength(FPoints, FList.Count);

if not FSingleRange then

begin

// Если хранимые координаты абсолютные,

// размер и смещения не важны

w := 1; h := 1;

l := 0; t := 0;

end

else

begin

// Если хранимые координаты относительные,

// размер и смещения важны

w := ARect.Width; h := ARect.Height;

l := ARect.Left; t := ARect.Top;

end;

// Пробег по хранимым координатам и расчёт точек линии

for i := 0 to High(FPoints) do

begin

p := FList[i];

v.X := l + Round(p.X*w);

v.Y := t + Round(p.Y*h);

FPoints[i] := v;

end;

Result := FPoints;

end;

procedure TRunningAnts.SetRect(const Value: TRect);

begin

if FCachedRect <> Value then

ClearCache;

FCachedRect := Value;

end;

procedure TRunningAnts.ClearCache;

begin

// Сброс массива

SetLength(FPoints, 0);

end;

Массив точек считается только если его длина равна нулю. Такое возможно в случае, если размеры нового прямоугольника не совпадают с запомненным ранее. Либо когда добавили новую координату. Либо очистили список.

function TRunningAnts.Add(X,Y: Single): Integer;
begin
  Result := Add(PointF(X,Y));
end;

function TRunningAnts.Add(X,Y: Single; const ARect: TRect): Integer;
begin
  // Если заказаны абсолютные координаты или
  // передан пустой прямоугольник,
  if not FSingleRange or ARect.IsEmpty then
  // То просто добавляем координаты и выходим
    exit(Add(X,Y));
  // Нормализуем координаты
  X := X - ARect.Left;
  Y := Y - ARect.Top;
  // Добавляем относительные координаты
  Result := Add(X/ARect.Width, Y/ARect.Height);
end;

function TRunningAnts.Add(const P: TPointF): Integer;
begin
  // Добавили точку в список
  Result := FList.Add(P);
  // Стартуем таймер
  Start;
  // Что-то изменилось...
  DoChange; // Внутри вызов ClearCache
end;

procedure TRunningAnts.Clear;
begin
  // Остановили (убили) таймер
  Stop;
  // Чистим список координат
  FList.Clear;
  // Что-то изменилось...
  DoChange; // Внутри вызов ClearCache
end;

function TRunningAnts.Add(X,Y: Single): Integer;

begin

Result := Add(PointF(X,Y));

end;

function TRunningAnts.Add(X,Y: Single; const ARect: TRect): Integer;

begin

// Если заказаны абсолютные координаты или

// передан пустой прямоугольник,

if not FSingleRange or ARect.IsEmpty then

// То просто добавляем координаты и выходим

exit(Add(X,Y));

// Нормализуем координаты

X := X - ARect.Left;

Y := Y - ARect.Top;

// Добавляем относительные координаты

Result := Add(X/ARect.Width, Y/ARect.Height);

end;

function TRunningAnts.Add(const P: TPointF): Integer;

begin

// Добавили точку в список

Result := FList.Add(P);

// Стартуем таймер

Start;

// Что-то изменилось...

DoChange; // Внутри вызов ClearCache

end;

procedure TRunningAnts.Clear;

begin

// Остановили (убили) таймер

Stop;

// Чистим список координат

FList.Clear;

// Что-то изменилось...

DoChange; // Внутри вызов ClearCache

end;

Бегущие муравьи в GDI

В нашем классе есть метод, который реализует алгоритм для GDI. В отличие от реализации в предыдущей статье, перед отрисовкой пользовательским стилем, рисуем белую сплошную линию по той же траектории. Еще отличие состоит в том, что мы создаём геометрическое перо с нужным стилем непосредственно в методе. Потому что точно знаем, какие параметры нужны. Зачем нам отдельная функция для создания пера?

procedure TRunningAnts.PaintGDI(ACanvas: TCanvas; const ARect: TRect; AFillEffect: Boolean);
type
  TUserStyle = array[0..3] of Cardinal;
const
  // Массив стилей
  UserStyles: array[0..3] of TUserStyle =
    ((4,4,0,0),(2,4,2,0),(0,4,4,0),(0,2,4,2));
var
  i: Integer;
  br: TLogBrush;
  Style: TUserStyle;
  Pts: TArray<TPoint>;
  OldPen, NewPen: HPEN;
  OldMode: Integer;
begin
  OldMode := 0; // Чтоб не бесил хинтами
  // Список пуст - делать тут нечего
  if FList.Count = 0 then exit;
  // Получаем массив точек линии
  Pts := GetPoints(ARect);
  // Определяем индекс в массиве стилей
  i := FTickTimer mod Length(UserStyles);
  // Получаем стиль
  Style := UserStyles[i];

  with ACanvas do
  begin
    // Рисуем сплошную белую
    Pen.Color := clWhite;
    Pen.Style := psSolid;
    if not AFillEffect then
      Brush.Style := bsClear
    else
      Pen.Mode := pmXor;
    Polygon(Pts);
    // Инициализируем цвет пера - черный
    br.lbStyle := BS_SOLID;
    br.lbColor := 0;
    // Создаем геометрическое перо
    NewPen := ExtCreatePen(
      PS_GEOMETRIC OR PS_USERSTYLE OR PS_ENDCAP_FLAT OR PS_JOIN_BEVEL,
      1, br, Length(Style), @Style);
    OldPen := SelectObject(Handle, NewPen);
    // Если указано, что с заливкой, меняем режим пера
    if AFillEffect then
      OldMode := SetROP2(Handle, R2_NOTXORPEN);
    // Рисуем полигон пользовательским стилем
    try
      Polygon(Pts);
    finally
      // Всё возвращаем на место
      SelectObject(Handle, OldPen);
      if AFillEffect and (OldMode<>0) then
        SetROP2(Handle, OldMode);
      // И удаляем геометрическое перо
      DeleteObject(NewPen);
    end;
  end;
end;

procedure TRunningAnts.PaintGDI(ACanvas: TCanvas; const ARect: TRect; AFillEffect: Boolean);

type

TUserStyle = array[0..3] of Cardinal;

const

// Массив стилей

UserStyles: array[0..3] of TUserStyle =

((4,4,0,0),(2,4,2,0),(0,4,4,0),(0,2,4,2));

var

i: Integer;

br: TLogBrush;

Style: TUserStyle;

Pts: TArray<TPoint>;

OldPen, NewPen: HPEN;

OldMode: Integer;

begin

OldMode := 0; // Чтоб не бесил хинтами

// Список пуст - делать тут нечего

if FList.Count = 0 then exit;

// Получаем массив точек линии

Pts := GetPoints(ARect);

// Определяем индекс в массиве стилей

i := FTickTimer mod Length(UserStyles);

// Получаем стиль

Style := UserStyles[i];

with ACanvas do

begin

// Рисуем сплошную белую

Pen.Color := clWhite;

Pen.Style := psSolid;

if not AFillEffect then

Brush.Style := bsClear

else

Pen.Mode := pmXor;

Polygon(Pts);

// Инициализируем цвет пера - черный

br.lbStyle := BS_SOLID;

br.lbColor := 0;

// Создаем геометрическое перо

NewPen := ExtCreatePen(

PS_GEOMETRIC OR PS_USERSTYLE OR PS_ENDCAP_FLAT OR PS_JOIN_BEVEL,

1, br, Length(Style), @Style);

OldPen := SelectObject(Handle, NewPen);

// Если указано, что с заливкой, меняем режим пера

if AFillEffect then

OldMode := SetROP2(Handle, R2_NOTXORPEN);

// Рисуем полигон пользовательским стилем

try

Polygon(Pts);

finally

// Всё возвращаем на место

SelectObject(Handle, OldPen);

if AFillEffect and (OldMode<>0) then

SetROP2(Handle, OldMode);

// И удаляем геометрическое перо

DeleteObject(NewPen);

end;

Как использовать

Где-то в момент инициализации, например в OnCreate формы, создаём экземпляр класса FList: TRunningAnts. На его событие OnPaint сразу вешаем обработчик отрисовки нашего героического пайнтбокса pb:

procedure TFmMain.FormCreate(Sender: TObject);
begin
  // Создаём рамку бегущих муравьёв с относительными координатами
  FList := TRunningAnts.Create(True);
  // Вешаем желание отрисоваться рамки на отрисовку пайнтбокса
  FList.OnPaint := pbPaint;
end;

procedure TFmMain.FormCreate(Sender: TObject);

begin

// Создаём рамку бегущих муравьёв с относительными координатами

FList := TRunningAnts.Create(True);

// Вешаем желание отрисоваться рамки на отрисовку пайнтбокса

FList.OnPaint := pbPaint;

end;

На pb обрабатываем события мыши и инициализируем линию муравьёв:

procedure TFmMain.pbMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  // Нажата именно левая кнопка мыши
  FMouseDown := ssLeft in Shift;
  if not FMouseDown then exit;
  // Если нажата, чистим список, уничтожаем предыдущую линию
  FList.Clear;
  // И добавляем первую точку
  FList.Add(X, Y, pb.ClientRect);
  // Отрисовку сгенерирует класс
end;

procedure TFmMain.pbMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  // Если сейчас нажата левая кнопка мыши, добавляем точки
  if FMouseDown then FList.Add(X, Y, pb.ClientRect);
  // Отрисовку сгенерирует класс
end;

procedure TFmMain.pbMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  // Мышь отжата, всё, построение закончилось
  FMouseDown := False;
  // Просим отрисоваться
  pbPaint(pb);
end;

procedure TFmMain.pbMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

// Нажата именно левая кнопка мыши

FMouseDown := ssLeft in Shift;

if not FMouseDown then exit;

// Если нажата, чистим список, уничтожаем предыдущую линию

FList.Clear;

// И добавляем первую точку

FList.Add(X, Y, pb.ClientRect);

// Отрисовку сгенерирует класс

end;

procedure TFmMain.pbMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

// Если сейчас нажата левая кнопка мыши, добавляем точки

if FMouseDown then FList.Add(X, Y, pb.ClientRect);

// Отрисовку сгенерирует класс

end;

procedure TFmMain.pbMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

// Мышь отжата, всё, построение закончилось

FMouseDown := False;

// Просим отрисоваться

pbPaint(pb);

end;

Обработчик события OnPaint пайнтбокса pb выглядит так:

procedure TFmMain.pbPaint(Sender: TObject);
var
  bmp: TBitmap;
  rct: TRect;
begin
  // Инициализация битмап-буфера, куда будем рисовать
  rct := pb.ClientRect;
  bmp := TBitmap.Create;
  bmp.SetSize(rct.Width, rct.Height);
  try
    with bmp.Canvas do
    begin
      // Подготовка холста, заливка белым
      rct := ClipRect;
      Brush.Color := clWhite;
      FillRect(rct);
      // Если требуется, рисунок на фон
      if CheckBox2.Checked then
        StretchDraw(rct, Image1.Picture.Graphic);
      // Рисуем то, что требуется
      if GDI.Checked then
        FList.PaintGDI(bmp.Canvas, pb.ClientRect, FillRegion.Checked)
      else if GDIP.Checked then
        FList.PaintGDIP(bmp.Canvas, pb.ClientRect, FillRegion.Checked)
      else
        FList.Paint(bmp.Canvas, pb.ClientRect, FillRegion.Checked);
      // Рисуем серую рамку вокруг всего
      Brush.Style := bsClear;
      Pen.Color := clBtnShadow;
      Pen.Mode := pmCopy;
      Pen.Width := 1;
      Rectangle(rct);
    end;
  finally
    // Рисуем битмап-буфер на холсте компонента
    pb.Canvas.Draw(0,0,bmp);
    // Освобождаем битмап-буфер
    bmp.Free;
  end;
end;

procedure TFmMain.pbPaint(Sender: TObject);

var

bmp: TBitmap;

rct: TRect;

begin

// Инициализация битмап-буфера, куда будем рисовать

rct := pb.ClientRect;

bmp := TBitmap.Create;

bmp.SetSize(rct.Width, rct.Height);

try

with bmp.Canvas do

begin

// Подготовка холста, заливка белым

rct := ClipRect;

Brush.Color := clWhite;

FillRect(rct);

// Если требуется, рисунок на фон

if CheckBox2.Checked then

StretchDraw(rct, Image1.Picture.Graphic);

// Рисуем то, что требуется

if GDI.Checked then

FList.PaintGDI(bmp.Canvas, pb.ClientRect, FillRegion.Checked)

else if GDIP.Checked then

FList.PaintGDIP(bmp.Canvas, pb.ClientRect, FillRegion.Checked)

else

FList.Paint(bmp.Canvas, pb.ClientRect, FillRegion.Checked);

// Рисуем серую рамку вокруг всего

Brush.Style := bsClear;

Pen.Color := clBtnShadow;

Pen.Mode := pmCopy;

Pen.Width := 1;

Rectangle(rct);

end;

finally

// Рисуем битмап-буфер на холсте компонента

pb.Canvas.Draw(0,0,bmp);

// Освобождаем битмап-буфер

bmp.Free;

end;

Остаётся загадкой, что такое FillRegion. Это опция, которая говорит — подзакрась выделенную область чем-нибудь полупрозрачным. Для метода PaintGDI это третий параметр AFillEffect: Boolean.

В итоге получаем следующее:

Бегущие муравьи в GDI+

Для отрисовки муравьёв в GDI+ у нас есть специальный метод:

procedure TRunningAnts.PaintGDIP(ACanvas: TCanvas; 
  const ARect: TRect; AFillEffect: Boolean);
type
  TUserStyleGDIP = array[0..3] of Single;
const
  // Массив стилей
  Zero = 1e-8; // Ноль воспринимает как ошибку
  UserStyles: array[0..3] of TUserStyleGDIP =
    ((4,4,Zero,Zero),(2,4,2,Zero),
     (Zero,4,4,Zero),(Zero,2,4,2));
var
  i: Integer;
  Style: TUserStyleGDIP;
  Pts: TArray<TPoint>;
  gpg: TGPGraphics;
  gppen: TGPPen;
  gpbrush: TGPBrush;
begin
  // Список пуст - делать тут нечего
  if FList.Count = 0 then exit;
  // Получаем массив точек линии
  Pts := GetPoints(ARect);
  // Определяем индекс в массиве стилей
  i := FTickTimer mod Length(UserStyles);
  // Получаем стиль
  Style := UserStyles[i];
  // Инициализируем холст и перо GDI+
  gpg := TGPGraphics.Create(ACanvas.Handle);
  gppen := TGPPen.Create(aclWhite);
  gpbrush := nil;

  try
    // Если указано, что надо закрасить
    if AFillEffect then
    begin
      // Создаем полупрозрачную кисть
      gpbrush := TGPSolidBrush.Create(MakeColor(120,$46,$82,$B4));
      // И рисуем до отрисовки линии, чтобы не перекрыть линии
      gpg.FillPolygon(gpbrush, PGPPoint(@Pts[0]), Length(Pts));
    end;
    // Рисуем белую сплошную линию
    gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));
    // Устанавливаем свой стиль для пера
    gppen.SetDashPattern(PSingle(@Style), Length(Style));
    // Указываем, что перо теперь чёрное
    gppen.SetColor(aclBlack);
    // И рисуем
    gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));
  finally
    // И потом всё освобождаем
    FreeAndNil(gpbrush);
    gppen.Free;
    gpg.Free;
  end;
end;

procedure TRunningAnts.PaintGDIP(ACanvas: TCanvas;

const ARect: TRect; AFillEffect: Boolean);

type

TUserStyleGDIP = array[0..3] of Single;

const

// Массив стилей

Zero = 1e-8; // Ноль воспринимает как ошибку

UserStyles: array[0..3] of TUserStyleGDIP =

((4,4,Zero,Zero),(2,4,2,Zero),

(Zero,4,4,Zero),(Zero,2,4,2));

var

i: Integer;

Style: TUserStyleGDIP;

Pts: TArray<TPoint>;

gpg: TGPGraphics;

gppen: TGPPen;

gpbrush: TGPBrush;

begin

// Список пуст - делать тут нечего

if FList.Count = 0 then exit;

// Получаем массив точек линии

Pts := GetPoints(ARect);

// Определяем индекс в массиве стилей

i := FTickTimer mod Length(UserStyles);

// Получаем стиль

Style := UserStyles[i];

// Инициализируем холст и перо GDI+

gpg := TGPGraphics.Create(ACanvas.Handle);

gppen := TGPPen.Create(aclWhite);

gpbrush := nil;

try

// Если указано, что надо закрасить

if AFillEffect then

begin

// Создаем полупрозрачную кисть

gpbrush := TGPSolidBrush.Create(MakeColor(120,$46,$82,$B4));

// И рисуем до отрисовки линии, чтобы не перекрыть линии

gpg.FillPolygon(gpbrush, PGPPoint(@Pts[0]), Length(Pts));

end;

// Рисуем белую сплошную линию

gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));

// Устанавливаем свой стиль для пера

gppen.SetDashPattern(PSingle(@Style), Length(Style));

// Указываем, что перо теперь чёрное

gppen.SetColor(aclBlack);

// И рисуем

gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));

finally

// И потом всё освобождаем

FreeAndNil(gpbrush);

gppen.Free;

gpg.Free;

end;

Пользовательский стиль для GDIP пера устанавливается его методом SetDashPattern. Первый параметр — указатель на массив стиля, второй — количество элементов в массиве.

    // Устанавливаем свой стиль для пера
    gppen.SetDashPattern(PSingle(@Style), Length(Style));

1 2	// Устанавливаем свой стиль для пера gppen.SetDashPattern(PSingle(@Style), Length(Style));

Хорошая новость: количество элементов не ограничено максимум 16-тью, как для GDI-пера (ограничения).

Плохая новость в том, что он точно также, как и косметическое GDI-перо, ненавидит нулевые значения в массиве стиля. Поэтому мы просто заменим ноль очень маленьким числом Zero = 1e-8.

Собственно:

Чем GDI+ отличается от GDI?

В первую очередь, временем выполнения. Сравните вот эти скачущие циферки внизу окна у GDI и GDI+. Это одна и та же траектория. Но в первом случае там мелькает даже 47 msec, а у второго максимум 11. Если мы максимизируем окно, точные числа станут вообще не важны. В этом случае у GDI может и до полсекунды доходить, в то время как GDI+ будет примерно 50 msec. Быстрый и шустрый GDI проигрывает GDI+ вчистую.

GDI+ медленный… GDI+ глючный… да?

Да и остальных плюсов масса — одна полупрозрачная заливка чего стоит.

Бегущие муравьи в GDI+ по другому

Есть в GDI+ способ, чтобы обойти этот трюк с очень маленьким Zero и сделать код куда более понятным.

У пера GDI+ есть метод SetDashOffset, который меняет стартовую позицию первого штриха. Поэтому мы не будем назначать всякий раз другие стили, пытаться обходить нулевые значения, а просто зададим один очень простой стиль:

const
  // Очень простой стиль
  UserStyle : array[0..1] of Single = (4,4);

const

// Очень простой стиль

UserStyle : array[0..1] of Single = (4,4);

И дальше будем просто смещать стартовую позицию на 2 логические единицы. Или пикселя.

    // Меняем стартовую точку пера
    i := FTickTimer mod 4;
    gppen.SetDashOffset(i*2);

// Меняем стартовую точку пера

i := FTickTimer mod 4;

gppen.SetDashOffset(i*2);

И теперь весь код метода, без лишних комментариев:

procedure TRunningAnts.Paint(ACanvas: TCanvas; 
  const ARect: TRect; AFillEffect: Boolean);
const
  UserStyle : array[0..1] of Single = (4,4);
var
  i: Integer;
  Pts: TArray<TPoint>;
  gpg: TGPGraphics;
  gppen: TGPPen;
  gpbrush: TGPBrush;
begin
  if FList.Count = 0 then exit;
  Pts := GetPoints(ARect);

  gpg := TGPGraphics.Create(ACanvas.Handle);
  gppen := TGPPen.Create(aclWhite);
  gpbrush := nil;

  try
    if AFillEffect then
    begin
      gpbrush := TGPSolidBrush.Create(MakeColor(80,$B0,$C4,$DE));
      gpg.FillPolygon(gpbrush, PGPPoint(@Pts[0]), Length(Pts));
    end;

    gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));
    gppen.SetDashPattern(PSingle(@UserStyle), Length(UserStyle));
    // Меняем стартовую точку пера
    i := FTickTimer mod 4;
    gppen.SetDashOffset(i*2);
    gppen.SetColor(aclBlack);
    gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));
  finally
    FreeAndNil(gpbrush);
    gppen.Free;
    gpg.Free;
  end;
end;

procedure TRunningAnts.Paint(ACanvas: TCanvas;

const ARect: TRect; AFillEffect: Boolean);

const

UserStyle : array[0..1] of Single = (4,4);

var

i: Integer;

Pts: TArray<TPoint>;

gpg: TGPGraphics;

gppen: TGPPen;

gpbrush: TGPBrush;

begin

if FList.Count = 0 then exit;

Pts := GetPoints(ARect);

gpg := TGPGraphics.Create(ACanvas.Handle);

gppen := TGPPen.Create(aclWhite);

gpbrush := nil;

try

if AFillEffect then

begin

gpbrush := TGPSolidBrush.Create(MakeColor(80,$B0,$C4,$DE));

gpg.FillPolygon(gpbrush, PGPPoint(@Pts[0]), Length(Pts));

end;

gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));

gppen.SetDashPattern(PSingle(@UserStyle), Length(UserStyle));

// Меняем стартовую точку пера

i := FTickTimer mod 4;

gppen.SetDashOffset(i*2);

gppen.SetColor(aclBlack);

gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));

finally

FreeAndNil(gpbrush);

gppen.Free;

gpg.Free;

end;

Всё очень просто.

Рис.3. Бегущие муравьи GDI+ SetDashOffset

Оба GDIP-метода примерно одинаковы по времени. И сильно быстрее GDI.

Практическое использование

Это конечно некое приближение. Писать полноценный редактор — формат статьи никак не позволяет. А исходник для такой статьи, в силу своей сложности, мало кому будет нужен. Поэтому это попытка показать практическое применение при минимальной сложности.

Итак, нужную область мы выделили. Теперь нужно произвести какое-то действие с этой областью. В нашем случае — сделать серым, повысить яркость, насыщенность или просто скопировать.

Здесь будет много под спойлерами и практически без комментариев. Всё это не по теме статьи, поэтому, чтобы не растекаться мыслью по древу.

Дополнительно в класс

Основная сложность — получить данные о выделенной области. Какая точка принадлежит ей, какая нет. Для этой цели добавим в класс перегруженный метод PtInArea:

    // Точка находится внутри выделенной области
    function PtInArea(X,Y: Integer): Boolean; overload;
    function PtInArea(const p: TPoint): Boolean; overload;

// Точка находится внутри выделенной области

function PtInArea(X,Y: Integer): Boolean; overload;

function PtInArea(const p: TPoint): Boolean; overload;

Медленная реализация PtInArea

function TRunningAnts.PtInArea(X,Y: Integer): Boolean;
begin
  Result := PtInArea(Point(X,Y));
end;

function TRunningAnts.PtInArea(const p: TPoint): Boolean;
var
  Path: TGPGraphicsPath;
begin
  Path := GetPath;
  Result := (Path <> nil) and (Path.IsVisible(p.X, p.Y));
end;

function TRunningAnts.PtInArea(X,Y: Integer): Boolean;

begin

Result := PtInArea(Point(X,Y));

end;

function TRunningAnts.PtInArea(const p: TPoint): Boolean;

var

Path: TGPGraphicsPath;

begin

Path := GetPath;

Result := (Path <> nil) and (Path.IsVisible(p.X, p.Y));

end;

Метод GetPath отдаёт кэшируемый объект типа TGPGraphicsPath, подобно массиву точек. Если путь был удалён ранее при изменении чего либо в классе, то метод создаст и проинициализирует его. TGPGraphicsPath умеет ответить на вопрос — принадлежит ли ему точка. Это метод IsVisible. Если требуется узнать, лежит ли точка на его внешней границе, надо использовать IsOutlineVisible.

[свернуть]

Эти методы используют TGPGraphicsPath в качестве источника информации о принадлежности точки. Эти методы оказались медленными. Это означает, что при выделении области мы не увидим немедленный эффект внутри области и будут очень неприятные тормоза.

Поэтому пишем быстрый метод PtInAreaEx, который использует весьма нетривиальный способ определения принадлежности точки.

function TRunningAnts.PtInAreaEx(X,Y: Integer): Boolean;
var
  bmp: TBitmap;
  i: Integer;
  p: PByte;
begin
  bmp := GetBitmap;
  if (bmp = nil) or (X>= FScanW) or (Y >= FScanH) then exit(False);
  p := FScan0;
  i := FScanL * (FScanH-1-Y) + X;
  Inc(p,i);
  Result := p^ <> 0;
end;

function TRunningAnts.PtInAreaEx(X,Y: Integer): Boolean;

var

bmp: TBitmap;

i: Integer;

p: PByte;

begin

bmp := GetBitmap;

if (bmp = nil) or (X>= FScanW) or (Y >= FScanH) then exit(False);

p := FScan0;

i := FScanL * (FScanH-1-Y) + X;

Inc(p,i);

Result := p^ <> 0;

end;

И GetBitmap, и GetPath возвращают кэшируемые данные. Они очищаются на любое изменение данных класса. На любое изменение в данных у нас появляется новое событие OnChange и метод его генерирующий:

procedure TRunningAnts.DoChange;
begin
  // Чистим кэш
  ClearCache;
  // Генерация события, если нет блокировки
  if not IsLocked and Assigned(FOnChange) then FOnChange(Self);
end;

procedure TRunningAnts.DoChange;

begin

// Чистим кэш

ClearCache;

// Генерация события, если нет блокировки

if not IsLocked and Assigned(FOnChange) then FOnChange(Self);

end;

В котором помимо генерации происходит очистка кэша.

procedure TRunningAnts.ClearCache;
begin
  // Сброс массива
  SetLength(FPoints, 0);
  // Уничтожаем путь
  FreeAndNil(FCachedPath);
  // Уничтожаем битмап
  FreeAndNil(FCachedBmp);
end;

procedure TRunningAnts.ClearCache;

begin

// Сброс массива

SetLength(FPoints, 0);

// Уничтожаем путь

FreeAndNil(FCachedPath);

// Уничтожаем битмап

FreeAndNil(FCachedBmp);

end;

Методы получения кэшированных данных

Метод, возвращающий кэшированную траекторию:

function TRunningAnts.GetPath: TGPGraphicsPath;
var
  Pts: TArray<TPoint>;
begin
  if FCachedPath = nil then
  begin
    Pts := GetPoints(FCachedRect);
    FCachedPath := TGPGraphicsPath.Create;
    FCachedPath.AddPolygon(PGPPoint(@Pts[0]), Length(Pts));
  end;
  Result := FCachedPath;
end;

function TRunningAnts.GetPath: TGPGraphicsPath;

var

Pts: TArray<TPoint>;

begin

if FCachedPath = nil then

begin

Pts := GetPoints(FCachedRect);

FCachedPath := TGPGraphicsPath.Create;

FCachedPath.AddPolygon(PGPPoint(@Pts[0]), Length(Pts));

end;

Result := FCachedPath;

end;

И метод, возвращающий кэшированный битмап, с форматом пикселя в один байт.

function TRunningAnts.GetBitmap: TBitmap;
var
  Pts: TArray<TPoint>;
begin
  if (FCachedBmp = nil) and (FCachedRect.Width > 0) and
    (FCachedRect.Height > 0)
  then
  begin
    FCachedBmp := TBitmap.Create;
    FCachedBmp.SetSize(FCachedRect.Width,FCachedRect.Height);
    FCachedBmp.PixelFormat := pf8bit;
    Pts := GetPoints(FCachedRect);
    with FCachedBmp.Canvas do
    begin
      Brush.Color := clBlack;
      FillRect(ClipRect);
      Brush.Color := clWhite;
      Polygon(Pts);
    end;
    FScan0 := FCachedBmp.ScanLine[FCachedBmp.Height-1];
    FScanW := FCachedBmp.Width;
    FScanH := FCachedBmp.Height;
    FScanL := BytesPerScanline(FScanW, 8, 32);
  end;
  Result := FCachedBmp;
end;

function TRunningAnts.GetBitmap: TBitmap;

var

Pts: TArray<TPoint>;

begin

if (FCachedBmp = nil) and (FCachedRect.Width > 0) and

(FCachedRect.Height > 0)

then

begin

FCachedBmp := TBitmap.Create;

FCachedBmp.SetSize(FCachedRect.Width,FCachedRect.Height);

FCachedBmp.PixelFormat := pf8bit;

Pts := GetPoints(FCachedRect);

with FCachedBmp.Canvas do

begin

Brush.Color := clBlack;

FillRect(ClipRect);

Brush.Color := clWhite;

Polygon(Pts);

end;

FScan0 := FCachedBmp.ScanLine[FCachedBmp.Height-1];

FScanW := FCachedBmp.Width;

FScanH := FCachedBmp.Height;

FScanL := BytesPerScanline(FScanW, 8, 32);

end;

Result := FCachedBmp;

end;

Помимо самого битмапа, кэшируются сопутствующие данные, используемые в PtInAreaEx.

Что тут конкретно происходит расскажу позже, о чём непременно сообщу в телеге, подписывайтесь.

[свернуть]

Действия с выбранной областью

Там, где класс используется, в нашем случае в главной (единственной) форме приложения, вешаемся на его событие OnChange

procedure TFmMain.FormCreate(Sender: TObject);
begin

  ...
  FList.OnChange := AntsChange;
end;

procedure TFmMain.FormCreate(Sender: TObject);

begin

...

FList.OnChange := AntsChange;

end;

с таким обработчиком:

procedure TFmMain.AntsChange(Sender: TObject);
begin
  FreeAndNil(FBitmapCache);
  pbPaint(pb);
end;

procedure TFmMain.AntsChange(Sender: TObject);

begin

FreeAndNil(FBitmapCache);

pbPaint(pb);

end;

При отрисовке, вызовется метод получения битмапа, который теперь создаётся на каждый чих. Внутри, в зависимости от выбранного эффекта, происходит определённая модификация выделенной области.

Обработка выбранной области

Если битмап был уничтожен, происходит не только создание и инициализация его, но и применяется выбранный эффект. При движении нажатой мыши, которая формирует выделенную область, можно видеть немедленное применение эффекта.

function TFmMain.BitmapCache: TBitmap;
var rct, Bounds: TRect;
begin
  if FBitmapCache = nil then
  begin
    rct := pb.ClientRect;
    FList.AreaRect := rct;
    Bounds := FList.Bounds;
    FBitmapCache := TBitmap.Create;
    FBitmapCache.SetSize(rct.Width, rct.Height);
    FBitmapCache.Canvas.StretchDraw(rct, Image1.Picture.Graphic);
    if GrayScale.Checked then
      FBitmapCache := EffectBitmap(FBitmapCache, 
        befGrayScale, Bounds, FList.PtInAreaEx)
    else if Brightness.Checked then
      FBitmapCache := EffectBitmap(FBitmapCache, 
        befBrightness, Bounds, FList.PtInAreaEx)
    else if Saturation.Checked then
      FBitmapCache := EffectBitmap(FBitmapCache, 
        befSaturation, Bounds, FList.PtInAreaEx)
    else if AlphaBlend.Checked then
      FBitmapCache := EffectBitmap(FBitmapCache, 
        befAlphaBlend, Bounds, FList.PtInAreaEx);
    FBitmapCache.AlphaFormat := afDefined;
  end;
  Result := FBitmapCache;
end;

function TFmMain.BitmapCache: TBitmap;

var rct, Bounds: TRect;

begin

if FBitmapCache = nil then

begin

rct := pb.ClientRect;

FList.AreaRect := rct;

Bounds := FList.Bounds;

FBitmapCache := TBitmap.Create;

FBitmapCache.SetSize(rct.Width, rct.Height);

FBitmapCache.Canvas.StretchDraw(rct, Image1.Picture.Graphic);

if GrayScale.Checked then

FBitmapCache := EffectBitmap(FBitmapCache,

befGrayScale, Bounds, FList.PtInAreaEx)

else if Brightness.Checked then

FBitmapCache := EffectBitmap(FBitmapCache,

befBrightness, Bounds, FList.PtInAreaEx)

else if Saturation.Checked then

FBitmapCache := EffectBitmap(FBitmapCache,

befSaturation, Bounds, FList.PtInAreaEx)

else if AlphaBlend.Checked then

FBitmapCache := EffectBitmap(FBitmapCache,

befAlphaBlend, Bounds, FList.PtInAreaEx);

FBitmapCache.AlphaFormat := afDefined;

end;

Result := FBitmapCache;

end;

Сама функция обработки битмапа такова (функции эффектов находятся в IP76.ColorUtils):

type
  TPointInArea = function(X,Y: Integer): Boolean of object;

  TBitmapEffect = (
    befGrayScale,  // Градации серого
    befBrightness, // Яркость
    befSaturation, // Насыщенность
    befAlphaBlend  // Полупрозрачность
    );

function EffectBitmap(ABitmap: TBitmap; AEffect: TBitmapEffect;
  const Bounds: TRect; const APtInArea: TPointInArea = nil): TBitmap;
var
  X,Y, RY: Integer;
  clr: TColor;
  rct: TRect;
  P: PRGBQuad;
begin
  ABitmap.PixelFormat := pf32bit;
  p := ABitmap.ScanLine[ABitmap.Height-1];
  rct := Bounds;
  for Y := 0 to ABitmap.Height-1 do
  begin
    RY := ABitmap.Height-Y-1;
    for X := 0 to ABitmap.Width-1 do
    begin
      p^.rgbReserved := 255;
      if (X>= rct.Left) and (X<=rct.Right) and
         (RY>= rct.Top) and (RY<=rct.Bottom) then
      if not Assigned(APtInArea) or APtInArea(X, RY) then
      begin
        case AEffect of
          befGrayScale:
              clr := GrayScaleColor(p);
          befBrightness:
              clr := BrightnessColor(RGB(p^.rgbRed,p^.rgbGreen,p^.rgbBlue), 0.5);
          befSaturation:
              clr := SaturationColor(RGB(p^.rgbRed,p^.rgbGreen,p^.rgbBlue), 1);
          else { befAlphaBlend }
            begin
              clr := RGB(p^.rgbRed,p^.rgbGreen,p^.rgbBlue);
              p^.rgbReserved := 70;
            end;
        end;
        p^.rgbBlue := GetBValue(clr);
        p^.rgbGreen := GetGValue(clr);
        p^.rgbRed := GetRValue(clr);
      end;
      inc(p);
    end;
  end;
  Result := ABitmap;
end;

type

TPointInArea = function(X,Y: Integer): Boolean of object;

TBitmapEffect = (

befGrayScale, // Градации серого

befBrightness, // Яркость

befSaturation, // Насыщенность

befAlphaBlend // Полупрозрачность

);

function EffectBitmap(ABitmap: TBitmap; AEffect: TBitmapEffect;

const Bounds: TRect; const APtInArea: TPointInArea = nil): TBitmap;

var

X,Y, RY: Integer;

clr: TColor;

rct: TRect;

P: PRGBQuad;

begin

ABitmap.PixelFormat := pf32bit;

p := ABitmap.ScanLine[ABitmap.Height-1];

rct := Bounds;

for Y := 0 to ABitmap.Height-1 do

begin

RY := ABitmap.Height-Y-1;

for X := 0 to ABitmap.Width-1 do

begin

p^.rgbReserved := 255;

if (X>= rct.Left) and (X<=rct.Right) and

(RY>= rct.Top) and (RY<=rct.Bottom) then

if not Assigned(APtInArea) or APtInArea(X, RY) then

begin

case AEffect of

befGrayScale:

clr := GrayScaleColor(p);

befBrightness:

clr := BrightnessColor(RGB(p^.rgbRed,p^.rgbGreen,p^.rgbBlue), 0.5);

befSaturation:

clr := SaturationColor(RGB(p^.rgbRed,p^.rgbGreen,p^.rgbBlue), 1);

else { befAlphaBlend }

begin

clr := RGB(p^.rgbRed,p^.rgbGreen,p^.rgbBlue);

p^.rgbReserved := 70;

end;

p^.rgbBlue := GetBValue(clr);

p^.rgbGreen := GetGValue(clr);

p^.rgbRed := GetRValue(clr);

end;

inc(p);

end;

Result := ABitmap;

end;

Параметр Bounds: TRect — это объемлющий прямоугольник траектории выделенной области. Его задача — сузить поиск точек, входящих в эту область.

[свернуть]

Копирование выбранной области

И наконец, копирование. Чтобы не засорять код — просто принцип, копируем область из натурального, не отмасштабированного изображения, без применения эффектов. Просто вырезаем выделенный кусок. Доступно по контекстному меню на изображении. Или Ctrl+C.

Поддержка альфа-канала тут весьма условна. Под ней понимается следующее: участок изображения вне области выделения должен стать прозрачным. Но это верно только для тех приложений, которые конкретно этот альфа-канал понимают. Например, Paint.net. Другие, те которые не понимают, вставят с черным фоном. Для них нужны особенные танцы с бубном.

Копировать выделенный участок изображения в буфер обмена

procedure TFmMain.Copy1Click(Sender: TObject);
var
  X,Y: Integer;
  bmp, src: TBitmap;
  b,s: PRGBQuad;
begin
  FList.Lock;
  try
    FList.AreaRect := Rect(0,0,
      Image1.Picture.Graphic.Width,
      Image1.Picture.Graphic.Height);

    src := TBitmap.Create;
    bmp := TBitmap.Create;
    try
      src.Assign(Image1.Picture.Graphic);
      src.PixelFormat := pf32bit;
      bmp.Assign(src);
      s := src.ScanLine[src.Height-1];
      b := bmp.ScanLine[bmp.Height-1];

      for Y := 0 to bmp.Height-1 do
        for X := 0 to bmp.Width-1 do
        begin
          if not FList.PtInAreaEx(X, bmp.Height-Y-1)
          then
            b^.rgbReserved := 0
          else
          begin
            b^ := s^;
            b^.rgbReserved := 255;
          end;
          inc(b);
          inc(s);
        end;
      // Чтобы вставился и альфа-канал
      bmp.AlphaFormat := afDefined;
      Clipboard.Assign(bmp);
    finally
      bmp.Free;
      src.Free;
    end;
  finally
    FList.Unlock;
  end;
end;

procedure TFmMain.Copy1Click(Sender: TObject);

var

X,Y: Integer;

bmp, src: TBitmap;

b,s: PRGBQuad;

begin

FList.Lock;

try

FList.AreaRect := Rect(0,0,

Image1.Picture.Graphic.Width,

Image1.Picture.Graphic.Height);

src := TBitmap.Create;

bmp := TBitmap.Create;

try

src.Assign(Image1.Picture.Graphic);

src.PixelFormat := pf32bit;

bmp.Assign(src);

s := src.ScanLine[src.Height-1];

b := bmp.ScanLine[bmp.Height-1];

for Y := 0 to bmp.Height-1 do

for X := 0 to bmp.Width-1 do

begin

if not FList.PtInAreaEx(X, bmp.Height-Y-1)

then

b^.rgbReserved := 0

else

begin

b^ := s^;

b^.rgbReserved := 255;

end;

inc(b);

inc(s);

end;

// Чтобы вставился и альфа-канал

bmp.AlphaFormat := afDefined;

Clipboard.Assign(bmp);

finally

bmp.Free;

src.Free;

end;

finally

FList.Unlock;

end;

[свернуть]

Рис.6. И вставляем в Paint.net. Всё что мимо — прозрачно.

Бегущие муравьи: Листинг

Вкратце получилось так. Это сугубо моё творчество, ни на что не претендующее. Тем более на истину в последней инстанции. Мне понадобилась такая рамка с муравьями, когда нужно было подсвечивать некие области произвольной формы. В инете ничего толкового не нашел, а хотелось быстро и просто. Думаю, что получилось достаточно просто. И надеюсь, полезно.

Для полноты картины привожу полный листинг модуля.

RunningAnts.pas

//******************************************************************************
//  Project: IP76.RU
//  Created: 2023-02-21
//  Article: https://ip76.ru/running-ants
//    Рамка "Бегущие муравьи" GDI,GDI+
//******************************************************************************

unit RunningAnts;

interface

uses Winapi.Windows, System.Classes, System.SysUtils, Vcl.Graphics,
  Vcl.ExtCtrls, System.Types, System.Generics.Collections,
  Winapi.GDIPAPI, Winapi.GDIPOBJ;

type

{$Region 'TRunningAnts: Рамка бегущих муравьёв'}

  // Рамка бегущих муравьёв
  TRunningAnts = class
  strict private
    // Список координат, которые могут быть относительными 0..1
    FList: TList<TPointF>;
    // Класс хранит относительные точки
    FSingleRange: Boolean;
  {$Region 'Кэшированные данные'}
  strict protected
    // Массив точек, по которым строится линия рамки
    FPoints: TArray<TPoint>;
    // Последний переданный прямоугольник при отрисовке
    FCachedRect: TRect;
    // Траектория, построенная на массиве точек
    FCachedPath: TGPGraphicsPath;
    // Объемлющий прямоугольник
    FBounds: TRect;
    // Маска выбранной области
    FCachedBmp: TBitmap;
    // Кэшированные параметры маски
    FScan0: PByte;   // Указатель на первый байт массива
    FScanW: Integer; // Ширина битмапа
    FScanH: Integer; // Высота битмапа
    FScanL: Integer; // Размер строки массива
    // Почистить кэшированные данные
    procedure ClearCache;
    // Получить путь, соответствующий траектории
    function GetPath: TGPGraphicsPath;
    // Получить битмап
    function GetBitmap: TBitmap;
    // Получить объемлющий прямоугольник
    function GetBounds: TRect;
    // Получить массив точек для построения полигона
    // Если класс хранит относительные координаты, происходит расчет
    // новых координат по ARect.Width и ARect.Height
    function GetPoints(const ARect: TRect): TArray<TPoint>;
    // Установить прямоугольник области рисования
    procedure SetRect(const Value: TRect);
  {$EndRegion}
  {$Region 'Таймер'}
  strict private
    // Внутренний таймер
    FTimer: TTimer;
    // Счётчик таймера
    FTickTimer: Integer;
  protected
    // Событие таймера
    procedure TimerEvent(Sender: TObject);
    // Стартовать таймер
    procedure Start;
    // Остановить и уничтожить таймер
    procedure Stop;
  {$EndRegion}
  {$Region 'Блокировки и события'}
  strict private
    // Счётчик блокировок
    FLockCount: Integer;
    // Событие - мне надо срочно нарисоваться
    FOnPaint: TNotifyEvent;
    // Событие - у меня что-то изменилось
    FOnChange: TNotifyEvent;
  strict protected
    // Генерация события OnPaint
    procedure DoPaint;
    // Генерация события OnChange
    procedure DoChange;
  public
    // Заблокировать/разблокировать генерацию событий
    // Должны идти парой Lock try ... finally Unlock end
    // Вложенность вызовов допустима
    procedure Lock;
    procedure Unlock;
    function IsLocked: Boolean;
  {$EndRegion}
  {$Region 'Работа с координатами'}
  public
    // Добавить точку
    function Add(X,Y: Single): Integer; overload;
    function Add(X,Y: Single; const ARect: TRect): Integer; overload;
    function Add(const P: TPointF): Integer; overload;
    // Очистить всё
    procedure Clear;
  {$EndRegion}
  public
    // ASingleRange - хранит ли класс относительные координаты (0..1)
    constructor Create(ASingleRange: Boolean);
    destructor Destroy; override;
    // Точка находится внутри выделенной области
    function PtInArea(X,Y: Integer): Boolean; overload;
    function PtInArea(const p: TPoint): Boolean; overload;
    function PtInAreaEx(X,Y: Integer): Boolean; overload;
    // Рисовать средствами GDI
    procedure PaintGDI(ACanvas: TCanvas; const ARect: TRect;
      AFillEffect: Boolean = False);
    // Рисовать средствами GDI+, переменный пользовательский стиль
    procedure PaintGDIP(ACanvas: TCanvas; const ARect: TRect;
      AFillEffect: Boolean = False);
    // Рисовать средствами GDI+, постоянный пользовательский стиль
    procedure Paint(ACanvas: TCanvas; const ARect: TRect;
      AFillEffect: Boolean = False);
    // Клиентская область, установка может привести к сбросу кэша
    property AreaRect: TRect read FCachedRect write SetRect;
    // Объемлющий прямоугольник
    property Bounds: TRect read GetBounds;
    // Надо меня нарисовать
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    // Произошли изменения
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

{$EndRegion}

implementation

{$Region 'TRunningAnts: Рамка бегущих муравьёв'}

{ TRunningAnts }
constructor TRunningAnts.Create(ASingleRange: Boolean);
begin
  FSingleRange := ASingleRange;
  FList := TList<TPointF>.Create;
end;

destructor TRunningAnts.Destroy;
begin
  FOnPaint := nil;
  FOnChange := nil;
  Clear; // Внутри вызов ClearCache
  FList.Free;
  inherited;
end;

  {$Region 'Кэшированные данные'}

procedure TRunningAnts.ClearCache;
begin
  // Сброс массива
  SetLength(FPoints, 0);
  // Уничтожаем путь
  FreeAndNil(FCachedPath);
  // Уничтожаем битмап
  FreeAndNil(FCachedBmp);
end;

function TRunningAnts.GetPath: TGPGraphicsPath;
var
  Pts: TArray<TPoint>;
  Rct: TGPRect;
begin
  if FCachedPath = nil then
  begin
    Pts := GetPoints(FCachedRect);
    FCachedPath := TGPGraphicsPath.Create;
    FCachedPath.AddPolygon(PGPPoint(@Pts[0]), Length(Pts));
    FCachedPath.GetBounds(rct);
    FBounds := Rect(rct.X, rct.Y, rct.X + rct.Width, rct.Y + rct.Height);
  end;
  Result := FCachedPath;
end;

function TRunningAnts.GetBitmap: TBitmap;
var
  Pts: TArray<TPoint>;
begin
  if (FCachedBmp = nil) and (FCachedRect.Width > 0) and
    (FCachedRect.Height > 0)
  then
  begin
    FCachedBmp := TBitmap.Create;
    FCachedBmp.SetSize(FCachedRect.Width,FCachedRect.Height);
    FCachedBmp.PixelFormat := pf8bit;
    Pts := GetPoints(FCachedRect);
    with FCachedBmp.Canvas do
    begin
      Brush.Color := clBlack;
      FillRect(ClipRect);
      Brush.Color := clWhite;
      Polygon(Pts);
    end;
    FScan0 := FCachedBmp.ScanLine[FCachedBmp.Height-1];
    FScanW := FCachedBmp.Width;
    FScanH := FCachedBmp.Height;
    FScanL := BytesPerScanline(FScanW, 8, 32);
  end;
  Result := FCachedBmp;
end;

function TRunningAnts.GetBounds: TRect;
// var rct: TGPRect;
begin
  if GetPath <> nil then exit(FBounds);
  Result := Rect(0,0,0,0);
// Или второй вариант, который без фанатизма
//  GetPath.GetBounds(rct);
//  Result := Rect(rct.X, rct.Y, rct.X + rct.Width, rct.Y + rct.Height);
end;

function TRunningAnts.GetPoints(const ARect: TRect): TArray<TPoint>;
var
  w,h: Integer; // Высота и ширина
  l,t: Integer; // Смещения слева и сверху
  p: TPointF;   // Хранимая координата
  v: TPoint;    // Расчётная координата
  i: Integer;
begin
  // Если размеры не совпадут, кэш сбросится
  SetRect(ARect);
  // Если массив точек уже посчитан - выходим
  if Length(FPoints) <> 0 then exit(FPoints);
  // Делаем размер массива равным количеству хранимых координат
  SetLength(FPoints, FList.Count);
  if not FSingleRange then
  begin
    // Если хранимые координаты абсолютные,
    // размер и смещения не важны
    w := 1; h := 1;
    l := 0; t := 0;
  end
  else
  begin
    // Если хранимые координаты относительные,
    // размер и смещения важны
    w := ARect.Width; h := ARect.Height;
    l := ARect.Left; t := ARect.Top;
  end;
  // Пробег по хранимым координатам и расчёт точек линии
  for i := 0 to High(FPoints) do
  begin
    p := FList[i];
    v.X := l + Round(p.X*w);
    v.Y := t + Round(p.Y*h);
    FPoints[i] := v;
  end;
  Result := FPoints;
end;

procedure TRunningAnts.SetRect(const Value: TRect);
begin
  if FCachedRect <> Value then
    ClearCache;
  FCachedRect := Value;
end;

  {$EndRegion}

  {$Region 'Таймер'}

procedure TRunningAnts.TimerEvent(Sender: TObject);
begin
  if Sender <> FTimer then exit;
  Inc(FTickTimer);
  DoPaint;
end;

procedure TRunningAnts.Start;
begin
  if FTimer = nil then
  begin
    FTimer := TTimer.Create(nil);
    FTimer.Enabled := False;
    FTimer.Interval := 50;
    FTimer.OnTimer := TimerEvent;
  end;
  FTimer.Enabled := True;
end;

procedure TRunningAnts.Stop;
begin
  if FTimer = nil then exit;
  FTimer.Enabled := False;
  FTimer.OnTimer := nil;
  FreeAndNil(FTimer);
end;

  {$EndRegion}

  {$Region 'Блокировки и события'}

procedure TRunningAnts.DoPaint;
begin
  // Генерация события, если нет блокировки
  if not IsLocked and Assigned(FOnPaint) then FOnPaint(Self);
end;

procedure TRunningAnts.DoChange;
begin
  // Чистим кэш
  ClearCache;
  // Генерация события, если нет блокировки
  if not IsLocked and Assigned(FOnChange) then FOnChange(Self);
end;

procedure TRunningAnts.Lock;
begin
  Inc(FLockCount);
end;

procedure TRunningAnts.Unlock;
begin
  Dec(FLockCount);
end;

function TRunningAnts.IsLocked: Boolean;
begin
  Result := FLockCount <> 0;
end;

  {$EndRegion}

  {$Region 'Работа с координатами'}

function TRunningAnts.Add(X,Y: Single): Integer;
begin
  Result := Add(PointF(X,Y));
end;

function TRunningAnts.Add(X,Y: Single; const ARect: TRect): Integer;
begin
  // Если заказаны абсолютные координаты или
  // передан пустой прямоугольник,
  if not FSingleRange or ARect.IsEmpty then
  // То просто добавляем координаты и выходим
    exit(Add(X,Y));
  // Нормализуем координаты
  X := X - ARect.Left;
  Y := Y - ARect.Top;
  // Добавляем относительные координаты
  Result := Add(X/ARect.Width, Y/ARect.Height);
end;

function TRunningAnts.Add(const P: TPointF): Integer;
begin
  // Добавили точку в список
  Result := FList.Add(P);
  // Стартуем таймер
  Start;
  // Что-то изменилось...
  DoChange; // Внутри вызов ClearCache
end;

procedure TRunningAnts.Clear;
begin
  // Остановили (убили) таймер
  Stop;
  // Чистим список координат
  FList.Clear;
  // Что-то изменилось...
  DoChange; // Внутри вызов ClearCache
end;

  {$EndRegion}

function TRunningAnts.PtInArea(X,Y: Integer): Boolean;
begin
  Result := PtInArea(Point(X,Y));
end;

function TRunningAnts.PtInArea(const p: TPoint): Boolean;
var
  Path: TGPGraphicsPath;
begin
  Path := GetPath;
  Result := (Path <> nil) and (Path.IsVisible(p.X, p.Y));
end;

function TRunningAnts.PtInAreaEx(X,Y: Integer): Boolean;
var
  bmp: TBitmap;
  i: Integer;
  p: PByte;
begin
  bmp := GetBitmap;
  if (bmp = nil) or (X>= FScanW) or (Y >= FScanH) then exit(False);
  p := FScan0;
  i := FScanL * (FScanH-1-Y) + X;
  Inc(p,i);
  Result := p^ <> 0;
end;

procedure TRunningAnts.PaintGDI(ACanvas: TCanvas; const ARect: TRect;
  AFillEffect: Boolean = False);
type
  TUserStyle = array[0..3] of Cardinal;
const
  // Массив стилей
  UserStyles: array[0..3] of TUserStyle =
    ((4,4,0,0),(2,4,2,0),(0,4,4,0),(0,2,4,2));
var
  i: Integer;
  br: TLogBrush;
  Style: TUserStyle;
  Pts: TArray<TPoint>;
  OldPen, NewPen: HPEN;
  OldMode: Integer;
begin
  OldMode := 0; // Чтоб не бесил хинтами
  // Список пуст - делать тут нечего
  if FList.Count = 0 then exit;
  // Получаем массив точек линии
  Pts := GetPoints(ARect);
  // Определяем индекс в массиве стилей
  i := FTickTimer mod Length(UserStyles);
  // Получаем стиль
  Style := UserStyles[i];

  with ACanvas do
  begin
    // Рисуем сплошную белую
    Pen.Color := clWhite;
    Pen.Style := psSolid;
    if not AFillEffect then
      Brush.Style := bsClear
    else
      Pen.Mode := pmXor;
    Polygon(Pts);
    // Инициализируем цвет пера - черный
    br.lbStyle := BS_SOLID;
    br.lbColor := 0;
    // Создаем геометрическое перо
    NewPen := ExtCreatePen(
      PS_GEOMETRIC OR PS_USERSTYLE OR PS_ENDCAP_FLAT OR PS_JOIN_BEVEL,
      1, br, Length(Style), @Style);
    OldPen := SelectObject(Handle, NewPen);
    // Если указано, что с заливкой, меняем режим пера
    if AFillEffect then
      OldMode := SetROP2(Handle, R2_NOTXORPEN);
    // Рисуем полигон пользовательским стилем
    try
      Polygon(Pts);
    finally
      // Всё возвращаем на место
      SelectObject(Handle, OldPen);
      if AFillEffect and (OldMode<>0) then
        SetROP2(Handle, OldMode);
      // И удаляем геометрическое перо
      DeleteObject(NewPen);
    end;
  end;
end;

procedure TRunningAnts.PaintGDIP(ACanvas: TCanvas; const ARect: TRect;
  AFillEffect: Boolean = false);
type
  TUserStyleGDIP = array[0..3] of Single;
const
  // Массив стилей
  Zero = 1e-8; // Ноль воспринимает как ошибку
  UserStyles: array[0..3] of TUserStyleGDIP =
    ((4,4,Zero,Zero),(2,4,2,Zero),
     (Zero,4,4,Zero),(Zero,2,4,2));
var
  i: Integer;
  Style: TUserStyleGDIP;
  Pts: TArray<TPoint>;
  gpg: TGPGraphics;
  gppen: TGPPen;
  gpbrush: TGPBrush;
begin
  // Список пуст - делать тут нечего
  if FList.Count = 0 then exit;
  // Получаем массив точек линии
  Pts := GetPoints(ARect);
  // Определяем индекс в массиве стилей
  i := FTickTimer mod Length(UserStyles);
  // Получаем стиль
  Style := UserStyles[i];
  // Инициализируем холст и перо GDI+
  gpg := TGPGraphics.Create(ACanvas.Handle);
  gppen := TGPPen.Create(aclWhite);
  gpbrush := nil;
  try
    // Если указано, что надо закрасить
    if AFillEffect then
    begin
      // Создаем полупрозрачную кисть
      gpbrush := TGPSolidBrush.Create(MakeColor(120,$46,$82,$B4));
      // И рисуем до отрисовки линии, чтобы не перекрыть линии
      gpg.FillPolygon(gpbrush, PGPPoint(@Pts[0]), Length(Pts));
    end;
    // Рисуем белую сплошную линию
    gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));
    // Устанавливаем свой стиль для пера
    gppen.SetDashPattern(PSingle(@Style), Length(Style));
    // Указываем, что перо теперь чёрное
    gppen.SetColor(aclBlack);
    // И рисуем
    gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));
  finally
    // И потом всё освобождаем
    FreeAndNil(gpbrush);
    gppen.Free;
    gpg.Free;
  end;
end;

procedure TRunningAnts.Paint(ACanvas: TCanvas; const ARect: TRect;
  AFillEffect: Boolean = False);
const
  UserStyle : array[0..1] of Single = (4,4);
var
  i: Integer;
  Pts: TArray<TPoint>;
  gpg: TGPGraphics;
  gppen: TGPPen;
  gpbrush: TGPBrush;
begin
  if FList.Count = 0 then exit;
  Pts := GetPoints(ARect);

  gpg := TGPGraphics.Create(ACanvas.Handle);
  gppen := TGPPen.Create(aclWhite);
  gpbrush := nil;

  try
    if AFillEffect then
    begin
      gpbrush := TGPSolidBrush.Create(MakeColor(80,$B0,$C4,$DE));
      gpg.FillPolygon(gpbrush, PGPPoint(@Pts[0]), Length(Pts));
    end;

    gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));
    gppen.SetDashPattern(PSingle(@UserStyle), Length(UserStyle));
    // Меняем стартовую точку пера
    i := FTickTimer mod 4;
    gppen.SetDashOffset(i*2);
    gppen.SetColor(aclBlack);
    gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));
  finally
    FreeAndNil(gpbrush);
    gppen.Free;
    gpg.Free;
  end;
end;

{$EndRegion}

end.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

450

451

452

453

454

455

456

457

458

459

460

461

462

463

464

465

466

467

468

469

470

471

472

473

474

475

476

477

478

479

480

481

482

483

484

485

486

487

488

489

490

491

492

493

494

495

496

497

498

499

500

501

502

503

504

505

506

507

508

509

510

511

512

513

514

515

516

517

518

519

520

521

522

523

524

525

526

527

528

529

530

531

532

533

534

535

536

537

538

539

540

541

542

543

544

545

546

547

548

549

550

551

552

553

554

555

556

//******************************************************************************

// Project: IP76.RU

// Created: 2023-02-21

// Article: https://ip76.ru/running-ants

// Рамка "Бегущие муравьи" GDI,GDI+

//******************************************************************************

unit RunningAnts;

interface

uses Winapi.Windows, System.Classes, System.SysUtils, Vcl.Graphics,

Vcl.ExtCtrls, System.Types, System.Generics.Collections,

Winapi.GDIPAPI, Winapi.GDIPOBJ;

type

{$Region 'TRunningAnts: Рамка бегущих муравьёв'}

// Рамка бегущих муравьёв

TRunningAnts = class

strict private

// Список координат, которые могут быть относительными 0..1

FList: TList<TPointF>;

// Класс хранит относительные точки

FSingleRange: Boolean;

{$Region 'Кэшированные данные'}

strict protected

// Массив точек, по которым строится линия рамки

FPoints: TArray<TPoint>;

// Последний переданный прямоугольник при отрисовке

FCachedRect: TRect;

// Траектория, построенная на массиве точек

FCachedPath: TGPGraphicsPath;

// Объемлющий прямоугольник

FBounds: TRect;

// Маска выбранной области

FCachedBmp: TBitmap;

// Кэшированные параметры маски

FScan0: PByte; // Указатель на первый байт массива

FScanW: Integer; // Ширина битмапа

FScanH: Integer; // Высота битмапа

FScanL: Integer; // Размер строки массива

// Почистить кэшированные данные

procedure ClearCache;

// Получить путь, соответствующий траектории

function GetPath: TGPGraphicsPath;

// Получить битмап

function GetBitmap: TBitmap;

// Получить объемлющий прямоугольник

function GetBounds: TRect;

// Получить массив точек для построения полигона

// Если класс хранит относительные координаты, происходит расчет

// новых координат по ARect.Width и ARect.Height

function GetPoints(const ARect: TRect): TArray<TPoint>;

// Установить прямоугольник области рисования

procedure SetRect(const Value: TRect);

{$EndRegion}

{$Region 'Таймер'}

strict private

// Внутренний таймер

FTimer: TTimer;

// Счётчик таймера

FTickTimer: Integer;

protected

// Событие таймера

procedure TimerEvent(Sender: TObject);

// Стартовать таймер

procedure Start;

// Остановить и уничтожить таймер

procedure Stop;

{$EndRegion}

{$Region 'Блокировки и события'}

strict private

// Счётчик блокировок

FLockCount: Integer;

// Событие - мне надо срочно нарисоваться

FOnPaint: TNotifyEvent;

// Событие - у меня что-то изменилось

FOnChange: TNotifyEvent;

strict protected

// Генерация события OnPaint

procedure DoPaint;

// Генерация события OnChange

procedure DoChange;

public

// Заблокировать/разблокировать генерацию событий

// Должны идти парой Lock try ... finally Unlock end

// Вложенность вызовов допустима

procedure Lock;

procedure Unlock;

function IsLocked: Boolean;

{$EndRegion}

{$Region 'Работа с координатами'}

public

// Добавить точку

function Add(X,Y: Single): Integer; overload;

function Add(X,Y: Single; const ARect: TRect): Integer; overload;

function Add(const P: TPointF): Integer; overload;

// Очистить всё

procedure Clear;

{$EndRegion}

public

// ASingleRange - хранит ли класс относительные координаты (0..1)

constructor Create(ASingleRange: Boolean);

destructor Destroy; override;

// Точка находится внутри выделенной области

function PtInArea(X,Y: Integer): Boolean; overload;

function PtInArea(const p: TPoint): Boolean; overload;

function PtInAreaEx(X,Y: Integer): Boolean; overload;

// Рисовать средствами GDI

procedure PaintGDI(ACanvas: TCanvas; const ARect: TRect;

AFillEffect: Boolean = False);

// Рисовать средствами GDI+, переменный пользовательский стиль

procedure PaintGDIP(ACanvas: TCanvas; const ARect: TRect;

AFillEffect: Boolean = False);

// Рисовать средствами GDI+, постоянный пользовательский стиль

procedure Paint(ACanvas: TCanvas; const ARect: TRect;

AFillEffect: Boolean = False);

// Клиентская область, установка может привести к сбросу кэша

property AreaRect: TRect read FCachedRect write SetRect;

// Объемлющий прямоугольник

property Bounds: TRect read GetBounds;

// Надо меня нарисовать

property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;

// Произошли изменения

property OnChange: TNotifyEvent read FOnChange write FOnChange;

end;

{$EndRegion}

implementation

{$Region 'TRunningAnts: Рамка бегущих муравьёв'}

{ TRunningAnts }

constructor TRunningAnts.Create(ASingleRange: Boolean);

begin

FSingleRange := ASingleRange;

FList := TList<TPointF>.Create;

end;

destructor TRunningAnts.Destroy;

begin

FOnPaint := nil;

FOnChange := nil;

Clear; // Внутри вызов ClearCache

FList.Free;

inherited;

end;

{$Region 'Кэшированные данные'}

procedure TRunningAnts.ClearCache;

begin

// Сброс массива

SetLength(FPoints, 0);

// Уничтожаем путь

FreeAndNil(FCachedPath);

// Уничтожаем битмап

FreeAndNil(FCachedBmp);

end;

function TRunningAnts.GetPath: TGPGraphicsPath;

var

Pts: TArray<TPoint>;

Rct: TGPRect;

begin

if FCachedPath = nil then

begin

Pts := GetPoints(FCachedRect);

FCachedPath := TGPGraphicsPath.Create;

FCachedPath.AddPolygon(PGPPoint(@Pts[0]), Length(Pts));

FCachedPath.GetBounds(rct);

FBounds := Rect(rct.X, rct.Y, rct.X + rct.Width, rct.Y + rct.Height);

end;

Result := FCachedPath;

end;

function TRunningAnts.GetBitmap: TBitmap;

var

Pts: TArray<TPoint>;

begin

if (FCachedBmp = nil) and (FCachedRect.Width > 0) and

(FCachedRect.Height > 0)

then

begin

FCachedBmp := TBitmap.Create;

FCachedBmp.SetSize(FCachedRect.Width,FCachedRect.Height);

FCachedBmp.PixelFormat := pf8bit;

Pts := GetPoints(FCachedRect);

with FCachedBmp.Canvas do

begin

Brush.Color := clBlack;

FillRect(ClipRect);

Brush.Color := clWhite;

Polygon(Pts);

end;

FScan0 := FCachedBmp.ScanLine[FCachedBmp.Height-1];

FScanW := FCachedBmp.Width;

FScanH := FCachedBmp.Height;

FScanL := BytesPerScanline(FScanW, 8, 32);

end;

Result := FCachedBmp;

end;

function TRunningAnts.GetBounds: TRect;

// var rct: TGPRect;

begin

if GetPath <> nil then exit(FBounds);

Result := Rect(0,0,0,0);

// Или второй вариант, который без фанатизма

// GetPath.GetBounds(rct);

// Result := Rect(rct.X, rct.Y, rct.X + rct.Width, rct.Y + rct.Height);

end;

function TRunningAnts.GetPoints(const ARect: TRect): TArray<TPoint>;

var

w,h: Integer; // Высота и ширина

l,t: Integer; // Смещения слева и сверху

p: TPointF; // Хранимая координата

v: TPoint; // Расчётная координата

i: Integer;

begin

// Если размеры не совпадут, кэш сбросится

SetRect(ARect);

// Если массив точек уже посчитан - выходим

if Length(FPoints) <> 0 then exit(FPoints);

// Делаем размер массива равным количеству хранимых координат

SetLength(FPoints, FList.Count);

if not FSingleRange then

begin

// Если хранимые координаты абсолютные,

// размер и смещения не важны

w := 1; h := 1;

l := 0; t := 0;

end

else

begin

// Если хранимые координаты относительные,

// размер и смещения важны

w := ARect.Width; h := ARect.Height;

l := ARect.Left; t := ARect.Top;

end;

// Пробег по хранимым координатам и расчёт точек линии

for i := 0 to High(FPoints) do

begin

p := FList[i];

v.X := l + Round(p.X*w);

v.Y := t + Round(p.Y*h);

FPoints[i] := v;

end;

Result := FPoints;

end;

procedure TRunningAnts.SetRect(const Value: TRect);

begin

if FCachedRect <> Value then

ClearCache;

FCachedRect := Value;

end;

{$EndRegion}

{$Region 'Таймер'}

procedure TRunningAnts.TimerEvent(Sender: TObject);

begin

if Sender <> FTimer then exit;

Inc(FTickTimer);

DoPaint;

end;

procedure TRunningAnts.Start;

begin

if FTimer = nil then

begin

FTimer := TTimer.Create(nil);

FTimer.Enabled := False;

FTimer.Interval := 50;

FTimer.OnTimer := TimerEvent;

end;

FTimer.Enabled := True;

end;

procedure TRunningAnts.Stop;

begin

if FTimer = nil then exit;

FTimer.Enabled := False;

FTimer.OnTimer := nil;

FreeAndNil(FTimer);

end;

{$EndRegion}

{$Region 'Блокировки и события'}

procedure TRunningAnts.DoPaint;

begin

// Генерация события, если нет блокировки

if not IsLocked and Assigned(FOnPaint) then FOnPaint(Self);

end;

procedure TRunningAnts.DoChange;

begin

// Чистим кэш

ClearCache;

// Генерация события, если нет блокировки

if not IsLocked and Assigned(FOnChange) then FOnChange(Self);

end;

procedure TRunningAnts.Lock;

begin

Inc(FLockCount);

end;

procedure TRunningAnts.Unlock;

begin

Dec(FLockCount);

end;

function TRunningAnts.IsLocked: Boolean;

begin

Result := FLockCount <> 0;

end;

{$EndRegion}

{$Region 'Работа с координатами'}

function TRunningAnts.Add(X,Y: Single): Integer;

begin

Result := Add(PointF(X,Y));

end;

function TRunningAnts.Add(X,Y: Single; const ARect: TRect): Integer;

begin

// Если заказаны абсолютные координаты или

// передан пустой прямоугольник,

if not FSingleRange or ARect.IsEmpty then

// То просто добавляем координаты и выходим

exit(Add(X,Y));

// Нормализуем координаты

X := X - ARect.Left;

Y := Y - ARect.Top;

// Добавляем относительные координаты

Result := Add(X/ARect.Width, Y/ARect.Height);

end;

function TRunningAnts.Add(const P: TPointF): Integer;

begin

// Добавили точку в список

Result := FList.Add(P);

// Стартуем таймер

Start;

// Что-то изменилось...

DoChange; // Внутри вызов ClearCache

end;

procedure TRunningAnts.Clear;

begin

// Остановили (убили) таймер

Stop;

// Чистим список координат

FList.Clear;

// Что-то изменилось...

DoChange; // Внутри вызов ClearCache

end;

{$EndRegion}

function TRunningAnts.PtInArea(X,Y: Integer): Boolean;

begin

Result := PtInArea(Point(X,Y));

end;

function TRunningAnts.PtInArea(const p: TPoint): Boolean;

var

Path: TGPGraphicsPath;

begin

Path := GetPath;

Result := (Path <> nil) and (Path.IsVisible(p.X, p.Y));

end;

function TRunningAnts.PtInAreaEx(X,Y: Integer): Boolean;

var

bmp: TBitmap;

i: Integer;

p: PByte;

begin

bmp := GetBitmap;

if (bmp = nil) or (X>= FScanW) or (Y >= FScanH) then exit(False);

p := FScan0;

i := FScanL * (FScanH-1-Y) + X;

Inc(p,i);

Result := p^ <> 0;

end;

procedure TRunningAnts.PaintGDI(ACanvas: TCanvas; const ARect: TRect;

AFillEffect: Boolean = False);

type

TUserStyle = array[0..3] of Cardinal;

const

// Массив стилей

UserStyles: array[0..3] of TUserStyle =

((4,4,0,0),(2,4,2,0),(0,4,4,0),(0,2,4,2));

var

i: Integer;

br: TLogBrush;

Style: TUserStyle;

Pts: TArray<TPoint>;

OldPen, NewPen: HPEN;

OldMode: Integer;

begin

OldMode := 0; // Чтоб не бесил хинтами

// Список пуст - делать тут нечего

if FList.Count = 0 then exit;

// Получаем массив точек линии

Pts := GetPoints(ARect);

// Определяем индекс в массиве стилей

i := FTickTimer mod Length(UserStyles);

// Получаем стиль

Style := UserStyles[i];

with ACanvas do

begin

// Рисуем сплошную белую

Pen.Color := clWhite;

Pen.Style := psSolid;

if not AFillEffect then

Brush.Style := bsClear

else

Pen.Mode := pmXor;

Polygon(Pts);

// Инициализируем цвет пера - черный

br.lbStyle := BS_SOLID;

br.lbColor := 0;

// Создаем геометрическое перо

NewPen := ExtCreatePen(

PS_GEOMETRIC OR PS_USERSTYLE OR PS_ENDCAP_FLAT OR PS_JOIN_BEVEL,

1, br, Length(Style), @Style);

OldPen := SelectObject(Handle, NewPen);

// Если указано, что с заливкой, меняем режим пера

if AFillEffect then

OldMode := SetROP2(Handle, R2_NOTXORPEN);

// Рисуем полигон пользовательским стилем

try

Polygon(Pts);

finally

// Всё возвращаем на место

SelectObject(Handle, OldPen);

if AFillEffect and (OldMode<>0) then

SetROP2(Handle, OldMode);

// И удаляем геометрическое перо

DeleteObject(NewPen);

end;

procedure TRunningAnts.PaintGDIP(ACanvas: TCanvas; const ARect: TRect;

AFillEffect: Boolean = false);

type

TUserStyleGDIP = array[0..3] of Single;

const

// Массив стилей

Zero = 1e-8; // Ноль воспринимает как ошибку

UserStyles: array[0..3] of TUserStyleGDIP =

((4,4,Zero,Zero),(2,4,2,Zero),

(Zero,4,4,Zero),(Zero,2,4,2));

var

i: Integer;

Style: TUserStyleGDIP;

Pts: TArray<TPoint>;

gpg: TGPGraphics;

gppen: TGPPen;

gpbrush: TGPBrush;

begin

// Список пуст - делать тут нечего

if FList.Count = 0 then exit;

// Получаем массив точек линии

Pts := GetPoints(ARect);

// Определяем индекс в массиве стилей

i := FTickTimer mod Length(UserStyles);

// Получаем стиль

Style := UserStyles[i];

// Инициализируем холст и перо GDI+

gpg := TGPGraphics.Create(ACanvas.Handle);

gppen := TGPPen.Create(aclWhite);

gpbrush := nil;

try

// Если указано, что надо закрасить

if AFillEffect then

begin

// Создаем полупрозрачную кисть

gpbrush := TGPSolidBrush.Create(MakeColor(120,$46,$82,$B4));

// И рисуем до отрисовки линии, чтобы не перекрыть линии

gpg.FillPolygon(gpbrush, PGPPoint(@Pts[0]), Length(Pts));

end;

// Рисуем белую сплошную линию

gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));

// Устанавливаем свой стиль для пера

gppen.SetDashPattern(PSingle(@Style), Length(Style));

// Указываем, что перо теперь чёрное

gppen.SetColor(aclBlack);

// И рисуем

gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));

finally

// И потом всё освобождаем

FreeAndNil(gpbrush);

gppen.Free;

gpg.Free;

end;

procedure TRunningAnts.Paint(ACanvas: TCanvas; const ARect: TRect;

AFillEffect: Boolean = False);

const

UserStyle : array[0..1] of Single = (4,4);

var

i: Integer;

Pts: TArray<TPoint>;

gpg: TGPGraphics;

gppen: TGPPen;

gpbrush: TGPBrush;

begin

if FList.Count = 0 then exit;

Pts := GetPoints(ARect);

gpg := TGPGraphics.Create(ACanvas.Handle);

gppen := TGPPen.Create(aclWhite);

gpbrush := nil;

try

if AFillEffect then

begin

gpbrush := TGPSolidBrush.Create(MakeColor(80,$B0,$C4,$DE));

gpg.FillPolygon(gpbrush, PGPPoint(@Pts[0]), Length(Pts));

end;

gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));

gppen.SetDashPattern(PSingle(@UserStyle), Length(UserStyle));

// Меняем стартовую точку пера

i := FTickTimer mod 4;

gppen.SetDashOffset(i*2);

gppen.SetColor(aclBlack);

gpg.DrawPolygon(gppen, PGPPoint(@Pts[0]), Length(Pts));

finally

FreeAndNil(gpbrush);

gppen.Free;

gpg.Free;

end;

{$EndRegion}

end.

[свернуть]

Скачать

Друзья, спасибо за внимание!

Бегущие муравьи: Рисование в GDI, GDI+

Исходник (zip) 172 Кб. Delphi XE 7, XE 10, XE 11

Исполняемый файл (zip) 1.03 Мб.

Бегущие муравьи: Использование

Исходник (zip) 378 Кб. Delphi XE 7, XE 10, XE 11

Исполняемый файл (zip) 1.16 Мб.

Друзья! Буду чрезвычайно признателен за комментарии, регистрацию на сайте, подписку в телеге. Это очень большая моральная поддержка для меня.

5 7 голоса

Рейтинг статьи

0 комментариев

Межтекстовые Отзывы

Посмотреть все комментарии