Recent

Author Topic: Special Progressbar  (Read 4357 times)

seghele0

  • Full Member
  • ***
  • Posts: 106
Special Progressbar
« on: November 22, 2021, 03:16:49 pm »
Code: [Select]
unit ALProgressBar;

{$MODE Delphi}

interface

uses
  LCLIntf, LCLType, SysUtils, Classes, Graphics, Controls;

type
  TProgressDirection = (pdLeftToRight, pdRightToLeft, pdBottomToTop, pdTopToBottom);
  TBarColorStyle = (cs1Color, cs2Colors, cs3Colors);

  TALProgressBar = class(TGraphicControl)
  private
    MainBitmap: TBitmap;
    fBorderColor1: TColor;
    fBorderColor2: TColor;
    fBackgroundColor: TColor;
    fPosition: Integer;
    fBarBitmap: TBitmap;
    fMin: Integer;
    fMax: Integer;
    fShowBorder: Boolean;
    fDirection: TProgressDirection;
    fShowPosText: Boolean;
    fPosTextSuffix: String;
    fPosTextPrefix: String;
    fBarColorStyle: TBarColorStyle;
    fBarColor1: TColor;
    fBarColor2: TColor;
    fBarColor3: TColor;
    RegenerateBitmap: Boolean;
    TiledBarBitmap: TBitmap;
    fPercentage: Boolean;
    procedure PaintBorder;
    procedure PaintPosText;
    procedure SetBorderColor1(const Value: TColor);
    procedure SetBorderColor2(const Value: TColor);
    procedure SetBarBitmap(const Value: TBitmap);
    procedure SetBackgroundColor(const Value: TColor);
    procedure SetPosition(const Value: Integer);
    procedure SetMax(const Value: Integer);
    procedure SetMin(const Value: Integer);
    procedure SetShowBorder(const Value: Boolean);
    procedure PaintBar(RegenerateBitmap: Boolean);
    procedure TileBitmap(TiledBitmap: TBitmap; var DestBitmap: TBitmap);
    procedure SetDirection(const Value: TProgressDirection);
    procedure SetBarColor1(const Value: TColor);
    procedure SetBarColor2(const Value: TColor);
    procedure SetBarColor3(const Value: TColor);
    procedure SetShowPosText(const Value: Boolean);
    procedure SetPosTextSuffix(const Value: String);
    procedure SetPosTextPrefix(const Value: String);
    function CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
    procedure SetBarColorStyle(const Value: TBarColorStyle);
    procedure DrawColorBlending;
    procedure SetPercentage(const Value: Boolean);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BackgroundColor: TColor        read fBackgroundColor       write SetBackgroundColor      default clBtnFace;
    property BarBitmap: TBitmap             read fBarBitmap             write SetBarBitmap;
    property BarColor1: TColor              read fBarColor1             write SetBarColor1            default clGreen;
    property BarColor2: TColor              read fBarColor2             write SetBarColor2            default clYellow;
    property BarColor3: TColor              read fBarColor3             write SetBarColor3            default clRed;
    property BarColorStyle: TBarColorStyle  read fBarColorStyle         write SetBarColorStyle        default cs3Colors;
    property BorderColor1: TColor           read fBorderColor1          write SetBorderColor1         default clBtnShadow;
    property BorderColor2: TColor           read fBorderColor2          write SetBorderColor2         default clBtnHighlight;
    property Direction: TProgressDirection  read fDirection             write SetDirection            default pdLeftToRight;
    property Max: Integer                   read fMax                   write SetMax                  default 100;
    property Min: Integer                   read fMin                   write SetMin                  default 0;
    property Percentage: Boolean            read fPercentage            write SetPercentage           default False;
    property Position: Integer              read fPosition              write SetPosition             default 0;
    property PosTextPrefix: String          read fPosTextPrefix         write SetPosTextPrefix;
    property PosTextSuffix: String          read fPosTextSuffix         write SetPosTextSuffix;
    property ShowBorder: Boolean            read fShowBorder            write SetShowBorder           default True;
    property ShowPosText: Boolean           read fShowPosText           write SetShowPosText          default True;
    property Align;
    property Font;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('ALComps', [TALProgressBar]);
