Автор: Роман Василенко
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Создание курсора с процентом выполнения

Функция возвращает хэндл на созданный курсор Windows (hcursor, hicon)
с процентным соотношением, указанным в min,max и pos.
Своего рода ProgressBar, но только зашитый в курсор.

Зависимости: Windows, SysUtils, Graphics, Classes
Автор:       Роман Василенко, romix@nm.ru, Пятигорск
Copyright:   Василенко Роман
Дата:        07 мая 2002 г.
***************************************************** }

//Используемые модули
uses Windows, SysUtils, Graphics, Classes;

//Сама функция

function create_prc_cursor(min, max, pos: integer): hicon;
var
  cwidth, cheight: integer;
  ii: iconinfo;
  bmc, bmm: tbitmap;
  icon: hicon;
  tw: integer;
  tx: string;

  function int_percent(umin, umax, upos, uabs: integer): integer;
  begin
    result := 0;
    if umax < umin then
      exit;
    if upos < umin then
      exit;
    if upos > umax then
    begin
      result := 100;
      exit;
    end;
    if (umin = upos) and (umax = upos) then
    begin
      result := 100;
      exit;
    end;
    result := round((upos - umin) / ((umax - umin) / uabs));
  end;

  function create_curspace: tbitmap;
  begin
    result := tbitmap.create;
    result.pixelformat := pf4bit;
    result.width := cwidth;
    result.height := cheight;
  end;

begin
  cwidth := getsystemmetrics(sm_cxcursor);
  cheight := getsystemmetrics(sm_cycursor);
  bmc := create_curspace;
  bmm := create_curspace;
  with bmm.Canvas do
  begin
    brush.color := clwhite;
    FillRect(rect(0, 0, bmm.width, bmm.height));
    brush.color := clblack;
    fillrect(rect(0, bmm.height - 8, bmm.width, bmm.height));
    brush.color := clwhite;
    framerect(rect(0, bmm.height - 8, bmm.width, bmm.height));
  end;
  with bmc.canvas do
  begin
    brush.color := clblack;
    FillRect(rect(0, 0, bmc.width, bmc.height));
    brush.color := clwhite;
    fillrect(rect(1 + int_percent(min, max, pos, bmc.width - 2), bmm.height - 7,
      bmc.width - 1, bmc.height - 1));
    brush.color := clwhite;
    framerect(rect(0, bmc.height - 8, bmc.width, bmc.height));
  end;
  tx := inttostr(int_percent(min, max, pos, 100)) + '%';
  with bmm.canvas do
  begin
    font.Size := 8;
    font.style := [fsbold];
    font.color := clwhite;
    brush.color := clwhite;
    tw := textwidth(tx);
    textout((cwidth - tw) div 2, 8, tx);
  end;
  with bmc.canvas do
  begin
    font.Size := 8;
    font.style := [fsbold];
    font.color := clwhite;
    brush.color := clblack;
    textout((cwidth - tw) div 2, 8, tx);
  end;

  ii.fIcon := false;
  ii.hbmColor := bmc.Handle;
  ii.hbmMask := bmm.handle;
  ii.xHotspot := 0;
  ii.yHotspot := 0;
  icon := createiconindirect(ii);
  result := copyicon(icon);
  destroyicon(icon);
  bmc.free;
  bmm.Free;
end;

Пример использования:

...
screen.cursors[1] := create_prc_cursor(0, 100, 25);
screen.cursor := crnone;
screen.cursor := 1;
...