Вопросы и ответы - Delphi - Работа с графикой и мультимедиа

Bitmap без формы

Как мне загрузить изображение (BMP) и отобразить это на рабочем столе без использования формы? (Я хочу отображать это из DLL).

Существует один способ сделать это: создать холст TCanvas, получить контекст устройства для рабочего стола и назначить его дескриптору холста. После рисования на холсте десктоп отобразит ваше творение. Вот пример:

Код

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;

Вы можете создать TBitmap и загрузить в него BMP-файл. Единственная гнустная вещь может произойти, если вы используете изображение с 256-цветной палитрой при работе в режиме с 256 цветами. Обойти это припятствие можно так: создать форму без границ и заголовка, установить ее высоту и ширину в ноль, поместить на нее компонент TImage и загрузить в него необходимое изображение. VCL реализует для вас нужную палитру.

TCanvas и освобождение дескрипторов

TCanvas автоматически ReleaseDC не вызывает. При создании холста с WindowDC в качестве дескриптора, лучшей идеей будет создание потомка TCanvas (моделированного с TControlCanvas):

Код

type
TWindowCanvas = class(TCanvas)
private
FWinControl: TWinControl;
FDeviceContext: HDC;
procedure SetWinControl(AControl: TWinControl);
protected
procedure CreateHandle; override;
public
destructor Destroy; override;
procedure FreeHandle;
property WinControl: TWinControl read FWinControl write SetWinControl;
end;

implementation

destructor TWindowCanvas.Destroy;
begin
FreeHandle;
inherited Destroy;
end;

procedure TWindowCanvas.CreateHandle;
begin
if FControl = nil then
inherited CreateHandle
else
begin
if FDeviceContext = 0 then
FDeviceContext := GetWindowDC(WinControl.Handle);
Handle := FDeviceContext;
end;
end;

procedure TControlCanvas.FreeHandle;
begin
if FDeviceContext <> 0 then
begin
Handle := 0;
ReleaseDC(WinControl.Handle, FDeviceContext);
FDeviceContext := 0;
end;
end;

procedure TControlCanvas.SetWinControl(AControl: TWinControl);
begin
if FWinControl <> AControl then
begin
FreeHandle;
FWinControl := AControl;
end;
end;

Очевидно, вы должны должны следить за ситуацией, и разрушать TWindowCanvas (или освобождать дескриптор) перед тем, как уничтожить элемент управления, связанный с ним. Также, имейте в виду, что дескриптор DeviceContext не освобождается автоматически после обработки каждого сообщения (как это происходит с дескрипторами TControlCanvas); для освобождения дескриптора вы должны явно вызвать FreeHandle (или разрушить Canvas). И, наконец, имейте в виду, что "WindowCanvas.Handle:= 0" не освобождает десктиптор, для его освобождения вы должны вызывать FreeHandle.

TImageList для рисования прозрачных картинок?

Следующий пример демонстрирует, динамическое создание компонента TImageList, используемого для рисования прозрачного битмапа.

Код

procedure TForm1.Button1Click(Sender: TObject);
var
bm : TBitmap;
il : TImageList;
begin
bm := TBitmap.Create;
bm.LoadFromFile('C:DownLoadTEST.BMP');
il := TImageList.CreateSize(bm.Width,
bm.Height);
il.DrawingStyle := dsTransparent;
il.Masked := true;
il.AddMasked(bm, clRed);
il.Draw(Form1.Canvas, 0, 0, 0);
bm.Free;
il.Free;
end;

TMetaFile – ошибка при работе с памятью

Для создания в памяти метафайла, я пытаюсь использовать TMetafile. Чтобы я ни делал, это не работает как надо. Я получаю метафайл или неверного размера, или без возможности масштабирования.

Я долго экспериментировал и пришел к выводу, что все эти ошибки возникают в случае, когда map mode (режим карты) использует не mm_Text. Я трассировал ошибку в TMetafile.SaveToClipboardFormat. Программа неверно использует значение по умолчанию TMetafileImage.FInch = 0. Я думаю что TMetafileImage должен иметь значение по умолчанию FInch = Screen.PixelsPerInch или программа, которая сохраняет его в буфере обмена, должна правильно использовать FInch = 0 (т.е. сделайте значение mm_Text)