end;

{ TALProgressBar }

constructor TALProgressBar.Create(AOwner: TComponent);
begin
  inherited;
  Width := 200;
  Height := 20;
  fBorderColor1 := clBtnShadow;
  fBorderColor2 := clBtnHighLight;
  fBackgroundColor := clBtnFace;
  fBarBitmap := TBitmap.Create;
  fBarColor1 := clGreen;
  fBarColor2 := clYellow;
  fBarColor3 := clRed;
  fBarColorStyle := cs3Colors;
  fPosition := 0;
  fMin := 0;
  fMax := 100;
  fShowBorder := True;
  fDirection := pdLeftToRight;
  fShowPosText := True;
  fPosTextSuffix := '';
  fPosTextPrefix := '';
  fPercentage := False;
  RegenerateBitmap := True;
  MainBitmap := TBitmap.Create;
  TiledBarBitmap := TBitmap.Create;
end;

destructor TALProgressBar.Destroy;
begin
  MainBitmap.Free;
  fBarBitmap.Free;
  TiledBarBitmap.Free;
  inherited;
end;

procedure TALProgressBar.Paint;
begin
  inherited;
  MainBitmap.Width := Width;
  MainBitmap.Height := Height;
  if not(csReading in ComponentState) then PaintBar(RegenerateBitmap);
  if fShowBorder then PaintBorder;
  if fShowPosText then PaintPosText;
  Canvas.Draw(0, 0, MainBitmap);
end;

procedure TALProgressBar.PaintBar(RegenerateBitmap: Boolean);
var
  BarLength, BarPixelLength, EmptySpaceLength: Integer;
  AreaTop, AreaBottom, AreaLeft, AreaRight: Integer;
begin
  if (fBarBitmap <> nil) and not fBarBitmap.Empty then
  begin
    if RegenerateBitmap then
    begin
      TiledBarBitmap.Height := Height;
      TiledBarBitmap.Width := Width;
      TileBitmap(fBarBitmap, TiledBarBitmap);
    end;
    MainBitmap.Canvas.Draw(0, 0, TiledBarBitmap);
  end
  else if fBarColorStyle = cs1Color then
  begin
    MainBitmap.Canvas.Brush.Color := fBarColor1;
    MainBitmap.Canvas.FillRect(Rect(0, 0, Width, Height));
  end
  else if fBarColorStyle in [cs2Colors, cs3Colors] then
  begin
    if RegenerateBitmap then
    begin
      TiledBarBitmap.Height := Height;
      TiledBarBitmap.Width := Width;
      DrawColorBlending;
    end;
    MainBitmap.Canvas.Draw(0, 0, TiledBarBitmap);
  end;
  if (fDirection = pdLeftToRight) or (fDirection = pdRightToLeft) then
  begin
    if fShowBorder then
      BarPixelLength := Width - 2
    else
      BarPixelLength := Width;
  end
  else
  begin
    if fShowBorder then
      BarPixelLength := Height - 2
    else
      BarPixelLength := Height;
  end;
  if fShowBorder then
  begin
    AreaTop := 1;
    AreaLeft := 1;
    AreaBottom := Height - 1;
    AreaRight := Width - 1;
  end
  else
  begin
    AreaTop := 0;
    AreaLeft := 0;
    AreaBottom := Height;
    AreaRight := Width;
  end;
  if (fPosition > Min) and (fMax-fMin <> 0) then
    BarLength := Round(((fPosition-fMin) / Abs(fMax-fMin)) * BarPixelLength)
  else
    BarLength := 0;
  EmptySpaceLength := BarPixelLength - BarLength;
  MainBitmap.Canvas.Brush.Color := fBackgroundColor;
  if fDirection = pdLeftToRight then
    MainBitmap.Canvas.FillRect(Rect(AreaRight-EmptySpaceLength, AreaTop, AreaRight,
          AreaBottom))
  else if fDirection = pdRightToLeft then
    MainBitmap.Canvas.FillRect(Rect(AreaLeft, AreaTop, AreaLeft+EmptySpaceLength,
          AreaBottom))
  else if fDirection = pdTopToBottom then
    MainBitmap.Canvas.FillRect(Rect(AreaLeft, AreaBottom-EmptySpaceLength,
          AreaRight, AreaBottom))
  else if fDirection = pdBottomToTop then
    MainBitmap.Canvas.FillRect(Rect(AreaLeft, AreaTop, AreaRight,
          AreaTop+EmptySpaceLength));
