|
:: 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 * ArcTan( ( EndPoint.y - BeginPoint.y ) / ( EndPoint.x - BeginPoint.x ) ) / pi;
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 );
var
A1, A2: Extended;
Arrow: array[0..3] of TPoint;
OldWidth: Integer;
const
Beta = 0.322;
LineLen = 4.74;
CentLen = 3;
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;
// Способ второй
// Неоптимизированный вариант
// Value - процент цвета рисунка от конечного цвета,
// (255-Value) - процент цвета Color от конечного цвета,
// где 255 - это 100%; Новый цвет получается путём нахождения
// среднеарифметического значения каждого компонента цвета
// в точке (x, y) и цвета Color после процентного преобразования.
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 );
/// <summary>
/// Вырезаем прямоугольники со сторонами Hor Ver
/// и копируем их в радиусе MaxOffset
/// </summary>
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;
/// <summary>
/// функция разбивает изображение на прямоугольники
/// (ширина - Hor; высота - Ver) и закрашивает эти
/// прямоугольники средним цветом, используя
/// среднеарифметическое составляющих
/// </summary>
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
Bitmap.PixelFormat := pf24Bit;
if ( Hor = 1 ) and ( Ver = 1 ) then
Exit;
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
// Если среднеарифметическое R, G и B больше Value,
// то точку (x, y) закрашиваем цветом Color1,
// иначе - цветом Color2
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
begin
ByteArray[x] := 255 - ByteArray[x];
end;
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;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
