Сглаживание (anti-aliasing)

Материал из DRKB


Сглаживание TCanvas на заданный процент[править | править код]

{ The parameter "percent" needs an integer between 0 and 100 (include zero and 100). If "Percent" is 0, there will be no effect. If it's 100 there will be the strongest effect. }

procedure Antialising(C: TCanvas; Rect: TRect; Percent: Integer);
var
  l, p: Integer;
  R, G, B: Integer;
  R1, R2, G1, G2, B1, B2: Byte;
begin
  with C do
  begin
    Brush.Style := bsclear;
    LineTo(200, 100);
    MoveTo(50, 150);
    Ellipse(50, 150, 200, 30);
    for l := Rect.Top to Rect.Bottom do
    begin
      for p := Rect.Left to Rect.Right do
      begin
        R1 := GetRValue(Pixels[p, l]);
        G1 := GetGValue(Pixels[p, l]);
        B1 := GetBValue(Pixels[p, l]);

        // Pixel links
        // Pixel left
        R2 := GetRValue(Pixels[p - 1, l]);
        G2 := GetGValue(Pixels[p - 1, l]);
        B2 := GetBValue(Pixels[p - 1, l]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p - 1, l] := RGB(R, G, B);
        end;

        // Pixel rechts
        // Pixel right
        R2 := GetRValue(Pixels[p + 1, l]);
        G2 := GetGValue(Pixels[p + 1, l]);
        B2 := GetBValue(Pixels[p + 1, l]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p + 1, l] := RGB(R, G, B);
        end;

        // Pixel oben
        // Pixel up
        R2 := GetRValue(Pixels[p, l - 1]);
        G2 := GetGValue(Pixels[p, l - 1]);
        B2 := GetBValue(Pixels[p, l - 1]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p, l - 1] := RGB(R, G, B);
        end;

        // Pixel unten
        // Pixel down
        R2 := GetRValue(Pixels[p, l + 1]);
        G2 := GetGValue(Pixels[p, l + 1]);
        B2 := GetBValue(Pixels[p, l + 1]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p, l + 1] := RGB(R, G, B);
        end;
      end;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Antialising(Image1.Canvas, Image1.Canvas.ClipRect, 100);
end;


Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03887



Сглаживание быстрым супер-сэмплингом FAA[править | править код]

Image 2021-03-07 171718.png


FAAlias.pas[править | править код]

FAAlias.pas
{***************************************************************
*
* Project : FastAntiAlias
* Unit    : FAAlias
* Purpose : To demonstrate the use of super-sampling technique
*           to anti-alias an image, as well to fast access to
*           a bitmap image pixels using the ScanLine property
* Author  : Nacho Urenda (based on an example project by Rod
*           Stephens published on Delphi Informant,
*           april 98 issue)
* Date    : 15/08/2000
*
***************************************************************}
unit FAAlias;

{$ifdef FPC}{$mode DELPHI}{$endif}

interface

uses
  Windows, SysUtils, Graphics, Controls, Forms, StdCtrls, ExtCtrls,
  ComCtrls, ShellApi, Classes;

type
  TAntiAliasForm = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    OutBox: TPaintBox;
    OrigBox: TPaintBox;
    Label1: TLabel;
    Label2: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    ProcessBtn: TButton;
    ZoomOutBox: TCheckBox;
    ZoomOrigBox: TCheckBox;
    Method: TRadioGroup;
    Memo1: TMemo;
    TabSheet3: TTabSheet;
    Label3: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    Label12: TLabel;
    OrigVScrollBar: TScrollBar;
    OutVScrollBar: TScrollBar;
    OrigHScrollBar: TScrollBar;
    OutHScrollBar: TScrollBar;
    procedure SeparateColor(AColor : TColor; var r, g, b: Integer);
    procedure OutBoxPaint(Sender: TObject);
    procedure DrawFace(bm: TBitmap; pen_width : Integer);
    procedure OrigBoxPaint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ProcessBtnClick(Sender: TObject);
    procedure DrawBigBmp;
    procedure FormCreate(Sender: TObject);
    procedure ZoomOrigBoxClick(Sender: TObject);
    procedure ZoomOutBoxClick(Sender: TObject);
    procedure Label10Click(Sender: TObject);
    procedure Label12Click(Sender: TObject);
    procedure OrigScrollBarChange(Sender: TObject);
    procedure OutScrollBarChange(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure AntiAliasPicture;
    procedure FastAntiAliasPicture;
  end;

var
  AntiAliasForm: TAntiAliasForm;

const
  MaxPixelCount = 32768;

type
  PRGBArray = ^TRGBArray;
  TRGBArray = array [0..MaxPixelCount-1] of TRGBTriple;

implementation

{$R *.DFM}

var
  orig_bmp, big_bmp, out_bmp: TBitmap;


{ The original procedure by Rod Stephens has been somewhat fastened }
procedure TAntiAliasForm.SeparateColor(AColor: TColor; var r, g, b: Integer);
begin
  r := Byte(AColor);
  g := Byte(AColor shr 8);
  b := Byte(AColor shr 16);
end;

{ The original AAliasPicture procedure by Rod Stephens has been
  rewritten to improve the supersampling from double to triple
  factor, and somewhat simplified... }
procedure TAntiAliasForm.AntiAliasPicture;
var
  x, y: Integer;
  totr, totg, totb, r, g, b: Integer;
  i, j: Integer;
begin
  // For each row
  for y := 0 to orig_bmp.Height - 1 do
  begin
    // For each column
    for x := 0 to orig_bmp.Width - 1 do
    begin
      totr := 0;
      totg := 0;
      totb := 0;

      // Read each of the sample pixels
      for i := 0 to 2 do
      begin
        for j := 0 to 2 do
        begin
          SeparateColor(big_bmp.Canvas.Pixels[(x*3) + j, (y*3) + i], r, g, b);
          totr := totr + r;
          totg := totg + g;
          totb := totb + b;
        end;
      end;

      out_bmp.Canvas.Pixels[x, y] := RGB(totr div 9,
                                         totg div 9,
                                         totb div 9);
    end; // end for columns
  end; // end for rows
end;

procedure TAntiAliasForm.FastAntiAliasPicture;
var
  x, y, cx, cy: Integer;
  totr, totg, totb: Integer;
  Row1, Row2, Row3, DestRow: PRGBArray;
  i: Integer;
begin
  {$ifdef FPC}out_bmp.BeginUpdate();{$endif}
  // For each row
  for y := 0 to orig_bmp.Height - 1 do
  begin
    // We compute samples of 3 x 3 pixels
    cy := y * 3;
    // Get pointers to actual, previous and next rows in supersampled bitmap
    Row1 := big_bmp.ScanLine[cy];
    Row2 := big_bmp.ScanLine[cy+1];
    Row3 := big_bmp.ScanLine[cy+2];

    // Get a pointer to destination row in output bitmap
    DestRow := out_bmp.ScanLine[y];

    // For each column...
    for x := 0 to orig_bmp.Width - 1 do
    begin
      // We compute samples of 3 x 3 pixels
      cx := 3 * x;

      // Initialize result color
      totr := 0;
      totg := 0;
      totb := 0;

      // For each pixel in sample
      for i := 0 to 2 do
      begin
        // New red value
        totr := totr + Row1[cx + i].rgbtRed
             + Row2[cx + i].rgbtRed
             + Row3[cx + i].rgbtRed;
        // New green value
        totg := totg + Row1[cx + i].rgbtGreen
             + Row2[cx + i].rgbtGreen
             + Row3[cx + i].rgbtGreen;
        // New blue value
        totb := totb + Row1[cx + i].rgbtBlue
             + Row2[cx + i].rgbtBlue
             + Row3[cx + i].rgbtBlue;
      end;

      // Set output pixel colors
      DestRow[x].rgbtRed := totr div 9;
      DestRow[x].rgbtGreen := totg div 9;
      DestRow[x].rgbtBlue := totb div 9;
    end;
  end;
  {$ifdef FPC}out_bmp.EndUpdate();{$endif}
end;

{ The original procedures by Rod Stephens have been modified
  to allow the zooming and panning effects }
procedure TAntiAliasForm.OrigBoxPaint(Sender: TObject);
var
  ZoomRect: TRect;
begin
  // If zoomed display an enlarged protion of the bitmap
  if ZoomOrigBox.Checked then
  begin
    ZoomRect := Rect(OrigHScrollBar.Position,
                     OrigVScrollBar.Position,
                     OrigHScrollBar.Position+60,
                     OrigVScrollBar.Position+60);
    OrigBox.Canvas.CopyRect(OrigBox.ClientRect, orig_bmp.Canvas, ZoomRect)
  end else
    OrigBox.Canvas.Draw(0, 0, orig_bmp);
end;

procedure TAntiAliasForm.OutBoxPaint(Sender: TObject);
var
  ZoomRect: TRect;
begin
  if ZoomOutBox.Checked then
  begin
    ZoomRect := Rect(OutHScrollBar.Position,
                     OutVScrollBar.Position,
                     OutHScrollBar.Position+60,
                     OutVScrollBar.Position+60);
    OutBox.Canvas.CopyRect(OutBox.ClientRect, out_bmp.Canvas, ZoomRect)
  end else
    OutBox.Canvas.Draw(0, 0, out_bmp);
end;


{ Procedure written by Rod Stephens (unmodified) }
procedure TAntiAliasForm.DrawFace(bm: TBitmap; pen_width: Integer);
var
  x1, y1, x2, y2, x3, y3, x4, y4: Integer;
  old_width: Integer;
  old_color: TColor;
begin
  // Save the original brush color and pen width.
  old_width := bm.Canvas.Pen.Width;
  old_color := bm.Canvas.Brush.Color;
  //orig_bmp.LoadFromFile('c:\1.bmp');
  // Erase background;
  bm.Canvas.Pen.Color := clwhite;
  bm.Canvas.Brush.Color := clwhite;
  bm.Canvas.Rectangle(0, 0, bm.Width, bm.Height);

  // Draw the head.
  bm.Canvas.Pen.Color := clBlack;
  bm.Canvas.Pen.Width := pen_width;
  bm.Canvas.Brush.Color := clYellow;
  x1 := Round(bm.Width * 0.05);
  y1 := x1;
  x2 := Round(bm.Height * 0.95);
  y2 := x2;
  bm.Canvas.Ellipse(x1, y1, x2, y2);

  // Draw the eyes.
  bm.Canvas.Brush.Color := clWhite;
  x1 := Round(bm.Width * 0.25);
  y1 := Round(bm.Height * 0.25);
  x2 := Round(bm.Width * 0.4);
  y2 := Round(bm.Height * 0.4);
  bm.Canvas.Ellipse(x1, y1, x2, y2);
  x1 := Round(bm.Width * 0.75);
  x2 := Round(bm.Width * 0.6);
  bm.Canvas.Ellipse(x1, y1, x2, y2);

  // Draw the pupils.
  bm.Canvas.Brush.Color := clBlack;
  bm.Canvas.Refresh;
  x1 := Round(bm.Width * 0.275);
  y1 := Round(bm.Height * 0.3);
  x2 := Round(bm.Width * 0.375);
  y2 := Round(bm.Height * 0.4);
  bm.Canvas.Ellipse(x1, y1, x2, y2);
  x1 := Round(bm.Width * 0.725);
  x2 := Round(bm.Width * 0.625);
  bm.Canvas.Ellipse(x1, y1, x2, y2);

  // Draw the nose.
  bm.Canvas.Brush.Color := clAqua;
  x1 := Round(bm.Width * 0.425);
  y1 := Round(bm.Height * 0.425);
  x2 := Round(bm.Width * 0.575);
  y2 := Round(bm.Height * 0.6);
  bm.Canvas.Ellipse(x1, y1, x2, y2);

  // Draw a crooked smile.
  x1 := Round(bm.Width * 0.25);
  y1 := Round(bm.Height * 0.25);
  x2 := Round(bm.Width * 0.75);
  y2 := Round(bm.Height * 0.75);
  x3 := Round(bm.Width * 0.4);
  y3 := Round(bm.Height * 0.6);
  x4 := Round(bm.Width * 0.8);
  y4 := Round(bm.Height * 0.6);
  bm.Canvas.Arc(x1, y1, x2, y2, x3, y3, x4, y4);

  bm.Canvas.Brush.Color := old_color;
  bm.Canvas.Pen.Width := old_width;
//  if pen_width = 6 then Image1.Picture.Assign(bm);
end;

{ We must free the memory bitmaps before exiting }
procedure TAntiAliasForm.FormDestroy(Sender: TObject);
begin
  orig_bmp.Free;
  big_bmp.Free;
  out_bmp.Free;
end;

procedure TAntiAliasForm.ProcessBtnClick(Sender: TObject);
var
  IniTime, ElapsedTime: DWord;
begin
  // Display the hourglass cursor.
  Screen.Cursor := crHourGlass;

  // Erase the time elapsed label
  Label4.Caption := '';
  Label4.Refresh;

  // Erase the result PaintBox.
  out_bmp.Canvas.Brush.color := clWhite;
  out_bmp.Canvas.FillRect(out_bmp.Canvas.ClipRect);
  // Force repaint of outbox
  OutBox.Refresh;

  // Draw the supersampled image
  DrawBigBmp;

  // Create the anti-aliased version.
  if Method.ItemIndex = 0 then
  begin
    IniTime := GetTickCount;
    AntiAliasPicture;
    ElapsedTime := GetTickCount - IniTime;
  end
  else
  begin
    IniTime := GetTickCount;
    FastAntiAliasPicture;
    ElapsedTime := GetTickCount - IniTime;
  end;

  // Force repaint of output PaintBox
  OutBox.Invalidate;

  // Just to display calculation time
  Label4.Caption := IntToStr(ElapsedTime) + ' ms';
  Label4.Refresh;

  // Force repaint of outbox
  OutBox.Invalidate;

  // Remove the hourglass cursor.
  Screen.Cursor := crDefault;
end;

procedure TAntiAliasForm.DrawBigBmp;
begin
  // Draw the supersampled image
  DrawFace(big_bmp, 6);
end;

procedure TAntiAliasForm.FormCreate(Sender: TObject);
begin
  // Create the necessary memory bitmaps.
  orig_bmp := TBitmap.Create;
  orig_bmp.Width := OrigBox.ClientWidth;
  orig_bmp.Height := OrigBox.ClientHeight;
  // Bitmap MUST be 24 bits to get ScanLine[] to work
  orig_bmp.PixelFormat := pf24bit;

  // Initialize original bitmap
  DrawFace(Orig_bmp, 2);

  // Create supersampled bitmap
  big_bmp := TBitmap.Create;
  big_bmp.Width := orig_bmp.Width * 3;
  big_bmp.Height := orig_bmp.Height * 3;
  big_bmp.PixelFormat := pf24bit;

  // Create output bitmap
  out_bmp := TBitmap.Create;
  out_bmp.Width := orig_bmp.Width;
  out_bmp.Height := orig_bmp.Height;
  out_bmp.PixelFormat := pf24bit;

  // Make sure the 'Example' page is visible on startup
  PageControl1.ActivePage := TabSheet1;

  // Initialize Scroll Bars
  OrigHScrollBar.Min := 0;
  OrigHScrollBar.Max := OrigBox.Width - (OrigBox.Width div 5);
  OrigHScrollBar.LargeChange := OrigBox.Width div 5;
  OrigVScrollBar.Min := 0;
  OrigVScrollBar.Max := OrigBox.Height - (OrigBox.Height div 5);
  OrigVScrollBar.LargeChange := OrigBox.Height div 5;

  OutHScrollBar.Min := 0;
  OutHScrollBar.Max := OutBox.Width - (OutBox.Width div 5);
  OutHScrollBar.LargeChange := OutBox.Width div 5;
  OutVScrollBar.Min := 0;
  OutVScrollBar.Max := OutBox.Height - (OutBox.Height div 5);
  OutVScrollBar.LargeChange := OutBox.Height div 5;

  // Load text into the 'How it works...' memo
  Memo1.Lines.LoadFromFile('ReadMe.txt');
end;

procedure TAntiAliasForm.ZoomOrigBoxClick(Sender: TObject);
begin
  with TCheckBox(Sender) do
  begin
    OrigHScrollBar.Visible := Checked;
    OrigVScrollBar.Visible := Checked;
  end;
  OrigBox.Invalidate;
end;

procedure TAntiAliasForm.ZoomOutBoxClick(Sender: TObject);
begin
  with TCheckBox(Sender) do
  begin
    OutHScrollBar.Visible := Checked;
    OutVScrollBar.Visible := Checked;
  end;
  OutBox.Invalidate;
end;

procedure TAntiAliasForm.Label10Click(Sender: TObject);
begin
 ShellExecute(ValidParentForm(Self).Handle, 'open',
              PChar(TLabel(Sender).Caption),
              NIL, NIL, SW_SHOWNORMAL);
end;

procedure TAntiAliasForm.Label12Click(Sender: TObject);
begin
 ShellExecute(ValidParentForm(Self).Handle, 'open',
              PChar('mailto:nurenda@wanadoo.es?subject=Fast antialias'),
              NIL, NIL, SW_SHOWNORMAL);
end;

procedure TAntiAliasForm.OrigScrollBarChange(Sender: TObject);
begin
  OrigBox.Invalidate;
end;

procedure TAntiAliasForm.OutScrollBarChange(Sender: TObject);
begin
  OutBox.Invalidate
end;

end.

FAAlias.dfm[править | править код]

FAAlias.dfm
object AntiAliasForm: TAntiAliasForm
  Left = 262
  Top = 193
  BorderIcons = [biSystemMenu]
  BorderStyle = bsDialog
  Caption = 'Antialiasing Pictures'
  ClientHeight = 450
  ClientWidth = 671
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object PageControl1: TPageControl
    Left = 0
    Top = 0
    Width = 671
    Height = 450
    ActivePage = TabSheet1
    Align = alClient
    TabOrder = 0
    object TabSheet1: TTabSheet
      Caption = 'Example'
      object OutBox: TPaintBox
        Left = 336
        Top = 32
        Width = 300
        Height = 300
        OnPaint = OutBoxPaint
      end
      object OrigBox: TPaintBox
        Left = 8
        Top = 32
        Width = 300
        Height = 300
        OnPaint = OrigBoxPaint
      end
      object Label1: TLabel
        Left = 8
        Top = 8
        Width = 69
        Height = 13
        Caption = 'Normal Picture'
      end
      object Label2: TLabel
        Left = 336
        Top = 8
        Width = 87
        Height = 13
        Caption = 'Antialiased Picture'
      end
      object Label4: TLabel
        Left = 520
        Top = 384
        Width = 89
        Height = 13
        AutoSize = False
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clRed
        Font.Height = -11
        Font.Name = 'MS Sans Serif'
        Font.Style = [fsBold]
        ParentFont = False
      end
      object Label5: TLabel
        Left = 440
        Top = 384
        Width = 63
        Height = 13
        Caption = 'Elapsed time:'
      end
      object ProcessBtn: TButton
        Left = 328
        Top = 376
        Width = 105
        Height = 33
        Caption = 'Process...'
        TabOrder = 0
        OnClick = ProcessBtnClick
      end
      object ZoomOutBox: TCheckBox
        Left = 456
        Top = 8
        Width = 49
        Height = 17
        Caption = 'Zoom'
        TabOrder = 1
        OnClick = ZoomOutBoxClick
      end
      object ZoomOrigBox: TCheckBox
        Left = 112
        Top = 8
        Width = 49
        Height = 17
        Caption = 'Zoom'
        TabOrder = 2
        OnClick = ZoomOrigBoxClick
      end
      object Method: TRadioGroup
        Left = 8
        Top = 368
        Width = 313
        Height = 41
        Caption = 'Pixel access method'
        Columns = 2
        ItemIndex = 0
        Items.Strings = (
          'Bitmap.Canvas.Pixels[x,y]'
          'Bitmap.ScanLine[y]'
        )
        TabOrder = 3
      end
      object OrigVScrollBar: TScrollBar
        Left = 310
        Top = 32
        Width = 16
        Height = 300
        Kind = sbVertical
        TabOrder = 4
        Visible = False
        OnChange = OrigScrollBarChange
      end
      object OutVScrollBar: TScrollBar
        Left = 638
        Top = 32
        Width = 16
        Height = 300
        Kind = sbVertical
        TabOrder = 5
        Visible = False
        OnChange = OutScrollBarChange
      end
      object OrigHScrollBar: TScrollBar
        Left = 8
        Top = 333
        Width = 300
        Height = 17
        TabOrder = 6
        Visible = False
        OnChange = OrigScrollBarChange
      end
      object OutHScrollBar: TScrollBar
        Left = 336
        Top = 333
        Width = 300
        Height = 17
        TabOrder = 7
        Visible = False
        OnChange = OutScrollBarChange
      end
    end
    object TabSheet2: TTabSheet
      Caption = 'How it works'
      object Memo1: TMemo
        Left = 8
        Top = 16
        Width = 641
        Height = 393
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clWindowText
        Font.Height = -11
        Font.Name = 'Courier'
        Font.Style = []
        ParentFont = False
        ReadOnly = True
        ScrollBars = ssVertical
        TabOrder = 0
      end
    end
    object TabSheet3: TTabSheet
      Caption = 'About...'
      object Label3: TLabel
        Left = 16
        Top = 32
        Width = 593
        Height = 49
        Alignment = taCenter
        AutoSize = False
        Caption = 'This programming example is based on an algorithm and sample code published in the april 98 issue of Delphi Informant magazine, written by Rod Stephens.'
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clWindowText
        Font.Height = -13
        Font.Name = 'MS Sans Serif'
        Font.Style = []
        ParentFont = False
        WordWrap = True
      end
      object Label6: TLabel
        Left = 16
        Top = 88
        Width = 593
        Height = 65
        Alignment = taCenter
        AutoSize = False
        Caption = 'The code has been rewritten to improve sampling quality (from double to triple size) and speed by Nacho Urenda, a senior programmer from Barcelona, Spain. Any possible error in the code must be imputed to him, and not to the original author and publisher.'
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clWindowText
        Font.Height = -13
        Font.Name = 'MS Sans Serif'
        Font.Style = []
        ParentFont = False
        WordWrap = True
      end
      object Label7: TLabel
        Left = 16
        Top = 160
        Width = 593
        Height = 65
        Alignment = taCenter
        AutoSize = False
        Caption = 'LEGAL DISCLAIMER: You may use and distribute this code freely, but the author cannot give any guarantees, explicit or implicit, that it will work properly under every possible circumstance. Use it at your own risk... Sorry. '
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clWindowText
        Font.Height = -13
        Font.Name = 'MS Sans Serif'
        Font.Style = []
        ParentFont = False
        WordWrap = True
      end
      object Label8: TLabel
        Left = 16
        Top = 224
        Width = 593
        Height = 49
        Alignment = taCenter
        AutoSize = False
        Caption = 'If you should find an error or have a suggestion to improve the code quality, you are invited to contact the author at the e-mail address below.'
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clWindowText
        Font.Height = -13
        Font.Name = 'MS Sans Serif'
        Font.Style = []
        ParentFont = False
        WordWrap = True
      end
      object Label9: TLabel
        Left = 24
        Top = 312
        Width = 125
        Height = 13
        Caption = 'Delphi informant web site:'
      end
      object Label10: TLabel
        Left = 24
        Top = 336
        Width = 170
        Height = 16
        Cursor = crHandPoint
        Caption = 'http://www.informant.com'
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clBlue
        Font.Height = -13
        Font.Name = 'MS Sans Serif'
        Font.Style = [fsBold, fsUnderline]
        ParentFont = False
        OnClick = Label10Click
      end
      object Label11: TLabel
        Left = 336
        Top = 312
        Width = 71
        Height = 13
        Caption = 'Authors e-mail:'
      end
      object Label12: TLabel
        Left = 336
        Top = 336
        Width = 156
        Height = 16
        Cursor = crHandPoint
        Caption = 'nurenda@wanadoo.es'
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clBlue
        Font.Height = -13
        Font.Name = 'MS Sans Serif'
        Font.Style = [fsBold, fsUnderline]
        ParentFont = False
        OnClick = Label12Click
      end
    end
  end
end


Author: Rouse_
Source: http://forum.sources.ru
ID: 03888


Сглаживание TImage на заданный процент[править | править код]

{ Originally written by Horst Kniebusch, modified by alioth to make it(alot) faster. }

procedure Antialiasing(Image: TImage; Percent: Integer);
type
  TRGBTripleArray = array[0..32767] of TRGBTriple;
  PRGBTripleArray = ^TRGBTripleArray;
var
  SL, SL2: PRGBTripleArray;
  l, m, p: Integer;
  R, G, B: TColor;
  R1, R2, G1, G2, B1, B2: Byte;
begin
  with Image.Canvas do
  begin
    Brush.Style  := bsClear;
    Pixels[1, 1] := Pixels[1, 1];
    for l := 0 to Image.Height - 1 do
    begin
      SL := Image.Picture.Bitmap.ScanLine[l];
      for p := 1 to Image.Width - 1 do
      begin
        R1 := SL[p].rgbtRed;
        G1 := SL[p].rgbtGreen;
        B1 := SL[p].rgbtBlue;

        // Left
        if (p < 1) then
          m := Image.Width
        else
          m := p - 1;
        R2 := SL[m].rgbtRed;
        G2 := SL[m].rgbtGreen;
        B2 := SL[m].rgbtBlue;
        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          SL[m].rgbtRed := R;
          SL[m].rgbtGreen := G;
          SL[m].rgbtBlue := B;
        end;

        //Right
        if (p > Image.Width - 2) then
          m := 0
        else
          m := p + 1;
        R2 := SL[m].rgbtRed;
        G2 := SL[m].rgbtGreen;
        B2 := SL[m].rgbtBlue;
        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          SL[m].rgbtRed := R;
          SL[m].rgbtGreen := G;
          SL[m].rgbtBlue := B;
        end;

        if (l < 1) then
          m := Image.Height - 1
        else
          m := l - 1;
        //Over
        SL2 := Image.Picture.Bitmap.ScanLine[m];
        R2  := SL2[p].rgbtRed;
        G2  := SL2[p].rgbtGreen;
        B2  := SL2[p].rgbtBlue;
        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          SL2[p].rgbtRed := R;
          SL2[p].rgbtGreen := G;
          SL2[p].rgbtBlue := B;
        end;

        if (l > Image.Height - 2) then
          m := 0
        else
          m := l + 1;
        // Under
        SL2 := Image.Picture.Bitmap.ScanLine[m];
        R2  := SL2[p].rgbtRed;
        G2  := SL2[p].rgbtGreen;
        B2  := SL2[p].rgbtBlue;
        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          SL2[p].rgbtRed := R;
          SL2[p].rgbtGreen := G;
          SL2[p].rgbtBlue := B;
        end;
      end;
    end;
  end;
end;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  Antialiasing(Image1, 80);
end;


Source: http://www.swissdelphicenter.ch
ID: 03889