Виртуальная библиотека Delphi

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.

Function PaintDesktop(HDC) : boolean;

Например:

PaintDesktop(form1.Canvas.Handle);

Для этого необходимо установить в инспекторе объектов поле Style в lbOwnerDrawFixed, при фиксированной высоте строки, или в lbOwnerDrawVariable, при переменной, и установить собственный обработчик события для OnDrawItem. В этом обработчике и надо рисовать растровое изображение.

Пример:

Рисуются изображения размером 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;

............

{Отобразить изображения и имена файлов в ListBox}

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;

Данный пример работает медленно, но оптимизация, для ускорения, вызвала бы трудность в понимании общего принципа его работы.

Для этого надо воспользоваться функциями 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;

Не забывайте после своих манипуляций посылать пострадавшим (или всем) окнам сообщение о необходимости перерисовки, для восстановления их первоначального вида.

{ Эта процедура устанавливает угол вывода текста для указанного Canvas, угол в градусах }

{ Шрифт должен быть TrueType ! }

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;

{ Максимальные значения }

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;

Эта функция возвращает число бит на точку у данного компьютера. Так, например, 8 — 256 цветов, 4 — 16 цветов ...

function GetDisplayColors : integer;

var tHDC : hdc;

begin

tHDC:=GetDC(0);

result:=GetDeviceCaps(tHDC, 12)* GetDeviceCaps(tHDC, 14);