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

Добро пожаловать,

Регистрация или входРегистрация или вход
Потеряли пароль?Потеряли пароль?

Ник:
Пароль:

Меню сайта




Ваше мнение
Оцените дизайн сайта

Супер
Симпатично
Пойдет
Ничего хорошего
Просто клиника


Результаты
Другие опросы

Всего голосов: 851
Комментарии: 2


Наши партнеры



Статистика




Programming books  Download software  Documentation  Scripts  Content Managment Systems(CMS)  Templates  Icon Sets  Articles  Contacts  Voting  Site Search




Вопросы и ответы - 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;

Как получить доступ к объекту метафайла?
Код
function MyEnhMetaFileProc(DC: HDC; {handle to device context}
lpHTable: PHANDLETABLE; {pointer to metafile handle table}
lpEMFR: PENHMETARECORD; {pointer to metafile record}
nObj: integer; {count of objects}
TheForm: TForm1): integer; stdcall;
begin
{draw the metafile record}
PlayEnhMetaFileRecord(dc, lpHTable^, lpEMFR^, nObj);
{set to zero to stop metafile enumeration}
result := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
MyMetafile: TMetafile;
lpENHMETAHEADER: PENHMETAHEADER; {extra metafile info}
lpENHMETAHEADERSIZE: DWORD;
NumMetaRecords: DWORD;
begin
{Create a metafile}
MyMetafile := TMetafile.Create;
with TMetafileCanvas.Create(MyMetafile, 0) do
try
Brush.Color := clRed;
Ellipse(0, 0, 100, 100);
Ellipse(100, 100, 200, 200);
Ellipse(200, 200, 300, 300);
Ellipse(300, 300, 400, 400);
Ellipse(400, 400, 500, 500);
Ellipse(500, 500, 600, 600);
finally
Free;
end;
{we might as well get some extra metafile info}
lpENHMETAHEADERSIZE := GetEnhMetaFileHeader(MyMetafile.Handle, 0, nil);
NumMetaRecords := 0;
if (lpENHMETAHEADERSIZE > 0) then
begin
GetMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
GetEnhMetaFileHeader(MyMetafile.Handle, lpENHMETAHEADERSIZE, lpENHMETAHEADER);
{Here is an example of getting number of metafile records}
NumMetaRecords := lpENHMETAHEADER^.nRecords;
{enumerate the records}
EnumEnhMetaFile(Canvas.Handle, MyMetafile.Handle, @MyEnhMetaFileProc, self,
Rect(0, 0, 600, 600));
FreeMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
end;
MyMetafile.Free;
end;
Как получить размер 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;


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




Внимание! Если у вас не получилось найти нужную информацию, используйте рубрикатор или воспользуйтесь поиском


.



книги по программированию исходники компоненты шаблоны сайтов C++ PHP Delphi скачать