|
:: 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);
{...}
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;
|
Как конвертировать изображение из одного формата ы другой?
uses
{...,} FMX.Surfaces;
// BMP/PNG/JPG/GIF/TIFF
procedure ConvertImage(InputBitmap: TBitmap; OutFileFame, OutFormat: string);
var
Stream: TMemoryStream;
Surf: TBitmapSurface;
begin
Stream := TMemoryStream.Create;
try
Stream.Position := 0;
Surf := TBitmapSurface.Create;
try
Surf.Assign(InputBitmap);
if not TBitmapCodecManager.SaveToStream(Stream, Surf, OutFormat) then
raise EBitmapSavingFailed.Create('Error saving Bitmap to ' + OutFormat);
finally
Surf.Free;
end;
Stream.Position := 0;
//ImageViewer1.Bitmap.LoadFromStream(Stream);
Stream.Position := 0;
Stream.SaveToFile(OutFileFame);
finally
Stream.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Image: TBitmap;
begin
try
Image := TBitmap.Create;
Image.LoadFromFile('c:\test.bmp');
ConvertImage(Image, 'c:\test.jpg', '.jpg');
finally
Image.Free;
end;
end;
|
Как преобразовать RGB-цвет в оттенки серого?
// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
Data: TBitmapData;
x, y: Integer;
Pixel: TAlphaColor;
Color: Single;
begin
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile('c:\color.jpg');
Bitmap.Canvas.BeginScene;
if Bitmap.Map(TMapAccess.ReadWrite, Data) then
try
for x := 0 to Data.Width - 1 do
for y := 0 to Data.Height - 1 do
begin
Pixel := Data.GetPixel(x, y);
Color := (TAlphaColorRec(Pixel).R * 0.3 +
TAlphaColorRec(Pixel).G * 0.59 +
TAlphaColorRec(Pixel).B * 0.11) / 255;
Pixel := TAlphaColorF.Create(Color, Color, Color).ToAlphaColor;
Data.SetPixel(x, y, Pixel);
end;
finally
Bitmap.Unmap(Data);
end;
Bitmap.Canvas.EndScene;
Bitmap.SaveToFile('c:\gray.jpg');
finally
Bitmap.Free;
end;
end;
// Способ второй
uses
{...,} FMX.Utils;
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
Data: TBitmapData;
x, y: Integer;
Pixel: TAlphaColor;
b, w: UInt64;
Color: Single;
Line: PAlphaColorArray;
begin
b := 0;
w := 0;
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile('c:\color.jpg');
Bitmap.Canvas.BeginScene;
if Bitmap.Map(TMapAccess.ReadWrite, Data) then
try
for y := 0 to Data.Height - 1 do
begin
Line := Data.GetScanline(y);
for x := 0 to Data.Width - 1 do
begin
Pixel := TAlphaColorArray(Line^)[x];
Color := (TAlphaColorRec(Pixel).R * 0.3 +
TAlphaColorRec(Pixel).G * 0.59 +
TAlphaColorRec(Pixel).B * 0.11) / 255;
Pixel := TAlphaColorF.Create(Color, Color, Color).ToAlphaColor;
TAlphaColorArray(Line^)[x] := Pixel;
end;
end;
finally
Bitmap.Unmap(Data);
end;
Bitmap.Canvas.EndScene;
Bitmap.SaveToFile('c:\gray.jpg');
finally
Bitmap.Free;
end;
end;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