end;

procedure TALProgressBar.DrawColorBlending;
var
  IndexCount, MaxWidth, MaxHeight, StartPoint: Integer;
  FirstColor, SecondColor: TColor;
begin
  if fBarColorStyle = cs2Colors then
  begin
    MaxWidth := TiledBarBitmap.Width;
    MaxHeight := TiledBarBitmap.Height;
  end
  else
  begin
    MaxWidth := TiledBarBitmap.Width div 2;
    MaxHeight := TiledBarBitmap.Height div 2;
  end;

  StartPoint := 1;
  if fDirection in [pdLeftToRight, pdRightToLeft] then
  begin
    if fDirection = pdLeftToRight then
    begin
      FirstColor := fBarColor1;
      SecondColor := fBarColor2;
    end
    else
    begin
      if fBarColorStyle = cs2Colors then
      begin
        FirstColor := fBarColor2;
        SecondColor := fBarColor1;
      end
      else
      begin
        FirstColor := fBarColor3;
        SecondColor := fBarColor2;
      end;
    end;
    for IndexCount := StartPoint to MaxWidth do
    begin
      TiledBarBitmap.Canvas.Pen.Color := CalcColorIndex(FirstColor, SecondColor,
             MaxWidth, IndexCount);
      TiledBarBitmap.Canvas.MoveTo(IndexCount-1, 0);
      TiledBarBitmap.Canvas.LineTo(IndexCount-1, TiledBarBitmap.Height);
    end;
    if fBarColorStyle = cs3Colors then
    begin
      if fDirection = pdLeftToRight then
      begin
        FirstColor := fBarColor2;
        SecondColor := fBarColor3;
      end
      else
      begin
        FirstColor := fBarColor2;
        SecondColor := fBarColor1;
      end;
      for IndexCount := MaxWidth+1 to TiledBarBitmap.Width do
      begin
        TiledBarBitmap.Canvas.Pen.Color := CalcColorIndex(FirstColor, SecondColor,
                   TiledBarBitmap.Width-MaxWidth, IndexCount-MaxWidth);
        TiledBarBitmap.Canvas.MoveTo(IndexCount-1, 0);
        TiledBarBitmap.Canvas.LineTo(IndexCount-1, TiledBarBitmap.Height);
      end;
    end;
  end
  else {if fDirection in [pdTopToBottom, pdBottomToTop] then}
  begin
    if fDirection = pdTopToBottom then
    begin
      FirstColor := fBarColor1;
      SecondColor := fBarColor2;
    end
    else
    begin
      if fBarColorStyle = cs2Colors then
      begin
        FirstColor := fBarColor2;
        SecondColor := fBarColor1;
      end
      else
      begin
        FirstColor := fBarColor3;
        SecondColor := fBarColor2;
      end;
    end;
    for IndexCount := StartPoint to MaxHeight do
    begin
      TiledBarBitmap.Canvas.Pen.Color := CalcColorIndex(FirstColor, SecondColor,
               MaxHeight, IndexCount);
      TiledBarBitmap.Canvas.MoveTo(0, IndexCount-1);
      TiledBarBitmap.Canvas.LineTo(TiledBarBitmap.Width, IndexCount-1);
    end;
    if fBarColorStyle = cs3Colors then
    begin
      if fDirection = pdTopToBottom then
      begin
        FirstColor := fBarColor2;
        SecondColor := fBarColor3;
      end
      else
      begin
        FirstColor := fBarColor2;
        SecondColor := fBarColor1;
      end;
      for IndexCount := MaxHeight+1 to TiledBarBitmap.Height do
      begin
        TiledBarBitmap.Canvas.Pen.Color := CalcColorIndex(FirstColor, SecondColor,     
               TiledBarBitmap.Height-MaxHeight, IndexCount-MaxHeight);
        TiledBarBitmap.Canvas.MoveTo(0, IndexCount-1);
        TiledBarBitmap.Canvas.LineTo(TiledBarBitmap.Width, IndexCount-1);
      end;
    end;
  end
