|
:: MVP ::
|
|
|
:: RSS ::
|
|
|
Как нарисовать стрелку?
uses
Math;
procedure DrawEdje(BeginPoint, EndPoint:TPoint; Canvas: TCanvas; Arrow: boolean = True);
var
Angle: Real;
p1, p2: TPoint;
begin
with Canvas do
begin
MoveTo( BeginPoint.X, BeginPoint.Y );
LineTo( EndPoint.X, EndPoint.Y );
if Arrow then
begin
Angle := 180 * ArcTan2(EndPoint.y - BeginPoint.y, EndPoint.x - BeginPoint.x) / pi;
p1 := Point(EndPoint.X + Round(15 * cos(pi * (Angle + 150) / 180)),
EndPoint.Y + Round(15 * sin(pi * (Angle + 150) / 180)));
p2 := Point(EndPoint.X + Round(15 * cos(pi * (Angle - 150) / 180)),
EndPoint.Y + Round(15 * sin(pi * (Angle - 150) / 180)));
MoveTo(EndPoint.X, EndPoint.Y);
LineTo(p1.X, p1.y);
MoveTo(EndPoint.X, EndPoint.Y);
LineTo(p2.X, p2.y);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DrawEdje(Point(10, 10), Point(50, 50), Canvas);
end;
uses
Math;
procedure DrawArrowHead(Canvas: TCanvas; X, Y: Integer; Angle, LW: Extended);
const
Beta = 0.322;
LineLen = 4.74;
CentLen = 3;
var
A1, A2: Extended;
Arrow: array[0..3] of TPoint;
OldWidth: Integer;
begin
Angle := Pi + Angle;
Arrow[0] := Point(X, Y);
A1 := Angle - Beta;
A2 := Angle + Beta;
Arrow[1] := Point(X + Round(LineLen * LW * Cos(A1)), Y - Round(LineLen * LW * Sin(A1)));
Arrow[2] := Point(X + Round(CentLen * LW * Cos(Angle)), Y - Round(CentLen * LW * Sin(Angle)));
Arrow[3] := Point(X + Round(LineLen * LW * Cos(A2)), Y - Round(LineLen * LW * Sin(A2)));
OldWidth := Canvas.Pen.Width;
Canvas.Pen.Width := 1;
Canvas.Polygon(Arrow);
Canvas.Pen.Width := OldWidth;
end;
procedure DrawArrow(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; LW: Extended);
var
Angle: Extended;
begin
Angle := ArcTan2(Y1 - Y2, X2 - X1);
Canvas.MoveTo(X1, Y1);
Canvas.LineTo(X2 - Round(2 * LW * Cos(Angle)), Y2 + Round(2 * LW * Sin(Angle)));
DrawArrowHead(Canvas, X2, Y2, Angle, LW );
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Pen.Color := clBlack;
Canvas.Pen.Width := 2;
Canvas.Brush.Color := clBlack;
DrawArrow(Canvas, 10, 100, 300, 100, 4);
end;
|
|
Как вывести полупрозрачный текст?
procedure TForm1.FormPaint(Sender: TObject);
begin
Font.Style := Font.Style + [fsBold];
Font.Size := 20;
Canvas.Brush.Color := clBlue;
GrayString(Canvas.Handle, Canvas.Brush.Handle, nil,
Integer(PChar('aaa')), 0, 10, 10, 0, 0);
end;
|
|
Как смешать цвета рисунка с другим цветом?
procedure Mixer(Bitmap: TBitmap; Value: Byte; Color: TColor);
function BLimit(B: Integer): Byte;
begin
if B < 0 then
Result := 0
else if B > 255 then
Result := 255
else
Result := B;
end;
type
pRGB = ^TRGB;
TRGB = record
B, G, R: Byte;
end;
var
x, y: Word;
Dest: pRGB;
DR, DG, DB, D: Double;
begin
D := Value / 200;
DR := Lo(Color) * (1.275 - D);
DG := Lo(Color shr 8) * (1.275 - D );
DB := Lo((Color shr 8) shr 8) * (1.275 - D);
for y := 0 to Bitmap.Height - 1 do
begin
Dest := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with Dest^ do
begin
B := BLimit(Round(B * D + DB));
G := BLimit(Round(G * D + DG));
R := BLimit(Round(R * D + DR));
end;
Inc(Dest);
end;
end;
end;
procedure Mixer(Bitmap: TBitmap; Value: Byte; Color: TColor);
function BLimit(B: Integer): Byte;
begin
if B < 0 then
Result := 0
else if B > 255 then
Result := 255
else
Result := B;
end;
type
pRGB = ^TRGB;
TRGB = record
B, G, R: Byte;
end;
var
x, y: Word;
Dest: pRGB;
DR, DG, DB, D: Double;
begin
DR := Lo(Color);
DG := Lo(Color shr 8);
DB := Lo((Color shr 8) shr 8);
for y := 0 to Bitmap.Height - 1 do
begin
Dest := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
with Dest^ do
begin
R := BLimit(Round((R/100 * Value + DR/100 * (255-Value)) / 2));
G := BLimit(Round((G/100 * Value + DG/100 * (255-Value)) / 2));
B := BLimit(Round((B/100 * Value + DB/100 * (255-Value)) / 2));
end;
Inc(Dest);
end;
end;
end;
|
|
Как сделать эффект блоков?
procedure Blocks(Bitmap: TBitmap; Hor, Ver, MaxOffset: Integer; BackColor: TColor);
function RandomInRadius(Num, Radius: Integer): Integer;
begin
if Random(2) = 0 then
Result := Num + Random(Radius)
else
Result := Num - Random(Radius);
end;
var
x, y, xd, yd: Integer;
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.Assign( Bitmap );
Bitmap.Canvas.Brush.Color := BackColor;
Bitmap.Canvas.FillRect( Rect( 0, 0, Bitmap.Width, Bitmap.Height ) );
xd := ( Bitmap.Width - 1 ) div Hor;
yd := ( Bitmap.Height - 1 ) div Ver;
Randomize;
for x := 0 to xd do
for y := 0 to yd do
BitBlt(Bitmap.Canvas.Handle,
RandomInRadius(Hor * x, MaxOffset),
RandomInRadius(Ver * y, MaxOffset),
Hor, Ver, Bmp.Canvas.Handle, Hor * x, Ver * y, SRCCOPY);
finally
Bmp.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Blocks(bm, bm.Width div 10, bm.Height div 10, 4, clWhite);
Canvas.Draw(0, 0, bm);
end;
|
|
Как сделать эффект волны?
uses
Math;
procedure WaveSin(Bitmap: TBitmap; Frequency, Length:
Integer; Hor: Boolean; BackColor: TColor);
const
Rad = Pi / 180;
type
pRGB = ^TRGB;
TRGB = record
B, G, R: Byte;
end;
var
x, y, f: Integer;
Dest, Src: pRGB;
Bmp: TBitmap;
begin
Bitmap.PixelFormat := pf24Bit;
Bmp := TBitmap.create;
try
Bmp.Assign(Bitmap);
Bitmap.Canvas.Brush.Color := BackColor;
Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height));
for y := 0 to Bmp.Height - 1 do
begin
Src := Bmp.ScanLine[y];
for x := 0 to Bmp.Width - 1 do
begin
if Hor then
begin
f := Min(Max(Round(Sin(x * Rad * Length) * Frequency) + y, 0),
Bitmap.Height - 1);
Dest := Bitmap.ScanLine[f];
Inc(Dest, x);
end
else
begin
f := Min(Max(Round(Sin(y * Rad * Length) * Frequency) + x, 0),
Bitmap.Width - 1);
Dest := Bitmap.ScanLine[y];
Inc(Dest, f);
end;
Dest^ := Src^;
Inc(Src);
end;
end;
finally
Bmp.free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WaveSin(bm, bm.Width div 50, bm.Width div 40, True, clWhite);
Canvas.Draw(0, 0, bm);
end;
|
|
Как сделать эффект инея (разброса)?
procedure Disorder(Bitmap: TBitmap; Hor, Ver: Integer; BackColor: TColor);
function RandomInRadius(Num, Radius: Integer): Integer;
begin
if Random(2) = 0 then
Result := Num + Random(Radius)
else
Result := Num - Random(Radius);
end;
type
pRGB = ^TRGB;
TRGB = record
B, G, R: Byte;
end;
var
x, y, WW, HH, xr, yr: Integer;
Dest1, Dest2, Src1, Src2: PRGB;
Bmp: TBitmap;
begin
Randomize;
Bitmap.PixelFormat := pf24Bit;
Bmp := TBitmap.Create;
try
Bmp.Assign(Bitmap);
WW := Bitmap.Width - 1;
HH := Bitmap.Height - 1;
Bitmap.Canvas.Brush.Color := BackColor;
Bitmap.Canvas.FillRect(Rect(0, 0, WW + 1, HH + 1));
for y := 0 to HH do
begin
for x := 0 to WW do
begin
xr := RandomInRadius(x, Hor);
yr := RandomInRadius(y, Ver);
if (xr >= 0) and (xr < WW) and (yr >= 0) and (yr < HH) then
begin
Src1 := Bmp.ScanLine[y];
Src2 := Bmp.ScanLine[yr];
Dest1 := Bitmap.ScanLine[y];
Dest2 := Bitmap.ScanLine[yr];
Inc(Src1, x);
Inc(Src2, xr);
Inc(Dest1, x);
Inc(Dest2, xr);
Dest1^ := Src2^;
Dest2^ := Src1^;
end;
end;
end;
finally
Bmp.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Disorder(bm, 5, 5, clWhite);
Canvas.Draw(0, 0, bm);
end;
|
|
Как сделать эффект мозаики (пикселизации)?
uses
Math;
procedure PixelsEffect(Bitmap: TBitmap; Hor, Ver: Word);
type
pRGB = ^TRGB;
TRGB = record
B, G, R: Byte;
end;
var
i, j, x, y, xd, yd, rr, gg, bb, h, hx, hy: Integer;
Dest: pRGB;
begin
if (Hor = 1) and (Ver = 1) then
Exit;
Bitmap.PixelFormat := pf24Bit;
xd := (Bitmap.Width - 1) div Hor;
yd := (Bitmap.Height - 1) div Ver;
for i := 0 to xd do
for j := 0 to yd do
begin
h := 0;
rr := 0;
gg := 0;
bb := 0;
hx := Min(Hor * (i + 1), Bitmap.Width - 1);
hy := Min(Ver * (j + 1), Bitmap.Height - 1);
for y := j * Ver to hy do
begin
Dest := Bitmap.ScanLine[y];
Inc(Dest, i * Hor);
for x := i * Hor to hx do
begin
Inc(rr, Dest^.R);
Inc(gg, Dest^.G);
Inc(bb, Dest^.B);
Inc(h);
Inc(Dest);
end;
end;
Bitmap.Canvas.Brush.Color := RGB(rr div h, gg div h, bb div h);
Bitmap.Canvas.FillRect(Rect(i * Hor, j * Ver, hx + 1, hy + 1));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
PixelsEffect(bm, 8, 8);
Canvas.Draw(0, 0, bm);
end;
|
|
Как преобразовать Bitmap в двухцветное изображение (порог цветов)?
procedure Threshold(Bitmap: TBitmap; Value: Byte; Color1, Color2: TColor);
type
pRGB = ^TRGB;
TRGB = record
B, G, R: Byte;
end;
function ColorToRGB(Color: TColor): TRGB;
begin
with Result do
begin
R := Lo(Color);
G := Lo(Color shr 8);
B := Lo((Color shr 8) shr 8);
end;
end;
var
x, y: Word;
C1, C2: TRGB;
Dest: pRGB;
begin
Bitmap.PixelFormat := pf24Bit;
C1 := ColorToRGB( Color1 );
C2 := ColorToRGB( Color2 );
for y := 0 to Bitmap.Height-1 do
begin
Dest := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width-1 do
begin
if (Dest^.r + Dest^.g + Dest^.b) / 3 > Value then
Dest^ := C1
else
Dest^ := C2;
Inc(Dest);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Threshold(FBitmap, 127, clWhite, clBlack);
end;
|
|
Как инвертировать Bitmap?
function InvertBitmap(MyBitmap: TBitmap): TBitmap;
var
x, y: Integer;
ByteArray: PByteArray;
begin
MyBitmap.PixelFormat := pf24Bit;
for y := 0 to MyBitmap.Height-1 do
begin
ByteArray := MyBitmap.ScanLine[y];
for x := 0 to MyBitmap.Width * 3 - 1 do
ByteArray[x] := 255 - ByteArray[x];
end;
Result := MyBitmap;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Picture.Bitmap := InvertBitmap(Image1.Picture.Bitmap);
Image1.Refresh;
end;
|
|
Как рисовать на рабочем столе?
procedure TForm1.Button1Click(Sender: TObject);
var
DesktopCanvas: TCanvas;
begin
DesktopCanvas := TCanvas.Create;
try
DesktopCanvas.Handle := GetDC(0);
try
DesktopCanvas.MoveTo(0, 0);
DesktopCanvas.LineTo(Screen.Width, Screen.Height);
finally
ReleaseDC(0, DesktopCanvas.Handle);
DesktopCanvas.Handle := 0;
end;
finally
DesktopCanvas.Free;
end;
end;
|
|
|
При использовании материала - ссылка на сайт обязательна
|
|
