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

(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);

ReleaseDC(0, tHDC);

end;

unit ScrnCap;

interface

uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;

{ Копирует прямоугольную область экрана }

function CaptureScreenRect(ARect : TRect) : TBitmap;

{ Копирование всего экрана }

function CaptureScreen : TBitmap;

{ Копирование клиентской области формы или элемента }

function CaptureClientImage(Control : TControl) : TBitmap;