Вставить Bitmap

Код

function InvertBmp1(SourceBmp: TBitmap): TBitMap;
var
i, j: Longint;
tmp: TBitMap;
red, green, blue: Byte;
PixelColor: Longint;
begin
tmp := TBitmap.Create;
tmp.Width := SourceBmp.Width;
tmp.Height := SourceBmp.Height;
for i := 0 to SourceBmp.Width - 1 do
begin
for j := 0 to SourceBmp.Height - 1 do
begin
PixelColor := ColorToRGB(SourceBmp.Canvas.Pixels[i, j]);
red := PixelColor;
green := PixelColor shr 8;
blue := PixelColor shr 16;
red := 255 - red;
green := 255 - green;
blue := 255 - blue;
tmp.Canvas.pixels[i, j] := (red shl 8 + green) shl 8 + blue;
end;
end;
Result := tmp;
end;

function InvertBmp2(ABitmap : TBitmap) : TBitmap;
var
l_bmp : TBitmap;
begin
l_bmp := TBitmap.Create;
l_bmp.Width := ABitmap.Width;
l_bmp.Height := ABitmap.Height;
l_bmp.PixelFormat := ABitmap.PixelFormat;
BitBlt( l_bmp.Canvas.Handle, 0, 0, l_bmp.Width, l_bmp.Height,
ABitmap.Canvas.Handle, 0, 0, SRCINVERT );
result := l_bmp;
end;

Вывод изображения по маске, используется MaskBlt

Код

procedure TForm1.Button1Click(Sender: TObject);
var
BitmapSrc, BitmapMask: TBitmap;
begin
BitmapSrc := TBitmap.Create;
try
BitmapMask := TBitmap.Create;
try
BitmapSrc.LoadFromFile('c:src.bmp');
BitmapMask.LoadFromFile('c:mask.bmp');
MaskBlt(Canvas.Handle, 0, 0, BitmapSrc.Width, BitmapSrc.Height,
BitmapSrc.Canvas.Handle, 0, 0, BitmapMask.Handle, 0, 0, MakeROP4(PATCOPY xor PATINVERT, SRCCOPY));
finally
BitmapMask.Free;
end;
finally
BitmapSrc.Free;
end;
end;

Вырезание эллиптической области на Bitmap

Код

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Вырезание эллиптической области на Bitmap

Овальная рамка для изображения.

Зависимости: Classes, Graphics
Автор: Fenik, chook_nu@uraltc.ru, Новоуральск
Copyright: Собственное написание (Николай федоровских)
Дата: 1 июня 2002 г.
***************************************************** }

procedure EllipticBitmap(Bitmap: TBitmap; BackColor: TColor);
type
TRGB = record
B, G, R: Byte;
end;
pRGB = ^TRGB;
var
C: TRGB;
x, y: Integer;
Dest, Src: pRGB;
Bmp: TBitmap;
begin
Bitmap.PixelFormat := pf24Bit;
C.R := Lo(BackColor);
C.G := Lo(BackColor shr 8);
C.B := Lo((BackColor shr 8) shr 8);
//создаём дополнительный Bitmap
Bmp := TBitmap.Create;
try
Bmp.Width := Bitmap.Width;
Bmp.Height := Bitmap.Height;
Bmp.PixelFormat := Bitmap.PixelFormat;
//рисуем на созданном Bitmap чёрный эллипс на белом фоне
with Bmp.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clWhite;
FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
Brush.Color := clBlack;
Pen.Style := psClear;
Ellipse(Rect(0, 0, Bmp.Width, Bmp.Height));
end;
for y := 0 to Bitmap.Height - 1 do
begin
Src := Bmp.ScanLine[y];
Dest := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do
begin
//если точка (x, y) на созданном Bitmap белая,
//то точку (x, y) на исходном Bitmap закрашиваем BackColor
if Src^.r = 255 then
Dest^ := C;
Inc(Dest);
Inc(Src);
end;
end;
finally
Bmp.Free;
end;
end;
Пример использования:
EllipticBitmap(FBitmap, clWhite);

