Убрать зазубринки при рисовании линий
01.01.2007
При рисовании линии, особенно под маленьким углом, хорошо различимы отдельные точки. Для устранения этого недостатка я использую уменьшение изображения, как в предыдущем совете.
procedure TForm1.Button1Click(Sender: TObject); var x, y: integer; i, j: integer; r, g, b: integer; begin Form1.Canvas.Pen.Width := 10; Form1.Canvas.MoveTo(10, 10); Form1.Canvas.LineTo(90, 20); for y := 0 to 10 do begin for x := 0 to 25 do begin r := 0; for i := 0 to 3 do for j := 0 to 3 do r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]); r := round(r / 16); g := 0; for i := 0 to 3 do for j := 0 to 3 do g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]); g := round(g / 16); b := 0; for i := 0 to 3 do for j := 0 to 3 do b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]); b := round(b / 16); Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b) end; Application.ProcessMessages; end; end;
DelphiWorld 6.0
{ This code draws an anti-aliased line on a bitmap This means that the line is not jagged like the lines drawn using the LineTo() function } uses Graphics, Windows; type TRGBTripleArray = array[0..1000] of TRGBTriple; PRGBTripleArray = ^TRGBTripleArray; // anti-aliased line procedure WuLine(ABitmap : TBitmap ; Point1, Point2 : TPoint ; AColor : TColor); var deltax, deltay, loop, start, finish : integer; dx, dy, dydx : single; // fractional parts LR, LG, LB : byte; x1, x2, y1, y2 : integer; begin x1 := Point1.X; y1 := Point1.Y; x2 := Point2.X; y2 := Point2.Y; deltax := abs(x2 - x1); // Calculate deltax and deltay for initialisation deltay := abs(y2 - y1); if (deltax = 0) or (deltay = 0) then begin // straight lines ABitmap.Canvas.Pen.Color := AColor; ABitmap.Canvas.MoveTo(x1, y1); ABitmap.Canvas.LineTo(x2, y2); exit; end; LR := (AColor and $000000FF); LG := (AColor and $0000FF00) shr 8; LB := (AColor and $00FF0000) shr 16; if deltax > deltay then begin // horizontal or vertical if y2 > y1 then // determine rise and run dydx := -(deltay / deltax) else dydx := deltay / deltax; if x2 < x1 then begin start := x2; // right to left finish := x1; dy := y2; end else begin start := x1; // left to right finish := x2; dy := y1; dydx := -dydx; // inverse slope end; for loop := start to finish do begin AlphaBlendPixel(ABitmap, loop, trunc(dy), LR, LG, LB, 1 - frac(dy)); AlphaBlendPixel(ABitmap, loop, trunc(dy) + 1, LR, LG, LB, frac(dy)); dy := dy + dydx; // next point end; end else begin if x2 > x1 then // determine rise and run dydx := -(deltax / deltay) else dydx := deltax / deltay; if y2 < y1 then begin start := y2; // right to left finish := y1; dx := x2; end else begin start := y1; // left to right finish := y2; dx := x1; dydx := -dydx; // inverse slope end; for loop := start to finish do begin AlphaBlendPixel(ABitmap, trunc(dx), loop, LR, LG, LB, 1 - frac(dx)); AlphaBlendPixel(ABitmap, trunc(dx) + 1, loop, LR, LG, LB, frac(dx)); dx := dx + dydx; // next point end; end; end; // blend a pixel with the current colour procedure AlphaBlendPixel(ABitmap : TBitmap ; X, Y : integer ; R, G, B : byte ; ARatio : Real); Var LBack, LNew : TRGBTriple; LMinusRatio : Real; LScan : PRGBTripleArray; begin if (X < 0) or (X > ABitmap.Width - 1) or (Y < 0) or (Y > ABitmap.Height - 1) then Exit; // clipping LScan := ABitmap.Scanline[Y]; LMinusRatio := 1 - ARatio; LBack := LScan[X]; LNew.rgbtBlue := round(B*ARatio + LBack.rgbtBlue*LMinusRatio); LNew.rgbtGreen := round(G*ARatio + LBack.rgbtGreen*LMinusRatio); LNew.rgbtRed := round(R*ARatio + LBack.rgbtRed*LMinusRatio); LScan[X] := LNew; end;