Программирование на Delphi

FAQ VCL
Графика

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как нарисовать стрелку?


// Способ первый
uses
  {...,} Math;

procedure DrawEdje(BeginPoint, EndPoint:TPoint; Canvas: TCanvas; Arrow: boolean = True);
var
  Angle: Real;
  p1, p2: TPoint;
begin
  with Canvas do
  begin
    MoveTo( BeginPoint.X, BeginPoint.Y );
    LineTo( EndPoint.X, EndPoint.Y );
    if Arrow then
    begin
      // Angle := 180 * ArcTan((EndPoint.y - BeginPoint.y) / (EndPoint.x - BeginPoint.x)) / pi;
      Angle := 180 * ArcTan2(EndPoint.y - BeginPoint.y, EndPoint.x - BeginPoint.x) / pi;
      p1 := Point(EndPoint.X + Round(15 * cos(pi * (Angle + 150) / 180)),
                  EndPoint.Y + Round(15 * sin(pi * (Angle + 150) / 180)));
      p2 := Point(EndPoint.X + Round(15 * cos(pi * (Angle - 150) / 180)),
                  EndPoint.Y + Round(15 * sin(pi * (Angle - 150) / 180)));
      MoveTo(EndPoint.X, EndPoint.Y);
      LineTo(p1.X, p1.y);
      MoveTo(EndPoint.X, EndPoint.Y);
      LineTo(p2.X, p2.y);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DrawEdje(Point(10, 10), Point(50, 50), Canvas);
end;

// Способ второй
uses
  {...,} Math;

procedure DrawArrowHead(Canvas: TCanvas; X, Y: Integer; Angle, LW: Extended);
const
  Beta = 0.322;
  LineLen = 4.74;
  CentLen = 3;
var
  A1, A2: Extended;
  Arrow: array[0..3] of TPoint;
  OldWidth: Integer;
begin
   Angle := Pi + Angle;
   Arrow[0] := Point(X, Y);
   A1 := Angle - Beta;
   A2 := Angle + Beta;
   Arrow[1] := Point(X + Round(LineLen * LW * Cos(A1)), Y - Round(LineLen * LW * Sin(A1)));
   Arrow[2] := Point(X + Round(CentLen * LW * Cos(Angle)), Y - Round(CentLen * LW * Sin(Angle)));
   Arrow[3] := Point(X + Round(LineLen * LW * Cos(A2)), Y - Round(LineLen * LW * Sin(A2)));
   OldWidth := Canvas.Pen.Width;
   Canvas.Pen.Width := 1;
   Canvas.Polygon(Arrow);
   Canvas.Pen.Width := OldWidth;
end;

procedure DrawArrow(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; LW: Extended);
var
  Angle: Extended;
begin
   Angle := ArcTan2(Y1 - Y2, X2 - X1);
   Canvas.MoveTo(X1, Y1);
   Canvas.LineTo(X2 - Round(2 * LW * Cos(Angle)), Y2 + Round(2 * LW * Sin(Angle)));
   DrawArrowHead(Canvas, X2, Y2, Angle, LW {размер стрелки});
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Canvas.Pen.Color := clBlack;
  Canvas.Pen.Width := 2;
  Canvas.Brush.Color := clBlack;
  DrawArrow(Canvas, 10, 100, 300, 100, 4);
end;

Как вывести полупрозрачный текст?


procedure TForm1.FormPaint(Sender: TObject);
begin
  Font.Style := Font.Style + [fsBold];
  Font.Size := 20;
  Canvas.Brush.Color := clBlue;
  GrayString(Canvas.Handle, Canvas.Brush.Handle, nil, 
             Integer(PChar('aaa')), 0, 10, 10, 0, 0);
end;

Как смешать цвета рисунка с другим цветом?


// Способ первый
procedure Mixer(Bitmap: TBitmap; Value: Byte; Color: TColor);

  function BLimit(B: Integer): Byte;
  begin
    if B < 0 then
      Result := 0
    else if B > 255 then
      Result := 255
    else
      Result := B;
  end;

