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
paclass="underline" PLogPalette;
hpaclass="underline" 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(Controclass="underline" 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);