Двигаем крестик для показа значений X/Y

Код

// TPanel, TImage e TLabel components
// Insert Image into Panel...

private
BmpH, BmpV : TBitmap;
OldX, OldY: Integer;
end;

var
RectSaved : boolean = false;

procedure TFormMain.FormCreate(Sender: TObject);
begin
PanelImage.DoubleBuffered := true; // This prevents that the image is blinking
LabelHint.Transparent := true;
LabelHint.Font.Color := clNave;
end;

procedure TFormMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Cross(X, Y);
end;

procedure TFormMain.Cross(X, Y: Integer);
begin
Image.Canvas.Pen.Color := clBlack;
// Restore last image to erase line
if RectSaved then
begin
Image.Canvas.CopyRect(Rect(OldX - 5, 0, OldX + 5, BmpV.Height),
BmpV.Canvas, Rect(0,0,BmpV.Width,BmpV.Height));
Image.Canvas.CopyRect(Rect(0, OldY - 5, BmpH.Width, OldY + 5),
BmpH.Canvas, Rect(0,0,BmpH.Width,BmpH.Height));
BmpH.Free;
BmpV.Free;
end;
// Now save the image at new position for each line
// horizontal line
BmpH := TBitmap.Create;
BmpH.Width := Image.Width;
BmpH.Height := 10;
BmpH.Canvas.CopyRect(Rect(0,0,BmpH.Width,BmpH.Height),
Image.Canvas,Rect(0, Y - 5, BmpH.Width, Y + 5));
// Vertical line
BmpV := TBitmap.Create;
BmpV.Width := 10;
BmpV.Height := Image.Height;
BmpV.Canvas.CopyRect(Rect(0,0,BmpV.Width,BmpV.Height),
Image.Canvas,Rect(X - 5, 0, X + 5, BmpV.Height));

// Now draw the current position
Image.Canvas.MoveTo(0, Y);
Image.Canvas.LineTo(Image.Width, Y);
Image.Canvas.MoveTo(X, 0);
Image.Canvas.LineTo(X, Image.Height);

RectSaved := true;
OldX := X;
OldY := Y;

LabelHint.Left := X + 36;
LabelHint.Top := Y - 15;
LabelHint.Caption := '(X:' + IntToStr(X) + ' x Y:' + IntToStr(Y) +')';
end;

Движение окружности

Код

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;

type
TForm1 = class(TForm)
Timer1: TTimer;
procedure FormActivate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
x, y: byte; // координаты центра окружности
dx: byte; // приращение координаты x при движении окружности

implementation

{$R *.dfm}

procedure TForm1.FormActivate(Sender: TObject);
begin
x := 0;
y := 10;
dx := 5;
timer1.Interval := 50; // период возникновения события OnTimer - 0.5 сек
form1.canvas.brush.color := form1.color;
end;

procedure Ris;
begin
// стереть окружность
form1.Canvas.Pen.Color := form1.Color;
form1.Canvas.Ellipse(x, y, x + 10, y + 10);

x := x + dx;

// нарисовать окружность на новом месте
form1.Canvas.Pen.Color := clBlack;
form1.Canvas.Ellipse(x, y, x + 10, y + 10);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Ris;
end;

end.

Загрузка 256-цветного TBitmap

Windows не очень полезен, когда мы имеем дело с 256-цветными изображениями. Что делаю я (поскольку думаю, что это самый простой метод): я создаю в памяти изображение таким образом, чтобы TBitmap.LoadFromStream мог "принять" его. Данным методом я загружаю "сырой" ресурс изображения и размещаю его, используя инфорационный заголовок файла изображения. Вот потомок TBitmap, инкапсулирующий вышесказанное:

Код

type
TMyBitmap = class(TBitmap)
public
procedure Load256ColorBitmap(Instance: THandle; BitmapName: PChar);
end;