end;

procedure TALProgressBar.TileBitmap(TiledBitmap: TBitmap; var DestBitmap: TBitmap);
var
  NoOfImagesX, NoOfImagesY, ix, iy, XPos, YPos: Integer;
begin
  NoOfImagesX := (Width div TiledBitmap.Width) + 1;
  NoOfImagesY := (Height div TiledBitmap.Height) + 1;
  XPos := 0;
  YPos := 0;
  for iy := 1 to NoOfImagesY do
  begin
    for ix := 1 to NoOfImagesX do
    begin
      DestBitmap.Canvas.Draw(XPos, YPos, TiledBitmap);
      XPos := XPos + TiledBitmap.Width;
    end;
    YPos := YPos + TiledBitmap.Height;
    XPos := 0;
  end;
end;

procedure TALProgressBar.PaintPosText;
var
  Text: String;
  TextPosX, TextPosY: Integer;
begin
  if not fPercentage then
    Text := fPosTextPrefix + IntToStr(fPosition) + fPosTextSuffix
  else
    Text := fPosTextPrefix + IntToStr(Round((fPosition / fMax) * 100)) + fPosTextSuffix;
  TextPosX := (Width div 2) - (MainBitmap.Canvas.TextWidth(Text) div 2);
  TextPosY := (Height div 2) - (MainBitmap.Canvas.TextHeight(Text) div 2);
  MainBitmap.Canvas.Brush.Style := bsClear;
  MainBitmap.Canvas.TextOut(TextPosX, TextPosY, Text);
end;

procedure TALProgressBar.PaintBorder;
begin
  with MainBitmap.Canvas do
  begin
    Pen.Color := fBorderColor1;
    MoveTo(Width-1, 0);
    LineTo(0, 0);
    LineTo(0, Height);
    Pen.Color := fBorderColor2;
    MoveTo(1, Height-1);
    LineTo(Width-1, Height-1);
    LineTo(Width-1, 0);
  end;
end;

function TALProgressBar.CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
var
  BeginRGBValue: Array[0..2] of Byte;
  RGBDifference: Array[0..2] of Integer;
  Red, Green, Blue: Byte;
  NumColors: Integer;
begin
  if (ColorIndex < 1) or (ColorIndex > Steps) then
    raise ERangeError.Create('ColorIndex can''t be less than 1 or greater than ' + IntToStr(Steps));
  NumColors := Steps;
  Dec(ColorIndex);
  BeginRGBValue[0] := GetRValue(ColorToRGB(StartColor));
  BeginRGBValue[1] := GetGValue(ColorToRGB(StartColor));
  BeginRGBValue[2] := GetBValue(ColorToRGB(StartColor));
  RGBDifference[0] := GetRValue(ColorToRGB(EndColor)) - BeginRGBValue[0];
  RGBDifference[1] := GetGValue(ColorToRGB(EndColor)) - BeginRGBValue[1];
  RGBDifference[2] := GetBValue(ColorToRGB(EndColor)) - BeginRGBValue[2];
  // Calculate the bands color
  Red := BeginRGBValue[0] + MulDiv(ColorIndex, RGBDifference[0], NumColors - 1);
  Green := BeginRGBValue[1] + MulDiv(ColorIndex, RGBDifference[1], NumColors - 1);
  Blue := BeginRGBValue[2] + MulDiv(ColorIndex, RGBDifference[2], NumColors - 1);
  Result := RGB(Red, Green, Blue);
