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

== Сглаживание 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 ==
=== 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
Category:Графика
Category:Bitmap