unit Progresses;
interface
uses
	Windows, Classes, StdCtrls, ComCtrls, Controls, Themes;

type
	TProgress = class(TComponent)
	private
		FLabel: TLabel;
		FProgress: TProgressBar;

		FMax: Longint;
		FPos: Longint;
		FBarMax,
		FBarPos: Integer;
		FVisible: Boolean;
		procedure SetProgressLabel(aValue: TLabel);
		procedure SetProgressBar(aValue: TProgressBar);
		procedure SetVisible(aValue: Boolean);
		procedure SetPos(aValue: Longint);
	public
		property Pos: Longint read FPos write SetPos;

		constructor Create(anOwner: TComponent); override;
		procedure Start(const aCaption: String; aMaxValue: Longint);
		procedure Next;
		procedure Finish;

	published
		property ProgressBar: TProgressBar read FProgress write SetProgressBar;
		property ProgressLabel: TLabel read FLabel write SetProgressLabel;
		property Visible: Boolean read FVisible write SetVisible;
		property Max: Integer read FMax;
	end;

	TStepByStepItemState = (sbsUnprocessed, sbsProcessing, sbsProcessed, sbsDisabled);
	TStepByStep = class(TGraphicControl)
	private
		FItems: TStringList;
		FProgress: TProgress;
		FStep: Integer;

		procedure SetItems(aValue: TStringList);
    function GetItemState(Index: Integer): TStepByStepItemState;
  protected

    function  GetParentBackground: Boolean;
    procedure SetParentBackground(const Value: Boolean);
		procedure SetItemState(anIndex: Integer; aState: TStepByStepItemState);

		procedure InvalidateItem(anIndex: Integer);
	public
		constructor Create(anOwner: TComponent); override;
		destructor Destroy; override;

		procedure Paint; override;

		procedure Reset;
		procedure Start(anIndex: Integer; const aCaption: String; aMaxValue: Longint); overload;
		procedure Start(const aCaption: String; aMaxValue: Longint); overload;
		procedure SetPos(aValue: Longint);
		procedure Next;
		procedure Finish;

 		function  GetItemRect(anIndex: Integer): TRect;

    property ItemState[Index: Integer]: TStepByStepItemState read GetItemState write SetItemState;
	published
    property Align;
    property Anchors;
    property Color;
    property Font;
    property ParentBackground: Boolean read GetParentBackground write SetParentBackground;

		property Step: Integer read FStep;
		property Items: TStringList read FItems write SetItems;
		property Progress: TProgress read FProgress write FProgress;
	end;


implementation
uses
	Forms, Graphics, SysUtils;

{	TProgress }

constructor TProgress.Create(anOwner: TComponent);
begin
	inherited Create(anOwner);
	FVisible := True;
end;

procedure TProgress.SetProgressLabel(aValue: TLabel);
begin
	FLabel := aValue;
	if Assigned(aValue) then
		aValue.Visible := FVisible;
end;

procedure TProgress.SetProgressBar(aValue: TProgressBar);
begin
	FProgress := aValue;
	if Assigned(aValue) then begin
		aValue.Max := FBarMax;
		aValue.Position := FBarPos;
		aValue.Visible := FVisible;
	end;
end;

procedure TProgress.Start(const aCaption: String; aMaxValue: Longint);
begin
	FMax := aMaxValue;
	FPos := 0;
	FBarMax := FProgress.Width;
	FBarPos := 0;
	if Assigned(FLabel) then
		FLabel.Caption := aCaption;
	if Assigned(FProgress) then begin
		FProgress.Position := 0;
		FProgress.Max := FBarMax;
	end;
	Application.ProcessMessages;
end;

procedure TProgress.SetPos(aValue: Longint);
var
	aBarPos: Integer;
begin
	FPos := aValue;
	if Assigned(FProgress) and (FMax > 0) then begin
		aBarPos := MulDiv(aValue, FBarMax, FMax);
		if aBarPos <> FBarPos then begin
			FBarPos := aBarPos;
			FProgress.Position := aBarPos;
			Application.ProcessMessages;
		end
	end;
end;

procedure TProgress.Next;
begin
	Pos := Pos + 1;
end;

procedure TProgress.Finish;
begin
	if Assigned(FProgress) then
		FProgress.Position := 0;
	Application.ProcessMessages;
end;

procedure TProgress.SetVisible(aValue: Boolean);
begin
	if aValue <> FVisible then begin
		FVisible := aValue;
		if Assigned(FLabel) then
			FLabel.Visible := aValue;
		if Assigned(FProgress) then
			FProgress.Visible := aValue;
	end;
end;

{	TStepByStep }

constructor TStepByStep.Create(anOwner: TComponent);
begin
	inherited Create(anOwner);
	FStep := -1;
	ControlStyle := ControlStyle + [csReplicatable];
	Width := 100;
	Height := 50;
	FItems := TStringList.Create;
end;

destructor TStepByStep.Destroy;
begin
	FItems.Free;
	inherited Destroy;
end;