end;

procedure TALProgressBar.SetBarBitmap(const Value: TBitmap);
begin
  fBarBitmap.Assign(Value);
  Paint;
end;

procedure TALProgressBar.SetBackgroundColor(const Value: TColor);
begin
  fBackgroundColor := Value;
  Paint;
end;

procedure TALProgressBar.SetBorderColor1(const Value: TColor);
begin
  fBorderColor1 := Value;
  Paint;
end;

procedure TALProgressBar.SetBorderColor2(const Value: TColor);
begin
  fBorderColor2 := Value;
  Paint;
end;

procedure TALProgressBar.SetPosition(const Value: Integer);
begin
  if (fPosition <> Value) and (Value <= fMax) and (Value >= fMin) then
  begin
    fPosition := Value;
    RegenerateBitmap := False;
    Paint;
    RegenerateBitmap := True;
  end;
end;

procedure TALProgressBar.SetMax(const Value: Integer);
begin
  fMax := Value;
  Paint;
end;

procedure TALProgressBar.SetMin(const Value: Integer);
begin
  fMin := Value;
  Paint;
end;

procedure TALProgressBar.SetShowBorder(const Value: Boolean);
begin
  fShowBorder := Value;
  Paint;
end;

procedure TALProgressBar.SetDirection(const Value: TProgressDirection);
begin
  fDirection := Value;
  Paint;
end;

procedure TALProgressBar.SetBarColor1(const Value: TColor);
begin
  fBarColor1 := Value;
  Paint;
end;

procedure TALProgressBar.SetBarColor2(const Value: TColor);
begin
  fBarColor2 := Value;
  Paint;
end;

procedure TALProgressBar.SetBarColor3(const Value: TColor);
begin
  fBarColor3 := Value;
  Paint;
end;

procedure TALProgressBar.SetShowPosText(const Value: Boolean);
begin
  fShowPosText := Value;
  Paint;
end;

procedure TALProgressBar.SetPosTextSuffix(const Value: String);
begin
  fPosTextSuffix := Value;
  Paint;
end;

procedure TALProgressBar.SetPosTextPrefix(const Value: String);
begin
  fPosTextPrefix := Value;
  Paint;
end;

procedure TALProgressBar.SetBarColorStyle(const Value: TBarColorStyle);
begin
  fBarColorStyle := Value;
  Paint;
end;

procedure TALProgressBar.SetPercentage(const Value: Boolean);
begin
  fPercentage := Value;
  Paint;
end;
end.

I was able to obtain this component via Google
The component net "ALProgressBar" works perfectly in my program with Lazarus.
In the progress bar, a number appears with an addition, from 1 to 100.
Is it possible to put a "%" (percent sign) after this number?
Can you indicate where and how?
Thanks already.


Zvoni

  • Hero Member
  • *****
  • Posts: 842
Re: Special Progressbar
« Reply #1 on: November 22, 2021, 03:24:41 pm »
My money is on "PosTextSuffix"-Property, maybe in combination with the "Percentage"-Property.
Both should be available in Object Inspector (since published props)
« Last Edit: November 22, 2021, 03:27:20 pm by Zvoni »
One System to rule them all, One Code to find them,
One IDE to bring them all, and to the Framework bind them,
in the Land of Redmond, where the Windows lie
---------------------------------------------------------------------
Code is like a joke: If you have to explain it, it's bad

seghele0

  • Full Member
  • ***
  • Posts: 106
Re: Special Progressbar
« Reply #2 on: November 22, 2021, 03:38:21 pm »
 :(
Can I hope for clear information via code?
This unit (unit ALProgressBar.pas) is not a visible component.

Alextp

  • Hero Member
  • *****
  • Posts: 1572
    • UVviewsoft
Re: Special Progressbar
« Reply #3 on: November 22, 2021, 04:44:20 pm »
You may be interested in https://wiki.freepascal.org/ATGauge

seghele0

  • Full Member
  • ***
  • Posts: 106
Re: Special Progressbar
« Reply #4 on: November 22, 2021, 05:14:36 pm »
Thanks.
I'll try to make it work.
Will keep you informed.... within a few days.
 ;)

