Сглаживание (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[править | править код]
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