:: MVP ::
|
|
:: RSS ::
|
|
|
Как изменить цветовые каналы битового изображения?
function SetRGBChannelValue(Bitmap: TBitmap; Red, Green, Blue: Integer): Boolean;
type
pRGB = ^TRGB;
TRGB = record
B, G, R: Byte;
end;
var
x, y: Integer;
rgbc: array[0..2] of Byte;
Dest: pRGB;
begin
if (Red = 0) and (Green = 0) and (Blue = 0) then
begin
Result := False;
Exit;
end;
for y := 0 to Bitmap.Height - 1 do
begin
Dest := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
rgbc[0] := Dest^.R;
rgbc[1] := Dest^.G;
rgbc[2] := Dest^.B;
if not (rgbc[0] + Red < 0) and not (rgbc[0] + Red > 255) then
rgbc[0] := rgbc[0] + Red;
if not (rgbc[1] + Green < 0) and not (rgbc[1] + Green > 255) then
rgbc[1] := rgbc[1] + Green;
if not (rgbc[2] + Blue < 0) and not (rgbc[2] + Blue > 255) then
rgbc[2] := rgbc[2] + Blue;
Dest^.R := rgbc[0];
Dest^.G := rgbc[1];
Dest^.B := rgbc[2];
Inc(Dest);
end;
end;
Result := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile('c:\in.bmp');
SetRGBChannelValue(Bitmap, 10, 50, 180);
Bitmap.SaveToFile('c:\out.bmp')
finally
Bitmap.Free;
end;
end;
|
Как изменить контрастность изображения?
// Спрсоб первый
/// <summary>
/// Изменение контрастности изображения
/// </summary>
/// <param name="Value">значение контрастности на отрезке [-100..100]</param>
/// <param name="Local">true - применяется "местный контраст", false - "общий" (более красивый)</param>
procedure Contrast(Bitmap: TBitmap; Value: Integer; Local: Boolean);
function BLimit(B: Integer): Byte;
begin
if B < 0 then
Result := 0
else if B > 255 then
Result := 255
else
Result := B;
end;
var
Dest: pRGBTriple;
x, y, mr, mg, mb, W, H, tr, tg, tb: Integer;
vd: Double;
begin
if Value = 0 then
Exit;
W := Bitmap.Width - 1;
H := Bitmap.Height - 1;
if Local then
begin
mR := 128;
mG := 128;
mB := 128;
end
else
begin
tr := 0;
tg := 0;
tb := 0;
for y := 0 to H do
begin
Dest := Bitmap.ScanLine[y];
for x := 0 to W do
begin
with Dest^ do
begin
Inc(tb, rgbtBlue);
Inc(tg, rgbtGreen);
Inc(tr, rgbtRed);
end;
Inc(Dest);
end;
end;
mB := Trunc(tb / (W * H));
mG := Trunc(tg / (W * H));
mR := Trunc(tr / (W * H));
end;
if Value > 0 then
vd := 1 + (Value / 10)
else
vd := 1 - (Sqrt(-Value) / 10);
for y := 0 to H do
begin
Dest := Bitmap.ScanLine[y];
for x := 0 to W do
begin
with Dest^ do
begin
rgbtBlue := BLimit(mB + Trunc((rgbtBlue - mB) * vd));
rgbtGreen := BLimit(mG + Trunc((rgbtGreen - mG) * vd));
rgbtRed := BLimit(mR + Trunc((rgbtRed - mR) * vd));
end;
Inc(Dest);
end;
end;
end;
// Спрсоб второй
uses
{...,} Math;
procedure Gamma(Bitmap: TBitmap; L: Double); {0.0 < L < 7.0}
type
pRGB = ^TRGB;
TRGB = record
B, G, R: Byte;
end;
var
Dest: pRGB;
X, Y: Word;
GT: array[0..255] of Byte;
begin
Bitmap.PixelFormat := pf24Bit;
GT[0] := 0;
if L = 0 then
L := 0.01;
for X := 1 to 255 do
GT[X] := Round(255 * Power(X / 255, 1 / L));
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 := GT[R];
G := GT[G];
B := GT[B];
end;
Inc(Dest);
end;
end;
end;
|
Как отобразить Bitmap зеркально?
// Способ первый
procedure FlipBitmap(Bitmap: TBitmap; FlipHor: Boolean);
var
x, y, W, H: Integer;
Pixel_1, Pixel_2: PRGBTriple;
MemPixel: TRGBTriple;
begin
Bitmap.PixelFormat := pf24Bit;
W := Bitmap.Width-1;
H := Bitmap.Height-1;
if FlipHor then {отражение по горизонтали}
for y := 0 to H do
begin
// помещаем оба указателя на строку H:
Pixel_1 := Bitmap.ScanLine[y];
Pixel_2 := Bitmap.ScanLine[y];
// помещаем второй указатель в конец строки:
Inc(Pixel_2, W);
// цикл идёт только до середины строки:
for x := 0 to W div 2 do
begin
// симметричные точки обмениваются цветами:
MemPixel := Pixel_1^;
Pixel_1^ := Pixel_2^;
Pixel_2^ := MemPixel;
Inc(Pixel_1); // смещаем указатель вправо
Dec(Pixel_2); // смещаем указатель влево
end;
end
else // отражение по вертикали
// цикл идёт только до средней строки:
for y := 0 to H div 2 do
begin
// помещаем первый указатель на строку H,
// а второй на строку симметричную H:
Pixel_1 := Bitmap.ScanLine[y];
Pixel_2 := Bitmap.ScanLine[H-y];
for x := 0 to W do
begin
// симметричные точки обмениваются цветами:
MemPixel := Pixel_1^;
Pixel_1^ := Pixel_2^;
Pixel_2^ := MemPixel;
Inc(Pixel_1); // смещаем указатель вправо
Inc(Pixel_2); // смещаем указатель вправо
end;
end;
end;
|
Как заменить все цвета Bitmap`a оттенками одного цвета?
procedure ModColors(Bitmap: TBitmap; 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
r1, g1, b1: Byte;
x, y: Integer;
Dest: pRGB;
A: Double;
begin
Bitmap.PixelFormat := pf24Bit;
r1 := Round(255 / 100 * GetRValue(Color));
g1 := Round(255 / 100 * GetGValue(Color));
b1 := Round(255 / 100 * GetBValue(Color));
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
A := (r + b + g) / 300;
with Dest^ do
begin
R := BLimit(Round(r1 * A));
G := BLimit(Round(g1 * A));
B := BLimit(Round(b1 * A));
end;
end;
Inc(Dest);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ModColors(FBitmap, RGB(218, 219, 230));
end;
|
Как залить канву градиентом?
// Способ первый
type
TOrientation = (orVertical, orHorizontal);
TForm1 = class(TForm)
procedure FormPaint(Sender: TObject);
private
procedure PaintGradientRect(StartColor, EndColor: TColor;
Orientation: TOrientation);
procedure PaintGradientTriangle;
end;
// Переопределение типа из Windows.pas
COLOR16 = $0000..$FF00;
TTriVertex = packed record
x, y: DWORD; // Координаты вершины
Red, Green, Blue, Alpha: COLOR16; // Каналы цветов
end;
function GradientFill(DC: HDC; Vertex: Pointer; NumVertex: Cardinal;
Mesh: Pointer; NumMesh, Mode: DWORD): BOOL; stdcall;
external 'msimg32.dll' name 'GradientFill';
{...}
implementation
{...}
procedure TForm1.PaintGradientRect(StartColor, EndColor: TColor;
Orientation: TOrientation);
var
// Массив вершин (нужны две - верхнелевая и нижнеправая)
vert: array[0..1] of TTriVertex;
gRect: TGradientRect; // Индексы вершин в массиве vert (из Windows.pas)
begin
// Определяем вершины
vert[0].x := 0; // Верхняя левая точка
vert[0].y := 0;
vert[0].Red := GetRValue(StartColor) shl 8;
vert[0].Green := GetGValue(StartColor) shl 8;
vert[0].Blue := GetBValue(StartColor) shl 8;
vert[0].Alpha := $0000; // Видать прозрачность?..
vert[1].x := ClientWidth; // Нижняя правая точка
vert[1].y := ClientHeight;
vert[1].Red := GetRValue(EndColor) shl 8;
vert[1].Green := GetGValue(EndColor) shl 8;
vert[1].Blue := GetBValue(EndColor) shl 8;
vert[1].Alpha := $0000;
gRect.UpperLeft := 0; // Назначаем вершины верхнелевому
gRect.LowerRight := 1; // и нижнеправому углам.
// Заливаем в зависимости от ориентации
if Orientation = orHorizontal then
GradientFill(Canvas.Handle, @vert, 2, @gRect, 1, GRADIENT_FILL_RECT_H)
else
GradientFill(Canvas.Handle, @vert, 2, @gRect, 1, GRADIENT_FILL_RECT_V);
end;
procedure TForm1.PaintGradientTriangle;
var
vert: array[0..3] of TTriVertex; // 4 точки для 2 треугольников<
gTri: array[0..1] of TGradientTriangle; // массив из 2 треугольников
begin
// Красная вершина
vert[0].x := 80;
vert[0].y := 50;
vert[0].Alpha := $0000;
vert[0].Red := $FF00;
vert[0].Green := $0000;
vert[0].Blue := $0000;
// Желтая вершина
vert[1].x := 50;
vert[1].y := 120;
vert[1].Alpha := $0000;
vert[1].Red := $FF00;
vert[1].Green := $FF00;
vert[1].Blue := $0000;
// Синяя вершина
vert[2].x := 150;
vert[2].y := 80;
vert[2].Alpha := $0000;
vert[2].Red := $0000;
vert[2].Green := $0000;
vert[2].Blue := $FF00;
// Зеленая вершина
vert[3].x := 120;
vert[3].y := 150;
vert[3].Alpha := $0000;
vert[3].Red := $0000;
vert[3].Green := $FF00;
vert[3].Blue := $0000;
// Назначаем индексы вершин углам треугольников
gTri[0].Vertex1 := 0; gTri[0].Vertex2 := 1; gTri[0].Vertex3 := 2;
gTri[1].Vertex1 := 3; gTri[1].Vertex2 := 1; gTri[1].Vertex3 := 2;
// Рисуем красивый градиент
GradientFill(Canvas.Handle, @vert, 4, @gTri, 2, GRADIENT_FILL_TRIANGLE);
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
PaintGradientRect(clRed, clLime, orVertical);
PaintGradientTriangle;
end;
// **********************************************
// В полседних версиях Delphi это уже реализовано
// **********************************************
uses
GraphUtil;
procedure TForm1.FormPaint(Sender: TObject);
begin
GradientFillCanvas(Canvas, clMaroon, clWhite, ClientRect, gdVertical);
end;
// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
const
N = 200;
M = 100;
var
i, j, a: Integer;
begin
a := 255 div N;
for i := 1 to N do
for j := 1 to M do
Form1.Canvas.Pixels[20+i, 30+j] := RGB(255, 255-i*a, 255);
end;
// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
var
StartC, EndC: TColor; // Начальный и конечный цвета
GradRECT: TRect; // Размер области, на которой будем рисовать
StartRGB, EndRGB: array[0..2] of Byte; // Разложенный цвет
Colors, i, Delta: Word; // Число цветов, которые использовать для создания градиента
begin
// Область заливки
GradRECT := Image1.ClientRect;
// Цвета
StartC := ColorToRGB(clRed);
EndC := ColorToRGB(clLime);
// Массив с исходными цветами (1)
StartRGB[0] := GetRValue(StartC);
StartRGB[1] := GetGValue(StartC);
StartRGB[2] := GetBValue(StartC);
// Массив с конечными цветами (2)
EndRGB[0] := GetRValue(EndC);
EndRGB[1] := GetGValue(EndC);
EndRGB[2] := GetBValue(EndC);
// Число градаций на ширину
Colors := Image1.Width div 2;
// Число пикселей для одной градации
Delta := Image1.Width div Colors;
for i := 0 to Colors do
begin
// Определяем область для градации
GradRECT.Left := i * Delta;
GradRECT.Right := GradRECT.Left + Delta;
with Image1.Canvas do
begin
Pen.Style := psSolid;
Brush.Color := RGB((StartRGB[0] + MulDiv(i, EndRGB[0] - StartRGB[0], Colors{-1})),
(StartRGB[1] + MulDiv(i, EndRGB[1] - StartRGB[1], Colors{-1})),
(StartRGB[2] + MulDiv(i, EndRGB[2] - StartRGB[2], Colors{-1})));
// Заливаем
FillRect(GradRect);
end;
end;
end;
|
Как просмотреть все стили кисти?
var
BrushStyle: Byte = 0;
implementation
uses
{...,} TypInfo;
procedure TForm1.FormCreate(Sender: TObject);
begin
Caption := GetEnumName(TypeInfo(TBrushStyle), BrushStyle);
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
with Canvas do
begin
Brush.Style:= bsSolid;
Brush.Color:= clWhite;
Rectangle(0, 0, ClientWidth, ClientHeight);
Brush.Style := TBrushStyle(BrushStyle);
Brush.Color := clRed;
Rectangle(0, 0, ClientWidth, ClientHeight);
end;
end;
// Timer1.Interval = 1000
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Inc(BrushStyle);
if BrushStyle > 7 then
BrushStyle := 0;
InvalidateRect(Handle, nil, False);
Caption := GetEnumName(TypeInfo(TBrushStyle), BrushStyle);
end;
|
Как преобразовать EMF (Enhanced Metafile) в BMP?
// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
Bitmap: TBitmap;
Met: TMetafile;
begin
Bitmap := TBitmap.Create;
try
Metafile := TMetafile.Create;
try
Metafile.LoadFromFile('c:\test.emf');
Bitmap.Width := Metafile.Width;
Bitmap.Height := Metafile.Height;
Bitmap.Canvas.Draw(0, 0, Metafile);
Bitmap.SaveToFile('c:\test.bmp');
finally
Metafile.Free;
end;
finally
Bitmap.Free;
end;
end;
// Способ второй
procedure ConvertEMF2BMP(const EMFFileName, BMPFileName: TFileName);
var
p: Pointer;
Metafile: TMetafile;
Bitmap: TBitmap;
begin
Metafile := TMetaFile.Create;
try
Bitmap := TBitmap.Create;
try
Metafile.LoadFromFile(EMFFileName);
Bitmap.Width := Metafile.Width;
Bitmap.Height := Metafile.Height;
Bitmap.SetSize(Metafile.Width, Metafile.Height);
PlayEnhMetaFile(Bitmap.Canvas.Handle, Metafile.Handle, Bitmap.Canvas.ClipRect);
finally
Metafile.Free;
end;
Bitmap.SaveToFile(BMPFileName);
finally
Bitmap.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ConvertEMF2BMP('c:\123456.emf', 'c:\123456.bmp');
end;
|
Как сделать эффект "муравьев"?
const
ANT_WIDTH = 10;
ANT_MOVE_STEP = 2;
var
antPos: Word = 0;
procedure ant_Line(x1, y1, x2, y2: integer; Canvas: TCanvas; Otstup, Interval: Word);
var
i, d, a, b: Word;
znx, zny: SmallInt;
px, py: integer;
begin
d := Trunc(Sqrt(Sqr(x2-x1) + Sqr(y2-y1)));
znx := 1;
zny := 1;
if x2-x1 < 0 then
znx := -1;
if y2-y1 < 0 then
zny := -1;
a := Trunc(Interval * (x2-x1) * znx / d);
b := Trunc(Interval * (y2-y1) * zny / d);
if Otstup >= Interval * 2 then
Otstup := Otstup mod (Interval * 2);
for i := 0 to Trunc(d / Interval) do
begin
if i mod 2 <> 0 then
Continue;
px := x1 + i * a * znx + Trunc(Otstup * (x2-x1) / d);
py := y1 + i * b * zny + Trunc(Otstup * (y2-y1) / d);
if (d < Trunc(Sqrt(Sqr(px-x1) + Sqr(py-y1)))) or
((px * znx > x2) or (py * zny > y2)) then
Continue;
Canvas.MoveTo(px, py);
px := x1 + (i+1) * a * znx + Trunc(Otstup * (x2-x1) / d);
py := y1 + (i+1) * b * zny + Trunc(Otstup * (y2-y1) / d);
if d < Trunc(Sqrt(Sqr(px-x1) + Sqr(py-y1))) then
begin
px := x2;
py := y2;
end;
if px * znx > x2 then
px := x2;
if py * zny > y2 then
py := y2;
Canvas.LineTo(px, py);
if Otstup > Interval then
begin
Canvas.MoveTo(x1, y1);
px := x1 + Trunc((Otstup-Interval) * (x2-x1) / d);
py := y1 + Trunc((Otstup-Interval) * (y2-y1) / d);
Canvas.LineTo(px, py);
end;
end;
end;
// Otstup - смещение для рисования "муравьев"
// Interval - длина линий ("муравьев")
procedure ant_Rectangle(x1, y1, x2, y2: integer; Canvas: TCanvas; Otstup, Interval: Word);
var
pogr, pogr1: Word;
begin
if (x1 = x2) or (y1 = y2) then
Exit;
ant_Line(x1, y1, x2, y1, Canvas, Otstup, Interval);
pogr := (Abs(x2-x1) div Interval) mod 2;
if pogr = 0 then
pogr := Interval * 2 - (Abs(x2-x1) mod (Interval))
else
pogr := Interval - (Abs(x2-x1) mod (Interval));
ant_Line(x2, y1, x2, y2, Canvas, Otstup + pogr, Interval);
pogr1 := (Abs(y1-y2) div Interval) mod 2;
if pogr1 = 0 then
pogr1 := Interval * 2 - (Abs(y1-y2) mod (Interval))
else
pogr1 := Interval - (Abs(y1-y2) mod (Interval));
ant_Line(x2, y2, x1, y2, Canvas, Otstup + pogr + pogr1, Interval);
ant_Line(x1, y2, x1, y1, Canvas, otstup + 2 * pogr + pogr1, Interval);
end;
// Timer.Interval = 50
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Refresh;
Canvas.Pen.Width := 2;
Canvas.Pen.Color := clNavy;
ant_Rectangle(10, 10, 200, 200, Canvas, antPos, ANT_WIDTH);
antPos := antPos + ANT_MOVE_STEP;
if antPos >= ANT_WIDTH * 2 then
antPos := 0;
end;
|
Как ограничить область рисования на канве?
// Установка области клиппинга - данные вне этой области не отображаются
procedure TForm1.Button1Click(Sender: TObject);
var
ClipRect: TRect;
begin
ClipRect := ClientRect;
with ClipRect do
begin
InflateRect(ClipRect, -(Right div 4), -(Bottom div 4));
IntersectClipRect(Canvas.Handle, Left, Top, Right, Bottom);
end;
Canvas.Brush.Color := clWhite;
Canvas.FillRect(ClientRect);
end;
// Удаление области рисования - данные в этой области не отображаются
procedure TForm1.Button1Click(Sender: TObject);
var
ClipRect: TRect;
begin
ClipRect := ClientRect;
with ClipRect do
begin
InflateRect(ClipRect, -(Right div 4), -(Bottom div 4));
ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom);
end;
Canvas.Brush.Color := clWhite;
Canvas.FillRect(ClientRect);
end;
|
Как нарисовать Bitmap с прозрачностью?
procedure DrawTransparentBmp(Canvas: TCanvas; X,Y: Integer; Bmp: TBitmap;
clTransparent: TColor);
var
bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
OldCol: Longint;
begin
try
bmpAND := TBitmap.Create;
bmpAND.Width := Bmp.Width;
bmpAND.Height := Bmp.Height;
bmpAND.Monochrome := True;
OldCol := SetBkColor(Bmp.Canvas.Handle, ColorToRGB(clTransparent));
BitBlt(bmpAND.Canvas.Handle, 0, 0, Bmp.Width,Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
SetBkColor(Bmp.Canvas.Handle, OldCol);
bmpINVAND := TBitmap.Create;
bmpINVAND.Width := Bmp.Width;
bmpINVAND.Height := Bmp.Height;
bmpINVAND.Monochrome := True;
BitBlt(bmpINVAND.Canvas.Handle, 0, 0, Bmp.Width,Bmp.Height, bmpAND.Canvas.Handle, 0, 0, NOTSRCCOPY);
bmpXOR := TBitmap.Create;
bmpXOR.Width := Bmp.Width;
bmpXOR.Height := Bmp.Height;
BitBlt(bmpXOR.Canvas.Handle, 0, 0, Bmp.Width,Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
BitBlt(bmpXOR.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpINVAND.Canvas.Handle, 0, 0, SRCAND);
bmpTarget := TBitmap.Create;
bmpTarget.Width := Bmp.Width;
bmpTarget.Height := Bmp.Height;
BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Canvas.Handle, X, Y, SRCCOPY);
BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpAND.Canvas.Handle, 0, 0, SRCAND);
BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpXOR.Canvas.Handle, 0, 0, SRCINVERT);
BitBlt(Canvas.Handle, X, Y, Bmp.Width,Bmp.Height, bmpTarget.Canvas.Handle, 0, 0, SRCCOPY);
finally
bmpXOR.Free;
bmpAND.Free;
bmpINVAND.Free;
bmpTarget.Free;
end;
end;
|
При использовании материала - ссылка на сайт обязательна
|
|