procedure TMyBitmap.Load256ColorBitmap(Instance: THandle;
BitmapName: PChar);
var
HDib: THandle;
Size: LongInt;
Info: PBitmapInfo;
FileHeader: TBitmapFileHeader;
S: TMemoryStream;
begin
HDib := LoadResource(Instance, FindResource(Instance, BitmapName,
RT_BITMAP));
if HDib <> 0 then
begin
Info := LockResource(HDib);
Size := GetSelectorLimit(Seg(Info^)) + SizeOf(TBitmapFileHeader);
with FileHeader do
begin
bfType := $4D42;
bfSize := Size;
bfReserved1 := 0;
bfReserved2 := 0;
bfOffBits := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader);
case Info^.bmiHeader.biBitCount of
1: bfOffBits := bfOffBits + 2 * 4;
4: bfOffBits := bfOffBits + 16 * 4;
8: bfOffBits := bfOffBits + 256 * 4;
end;
end;
S := TMemoryStream.Create;
try
S.SetSize(Size);
S.Write(FileHeader, SizeOf(TBitmapFileHeader));
S.Write(Info^, Size - SizeOf(TBitmapFileHeader));
S.Position := 0;
LoadFromStream(S);
finally
S.Free;
FreeResource(HDib);
end;
end
else
raise EResNotFound.Create(Format('Не могу найти ресурс изображения %s',
[BitmapName]));
end;

Вот как можно это использовать:

Код

Image1.Picture.Bitmap := TMyBitmap.Create;
TMyBitmap(Image1.Picture.Bitmap).Load256ColorBitmap(hInstance, 'BITMAP_1');

Загрузка bitmap из .res без потери палитры

Код

procedure loadgraphic(naam:string);
var
HResInfo: THandle;
BMF: TBitmapFileHeader;
MemHandle: THandle;
Stream: TMemoryStream;
ResPtr: PByte;
ResSize: Longint;
null:array [0..8] of char;
begin
strpcopy (null, naam);
HResInfo := FindResource(HInstance, null, RT_Bitmap);
ResSize := SizeofResource(HInstance, HResInfo);
MemHandle := LoadResource(HInstance, HResInfo);
ResPtr := LockResource(MemHandle);
Stream := TMemoryStream.Create;
try
Stream.SetSize(ResSize + SizeOf(BMF));
BMF.bfType := $4D42;
Stream.write(BMF, SizeOf(BMF));
Stream.write(ResPtr^, ResSize);
Stream.Seek(0, 0);
Bitmap:=tbitmap.create;
Bitmap.LoadFromStream(Stream);
finally
Stream.Free;
end;
FreeResource(MemHandle);
end;

Загрузка JPEG из ресурсов

Код

uses Jpeg;
{$R test.res}

function LoadJpegRes(const ID: string): TJpegImage;
var
RS: TResourceStream;
begin
Result := TJpegImage.Create;
RS := TResourceStream.Create(HInstance, ID, RT_RCDATA);
try
RS.Seek(0, soBeginning);
Result.LoadFromStream(RS);
finally
RS.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
MyJpeg: TJpegImage;
begin
MyJpeg := LoadJpegRes('MYJPEG');
Image1.Canvas.Draw(0, 0, MyJpeg);
end;

Для JPEG, загнанного в ресурсы таким образом:

Код

MYJPEG RCDATA "Test.jpg"

Заполняем Canvas рисунком с рабочего стола

Function PaintDesktop(HDC) : boolean;

Например: PaintDesktop(form1.Canvas.Handle);

Информация о BMP-файлах

Код

{
This tip show, how to get the filesize, width, height, bitcount and color used
from a bitmap.

Dieses Beispiel zeigt, wie man Dateigrosse, breite, hohe, Farbtiefe und Farbanzahl
von einem Bitmap ausliest.
}

procedure TForm1.Button1Click(Sender: TObject);
var
fileheader: TBitmapfileheader;
infoheader: TBitmapinfoheader;
s: TFilestream;
begin
s := TFileStream.Create('c:YourBitmap.bmp', fmOpenRead);
try
s.Read(fileheader, SizeOf(fileheader));
s.Read(infoheader, SizeOf(infoheader));
finally
s.Free;
end;
listbox1.Items.Clear;
listbox1.Items.Add('Filesize: ' + IntToStr(fileheader.bfSize));
listbox1.Items.Add('Width: ' + IntToStr(infoheader.biWidth));
listbox1.Items.Add('Height: ' + IntToStr(infoheader.biHeight));
listbox1.Items.Add('BitCount: ' + IntToStr(infoheader.biBitCount));
listbox1.Items.Add('Used: ' + IntToStr(infoheader.biClrUsed));
end;

