Создание курсора с процентом выполнения

Материал из DRKB

Создание курсора с процентом выполнения[править | править код]

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

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

Зависимости: Windows, SysUtils, Graphics, Classes

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;


Author: Роман Василенко, romix@nm.ru, Пятигорск
ID: 02333