type
  pRGB = ^TRGB;
  TRGB = record
    B, G, R: Byte;
  end;

var
  x, y: Word;
  Dest: pRGB;
  DR, DG, DB, D: Double;
begin
  D := Value / 200;
  DR := Lo(Color) * (1.275 - D);
  DG := Lo(Color shr 8) * (1.275 - D );
  DB := Lo((Color shr 8) shr 8) * (1.275 - D);
  for y := 0 to Bitmap.Height - 1 do
  begin
    Dest := Bitmap.ScanLine[y];
    for x := 0 to Bitmap.Width - 1 do
    begin
      with Dest^ do
      begin
        B := BLimit(Round(B * D + DB));
        G := BLimit(Round(G * D + DG));
        R := BLimit(Round(R * D + DR));
      end;
      Inc(Dest);
    end;
  end;
end;

// Способ второй
// Неоптимизированный вариант
// Value - процент цвета рисунка от конечного цвета,
// (255-Value) - процент цвета Color от конечного цвета,
// где 255 - это 100%; Новый цвет получается путём нахождения
// среднеарифметического значения каждого компонента цвета
// в точке (x, y) и цвета Color после процентного преобразования.
procedure Mixer(Bitmap: TBitmap; Value: Byte; Color: TColor);

  function BLimit(B: Integer): Byte;
  begin
    if B < 0 then
      Result := 0
    else if B > 255 then
      Result := 255
    else
      Result := B;
  end;

type
  pRGB = ^TRGB;
  TRGB = record
    B, G, R: Byte;
  end;

var
  x, y: Word;
  Dest: pRGB;
  DR, DG, DB, D: Double;
begin
  DR := Lo(Color);
  DG := Lo(Color shr 8);
  DB := Lo((Color shr 8) shr 8);
  for y := 0 to Bitmap.Height - 1 do
  begin
    Dest := Bitmap.ScanLine[y];
    for x := 0 to Bitmap.Width - 1 do
    begin
      with Dest^ do
      begin
        R := BLimit(Round((R/100 * Value + DR/100 * (255-Value)) / 2));
        G := BLimit(Round((G/100 * Value + DG/100 * (255-Value)) / 2));
        B := BLimit(Round((B/100 * Value + DB/100 * (255-Value)) / 2));
      end;
      Inc(Dest);
    end;
  end;
end;

Как сделать эффект блоков?


procedure Blocks(Bitmap: TBitmap; Hor, Ver, MaxOffset: Integer; BackColor: TColor);

  /// <summary>
  /// Вырезаем прямоугольники со сторонами Hor Ver
  /// и копируем их в радиусе MaxOffset
  /// </summary>
  function RandomInRadius(Num, Radius: Integer): Integer;
  begin
    if Random(2) = 0 then
      Result := Num + Random(Radius)
    else
      Result := Num - Random(Radius);
  end;

var
  x, y, xd, yd: Integer;
  Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;
  try
    Bmp.Assign( Bitmap );
    Bitmap.Canvas.Brush.Color := BackColor;
    Bitmap.Canvas.FillRect( Rect( 0, 0, Bitmap.Width, Bitmap.Height ) );
    xd := ( Bitmap.Width - 1 ) div Hor;
    yd := ( Bitmap.Height - 1 ) div Ver;
    Randomize;
    for x := 0 to xd do
      for y := 0 to yd do
        BitBlt(Bitmap.Canvas.Handle,
               RandomInRadius(Hor * x, MaxOffset),
               RandomInRadius(Ver * y, MaxOffset),
               Hor, Ver, Bmp.Canvas.Handle, Hor * x, Ver * y, SRCCOPY);
  finally
    Bmp.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Blocks(bm, bm.Width div 10, bm.Height div 10, 4, clWhite);
  Canvas.Draw(0, 0, bm);
end;

Как сделать эффект волны?


uses
  {...,} Math;

