|
Графика
- создание и обработка изображений
|
||||
|
Главная
|
Программы
|
Исходники
|
Содержание
|
О себе
|
| Вопросы |
| Ответы |
Как создать BitMap большого (любого) размера
var Scr: Pointer; procedure BitmapSize(var bitmap: TBitmap; aSX, aSY: Integer); var BInfo: tagBITMAPINFO; begin // Создание DIB BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER); BInfo.bmiHeader.biWidth := aSX; BInfo.bmiHeader.biHeight := -aSY; BInfo.bmiHeader.biPlanes := 1; BInfo.bmiHeader.biBitCount := 32; BInfo.bmiHeader.biCompression := BI_RGB; Bitmap.Handle := CreateDIBSection(GetDC(0), BInfo, DIB_RGB_COLORS, Scr, 0, 0); ZeroMemory(Scr, aSX * aSY * 4); end;
Как преобразовать цвет в оттенки серого
Следущий пример показывает, как преобразовать RGB цвет в аналогичный оттенок серого,
наподобие того, как это делает чёрно-белый телевизор:
function RgbToGray(RGBColor : TColor) : TColor;
var
Gray: byte;
begin
Gray := Round((0.30 * GetRValue(RGBColor)) +
(0.59 * GetGValue(RGBColor)) +
(0.11 * GetBValue(RGBColor)));
Result := RGB(Gray, Gray, Gray);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Shape1.Brush.Color := RGB(255, 64, 64);
Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);
end;
Как преобразовать цвет из RGB в CMYK и обратно.
Ниже представлены две функции RGBTOCMYK() и CMYKTORGB(), которые позволяют преобразовывать
набор цветов RGB и CMYK.
Замечание: В цвете CMY чёрные тона достигаются путём одинаковых значений Циана, Магенты и
Жёлтого чернил. Чёрные чернила используются только при чисто чёрных точках, для повышения
контрастности и экономии цветных чернил. Как раз для этого предназначена третья функция
ColorCorrectCMYK().
Пример:
procedure RGBTOCMYK(R: byte;
G: byte;
B: byte;
var C: byte;
var M: byte;
var Y: byte;
var K: byte);
begin
C := 255 - R;
M := 255 - G;
Y := 255 - B;
if C < M then K := C
else K := M;
if Y < K then K := Y;
if k > 0 then begin
c := c - k;
m := m - k;
y := y - k;
end;
end;
procedure CMYKTORGB(C: byte;
M: byte;
Y: byte;
K: byte;
var R: byte;
var G: byte;
var B: byte);
begin
if (Integer(C) + Integer(K)) < 255 then R := 255 - (C + K)
else R := 0;
if (Integer(M) + Integer(K)) < 255 then G := 255 - (M + K)
else G := 0;
if (Integer(Y) + Integer(K)) < 255 then B := 255 - (Y + K)
else B := 0;
end;
procedure ColorCorrectCMYK(var C: byte;
var M: byte;
var Y: byte;
var K: byte);
var
MinColor: byte;
begin
if C < M then MinColor := C
else MinColor := M;
if Y < MinColor then MinColor := Y;
if MinColor + K > 255 then MinColor := 255 - K;
C := C - MinColor;
M := M - MinColor;
Y := Y - MinColor;
K := K + MinColor;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
R: byte;
G: byte;
B: byte;
C: byte;
M: byte;
Y: byte;
K: byte;
begin
R := 151;
G := 81;
B := 55;
Memo1.Lines.Add('R = ' + IntToStr(R));
Memo1.Lines.Add('G = ' + IntToStr(G));
Memo1.Lines.Add('B = ' + IntToStr(B));
Memo1.Lines.Add('-------------------');
RGBTOCMYK(R, G, B, C, M, Y, K);
Memo1.Lines.Add('C = ' + IntToStr(C));
Memo1.Lines.Add('M = ' + IntToStr(M));
Memo1.Lines.Add('Y = ' + IntToStr(Y));
Memo1.Lines.Add('K = ' + IntToStr(K));
Memo1.Lines.Add('-------------------');
CMYKTORGB(C, M, Y, K, R, G, B);
Memo1.Lines.Add('R = ' + IntToStr(R));
Memo1.Lines.Add('G = ' + IntToStr(G));
Memo1.Lines.Add('B = ' + IntToStr(B));
Memo1.Lines.Add('-------------------');
RGBTOCMYK(R, G, B, C, M, Y, K);
c := c + 2;
m := m + 2;
y := y + 2;
ColorCorrectCMYK(C, M, Y, K);
Memo1.Lines.Add('C = ' + IntToStr(C));
Memo1.Lines.Add('M = ' + IntToStr(M));
Memo1.Lines.Add('Y = ' + IntToStr(Y));
Memo1.Lines.Add('K = ' + IntToStr(K));
end;
Самый простой способ смешать два цвета c1 и c2, это вычислить средние значения rgb-значений.
Данный пример не отличается особой быстротой, поэтому если Вам нужно быстро смешивать цвета,
то прийдётся пошевелить мозгами...
function GetMixColor(c1, c2: TColor): TColor;
begin
// вычисляем средние значения Красного, Синего и Зелёного значений
// цветов c1 и c2:
Result := RGB((GetRValue(c1) + GetRValue(c2)) div 2,
(GetGValue(c1) + GetGValue(c2)) div 2,
(GetBValue(c1) + GetBValue(c2)) div 2);
end;
TrackBar1.Max := 255;
TrackBar1.Min := 0;
procedure TForm1.TrackBar1Change(Sender: TObject);
var
x, y: Integer;
c: TColor;
r, g, b: Byte;
a: Real;
begin
for y := 0 to Image1.Picture.Height do
for x := 0 to Image1.Picture.Width do
begin
c := Image2.Canvas.Pixels[x, y];
r := GetRValue(c);
g := GetGValue(c);
b := GetBValue(c);
a := TrackBar1.Position / 128;
if TrackBar1.Position < 128 then
Image1.Canvas.Pixels[x, y] := RGB(255-Round((255-r)*a), 255-Round((255-g)*a), 255-Round((255-b)*a))
else
Image1.Canvas.Pixels[x, y] := RGB(Round(r*(2-a)), Round(g*(2-a)), Round(b*(2-a)));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
IconSizeX: integer;
IconSizeY: integer;
AndMask: TBitmap;
XOrMask: TBitmap;
IconInfo: TIconInfo;
Icon: TIcon;
begin
{Получаем размер иконки}
IconSizeX := GetSystemMetrics(SM_CXICON);
IconSizeY := GetSystemMetrics(SM_CYICON);
{Создаём маску "And" - маску прозрачности}
AndMask := TBitmap.Create;
AndMask.LoadFromFile(OpenPictureDialog1.FileName);
AndMask.Monochrome := true;
AndMask.Width := IconSizeX;
AndMask.Height := IconSizeY;
{Создаём маску "Xor" - маску цвета}
XOrMask := TBitmap.Create;
AndMask.LoadFromFile(OpenPictureDialog1.FileName);
XOrMask.Width := IconSizeX;
XOrMask.Height := IconSizeY;
{Создаём иконку}
Icon := TIcon.Create;
IconInfo.fIcon := true;
IconInfo.xHotspot := 0;
IconInfo.yHotspot := 0;
IconInfo.hbmMask := AndMask.Handle;
IconInfo.hbmColor := XOrMask.Handle;
Icon.Handle := CreateIconIndirect(IconInfo);
{Уничтожаем временные битмапы}
AndMask.Free;
XOrMask.Free;
{Сохраняем иконку}
Icon.SaveToFile(SaveDialog1.FileName);
Как из Icon получить в Bitmap маску цвета и маску прозрачности
var Icon: TIcon; IcInfo: TICONINFO; BMask, BCol: TBitmap; begin Icon.LoadFromFile(OpenPictureDialog1.FileName); GetIconInfo(Icon.Handle, IcInfo); BCol := TBitmap.Create; BCol.Width := Icon.Width; BCol.Height := Icon.Height; BCol.Handle := IcInfo.hbmColor; Image2.Canvas.Draw(0, 0, BCol); BMask := TBitmap.Create; BMask.Width := Icon.Width; BMask.Height := Icon.Height; BMask.Handle := IcInfo.hbmMask; Image1.Canvas.Draw(0, 0, BMask); BCol.Free; BMask.Free; end;
Как прорисовать BitMap с прозрачностью
//Рисует на Cnv, начиная с координат x, y картинку
//из Bmp с прозрачным цветом clTransparent
procedure DrawTransparentBmp(Cnv: 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, Cnv.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(Cnv.Handle, x,y,Bmp.Width,Bmp.Height, bmpTarget.Canvas.Handle, 0,0,
SRCCOPY);
finally
bmpXOR.Free;
bmpAND.Free;
bmpINVAND.Free;
bmpTarget.Free;
end;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
B: TBitMap;
begin
B := TBitMap.Create;
B.Width := Image2.Picture.Width;
B.Height := Image2.Picture.Height;
B.Canvas.Draw(0, 0, Image2.Picture.Bitmap);
DrawTransparentBmp(B.Canvas, 0, 0, Image1.Picture.Bitmap, RGB(0, 255, 128));
Canvas.Draw(10, 200, B);
B.Free;
end;
Быстрый способ получить цвет пиксела
Для увеличения скорости выгодно поместить всю картинку в доступную память.
Для этого используется функция GetDIB. Она копирует изображение в выделенную для этого память.
А дальше, чтобы узнать цвет точки (x,y) изображения WxH нужно воспользоваться следующей "формулой":
PRGBTriple(integer(p) + (H - y - 1) * (3 * W + dw) + x * 3)^
Эта "формула" возвращает цвет в формате TRGBTriple. TRGBTriple - это запись с тремя полями:
красная, зеленая и синяя составляющие цвета. dw - это w mod 4 , где w - ширина картинки в пикселях
и нужен он для того, чтобы создавать сдвиг, связанный с шириной изображения.
Пример: скопируем один bitmap в другой по пиксельно.
Используется два приема:
1. ScanLine[y],
2. GetDIB.
procedure TForm1.Button1Click(Sender: TObject);
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array [0..0] of TRGBTriple;
var
bi: PBitmapInfo;
InfoSize, ImageSize: cardinal;
bmS, bmD: TBitmap;
p: pointer;
line: PRGBTripleArray;
r, g, b: integer;
w, h, x, y: integer;
dw: integer;
begin
bmS := TBitmap.Create;
bmS.LoadFromFile('c:\1.bmp');
bmS.PixelFormat := pf24bit;
w := bmS.Width;
h := bmS.Height;
bmD := TBitmap.Create;
bmD.Width := w;
bmD.Height := h;
bmD.PixelFormat := pf24bit;
dw := w mod 4;
GetDIBSizes(bmS.Handle, InfoSize, ImageSize);
GetMem(p, ImageSize);
GetMem(bi, InfoSize);
GetDIB(bmS.Handle, 0, bi^, p^);
for y := 0 to h - 1 do
begin
line := bmD.ScanLine[y];
for x := 0 to w - 1 do
with PRGBTriple(integer(p) + (h - y - 1) * (3 * w + dw) + x * 3)^ do
begin
line^[x].rgbtRed := rgbtRed;
line^[x].rgbtGreen := rgbtGreen;
line^[x].rgbtBlue := rgbtBlue;
end;
end;
Form1.Canvas.Draw(0, 0, bmS);
Form1.Canvas.Draw(0, h + 5, bmD);
bmS.Destroy;
bmD.Destroy;
FreeMem(p, ImageSize);
FreeMem(bi, InfoSize);
end;
procedure TForm1.FormPaint(Sender: TObject);
var
lf: TLogFont;
begin
FillChar(lf, SizeOf(lf), 0);
with lf do begin
// Высота буквы
lfHeight := 15;
// Ширина буквы
lfWidth := 20;
// Угол наклона в десятых градуса
lfEscapement := 100;
// Жирность 0..1000, 0 - по умолчанию
lfWeight := 1000;
// Курсив
lfItalic := 0;
// Подчеркнут
lfUnderline := 1;
// Зачеркнут
lfStrikeOut := 1;
// CharSet
lfCharSet := RUSSIAN_CharSet;
// Название шрифта
StrCopy(lfFaceName, 'Arial');
end;
with Form1.Canvas do begin
FillRect(ClipRect);
Font.Handle := CreateFontIndirect(lf);
TextOut(0, 100, 'It is a text string');
end;
end;
Как повернуть BitMap на произволный угол
procedure TForm1.Button1Click(Sender: TObject);
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array [0..0] of TRGBTriple;
var
bi: PBitmapInfo;
InfoSize, ImageSize: cardinal;
p: pointer;
line: PRGBTripleArray;
bm, bm1: TBitMap;
x, y: integer;
r, aa: single;
xo, yo, xoi, yoi: integer;
s, c: extended;
rr, gg, bb: Integer;
w, h, dw: Integer;
begin
a := a + 30; // угол в градусах
bm := TBitMap.Create;
bm.LoadFromFile('c:\1.bmp');
bm1 := TBitMap.Create;
bm.PixelFormat := pf24bit;
bm1.PixelFormat := pf24bit;
if a >= 360 then a := 0;
if (a >= 0) and (a < 90) then aa := a;
if (a >= 90) and (a < 180) then aa := 180 - a;
if (a >= 180) and (a < 270) then aa := a - 180;
if (a >= 270) and (a < 360) then aa := a - 270;
// здесь лучше бы воспользоваться функцией BitmapSize из вопроса о создании большого bitmap-a
bm1.Width := abs(Round(bm.Width * cos(aa*Pi/180) + bm.Height * sin(aa*Pi/180)));
bm1.Height := abs(Round(bm.Height * cos(aa*Pi/180) + bm.Width * sin(aa*Pi/180)));
w := bm.Width;
h := bm.Height;
xo := bm.Width div 2;
yo := bm.Height div 2;
xoi := bm1.Width div 2;
yoi := bm1.Height div 2;
dw := w mod 4;
GetDIBSizes(bm.Handle, InfoSize, ImageSize);
GetMem(p, ImageSize);
GetMem(bi, InfoSize);
GetDIB(bm.Handle, 0, bi^, p^);
for y := 0 to bm1.Height - 1 do
begin
line := bm1.ScanLine[y];
for x := 0 to bm1.Width - 1 do
begin
r := sqrt(sqr(x - xoi) + sqr(y - yoi));
SinCos(a*Pi/180 + arctan2((y - yoi), (x - xoi)), s, c);
if (Round(xo + r * c) >= bm.Width) or (Round(yo + r * s) >= bm.Height) or
(Round(xo + r * c) < 0) or (Round(yo + r * s) < 0)
then
with line^[x] do
begin
rgbtRed := 255;
rgbtGreen := 255;
rgbtBlue := 255;
end
else
begin
with PRGBTriple(integer(p) + (h - Round(yo + r * s) - 1) * (3 * w + dw) + Round(xo + r * c) * 3)^ do
begin
rr := rgbtRed;
gg := rgbtGreen;
bb := rgbtBlue;
end;
with line^[x] do
begin
rgbtRed := rr;
rgbtGreen := gg;
rgbtBlue := bb;
end;
end;
end;
end;
Form1.Canvas.Draw(0, 0, bm1);
FreeMem(p, ImageSize);
FreeMem(bi, InfoSize);
bm.Destroy;
bm1.Destroy;
end;
Как объединить два BitMap-а в один
Важной деталью, здесь, является создание bitmap-а неограниченного размера.
Первым делом необходимо расчитать размер будущей картинки, затем создать ее,
а потом нарисовать на ней нужное и вывести ее.
var
Scr: Pointer;
procedure BitmapSize(var bitmap: TBitmap; aSX, aSY: Integer);
var
BInfo: tagBITMAPINFO;
begin
BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER);
BInfo.bmiHeader.biWidth := aSX;
BInfo.bmiHeader.biHeight := -aSY;
BInfo.bmiHeader.biPlanes := 1;
BInfo.bmiHeader.biBitCount := 32;
BInfo.bmiHeader.biCompression := BI_RGB;
Bitmap.Handle := CreateDIBSection(GetDC(0), BInfo, DIB_RGB_COLORS, Scr, 0, 0);
ZeroMemory(Scr, aSX * aSY * 4);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
bm, bm1, bm2: TBitmap;
maxy: Integer;
begin
bm1 := TBitmap.Create;
bm1.LoadFromFile('c:\1.bmp');
bm1.PixelFormat := pf24bit;
bm2 := TBitmap.Create;
bm2.LoadFromFile('c:\2.bmp');
bm2.PixelFormat := pf24bit;
bm := TBitmap.Create;
if bm1.Height > bm2.Height then maxy := bm1.Height
else maxy := bm2.Height;
BitmapSize(bm, bm1.Width + bm2.Width, maxy);
bm.Canvas.Draw(0, 0, bm1);
bm.Canvas.Draw(bm1.Width, 0, bm2);
Canvas.Draw(0, 0, bm1);
Canvas.Draw(bm1.Width + 5, 0, bm2);
Canvas.Draw(0, maxy + 5, bm);
bm.Free;
bm1.Free;
bm2.Free;
end;
Как качественно уменьшить картинку
// качественно, но медленно
procedure CreateBitMapXxX(BDesk, BSouces: TBitmap; SizeX, SizeY: Integer);
var
x, y: Integer;
begin
BDesk.PixelFormat := BSouces.PixelFormat;
BDesk.Width := SizeX + 1;
BDesk.Height := SizeY + 1;
for y := 0 to SizeY-1 do
for x := 0 to SizeX-1 do
BDesk.Canvas.Pixels[x, y] := BSouces.Canvas.Pixels[Round(BSouces.Width / SizeX * x),
Round(BSouces.Height / SizeY * y)];
end;
// быстро, но плохое качество
procedure CreateBitMapXxX(BDesk, BSouces: TBitmap; SizeX, SizeY: Integer);
var
x, y: Integer;
begin
BDesk.PixelFormat := BSouces.PixelFormat;
BDesk.Width := SizeX + 1;
BDesk.Height := SizeY + 1;
Windows.StretchBlt(BDesk.Canvas.Handle, 0, 0, SizeX, SizeY,
BSouces.Canvas.Handle, 0, 0,
BSouces.Canvas.ClipRect.Right,
BSouces.Canvas.ClipRect.Bottom, SRCCOPY);
end;
// быстро и качественно
procedure CreateBitMapXxX(BDesk, BSouces: TBitmap; SizeX, SizeY: Integer);
var
x, y: Integer;
pD, pS: PRGBTripleArray;
begin
BDesk.PixelFormat := BSouces.PixelFormat;
BDesk.Width := SizeX + 1;
BDesk.Height := SizeY + 1;
for y := 0 to SizeY-1 do
begin
pS := BSouces.ScanLine[Round(BSouces.Height / SizeY * y)];
pD := BDesk.ScanLine[y];
for x := 0 to SizeX-1 do
pD^[x] := pS[Round(BSouces.Width / SizeX * x)];
end;
end;
Как качественно увеличить картинку
Для ускорения работы воспользуйтесь вопросом "Быстрый способ получить цвет пиксела"
// увеличивает по х в dx раз, по y в dy раз.
procedure Interpolate(var bm: TBitMap; dx, dy: double);
var
bm1: TBitMap;
z1, z2: single;
k, k1, k2: single;
x1, y1: integer;
c: array [0..1, 0..1, 0..2] of byte;
res: array [0..2] of byte;
x, y: integer;
xp, yp: integer;
xo, yo: integer;
col: integer;
pix: TColor;
begin
bm1 := TBitMap.Create;
bm1.Width := round(bm.Width * dx);
bm1.Height := round(bm.Height * dy);
for y := 0 to bm1.Height - 1 do begin
for x := 0 to bm1.Width - 1 do begin
xo := trunc(x / dx);
yo := trunc(y / dy);
x1 := round(xo * dx);
y1 := round(yo * dy);
for yp := 0 to 1 do
for xp := 0 to 1 do begin
pix := bm.Canvas.Pixels[xo + xp, yo + yp];
c[xp, yp, 0] := GetRValue(pix);
c[xp, yp, 1] := GetGValue(pix);
c[xp, yp, 2] := GetBValue(pix);
end;
for col := 0 to 2 do begin
k1 := (c[1,0,col] - c[0,0,col]) / dx;
z1 := x * k1 + c[0,0,col] - x1 * k1;
k2 := (c[1,1,col] - c[0,1,col]) / dx;
z2 := x * k2 + c[0,1,col] - x1 * k2;
k := (z2 - z1) / dy;
res[col] := round(y * k + z1 - y1 * k);
end;
bm1.Canvas.Pixels[x,y] := RGB(res[0], res[1], res[2]);
end;
Form1.Caption := IntToStr(round(100 * y / bm1.Height)) + '%';
Application.ProcessMessages;
if Application.Terminated then Exit;
end;
bm := bm1;
end;
Написать в гостевую книгу