Bart

  • Hero Member
  • *****
  • Posts: 4611
    • Bart en Mariska's Webstek
Re: Special Progressbar
« Reply #5 on: November 22, 2021, 06:56:56 pm »
Setting property Percentage to True should be enough (is my guess after a quick reading of the code that paints the text).

Bart

Zvoni

  • Hero Member
  • *****
  • Posts: 842
Re: Special Progressbar
« Reply #6 on: November 22, 2021, 10:45:55 pm »
Setting property Percentage to True should be enough (is my guess after a quick reading of the code that paints the text).

Bart
Close. Percentage just calculates the value differently. You need the Suffix to append the %-sign
Percentage false paints absolute position/value (e.g. 357 of 1000 max).
Percentage true calculates the percentage (decimal 0 to 1 multiplied with 100)
« Last Edit: November 22, 2021, 10:50:21 pm by Zvoni »
One System to rule them all, One Code to find them,
One IDE to bring them all, and to the Framework bind them,
in the Land of Redmond, where the Windows lie
---------------------------------------------------------------------
Code is like a joke: If you have to explain it, it's bad

Bart

  • Hero Member
  • *****
  • Posts: 4611
    • Bart en Mariska's Webstek
Re: Special Progressbar
« Reply #7 on: November 22, 2021, 10:59:14 pm »

Zvoni

  • Hero Member
  • *****
  • Posts: 842
Re: Special Progressbar
« Reply #8 on: November 23, 2021, 08:32:19 am »
This unit (unit ALProgressBar.pas) is not a visible component.

Code: Pascal  [Select][+][-]
  1. implementation
  2.  
  3. procedure Register;
  4. begin
  5.   RegisterComponents('ALComps', [TALProgressBar]);
  6. end;
How do you figure that? You should have a components-tab called "ALComps"
One System to rule them all, One Code to find them,
One IDE to bring them all, and to the Framework bind them,
in the Land of Redmond, where the Windows lie
---------------------------------------------------------------------
Code is like a joke: If you have to explain it, it's bad

BSaidus

  • Sr. Member
  • ****
  • Posts: 406
  • lazarus 1.8.4 Win8.1 / cross FreeBSD
Re: Special Progressbar
« Reply #9 on: November 23, 2021, 09:06:15 am »
do in the code
Code: Pascal  [Select][+][-]
  1. procedure TForm1.Button1Click(Sender: TObject);
  2. var
  3.   I: Integer;
  4. begin
  5.   with TALProgressBar.Create(Application) do
  6.   begin
  7.     Parent := self;
  8.  
  9.     Left := 36;
  10.     Top := 54;
  11.     //Position := 65;
  12.     Percentage := true;
  13.     ShowBorder := false;
  14.     Max := 100;
  15.     PosTextSuffix := ' %';
  16.     for I := 0 to 99 do
  17.       begin
  18.         Position := I+1;
  19.         Application.ProcessMessages;
  20.         Sleep(100);
  21.       end;
  22.  
  23.   end;
  24. end;
  25.  
  26.  

Or set the property like this in object inspector:

Code: Pascal  [Select][+][-]
  1.     PosTextSuffix := ' %';
  2.  
lazarus 1.8.4 Win8.1 / cross FreeBSD
dhukmucmur vernadh!

seghele0

  • Full Member
  • ***
  • Posts: 106
Re: Special Progressbar
« Reply #10 on: November 23, 2021, 11:27:32 am »
Code: Pascal  [Select][+][-]
  1. Percentage := true;
  2. PosTextSuffix := ' %';
  3.  
This works.  :)
THANK YOU ALL.
 ;)

 

TinyPortal © 2005-2018