|
:: MVP ::
|
|
|
:: RSS ::
|
|
|
Как отразить Bitmap по горизонтали?
procedure FlipHorizontal( var ABitmap: TBitmap );
var
Data: TBitmapData;
X, Y: Integer;
Pixel: TAlphaColor;
begin
Assert( ABitmap <> nil );
if ABitmap.Map(TMapAccess.ReadWrite, Data) then
try
for X := 0 to (Data.Width div 2) - 1 do
for Y := 0 to Data.Height - 1 do
begin
Pixel := Data.GetPixel( X, Y );
Data.SetPixel( X, Y, Data.GetPixel( Data.Width - X, Y ) );
Data.SetPixel( Data.Width - X, Y, Pixel );
end;
finally
ABitmap.Unmap( Data );
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile( 'c:\test.jpg' );
FlipHorizontal( Bitmap );
Image1.Bitmap.Assign( Bitmap );
end;
|
Как отразить Bitmap по вертикали?
procedure FlipVertical( var ABitmap: TBitmap );
var
Data: TBitmapData;
X, Y: Integer;
Pixel: TAlphaColor;
begin
Assert( ABitmap <> nil );
if ABitmap.Map( TMapAccess.ReadWrite, Data ) then
try
for X := 0 to Data.Width - 1 do
for Y := 0 to (Data.Height div 2) - 1 do
begin
Pixel := Data.GetPixel( X, Y );
Data.SetPixel( X, Y, Data.GetPixel( X, Data.Height - Y ) );
Data.SetPixel( X, Data.Height - Y, Pixel );
end;
finally
ABitmap.Unmap( Data );
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile( 'c:\test.jpg' );
FlipVertical( Bitmap );
Image1.Bitmap.Assign( Bitmap );
end;
|
Как программно добавить изображения в MultiResBitmap?
const
RequiredSclae = 1.0;
var
BitmapItem: TFixedBitmapItem;
Bitmap: TBitmap;
begin
if OpenDialog.Execute then
begin
// Запрашиваем картинку для нужного Scale
Bitmap := Image1.MultiResBitmap.Bitmaps[RequiredSclae];
// Проверяем, есть картинка или нет.
if Bitmap = nil then
begin
// Если нет, то заводим контейнер для новой картинки
BitmapItem := Image1.MultiResBitmap.Add;
BitmapItem.Scale := RequiredSclae;
Bitmap := BitmapItem.Bitmap;
end;
Bitmap.LoadFromFile( OpenDialog.FileName );
end;
end;
|
Как указать цвет по RGB?
// RGB
var
Color: TColor;
begin
TColorRec( Color ).R := 123;
TColorRec( Color ).G := 113;
TColorRec( Color ).B := 13;
Rectangle1.Fill.Color := Color;
end;
// ARGB
var
Color: TAlphaColor;
begin
TAlphaColorRec( Color ).R := 123;
TAlphaColorRec( Color ).G := 113;
TAlphaColorRec( Color ).B := 13;
TAlphaColorRec( Color ).A := 126;
Rectangle1.Fill.Color := Color;
end;
|
Как изменить качество изображения (Quality)?
procedure ChangeQuality( SrcBitmap: TBitmap; var DstBitmap: TBitmap; AQuality: Integer );
var
Stream: TStream;
Surface: TBitmapSurface;
SaveParam: TBitmapCodecSaveParams;
begin
if Assigned( DstBitmap ) then
begin
//DstBitmap.SetSize( SrcBitmap.Width, SrcBitmap.Height );
Stream := TMemoryStream.Create;
Surface := TBitmapSurface.Create;
try
Surface.Assign( SrcBitmap );
SaveParam.Quality := AQuality; // AQuality = 65
TBitmapCodecManager.SaveToStream( Stream, Surface, '.jpg', @SaveParam );
Stream.Position := 0;
DstBitmap.LoadFromStream( Stream );
finally
Surface.Free;
Stream.Free;
end;
end;
end;
|
Как отрисовать текст по дуге?
procedure TForm2.FormPaint(Sender: TObject; Canvas: TCanvas;
const ARect: TRectF);
const
S: String = 'Пример отрисовки текста по заданной траектории (дуга)';
var
i: Integer;
A, Ao, R, TextLen: Single;
Rect: TRectF;
M1, M2: TMatrix;
begin
// if Canvas.BeginScene then
// begin
Randomize;
R := 400;
Ao := DegToRad( 150 );
A := ( Pi - Ao ) / 2;
Canvas.Font.Size := 32;
Canvas.Stroke.Kind := TBrushKind.Solid;
Canvas.StrokeThickness := 3;
Canvas.Fill.Color := TAlphaColors.Palegreen xor $80000000;
Canvas.FillEllipse( TRectF.Create( 0, 0, 2 * R, 2 * R ), 1 );
TextLen := Canvas.TextWidth( S );
if TextLen > R * Ao then // Длина текста больше выделенной
Caption := 'АХТУНГ!'; // под него дуги (будет наложение букв)
for i := 1 to S.Length do
begin
Rect.Left := 0;
Rect.Top := R;
Rect.Width := Canvas.TextWidth( S[i] );
Rect.Height := Canvas.TextHeight( S[i] );
A := A + Ao / ( S.Length - 1 );
M1 := TMatrix.CreateTranslation( - Rect.CenterPoint.X, - Rect.CenterPoint.Y ) *
TMatrix.CreateRotation( A - A - Pi / 2 ) *
TMatrix.CreateTranslation( Rect.CenterPoint.X, Rect.CenterPoint.Y );
M2 := TMatrix.CreateTranslation( -R, -R ) *
TMatrix.CreateRotation( A ) *
TMatrix.CreateTranslation( R, R );
Canvas.SetMatrix( M1 * M2 );
Canvas.Fill.Color := TAlphaColor( Random( MaxInt ) or $FF000000 );
Canvas.FillText( Rect, S[i], False, 1, [{TFillTextFlag.RightToLeft}],
TTextAlign.Leading, TTextAlign.Center );
end;
Canvas.EndScene;
// end;
end;
|
Как нарисовать звезду?
type
TForm1 = class(TForm)
Image1: TImage;
Button1: TButton;
{...}
procedure Image1Paint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
implementation
var
// R - радиус описанного круга
// r - радиус вписанного круга
// d = R-r
R, d: Single;
Path: TPathData;
procedure Star;
var
i: Byte;
a1, a2: Single;
begin
Path.Clear;
Path.MoveTo(PointF(0, -R));
a1 := Pi/5 - Pi/2;
a2 := -Pi/2;
for i:=1 to 5 do
begin
Path.LineTo(
PointF((R * Cos(Pi/5)-d) * Cos(a1+(i-1) * 2*Pi/5),
(R * Cos(Pi/5)-d) * Sin(a1+(i-1) * 2*Pi/5))
);
Path.LineTo(PointF(R * Cos(i*2*Pi/5+a2), R * Sin(i*2*Pi/5+a2)));
end;
Path.ClosePath;
path.Translate(R * Cos(Pi/10), R);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i: Byte;
begin
R := 100;
d := 40;
Path := TPathData.Create;
Star;
Image1.Repaint;
end;
procedure TForm1.Image1Paint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
begin
with Canvas do
begin
Stroke.Color := TAlphaColors.Blue;
Fill.Color := TAlphaColors.Blue;
Stroke.Thickness := 4;
DrawPath(Path, 1);
FillPath(Path, 1);
end;
end;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
