GDI FAQ
Copyright © 2001, 2002 Мироводин
Дмитрий
Мне вы можете присылать свои вопросы/ответы
для добавления в этот раздел.
Как менять разрешение экрана по ходу выполнения программы
Отображение картинок в TListBox
Отображение строки повёрнутой под любым углом
Как быстро очистить TCanvas ?
Установка обоев (Wallpaper) в Windows
Вывод изображения с прозрачным цветом (Transparent)
Работа с палитрой BMP файла
Адрес автора FAQ
Q.Как менять разрешение экрана по ходу выполнения программы
A: Функция SetFullscreenMode устанавливает разрешение 640x480x16 bit,
а RestoreDefaultMode - возвращает исходное.
function SetFullscreenMode:Boolean;
var DeviceMode : TDevMode;
begin
with DeviceMode do
begin
dmSize:=SizeOf(DeviceMode);
dmBitsPerPel:=16;
dmPelsWidth:=640;
dmPelsHeight:=480;
dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
result:=False;
if ChangeDisplaySettings(DeviceMode, CDS_TEST or CDS_FULLSCREEN)
<> DISP_CHANGE_SUCCESSFUL then Exit;
Result:=ChangeDisplaySettings(DeviceMode,CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL;
end;
end;
procedure RestoreDefaultMode;
var T : TDevMode absolute 0;
begin
ChangeDisplaySettings(T,CDS_FULLSCREEN);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if setFullScreenMode then
begin
sleep(7000);
RestoreDefaultMode;
end;
end; |
Исходный код примера можно скачать по ссылке
Q. Отображение картинок в TListBox
A: Для отрисовки картинки (TBitmap) в качестве элемента Listbox.Items
нужно переписать событие OnDrawItem и в свойстве Style поставить lbOwnerDrawFixed.
При замене события, мы получаем доступ к номеру элемента и область занимаемую
им : Index: Integer; Rect: TRect и Canvas от TControl.
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;Rect:
TRect; State: TOwnerDrawState);
VAR
Bitmap : TBitmap;
Offset : Integer;
BMPRect : TRect;
begin
With (Control As TListBox).Canvas do
begin
FillRect(Rect);
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('bmp_file_name.bmp');
Offset := 0;
IF Bitmap <> nil then
Begin
BMPRect := Bounds(Rect.Left+2, Rect.Top+2,(Rect.Bottom-Rect.Top-2)*2,
Rect.Bottom-Rect.Top-2);
BrushCopy(BMPRect,Bitmap, Bounds(0,
0, Bitmap.Width, Bitmap.Height),
Bitmap.Canvas.Pixels[0, Bitmap.Height-1]);
Offset := (Rect.Bottom-Rect.Top+1)*2;
end;
TextOut(Rect.Left+Offset, Rect.Top, ListBox1.Items[Index]);
Bitmap.Free;
end;
end; |
А вот еще один простой пример, с помошью него можно выводить четные и нечетные
строки разным шрифтом:
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
With (Control As TListBox).Canvas do
Begin
FillRect(Rect);
if Odd(Index) then Font.Color:=clred else
Font.Color:=clblack;
TextOut(Rect.Left,Rect.Top,ListBox1.Items[Index]);
end;
end; |
Q. Отображение строки повёрнутой под любым углом
A: Стандартные средства Delphi не позволяют использовать вывод строки
текста под произвольным углом, так как в модуле Graphics оля отвечающие за угол
поворота строки принудительно обнуляются. Это приводит к необходимости использовать
средства API. Наверное, лучший способ - это исправить модуль Graphics и разрешить
использование произвольного угла поворота во всех объектах сразу. Но такой путь
потребует перекомпиляции нескольких модулей и приведет к некорректной работе ваших
кодов с другими версиями Delphi. Другой способ - написать процедуру вывода под
углом и пользоваться ею при необходимости. Чтобы не нарушать существующий порядок
вывода строки на экран, будем следовать следующим правилам:
a.Все параметры шрифта, кроме угла - брать из объекта Font;
b.Рисовать в контексте Canvas.
PROCEDURE FreeTextOut(Canvas: TCanvas; X, Y, A: Integer; S: String);
var
OldFont, NewFont: hFont;
lf : TLogFont;
begin
// Создаем описание для нового шрифта.
WITH lf, Canvas DO
BEGIN
// Устанавливаем текущие для объекта
Font параметры, кроме углов.
lfHeight := Font.Height;
lfWidth := 0;
lfEscapement := A*10; // Угол наклона
строки в 0.1 градуса
lfOrientation := A*10; // Угол наклона
символов в строке в 0.1 градуса
if fsBold in Font.Style then lfWeight :=
FW_BOLD else lfWeight := FW_NORMAL;
lfItalic := Byte(fsItalic in Font.Style);
lfUnderline := Byte(fsUnderline in Font.Style);
lfStrikeOut := Byte(fsStrikeOut in Font.Style);
lfCharSet := DEFAULT_CHARSET;
StrPCopy(lfFaceName, Font.Name);
lfQuality := DEFAULT_QUALITY;
lfOutPrecision := OUT_DEFAULT_PRECIS;
lfClipPrecision := CLIP_DEFAULT_PRECIS;
lfPitchAndFamily := DEFAULT_PITCH;
end;
// Создаем новый шрифт
NewFont := CreateFontIndirect(lf);
// Выбираем новый шрифт в контекст отображения
OldFont := SelectObject(Canvas.Handle, NewFont);
// Выводим текст на экран ПОД ЗАДАННЫМ УГЛОМ
Canvas.TextOut(X, Y, S);
// Восстанавливаем в контексте старый шрифт
SelectObject(Canvas.Handle, OldFont);
// Удаляем новый шрифт
DeleteObject(NewFont);
end; |
Созданную процедуру лучше всего оформить в виде модуля. Процедура работает
аналогично процедуре TextOut, единственное - ей необходимо явно передавать контекст
отображения:
procedure FreeTextOut(Canvas: TCanvas; X, Y, A: Integer; S: String);
где:
Canvas - контекст (канва) отображения;
X, Y - соответствующие координаты;
A - угол поворота строки (в углах);
S - выводимая строка
FreeTextOut(Canvas, 100, 100, 45, 'Пример вывода под углом');
P.S. Поворачивать можно только векторные и масштабируемые (True Type) шрифты.
А шрифт System, используемый Delphi по умолчанию - растровый! Поэтому, в отображаемой
экранной форме выберите свойство Font и установите необходимый True Type Font.
Q. Как быстро очистить TCanvas?
A: Используйте фукцию Windows API - PatBlt()
procedure TForm1.Button1Click(Sender: TObject);
begin
PatBlt(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight,
WHITENESS);
end; |
Q. Установка обоев (Wallpaper) в Windows
A: В качестве обоев устанавливается файл, путь к которому указан в sWallpaperBMPPath.
В зависимости от значения bTitle, изображение помещается либо в центр экрана,
либо размещается мозаикой.
procedure SetWallpaper(sWallpaperBMPPath : String;bTile : boolean
);
var reg : TRegIniFile;
begin
reg := TRegIniFile.Create('Control Panel\Desktop');
with reg do
begin
WriteString( '', 'Wallpaper', sWallpaperBMPPath);
if( bTile ) then WriteString('', 'TileWallpaper',
'1')
else WriteString('', 'TileWallpaper', '0');
end;
reg.Free;
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end; |
Q. Как вывести изображение с прозрачным цветом (Transparent)
A: Самый простой способ использование TImageList из стандартного набора
VCL компонентов.
TImageList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
Первый параметр - это Bitmap,
второй Transparent Color - цвет прозрачности.После загрузки всех картинок, можно
приступать к их выводу на экран. Для этого существует процедура:
procedure TImageList.Draw(Canvas: TCanvas; X, Y, Index: Integer); |
Более сложный способ, это самому создать маску:
function Min(X1, X2: integer): integer;
begin
if X1 < X2 then Result := X1
else Result := X2;
end;
function Max(X1, X2: integer): integer;
begin
if X1 > X2 then Result := X1
else Result := X2;
end;
procedure DrawTransparentBitmapRect (DC: HDC; Bitmap: HBitmap; xStart, yStart,
Width, Height: Integer; Rect: TRect; TransparentColor: TColorRef);
var
BM: Windows.TBitmap;
cColor: TColorRef;
bmAndBack, bmAndObject, bmAndMem, bmSave: HBitmap;
bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBitmap;
hdcMem, hdcBack, hdcObject, hdcTemp, hdcSave: HDC;
ptSize, ptRealSize, ptBitSize, ptOrigin: TPoint;
begin
hdcTemp := CreateCompatibleDC(DC); SelectObject(hdcTemp, Bitmap);
GetObject(Bitmap, SizeOf(BM), @BM);
ptRealSize.x := Min(Rect.Right - Rect.Left, BM.bmWidth - Rect.Left);
ptRealSize.y := Min(Rect.Bottom - Rect.Top, BM.bmHeight -
Rect.Top); DPtoLP(hdcTemp, ptRealSize, 1); ptOrigin.x := Rect.Left;
ptOrigin.y := Rect.Top;
DPtoLP(hdcTemp, ptOrigin, 1);
ptBitSize.x := BM.bmWidth;
ptBitSize.y := BM.bmHeight
DPtoLP(hdcTemp, ptBitSize, 1);
if (ptRealSize.x = 0) or (ptRealSize.y = 0) then
begin
ptSize := ptBitSize;
ptRealSize := ptSize;
end
else ptSize := ptRealSize;
if (Width = 0) or (Height = 0) then
begin
Width := ptSize.x;
Height := ptSize.y;
end;
hdcBack := CreateCompatibleDC(DC);
hdcObject := CreateCompatibleDC(DC);
hdcMem := CreateCompatibleDC(DC);
hdcSave := CreateCompatibleDC(DC);
bmAndBack := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
bmAndMem := CreateCompatibleBitmap(DC, Max(ptSize.x, Width), Max(ptSize.y,
Height));
bmSave := CreateCompatibleBitmap(DC, ptBitSize.x, ptBitSize.y);
bmBackOld := SelectObject(hdcBack, bmAndBack);
bmObjectOld := SelectObject(hdcObject, bmAndObject);
bmMemOld := SelectObject(hdcMem, bmAndMem);
bmSaveOld := SelectObject(hdcSave, bmSave);
SetMapMode(hdcTemp, GetMapMode(DC));
BitBlt(hdcSave, 0, 0, ptBitSize.x, ptBitSize.y, hdcTemp, 0, 0, SRCCOPY);
cColor := SetBkColor(hdcTemp, TransparentColor);
BitBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, ptOrigin.x, ptOrigin.y,
SRCCOPY);
SetBkColor(hdcTemp, cColor);
BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);
BitBlt(hdcMem, 0, 0, Width, Height, DC, xStart, yStart, SRCCOPY);
StretchBlt(hdcMem, 0, 0, Width, Height, hdcObject, 0, 0, ptSize.x,
ptSize.y, SRCAND);
BitBlt(hdcTemp, ptOrigin.x, ptOrigin.y, ptSize.x, ptSize.y, hdcBack,
0, 0, SRCAND);
StretchBlt(hdcMem, 0, 0, Width, Height, hdcTemp, ptOrigin.x, ptOrigin.y,
ptSize.x, ptSize.y, SRCPAINT);
BitBlt(DC, xStart, yStart, Max(ptRealSize.x, Width), Max(ptRealSize.y,
Height), hdcMem, 0, 0, SRCCOPY);
BitBlt(hdcTemp, 0, 0, ptBitSize.x, ptBitSize.y, hdcSave, 0, 0, SRCCOPY);
DeleteObject(SelectObject(hdcBack, bmBackOld));
DeleteObject(SelectObject(hdcObject, bmObjectOld));
DeleteObject(SelectObject(hdcMem, bmMemOld));
DeleteObject(SelectObject(hdcSave, bmSaveOld));
{ Delete the memory DCs }
DeleteDC(hdcMem);
DeleteDC(hdcBack);
DeleteDC(hdcObject);
DeleteDC(hdcSave);
DeleteDC(hdcTemp);
end; |
Вызов данной процедуры выглядит следующим образом:
var
BMP:TBitmap;
Rect:TRect;
...
begin
BMP:=TBitmap.Create;
BMP.LoadFromFile('filename.bmp');
// можно опустить, если не собираетесь менять
размера изображения.
Rect:=BMP.Canvas.ClipRect;
...
// действия с Rect
...
DrawTransparentBitmapRect(Form1.Canvas.Handle,
BMP.Handle,
0,0,BMP.Width,BMP.Height,
Rect,
ClBlack); |
Процедура работает достаточно медленно. Оптимизировать можно, если не нужно
растягивать/сжимать изображение, это несколько увеличит быстродействие.
P.S. если у Вас есть другие способы вывода избражений с прозрачным цветом,
то большая просьба прислать их, я уверен, что есть либо более изящные способы
сделать это.
Q. Работа с палитрой BMP файла
Как работать с палитрой в Delphi? На форме установлен TImage и видна картинка
(*.BMP файл), как изменить у него палитру цветов ?
Палитра в TBitmap и TMetaFile доступна через property Palette. Если палитра
имеется (что совсем необязательно), то Palette<>0:
procedure TMain.BitBtnClick(Sender: TObject);
var
Palette : HPalette;
PaletteSize : Integer;
LogSize: Integer;
LogPalette: PLogPalette;
Red : Byte;
begin
Palette := Image.Picture.Bitmap.ReleasePalette;
// здесь можно использовать просто Image.Picture.Bitmap.Palette,
но я не
// знаю, удаляются ли ненужные палитры автоматически
if Palette=0 then exit; //Палитра отсутствует
PaletteSize := 0;
if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then
Exit;
// Количество элементов в палитре = paletteSize
if PaletteSize = 0 then Exit; // палитра
пустая
// определение размера палитры
LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);
GetMem(LogPalette, LogSize);
try
// заполнение полей логической палитры
with LogPalette^ do begin
palVersion := $0300; palNumEntries := PaletteSize;
GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
// делаете что нужно с палитрой, например:
Red := palPalEntry[PaletteSize-1].peRed;
Edit1.Text := 'Красная составляющего последнего элемента палитры ='+
IntToStr(Red);
palPalEntry[PaletteSize-1].peRed := 0;
//.......................................
end;
// завершение работы
Image.Picture.Bitmap.Palette := CreatePalette(LogPalette^);
finally
FreeMem(LogPalette, LogSize);
// я должен позаботиться сам об удалении Released
Palette
DeleteObject(Palette);
end;
end |
Мне вы можете присылать свои вопросы/ответы для добавления
в этот раздел.
|