// Эффект волны (синусоидальные, вид сбоку)
procedure WaveSin(Bitmap: TBitmap; Frequency, Length:
  Integer; Hor: Boolean; BackColor: TColor);
const
  Rad = Pi / 180;

type
  pRGB = ^TRGB;
  TRGB = record
    B, G, R: Byte;
  end;

var
  x, y, f: Integer;
  Dest, Src: pRGB;
  Bmp: TBitmap;
begin
  Bitmap.PixelFormat := pf24Bit;
  Bmp := TBitmap.create;
  try
    Bmp.Assign(Bitmap);
    Bitmap.Canvas.Brush.Color := BackColor;
    Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height));
    for y := 0 to Bmp.Height - 1 do
    begin
      Src := Bmp.ScanLine[y];
      for x := 0 to Bmp.Width - 1 do
      begin
         if Hor then
         begin
           f := Min(Max(Round(Sin(x * Rad * Length) * Frequency) + y, 0),
                    Bitmap.Height - 1);
           Dest := Bitmap.ScanLine[f];
           Inc(Dest, x);
         end
         else
         begin
           f := Min(Max(Round(Sin(y * Rad * Length) * Frequency) + x, 0),
                    Bitmap.Width - 1);
           Dest := Bitmap.ScanLine[y];
           Inc(Dest, f);
         end;
         Dest^ := Src^;
         Inc(Src);
       end;
    end;
  finally
    Bmp.free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WaveSin(bm, bm.Width div 50, bm.Width div 40, True, clWhite);
  Canvas.Draw(0, 0, bm);
end;

Как сделать эффект инея (разброса)?


procedure Disorder(Bitmap: TBitmap; Hor, Ver: Integer; BackColor: TColor);

  function RandomInRadius(Num, Radius: Integer): Integer;
  begin
    if Random(2) = 0 then
      Result := Num + Random(Radius)
    else
      Result := Num - Random(Radius);
  end;

type
  pRGB = ^TRGB;
  TRGB = record
    B, G, R: Byte;
  end;

var
  x, y, WW, HH, xr, yr: Integer;
  Dest1, Dest2, Src1, Src2: PRGB;
  Bmp: TBitmap;
begin
  Randomize;
  Bitmap.PixelFormat := pf24Bit;
  Bmp := TBitmap.Create;
  try
    Bmp.Assign(Bitmap);
    WW := Bitmap.Width - 1;
    HH := Bitmap.Height - 1;
    Bitmap.Canvas.Brush.Color := BackColor;
    Bitmap.Canvas.FillRect(Rect(0, 0, WW + 1, HH + 1));
    for y := 0 to HH do
    begin
      for x := 0 to WW do
      begin
        xr := RandomInRadius(x, Hor);
        yr := RandomInRadius(y, Ver);
        if (xr >= 0) and (xr < WW) and (yr >= 0) and (yr < HH) then
        begin
          Src1 := Bmp.ScanLine[y];
          Src2 := Bmp.ScanLine[yr];
          Dest1 := Bitmap.ScanLine[y];
          Dest2 := Bitmap.ScanLine[yr];
          Inc(Src1, x);
          Inc(Src2, xr);
          Inc(Dest1, x);
          Inc(Dest2, xr);
          Dest1^ := Src2^;
          Dest2^ := Src1^;
        end;
      end;
    end;
  finally
    Bmp.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Disorder(bm, 5, 5, clWhite);
  Canvas.Draw(0, 0, bm);
end;

Как сделать эффект мозаики (пикселизации)?


uses
  {...,} Math;

/// <summary>
/// функция разбивает изображение на прямоугольники
/// (ширина - Hor; высота - Ver) и закрашивает эти
/// прямоугольники средним цветом, используя
/// среднеарифметическое составляющих
/// </summary>
procedure PixelsEffect(Bitmap: TBitmap; Hor, Ver: Word);
type
  pRGB = ^TRGB;
  TRGB = record
    B, G, R: Byte;
  end;