{
BitCount:
1 = black/white
4 = 16 colors
8 = 256 colors
}

Как быстро выводить графику?

Как быстро выводить графику (a то Canvas очень медленно работает)

Вот пример заполнения формы точками случайного цвета:

Код

type
TRGB = record
b, g, r: byte;
end;
ARGB = array[0..1] of TRGB;
PARGB = ^ARGB;

var
b: TBitMap;

procedure TForm1.FormCreate(sender: TObject);
begin
b := TBitMap.Create;
b.pixelformat := pf24bit;
b.width := Clientwidth;
b.height := Clientheight;
end;

procedure TForm1.Tim1OnTimer(sender: TObject);
var
p: PARGB;
x, y: integer;
begin
for y := 0 to b.height - 1 do
begin
p := b.scanline[y];
for x := 0 to b.width - 1 do
begin
p[x].r := random(256);
p[x].g := random(256);
p[x].b := random(256);
end;
end;
canvas.draw(0, 0, b);
end;

procedure TForm1.FormDestroy(sender: TObject);
begin
b.free;
end;

Как временно отключить перерисовку окна?

Вызовите функцию WinAPI LockWindowUpdate передав ей дескриптор окна, которое необходимо не обновлять. Передайте ноль в качестве параметра для восстановления нормального обновления.

Код

LockWindowUpdate(Memo1.Handle);
...

LockWindowUpdate(0);

Как очистить Canvas?

Есть два хороших способа очистить Canvas. Их скорости очень близки. В первом способе используются возможности Delphi, во втором – WinAPI. Первый способ удобнее тем, что позволяет закрашивать Canvas любым цветом.

Код

procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Canvas.Brush.Color := clRed;
Form1.Canvas.FillRect(Form1.ClientRect);
PatBlt(Form1.Canvas.Handle, 0, 0,
Form1.ClientWidth, Form1.ClientHeight, WHITENESS);
end;

Как показать и сохранить в базе картинку формата JPEG

Код

if Picture.Graphic is TJPegImage then
begin
bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
Picture.Graphic.SaveToStream(bs);
bs.Free;
end
else
if Picture.Graphic is TBitmap then
begin
Jpg:=TJPegImage.Create;
Jpg.CompressionQuality:=...;
Jpg.PixelFormat:=...;
Jpg.Assign(Picture.Graphic);
Jpg.JPEGNeeded;
bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
Jpg.SaveToStream(bs);
bs.Free;
Jpg.Free;
end
else
Field.Clear;

Как получить доступ к объекту метафайла?

Код

Как получить размер GIF-картинки?

Код

type
TImageSize = record
Width: Integer;
Height: Integer;
end;

function ReadGIFSize(Stream: TStream): TImageSize;
type
TGifHeader = record
Signature: array [0..5] of Char;
Width, Height: Word;
end;
var
Header: TGifHeader;
begin
FillChar(Header, SizeOf(TGifHeader), #0);
Result.Width := -1;
Result.Height := -1;
with Stream do
begin
Seek(0, soFromBeginning);
ReadBuffer(Header, SizeOf(TGifHeader));
end;
if (AnsiUpperCase(Header.Signature) = 'GIF89A') or
(AnsiUpperCase(Header.Signature) = 'GIF87A') then
begin
Result.Width := Header.Width;
Result.Height := Header.Height;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
FileName = 'D:test.gif';
var
fs: TFileStream;
gifsize: TImageSize;
begin
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
gifsize := ReadGIFSize(fs);
ShowMessage(Format('Breite %d Hцhe %d', [gifsize.Width, gifsize.Height]));
finally
fs.Free;
end;
end;

Печать страницы

Вопросы и ответы - Delphi - Работа с графикой и мультимедиа

Всего 48 на 3 страницах по 20 на каждой странице