|
|
Графика
Раздел, посвященный графике. Содержит описание базовых приемов, которые пригодятся при решении практических задач
Внимание !! Сайт переехал - он теперь расположен
по адресу http://z-oleg.com/delphi, размещенные
там материалы переработаны и дополнены. На z-ol.chat.ru остается копия, однако
обновляться она больше не будет
|
 |
 |
|
Общие вопросы
| Как работать с палитрой в 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;
{ Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов)
и меняет его палитру при нажатии кнопки }
unit bmpformu;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TBmpForm = class(TForm)
Button1: TButton;
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
Bitmap: TBitmap;
procedure ScrambleBitmap;
procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;
end;
var
BmpForm: TBmpForm;
implementation
{$R *.DFM}
procedure TBmpForm.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('bor6.bmp');
end;
procedure TBmpForm.FormDestroy(Sender: TObject);
begin
Bitmap.Free;
end;
// since we're going to be painting the whole form, handling this
// message will suppress the uneccessary repainting of the background
// which can result in flicker.
procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);
begin
m.Result := LRESULT(False);
end;
procedure TBmpForm.FormPaint(Sender: TObject);
var x, y: Integer;
begin
y := 0;
while y < Height do begin
x := 0;
while x < Width do begin
Canvas.Draw(x, y, Bitmap);
x := x + Bitmap.Width;
end;
y := y + Bitmap.Height;
end;
end;
procedure TBmpForm.Button1Click(Sender: TObject);
begin
ScrambleBitmap; Invalidate;
end;
// scrambling the bitmap is easy when it's has 256 colors:
// we just need to change each of the color in the palette
// to some other value.
procedure TBmpForm.ScrambleBitmap;
var
pal: PLogPalette;
hpal: HPALETTE;
i: Integer;
begin
pal := nil;
try
GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
pal.palVersion := $300;
pal.palNumEntries := 256;
for i := 0 to 255 do
begin
pal.palPalEntry[i].peRed := Random(255);
pal.palPalEntry[i].peGreen := Random(255);
pal.palPalEntry[i].peBlue := Random(255);
end;
hpal := CreatePalette(pal^);
if hpal <> 0 then
Bitmap.Palette := hpal;
finally
FreeMem(pal);
end;
end;
end.
| Как заполнить Canvas рисунком с рабочего стола, учитывая координаты. |
* |
* |
|
Для заполнения Canvas рисунком с рабочего стола неоьходимо использовать
вызов API Function PaintDesktop(HDC) : boolean;
Например: PaintDesktop(form1.Canvas.Handle);
| Как изменить вид ListBox (вставить изображения, изменить шрифт отдельных элеметов и т.п.) ? |
* |
* |
|
Для вставки растровых изображений в ListBox необходимо установить в инспекторе
объектов поле Style равным lbOwnerDrawFixed (при фиксированной высоте строки),
или в lbOwnerDrawVariable (при переменной). Затем следует создать собственный
обработчик события для OnDrawItem. Этот обработчик вызывается всякий раз, когда
возникает необходимость в отрисовке элемента списка.
Обработчик имеет вид
ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: DrawState);
где Control - указатель на ListBox, вызвавший событие; Index - индекс элемента,
который необходимо отобразить; Rect - координатный прямоугольник, в котором следует
рисовать элемент; State - состояние элемента
Пример:
Рисуются изображения размером 32*16 (размер стандартной картинки для Delphi). Очень
полезно при поиске нужного изображения для кнопок!
Установить в инспекторе объектов для ListBox поле
ItemHeight = 19, а поле Color = clBtnFace.
// Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)
procedure TForm1.bLoadClick(Sender: TObject);
VAR S : String;
begin
ListBox1.Clear; // Очистка списка
S := '*.bmp'#0; // Определение шаблона
// Заполнение списка
ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1]));
end;
............
// Отобразжение Элемента списка
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: DrawState);
VAR
Bitmap : TBitmap; // Картинка
Offset : Integer;
BMPRect: TRect;
begin
WITH (Control AS TListBox).Canvas DO BEGIN
FillRect(Rect);
Bitmap := TBitmap.Create;
// Попытка загрузки картинки
Bitmap.LoadFromFile(ListBox1.Items[Index]);
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);
{ StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон}
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;
Данный пример работает медленно, но оптимизация, для ускорения, вызвала бы
трудность в понимании общего принципа его работы.
| Как из программы на Delphi рисовать в любой части экрана или в чужом окне? |
* |
* |
|
Для этого надо воспользоваться функциями API. Получить контекст чужого окна,
либо всего экрана можно при помощи функции function GetDC(Wnd: HWnd): HDC;
где Wnd - указатель на нужное окно, или 0 для получения контекста всего экрана.
Затем, получив контекст, можно приступить к рисованию посредством функций API
Пример:
PROCEDURE DrawOnScreen;
VAR ScreenDC: hDC;
BEGIN
ScreenDC := GetDC(0); // получить контекст экрана
Ellipse(ScreenDC, 0, 0, 200, 200); // Нарисовали круг
ReleaseDC(0,ScreenDC); // освободили контекст
END;
Не забывайте после своих манипуляций посылать пострадавшим (или всем) окнам
сообщение о необходимости перерисовки для восстановления их первоначального
вида.
| Написание текста под углом |
* |
* |
|
В Delphi можно достаточно просто выводить текст под любым углом, единственное
условие - применяемый шрифт должен быть TrueType
// Эта процедура устанавливает угол вывода текста для указанного Canvas,
// угол задается в градусах
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var LogRec: TLOGFONT; // Информация о шрифте
begin
// Читаем текущюю информацию о шрифте
GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
// Изменяем угол
LogRec.lfEscapement := round(d*10);
// Устанавливаем новые параметры
c.Font.Handle := CreateFontIndirect(LogRec);
end;
| Преобразование цвета RGB в HLS (оттенок,яркость,насыщенность) и наоборот |
* |
* |
|
{ Максимальные значения }
Const
HLSMAX = 240;
RGBMAX = 255;
UNDEFINED = (HLSMAX*2) div 3;
Var
H, L, S : integer; { H-оттенок, L-яркость, S-насыщенность }
R, G, B : integer; { цвета }
procedure RGBtoHLS;
Var
cMax,cMin : integer;
Rdelta,Gdelta,Bdelta : single;
Begin
cMax := max( max(R,G), B);
cMin := min( min(R,G), B);
L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );
if (cMax = cMin) then begin
S := 0; H := UNDEFINED;
end else begin
if (L <= (HLSMAX/2)) then
S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )
else
S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )
/ (2*RGBMAX-cMax-cMin) );
Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
if (R = cMax) then H := round(Bdelta - Gdelta)
else if (G = cMax) then H := round( (HLSMAX/3) + Rdelta - Bdelta)
else H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta );
if (H < 0) then H:=H + HLSMAX;
if (H > HLSMAX) then H:= H - HLSMAX;
end;
if S<0 then S:=0; if S>HLSMAX then S:=HLSMAX;
if L<0 then L:=0; if L>HLSMAX then L:=HLSMAX;
end;
procedure HLStoRGB;
Var
Magic1,Magic2 : single;
function HueToRGB(n1,n2,hue : single) : single;
begin
if (hue < 0) then hue := hue+HLSMAX;
if (hue > HLSMAX) then hue:=hue -HLSMAX;
if (hue < (HLSMAX/6)) then
result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
else
if (hue < (HLSMAX/2)) then result:=n2 else
if (hue < ((HLSMAX*2)/3)) then
result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
else result:= ( n1 );
end;
begin
if (S = 0) then begin
B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B;
end else begin
if (L <= (HLSMAX/2)) then Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
else Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;
Magic1 := 2*L-Magic2;
R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
end;
if R<0 then R:=0; if R>RGBMAX then R:=RGBMAX;
if G<0 then G:=0; if G>RGBMAX then G:=RGBMAX;
if B<0 then B:=0; if B>RGBMAX then B:=RGBMAX;
end;
| Как определить число цветов для текущих настроек экрана |
* |
* |
|
Определить число цветов для текущих настроек экрана достаточно просто при помощи
функции API GetDeviceCaps. Например, описанная ниже функция возвращает число бит
на точку у данного компьютера. Так, например, 8 - 8 бит (256 цветов), 4 - 4 бит
(16 цветов) и т.п. Напоминаю, что число цветов легко получить как 2^N, где N -
число бит на точку.
function GetDisplayColors : integer;
var tHDC : hdc;
begin
tHDC:=GetDC(0);
result:=GetDeviceCaps(tHDC, 12)* GetDeviceCaps(tHDC, 14);
ReleaseDC(0, tHDC);
end;
| Как скопировать экран (или часть экрана) ? |
* |
* |
|
Копирование экрана легко произвести при помощи функций API. Приведенная ниже
библиотека позволит упростить эту операцию
unit ScrnCap;
interface
uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;
// Копирует прямоугольную область экрана
function CaptureScreenRect(ARect : TRect) : TBitmap;
// Копирование всего экрана
function CaptureScreen : TBitmap;
// Копирование клиентской области формы или элемента
function CaptureClientImage(Control : TControl) : TBitmap;
// Копирование всей формы элемента
function CaptureControlImage(Control : TControl) : TBitmap;
implementation
// Получение системной палитры
function GetSystemPalette : HPalette;
var
PaletteSize : integer;
LogSize : integer;
LogPalette : PLogPalette;
DC : HDC;
Focus : HWND;
begin
result:=0;
Focus:=GetFocus;
DC:=GetDC(Focus);
try
PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
GetMem(LogPalette, LogSize);
try
with LogPalette^ do
begin
palVersion:=$0300;
palNumEntries:=PaletteSize;
GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
end;
result:=CreatePalette(LogPalette^);
finally
FreeMem(LogPalette, LogSize);
end;
finally
ReleaseDC(Focus, DC);
end;
end;
// Копирование прямоугольной области
function CaptureScreenRect(ARect : TRect) : TBitmap;
var
ScreenDC : HDC;
begin
Result:=TBitmap.Create;
with result, ARect do begin
Width:=Right-Left;
Height:=Bottom-Top;
ScreenDC:=GetDC(0);
try
BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );
finally
ReleaseDC(0, ScreenDC);
end;
Palette:=GetSystemPalette;
end;
end;
// Копирование всего экрана
function CaptureScreen : TBitmap;
begin
with Screen do
Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;
function CaptureClientImage(Control : TControl) : TBitmap;
begin
with Control, Control.ClientOrigin do
result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;
function CaptureControlImage(Control : TControl) : TBitmap;
begin
with Control do
if Parent=Nil then
result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
else
with Parent.ClientToScreen(Point(Left, Top)) do
result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.
| Отображение текста со стилем "disabled" (характерный серый контурный текст) |
* |
* |
|
{************************ Draw Disabled Text **************
***** This function draws text in "disabled" style. *****
***** i.e. the text is grayed . *****
**********************************************************}
function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
var Rect: TRect; Format: Word): Integer;
begin
SetBkMode(Canvas.Handle, TRANSPARENT);
OffsetRect(Rect, 1, 1);
Canvas.Font.color:= ClbtnHighlight;
DrawText (Canvas.Handle, Str, Count, Rect,Format);
Canvas.Font.Color:= ClbtnShadow;
OffsetRect(Rect, -1, -1);
DrawText (Canvas.Handle, Str, Count, Rect, Format);
end;
| Как изменять разрешение экрана во время выполнения программы |
* |
* |
|
// Переход в полноэкранный режим
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;
| Как поместить картинку из базы данных в компонент TIMAGE ? |
* |
* |
|
1) Предполагается, что поле имеет тип BLOB (например, с именем Pict)
2) в запросе Query.SQL пишется что-то вроде
'select Pict from sometable where somefield=somevalue'
3) запрос открывается
4) делается "присваивание":
Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))
или, если известно, что эта картинка - Bitmap, то можно
Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))
| Как установить произвольный цвет, зная его RGB |
* |
* |
|
Самый простой путь - присвоение значения свойству Color, которое представляет
собой значение LongInt, байты которого кодируют цвета в следующем порядке BGR.
Пример - установка красного цвета - Color := $0000FF. Причем обычно принято писать
незначащие нули - это упрощает чтение и понимание принципа кодирования
Если Вам понравился мой сайт, то Вы можете проголосовать за него на Golden URL (заранее спасибо)
Я советую посетить и другие сайты, посвященные программированию. Это легко сделать по кольцу:
Algorithm project
: Кольцо сайтов, посвященных
программированию (подробнее о
проекте WebRing...) [ Предыдущие 5 сайтов | Предыдуший | Следующий | Следующие 5 сайтов | Выбрать сайт случайным образом | Список всех сайтов ]