var
  i, j, x, y, xd, yd, rr, gg, bb, h, hx, hy: Integer;
  Dest: pRGB;
begin
  if (Hor = 1) and (Ver = 1) then
    Exit;

  Bitmap.PixelFormat := pf24Bit;
  xd := (Bitmap.Width - 1) div Hor;
  yd := (Bitmap.Height - 1) div Ver;
  for i := 0 to xd do
    for j := 0 to yd do
    begin
      h := 0;
      rr := 0;
      gg := 0;
      bb := 0;
      hx := Min(Hor * (i + 1), Bitmap.Width - 1);
      hy := Min(Ver * (j + 1), Bitmap.Height - 1);
      for y := j * Ver to hy do
      begin
        Dest := Bitmap.ScanLine[y];
        Inc(Dest, i * Hor);
        for x := i * Hor to hx do
        begin
          Inc(rr, Dest^.R);
          Inc(gg, Dest^.G);
          Inc(bb, Dest^.B);
          Inc(h);
          Inc(Dest);
        end;
      end;
      Bitmap.Canvas.Brush.Color := RGB(rr div h, gg div h, bb div h);
      Bitmap.Canvas.FillRect(Rect(i * Hor, j * Ver, hx + 1, hy + 1));
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  PixelsEffect(bm, 8, 8);
  Canvas.Draw(0, 0, bm);
end;

Как преобразовать Bitmap в двухцветное изображение (порог цветов)?


procedure Threshold(Bitmap: TBitmap; Value: Byte; Color1, Color2: TColor);
type
  pRGB = ^TRGB;
  TRGB = record
    B, G, R: Byte;
  end;

  function ColorToRGB(Color: TColor): TRGB;
  begin
    with Result do
    begin
       R := Lo(Color);
       G := Lo(Color shr 8);
       B := Lo((Color shr 8) shr 8);
    end;
  end;

var
  x, y: Word;
  C1, C2: TRGB;
  Dest: pRGB;
begin
  Bitmap.PixelFormat := pf24Bit;
  C1 := ColorToRGB( Color1 );
  C2 := ColorToRGB( Color2 );
  for y := 0 to Bitmap.Height-1 do
  begin
    Dest := Bitmap.ScanLine[y];
    for x := 0 to Bitmap.Width-1 do
    begin
      // Если среднеарифметическое R, G и B больше Value,
      // то точку (x, y) закрашиваем цветом Color1,
      // иначе - цветом Color2
      if (Dest^.r + Dest^.g + Dest^.b) / 3 > Value then
        Dest^ := C1
      else
        Dest^ := C2;
      Inc(Dest);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Threshold(FBitmap, 127, clWhite, clBlack);
end;

Как инвертировать Bitmap?


function InvertBitmap(MyBitmap: TBitmap): TBitmap;
var
  x, y: Integer;
  ByteArray: PByteArray;
begin
  MyBitmap.PixelFormat := pf24Bit;
  for y := 0 to MyBitmap.Height-1 do
  begin
    ByteArray := MyBitmap.ScanLine[y];
    for x := 0 to MyBitmap.Width * 3 - 1 do
      ByteArray[x] := 255 - ByteArray[x];
  end;
  Result := MyBitmap;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Picture.Bitmap := InvertBitmap(Image1.Picture.Bitmap);
  Image1.Refresh;
end;

Как рисовать на рабочем столе?


procedure TForm1.Button1Click(Sender: TObject);
var
  DesktopCanvas: TCanvas;
begin
  DesktopCanvas := TCanvas.Create;
  try
    DesktopCanvas.Handle := GetDC(0);
    try
      DesktopCanvas.MoveTo(0, 0);
      DesktopCanvas.LineTo(Screen.Width, Screen.Height);
    finally
      ReleaseDC(0, DesktopCanvas.Handle);
      DesktopCanvas.Handle := 0;
    end;
  finally
    DesktopCanvas.Free;
  end;
end;

При использовании материала - ссылка на сайт обязательна