Виртуальная библиотека Delphi - [13]

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 рисунком с рабочего стола, учитывая координаты.

Function PaintDesktop(HDC) : boolean;

Например:

PaintDesktop(form1.Canvas.Handle);

Как вставить растровое изображение в компонент ListBox?

Для этого необходимо установить в инспекторе объектов поле 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;

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

Можно ли из 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;

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

Написание текста под углом

{ Эта процедура устанавливает угол вывода текста для указанного 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;

Преобразование цвета 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