procedure TStepByStep.SetItems(aValue: TStringList);
begin
	FItems.Assign(aValue);
	Invalidate;
end;

procedure TStepByStep.Reset;
begin
	SetItemState(-1, sbsUnprocessed);
	if Assigned(FProgress) then
		FProgress.SetPos(0);
end;

procedure TStepByStep.Start(anIndex: Integer; const aCaption: String; aMaxValue: Longint);
begin
	SetItemState(anIndex, sbsProcessing);
	FStep := anIndex;
	if Assigned(FProgress) then
		FProgress.Start(aCaption, aMaxValue);
end;

procedure TStepByStep.Start(const aCaption: String; aMaxValue: Longint);
begin
	if FStep >= 0 then
		Finish;
	Start(FStep + 1, aCaption, aMaxValue);
end;

procedure TStepByStep.SetPos(aValue: Longint);
begin
	if Assigned(FProgress) then
		FProgress.Pos := aValue;
end;

procedure TStepByStep.Next;
begin
	if Assigned(FProgress) then
		FProgress.Next;
end;

procedure TStepByStep.Finish;
begin
	SetItemState(FStep, sbsProcessed);
	if Assigned(FProgress) then
		FProgress.Finish;
end;

procedure TStepByStep.Paint;

type
	TStateFlags = set of (sfSign, sfCheckSign, sfGrayText, sfBoldText);

const
	StateFlags: array[TStepByStepItemState] of TStateFlags = (
		[], [sfSign, sfBoldText], [sfSign, sfCheckSign], [sfGrayText]);

	function UseParentBackGround: Boolean;
  begin
  	Result := ThemeServices.ThemesEnabled and
    	Assigned(Parent) and ParentBackground;
  end;

  procedure PaintItemState(const aRect: TRect; aFlags: TStateFlags);
  var
  	aSign: Char;
  begin
		if not (sfSign in aFlags) then
    	Exit;

		with Canvas do begin
			Font.Name := 'Marlett';
			Font.Size := Self.Font.Size;
			Font.Style := [];
			if sfCheckSign in aFlags then begin
				Font.Size := Font.Size + 2;
				aSign := 'a'
			end
			else
				aSign := '8';
			TextOut((aRect.Left + aRect.Bottom - aRect.Top - TextWidth(aSign)) div 2,
				(aRect.Top + aRect.Bottom - TextHeight(aSign)) div 2, aSign);
		end;
  end;

var
	aRect: TRect;
  aFlags: TStateFlags;
 	i: Integer;
begin
	try
		for i := 0 to FItems.Count - 1 do begin
			aRect := GetItemRect(i);

      aFlags := StateFlags[ItemState[i]];

			Canvas.Brush.Color := Color;
      if UseParentBackGround then
        Canvas.Brush.Style := bsClear;

      PaintItemState(aRect,	aFlags);

			Inc(aRect.Left, aRect.Bottom - aRect.Top);
			with Canvas do begin
				Font := Self.Font;
				if sfGrayText in aFlags then
					Font.Color := clGray;
				if sfBoldText in aFlags then
					Font.Style := [fsBold];
				TextOut(aRect.Left, (aRect.Top + aRect.Bottom - TextHeight(FItems[i])) div 2,
        	FItems[i]);
			end;
		end;
	except
		on e: Exception do
			MessageBox(0, PChar(e.Message), 'StepByStep', MB_OK);
	end;
end;

function TStepByStep.GetItemRect(anIndex: Integer): TRect;
var
	i: Integer;
begin
	Result.Left := 0;
	Result.Right := Width;
	Result.Top := 0;
	i := 0;
	repeat
		Result.Bottom := Result.Top + Canvas.TextHeight('>' + FItems[i]) + 4;
		if i < anIndex then
			Result.Top := Result.Bottom;
		Inc(i);
	until i > anIndex;
end;


procedure TStepByStep.InvalidateItem(anIndex: Integer);
var
	aR: TRect;
begin
	aR := GetItemRect(anIndex);
	OffsetRect(aR, Left, Top);
	InvalidateRect(Parent.Handle, @aR, True);
end;

procedure TStepByStep.SetItemState(anIndex: Integer; aState: TStepByStepItemState);
begin
	if anIndex = -1 then begin
		for anIndex := 0 to FItems.Count - 1 do begin
    	FItems.Objects[anIndex] := Pointer(aState);
    end;
    Invalidate;
  end
	else begin
		FItems.Objects[anIndex] := Pointer(aState);
		InvalidateItem(anIndex);
	end;
end;

function TStepByStep.GetItemState(Index: Integer): TStepByStepItemState;
begin
	Result := TStepByStepItemState(FItems.Objects[Index])
end;

function TStepByStep.GetParentBackground: Boolean;
begin
  Result := csParentBackground in ControlStyle;
end;

procedure TStepByStep.SetParentBackground(const Value: Boolean);
begin
  if ParentBackground <> Value then
  begin
    if Value then
      ControlStyle := ControlStyle + [csParentBackground]
    else
      ControlStyle := ControlStyle - [csParentBackground];
    Invalidate;
  end;
end;


end.
