Delphi World - Создание курсора с процентом выполнения
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Создание курсора с процентом выполнения

Автор: Роман Василенко
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;
...
Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования