Сглаживание Anti-aliasing

Guest · 06.05.2004

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

admin · 07.05.2004

Дущы
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;

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(color : 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;


{***************************************************************
TAntiAliasForm.SeparateColor
 15/08/2000

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


{***************************************************************
TAntiAliasForm.AntiAliasPicture
 15/08/2000

 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;



{***************************************************************
TAntiAliasForm.FastAAliasPicture
 20/08/2000
***************************************************************}
procedure TAntiAliasForm.FastAntiAliasPicture;
var
x, y, cx, cy : integer;
totr, totg, totb : integer;
Row1, Row2, Row3, DestRow: pRGBArray;
i: integer;
begin
// 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;
end;


{***************************************************************
TAntiAliasForm.OrigBoxPaint
TAntiAliasForm.OutBoxPaint
 15/08/2000

 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;


{***************************************************************
TAntiAliasForm.DrawFace
 15/08/2000

 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;

// 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;
end;


{***************************************************************
TAntiAliasForm.FormDestroy
 15/08/2000

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


{***************************************************************
TAntiAliasForm.Button1Click
 15/08/2000
***************************************************************}
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;


{***************************************************************
TAntiAliasForm.DrawBigBmp
 15/08/2000
***************************************************************}
procedure TAntiAliasForm.DrawBigBmp;
begin
// Draw the supersampled image
DrawFace(big_bmp, 6);
end;



{***************************************************************
TAntiAliasForm.FormCreate
 15/08/2000
***************************************************************}
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;


{***************************************************************
TAntiAliasForm.ZoomOrigBoxClick
 15/08/2000
***************************************************************}
procedure TAntiAliasForm.ZoomOrigBoxClick(Sender: TObject);
begin
with TCheckBox(Sender) do
begin
 OrigHScrollBar.Visible := Checked;
 OrigVScrollBar.Visible := Checked;
end;
OrigBox.Invalidate;
end;


{***************************************************************
TAntiAliasForm.ZoomOutBoxClick
 15/08/2000
***************************************************************}
procedure TAntiAliasForm.ZoomOutBoxClick(Sender: TObject);
begin
with TCheckBox(Sender) do
begin
 OutHScrollBar.Visible := Checked;
 OutVScrollBar.Visible := Checked;
end;
OutBox.Invalidate;
end;




{***************************************************************
TAntiAliasForm.Label10Click
 16/08/2000
***************************************************************}
procedure TAntiAliasForm.Label10Click(Sender: TObject);
begin
ShellExecute(ValidParentForm(Self).Handle, 'open',
      PChar(TLabel(Sender).Caption),
      NIL, NIL, SW_SHOWNORMAL);
end;


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


{***************************************************************
TAntiAliasForm.OrigScrollBarChange
 20/08/2000
***************************************************************}
procedure TAntiAliasForm.OrigScrollBarChange(Sender: TObject);
begin
OrigBox.Invalidate;
end;


{***************************************************************
TAntiAliasForm.OutScrollBarChange
 20/08/2000
***************************************************************}
procedure TAntiAliasForm.OutScrollBarChange(Sender: TObject);
begin
OutBox.Invalidate
end;

end.

FastAntiAlias.dpr

Код:

program FastAntiAlias;

uses
Forms,
FAAlias in 'FAAlias.pas' {AntiAliasForm};

{$R *.RES}

begin
Application.Initialize;
Application.CreateForm(TAntiAliasForm, AntiAliasForm);
Application.Run;
end.

FAAlias.dfm

Код:

object AntiAliasForm: TAntiAliasForm
Left = 262
Top = 193
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Antialiasing Pictures'
ClientHeight = 450
ClientWidth = 671
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
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
   PageSize = 0
   TabOrder = 4
   Visible = False
   OnChange = OrigScrollBarChange
  end
  object OutVScrollBar: TScrollBar
   Left = 638
   Top = 32
   Width = 16
   Height = 300
   Kind = sbVertical
   PageSize = 0
   TabOrder = 5
   Visible = False
   OnChange = OutScrollBarChange
  end
  object OrigHScrollBar: TScrollBar
   Left = 8
   Top = 333
   Width = 300
   Height = 17
   PageSize = 0
   TabOrder = 6
   Visible = False
   OnChange = OrigScrollBarChange
  end
  object OutHScrollBar: TScrollBar
   Left = 336
   Top = 333
   Width = 300
   Height = 17
   PageSize = 0
   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 cod' +
    'e 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 do' +
    'uble to triple size) and speed by Nacho Urenda, a senior program' +
    'mer from Barcelona, Spain. Any possible error in the code must b' +
    'e 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, b' +
    'ut the author cannot give any guarantees, explicit or implicit, ' +
    'that it will work properly under every possible circumstance. Us' +
    'e 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-mai' +
    'l 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 = 'Author''s 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

RAIN · 13.05.2004

Или Вот этот маленький кодик:

Код:

{ 
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;

Все сервисы Codeby

Поиск

Поиск

Сглаживание Anti-aliasing

Guest

admin

RAIN