I am converting a 30+ year old Turbo Pascal program to FireMonkey. One of the things that appears to have no equivalent is the SOUND command. I found elsewhere on StackOverflow that it can be replaced with the Windows beep (in VCL), but I need a solution that works for FireMonkey on Android. My program displays lyrics along with each sound, so I can't just record the sound and play MP3 files. I also want to maintain that clunky one-note 8-bit sound of the SOUND command in Turbo Pascal. The main command is Sound(Round(Frequency)). Any idea how to mimic that in FireMonkey? Here is the original code for playing each note, in case it helps:
procedure Playnote(speed,Octave,Note,Duration: integer);
var
Frequency : real;
I : integer;
begin
if note = 0 then sleep(speed*duration) // was "delay" in Turboo Pascal
else begin
Frequency := 32.625;
for I := 1 to Octave do Frequency := Frequency * 2;
for I := 1 to Note - 1 do Frequency := Frequency * 1.059463094;
if Duration <> 0 then begin
if soundon then Sound(Round(Frequency));
sleep(speed*Duration); // was "delay" in Turboo Pascal
NoSound;
end
else if soundon then Sound(Round(Frequency));
end;
end; {end PLAYNOTE }
For a little more background, it's a text adventure game. There is a saloon with a jukebox. Playing songs on the jukebox gives you clues from the lyrics, which display as the song plays.
Related
I'm quite new to programming and I can't get a function to calculate properly. It is a compound interest calculator that uses this formula:
I = P ( 1 + i )n — P (p= principal i= interest n= years) Rate := to interest value.
On pascal my function looks like this,
function Compoundinterest(principal, years: integer; rate: double): double;
var
divrate: double;
interest: Double;
begin
divrate := rate/100;
interest := principal * power(1 + divrate, years) - Principal;
result := interest;
end;
It compiles fine but just wont return the right value.
for example 1000 principal, 15% interest over 3 years returns this : 1.52087500000000E+000.
I assume I'm doing something wrong in the formula?
Thanks for your help in advance.
In pascal, a function returns what it's name has been set to within the function. For example:
function set_one(): integer;
begin
set_one := 1
end;
In your function, you should replace
result := interest;
with
Compoundinterest := interest;
or to show in completion (with a few changes):
function compound_interest(principal, years: integer; rate: double): double;
var
divrate: double;
begin
divrate := rate / 100.0;
compound_interest := principal * power(1 + divrate, years) - principal;
end;
However, this assumes that you have access to the power function. In order to access the power function, the program must have: uses math written under the program header. This code was tested on compiles on Free Pascal Compiler version 2.6.4.
For more info on Pascal, see: https://www.tutorialspoint.com/pascal/pascal_functions.htm
For an online Pascal terminal, see:
https://www.tutorialspoint.com/compile_pascal_online.php
I tested here with Free Pascal 3.0.0 and it works (5.20875. I added
{$mode delphi}
uses math;
before your code and
begin
writeln(compoundinterest(1000,3,15));
end.
after. Verify that you do this too, or explain more about which pascal system you use.
If this is only a first step in some calculation you might also be interested in the math unit financial functions
You have to set the format of decimal using
:0:2
Try this
result := interest:0:2;
Counting the number of decimal places in pascal
var
divrate: double;
interest: Double;
begin
divrate := rate/100;
interest := principal * power(1 + divrate, years) - Principal;
result := interest:0:2;
end;
I have ran into what I consider to be a progress bar bug on Windows 7. To demonstrate the bug I created a WinForm application with a button and a progress bar. In the button's 'on-click' handle I have the following code.
private void buttonGo_Click(object sender, EventArgs e)
{
this.progressBar.Minimum = 0;
this.progressBar.Maximum = 100;
this.buttonGo.Text = "Busy";
this.buttonGo.Update();
for (int i = 0; i <= 100; ++i)
{
this.progressBar.Value = i;
this.Update();
System.Threading.Thread.Sleep(10);
}
this.buttonGo.Text = "Ready";
}
The expected behavior is for the progress bar to advance to 100% and then the button text to change to 'Ready'. However, when developing this code on Windows 7, I noticed that the progress bar would rise to about 75% and then the button text would change to 'Ready'. Assuming the code is synchronous, this should not happen!
On further testing I found that the exact same code running on Windows Server 2003 produced the expected results. Furthermore, choosing a non aero theme on Windows 7 produces the expected results.
In my mind, this seems like a bug. Often it is very hard to make a progress bar accurate when the long operation involves complex code but in my particular case it was very straight forward and so I was little disappointed when I found the progress control did not accurately represent the progress.
Has anybody else noticed this behavior? Has anybody found a workaround?
It has to do with the animation of the progress bar. If your progress bar is at 0% and you set it to 100% then it will not jump there, but animate the progress bar smoothly filling up. If this is too slow, you will be done before the progress bar finished animating. So even though you have already set it to 80, 90 and 100%, the animation still lags behind.
I never found a way to turn this off, however I have a workaround. The animation is only being done if you increment the progress bar. If you move it backwards, it will immediately jump to that position. So if I want the progress bar to be at x% (x != 100) then I move it to x+1 and then to x. If I want it at 100% I move it to 100, 99 and 100%. (Or whatever values you use, you get the idea.) This works fast enough to not to be visible, and you can leave this code in for previous Windows versions as well. (though I don't)
HTH
I had the same problem. Fozi's tipp was helping me. Before setting a new value I have set the value + 1. To make this work also for 100% the maximum must be increased before. The following worked fine for me.
if (NewValue < progressBar.Maximum)
{
progressBar.Value = NewValue + 1;
progressBar.Value--;
}
else
{
progressBar.Maximum++;
progressBar.Value = progressBar.Maximum;
progressBar.Value--;
progressBar.Maximum--;
}
I think the original problem is related to timing and Win7's (or Aero's) animation mechanism for the progress bar.
This Sub is on the form that contains the progress bar (pBar).
It varies the bar's .Maximum and keeps .Value fixed at 10 for percent completes of 1 to 99. The bar's .Minimum is set to 0 at design time.
This sorted out the problem for me.
Public Sub UpdateStatusPC(ByVal pc As Integer)
Try
If pc < 0 Then
pBar.Maximum = 100
pBar.Value = 0
ElseIf pc > 100 Then
pBar.Maximum = 100
pBar.Value = 100
ElseIf pc = 0 Then
pBar.Maximum = 10
pBar.Value = 0
Else
pBar.Value = 10
pBar.Maximum = 10 / CDbl(pc / 100.0)
End If
pBar.Update()
Catch ex As Exception
MsgBox("UpdateStatusPC: " & ex.Message)
End Try
End Sub
To Delphi users facing the same problem: Below is a unit called ProgressBarFix that you can use to automatically patch the problem without worrying about changing your progress bar code -- just include ProgressBarFix in your form's interface "uses" clause after the ComCtrls uses and you'll get the workaround automatically:
unit ProgressBarFix;
(* The standard progress bar fails under Windows theming -- it fails to animate
all the way to the right side. C.f.,
http://stackoverflow.com/questions/2217688/windows-7-aero-theme-progress-bar-bug
To work around the problem, include ProgressBarFix in the interface section's
"uses" clause *after* ComCtrls (this replaces the TProgressBar definition in
ConCtrls with the one here, effectively allowing the control defined on the
form to be replaced with the patch version.
c.f., http://www.deltics.co.nz/blog/?p=222and http://melander.dk/articles/splitter *)
interface
uses ComCtrls ;
type TProgressBar = class(ComCtrls.TProgressBar)
private
procedure SetPosition(Value: Integer);
function GetPosition: Integer;
published
property Position: Integer read GetPosition write SetPosition default 0;
end ;
implementation
{ TProgressBar }
function TProgressBar.GetPosition: Integer;
begin
result := inherited Position
end;
procedure TProgressBar.SetPosition(Value: Integer);
begin
if Value=inherited Position then
exit ;
if value<Max then begin
inherited Position := value+1 ;
inherited Position := value
end else begin
Max := Max+1 ;
inherited Position := Max ;
inherited Position := value ;
Max := Max-1
end
end;
end.
Disable visual effect option "Animate controls and elements inside windows" in "Performance options". Then the progressbars won't be animated any longer.
I have seen similar issues with progress bars on Vista and Windows 7.
The key problem in my case was the blocking of the UI thread. (Like you do in your sample).
Windows does not like applications that don't respond to new messages in the message queue. If you spend too much time on one message, windows will mark your application as "not responsive". In Vista/Win7, windows also decides to stop updating your application window.
As a workaround, you could put the actual work on a background worker, or call Application.DoEvents() every once in a while. You do need to make sure that your progress bar window is modal, or else the DoEvents() may enable new commands to start executing halfway through your background processing.
If that feels to kludgy, the more proper way is to do your background work on a BackgroundWorker thread. It comes with support for sending events to the UI thread to update the progress bar.
(09/2015) I just jumped from D6 to XE8. Having a number of issues. Including this TProgressBar thing. Tabled it for a while. Came across this (Erik Knowles) fix tonight. Fantastic. Except: the first scenario I ran through had a Max value of 9,770,880. And it (Erik Knowles' "original" fix) REALLY added to the time this process took (with all the extra actual updating of the ProgressBar).
So I expanded his class to reduce the amount of times the ProgressBar actually redraws itself. But ONLY IF the "original" Max value is greater than MIN_TO_REWORK_PCTS (I settled on 5000 here).
If so, the ProgressBar only updates itself HUNDO times (here I started with and pretty much settled on 100, hence the "HUNDO" name).
I accounted for some quirkiness at the Max value as well:
if Abs(FOriginalMax - value) <= 1 then
pct := HUNDO
I tested this against my original 9.8m Max. And, with this standalone test app:
:
uses
:
ProgressBarFix;
const
PROGRESS_PTS = 500001;
type
TForm1 = class(TForm)
Label1: TLabel;
PB: TProgressBar;
Button1: TButton;
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
x: integer;
begin
PB.Min := 0;
PB.Max := PROGRESS_PTS;
PB.Position := 0;
for x := 1 to PROGRESS_PTS do
begin
//let's do something
//
Label1.Caption := Format('%d of %d',[x,PROGRESS_PTS]);
Update;
PB.Position := x;
end;
PB.Position := 0;
end;
end.
with PROGRESS_PTS values of:
10
100
1,000
10,000
100,000
1,000,000
It's smooth and "accurate" for all of these values - without really slowing anything down.
In testing, I was able to toggle my compiler directive DEF_USE_MY_PROGRESS_BAR to test both ways (this TProgressBar replacement vs the original).
Note that you might want to uncomment the call to Application.ProcessMessages.
Here is the (my "enhanced") ProgressBarFix source:
unit ProgressBarFix;
interface
uses
Vcl.ComCtrls;
type
TProgressBar = class(Vcl.ComCtrls.TProgressBar)
const
HUNDO = 100;
MIN_TO_REWORK_PCTS = 5000;
private
function GetMax: integer;
procedure SetMax(value: integer);
function GetPosition: integer;
procedure SetPosition(value: integer);
published
property Max: integer read GetMax write SetMax default 100;
property Position: integer read GetPosition write SetPosition default 0;
private
FReworkingPcts: boolean;
FOriginalMax: integer;
FLastPct: integer;
end;
implementation
function TProgressBar.GetMax: integer;
begin
result := inherited Max;
end;
procedure TProgressBar.SetMax(value: integer);
begin
FOriginalMax := value;
FLastPct := 0;
FReworkingPcts := FOriginalMax > MIN_TO_REWORK_PCTS;
if FReworkingPcts then
inherited Max := HUNDO
else
inherited Max := value;
end;
function TProgressBar.GetPosition: integer;
begin
result := inherited Position;
end;
procedure TProgressBar.SetPosition(value: integer);
var
pct: integer;
begin
//Application.ProcessMessages;
if value = inherited Position then
exit;
if FReworkingPcts then
begin
if Abs(FOriginalMax - value) <= 1 then
pct := HUNDO
else
pct := Trunc((value / FOriginalMax) * HUNDO);
if pct = FLastPct then
exit;
FLastPct := pct;
value := pct;
end;
if value < Max then
begin
inherited Position := Succ(value);
inherited Position := value;
end
else
begin
Max := Succ(Max);
inherited Position := Max;
inherited Position := value;
Max := Pred(Max);
end;
end;
end.
I have a piece of code, which is supposed to mute/unmute sound. I have patched it a lot, so now it enumerate all rendering device to toggle their mute status. However, although it perfectly unmute anything, for muting, the sound mixer will show that devices are muted, however the sound is still playing. On my laptop I have a LED which indicates if sound is muted, and it indactes that it's muted too...
I have had a look at similar C++ code to achieve the same and can't find a difference...
var
deviceEnumerator: IMMDeviceEnumerator;
MMDevice: IMMDevice;
EndpointVolume: IAudioEndpointVolume;
Muted: BOOL;
R: Integer;
MMDC: IMMDeviceCollection;
DC: UINT;
I: Integer;
begin
CoCreateInstance(CLSID_MMDeviceEnumerator, nil, CLSCTX_ALL, IID_IMMDeviceEnumerator, deviceEnumerator);
if (deviceEnumerator.EnumAudioEndpoints(eRender, DEVICE_STATE_ACTIVE, MMDC) = S_OK) then
begin
if MMDC.GetCount(DC) = S_OK then
begin
for I := 0 to DC - 1 do
begin
if (MMDC.Item(I, MMDevice) = S_OK) then
begin
MMDevice.Activate(IID_IAudioEndpointVolume, CLSCTX_ALL, nil, #EndpointVolume);
if EndpointVolume = nil then
begin
OutputDebugString('Unable to get endpoint!!!');
end
else
begin
R := EndpointVolume.GetMute(Muted); // R = S_OK, always
R := EndpointVolume.SetMute(not Muted, nil); // R = S_OK always, too
end;
end;
end;
end;
end
end;
If anyone has an idea about what's wrong... There's not a single call failing, and everything looks like it's muted, so I'm really puzzled...
I also use similar code to raise and lower volume, it works perfectly.
This is gonna sound dumb :) Since you're hearing sound, you're not muting something. Output the names of the devices you are muting; if the list doesn't match the list from the C++ code, that works, then you know where the problem is.
I know that I'm super late, but I think I know what is the problem! Maybe this will help somebody in the future! Basically, don't reuse Muted variable as not Muted :
R := EndpointVolume.GetMute(Muted);
R := EndpointVolume.SetMute(not Muted, nil);
Use something like this:
R := EndpointVolume.GetMute(Muted);
Bool bMuted = Muted;
R := EndpointVolume.SetMute(not bMuted, nil);
Or this:
R := EndpointVolume.GetMute(Muted);
R := EndpointVolume.SetMute(Muted = 0, nil);
What I think is happening, you (and me too, in C++!) are inverting BOOL (that is actually signed int) with not or ~ in C++ (like I did). GetMuted returns -1 on Mute ON and 0 on Mute OFF. When you invert 0 into -1 and send it to SetMute, something bugs out. It seems that SetMute is expecting to get 0 for false and 1 for true (not -1!). Undocumented quirks, I guess...
I am trying to port some xor-encryption code so it doesn't use any other units. I want to use just the commands, variables, and types that are supported natively by the compiler.
For example, here's some of the original code:
[...]
while (StreamIn.Position < StreamIn.Size) and
((StreamIn.Size -StreamIn.Position) >= szBuffer) do begin
(* read 4 bytes at a time into a local integer variable *)
StreamIn.ReadBuffer(buffer, szBuffer);
(* the XOR encryption/decryption *)
buffer := buffer xor theKey;
buffer := buffer xor $E0F;
(* write data to output stream *)
StreamOut.WriteBuffer(buffer, szBuffer);
end;
[...]
This is my code:
function __NativeEncrypt (const Key, Source : String) : String;
// this function should not be used directly
// use EncryptText and DecryptText
const
szBuffer = SizeOf(Integer); (* 4 bytes *)
szByteBuffer = SizeOf(Byte); (* 1 byte *)
var
byteBuffer,
buffer,
index,
theKey: Integer;
StreamIn : String;
StreamOut : String;
i : Integer;
begin
theKey := hashKey(Key);
StreamIn := Source;
StreamOut := '';
for i := 1 to Length (StreamIn) do begin
buffer := Integer(StreamIn[i]);
buffer := buffer xor thekey;
buffer := buffer xor $E0F;
StreamOut := StreamOut + char(Buffer);
end;
result := StreamOut; // wrong results.
// to continue...
end;
What tips are there for this task?
The only reason not to use library-provided units is as a learning exercise. I see no other reason to intentionally cripple yourself by refusing to use built-in features of your tools. Any answer to your general request for tips would rob you of the learning experience.
Most developers end up rewriting something from scratch at some point in their careers. However, unless it was imposed by a supervisor who suffers from extreme not-invested-here syndrome, it's nearly always a personal experience. You won't profit from their experience the same way you will from doing the work yourself. Doing it yourself will give you an understanding of what jobs the built-in tools do, and may give you some insight into why they're designed the way they are. Although you might be able to get those explanations from other people, unless you've actually tried to do it yourself, you won't really appreciate the explanations anyway.
My tip to you is to proceed with your project. I hope you find it interesting, and I wish you luck. If you eventually find yourself unable to make further progress, then identify the specific problem you're stuck on, and then ask others for help with that roadblock.
I have ran into what I consider to be a progress bar bug on Windows 7. To demonstrate the bug I created a WinForm application with a button and a progress bar. In the button's 'on-click' handle I have the following code.
private void buttonGo_Click(object sender, EventArgs e)
{
this.progressBar.Minimum = 0;
this.progressBar.Maximum = 100;
this.buttonGo.Text = "Busy";
this.buttonGo.Update();
for (int i = 0; i <= 100; ++i)
{
this.progressBar.Value = i;
this.Update();
System.Threading.Thread.Sleep(10);
}
this.buttonGo.Text = "Ready";
}
The expected behavior is for the progress bar to advance to 100% and then the button text to change to 'Ready'. However, when developing this code on Windows 7, I noticed that the progress bar would rise to about 75% and then the button text would change to 'Ready'. Assuming the code is synchronous, this should not happen!
On further testing I found that the exact same code running on Windows Server 2003 produced the expected results. Furthermore, choosing a non aero theme on Windows 7 produces the expected results.
In my mind, this seems like a bug. Often it is very hard to make a progress bar accurate when the long operation involves complex code but in my particular case it was very straight forward and so I was little disappointed when I found the progress control did not accurately represent the progress.
Has anybody else noticed this behavior? Has anybody found a workaround?
It has to do with the animation of the progress bar. If your progress bar is at 0% and you set it to 100% then it will not jump there, but animate the progress bar smoothly filling up. If this is too slow, you will be done before the progress bar finished animating. So even though you have already set it to 80, 90 and 100%, the animation still lags behind.
I never found a way to turn this off, however I have a workaround. The animation is only being done if you increment the progress bar. If you move it backwards, it will immediately jump to that position. So if I want the progress bar to be at x% (x != 100) then I move it to x+1 and then to x. If I want it at 100% I move it to 100, 99 and 100%. (Or whatever values you use, you get the idea.) This works fast enough to not to be visible, and you can leave this code in for previous Windows versions as well. (though I don't)
HTH
I had the same problem. Fozi's tipp was helping me. Before setting a new value I have set the value + 1. To make this work also for 100% the maximum must be increased before. The following worked fine for me.
if (NewValue < progressBar.Maximum)
{
progressBar.Value = NewValue + 1;
progressBar.Value--;
}
else
{
progressBar.Maximum++;
progressBar.Value = progressBar.Maximum;
progressBar.Value--;
progressBar.Maximum--;
}
I think the original problem is related to timing and Win7's (or Aero's) animation mechanism for the progress bar.
This Sub is on the form that contains the progress bar (pBar).
It varies the bar's .Maximum and keeps .Value fixed at 10 for percent completes of 1 to 99. The bar's .Minimum is set to 0 at design time.
This sorted out the problem for me.
Public Sub UpdateStatusPC(ByVal pc As Integer)
Try
If pc < 0 Then
pBar.Maximum = 100
pBar.Value = 0
ElseIf pc > 100 Then
pBar.Maximum = 100
pBar.Value = 100
ElseIf pc = 0 Then
pBar.Maximum = 10
pBar.Value = 0
Else
pBar.Value = 10
pBar.Maximum = 10 / CDbl(pc / 100.0)
End If
pBar.Update()
Catch ex As Exception
MsgBox("UpdateStatusPC: " & ex.Message)
End Try
End Sub
To Delphi users facing the same problem: Below is a unit called ProgressBarFix that you can use to automatically patch the problem without worrying about changing your progress bar code -- just include ProgressBarFix in your form's interface "uses" clause after the ComCtrls uses and you'll get the workaround automatically:
unit ProgressBarFix;
(* The standard progress bar fails under Windows theming -- it fails to animate
all the way to the right side. C.f.,
http://stackoverflow.com/questions/2217688/windows-7-aero-theme-progress-bar-bug
To work around the problem, include ProgressBarFix in the interface section's
"uses" clause *after* ComCtrls (this replaces the TProgressBar definition in
ConCtrls with the one here, effectively allowing the control defined on the
form to be replaced with the patch version.
c.f., http://www.deltics.co.nz/blog/?p=222and http://melander.dk/articles/splitter *)
interface
uses ComCtrls ;
type TProgressBar = class(ComCtrls.TProgressBar)
private
procedure SetPosition(Value: Integer);
function GetPosition: Integer;
published
property Position: Integer read GetPosition write SetPosition default 0;
end ;
implementation
{ TProgressBar }
function TProgressBar.GetPosition: Integer;
begin
result := inherited Position
end;
procedure TProgressBar.SetPosition(Value: Integer);
begin
if Value=inherited Position then
exit ;
if value<Max then begin
inherited Position := value+1 ;
inherited Position := value
end else begin
Max := Max+1 ;
inherited Position := Max ;
inherited Position := value ;
Max := Max-1
end
end;
end.
Disable visual effect option "Animate controls and elements inside windows" in "Performance options". Then the progressbars won't be animated any longer.
I have seen similar issues with progress bars on Vista and Windows 7.
The key problem in my case was the blocking of the UI thread. (Like you do in your sample).
Windows does not like applications that don't respond to new messages in the message queue. If you spend too much time on one message, windows will mark your application as "not responsive". In Vista/Win7, windows also decides to stop updating your application window.
As a workaround, you could put the actual work on a background worker, or call Application.DoEvents() every once in a while. You do need to make sure that your progress bar window is modal, or else the DoEvents() may enable new commands to start executing halfway through your background processing.
If that feels to kludgy, the more proper way is to do your background work on a BackgroundWorker thread. It comes with support for sending events to the UI thread to update the progress bar.
(09/2015) I just jumped from D6 to XE8. Having a number of issues. Including this TProgressBar thing. Tabled it for a while. Came across this (Erik Knowles) fix tonight. Fantastic. Except: the first scenario I ran through had a Max value of 9,770,880. And it (Erik Knowles' "original" fix) REALLY added to the time this process took (with all the extra actual updating of the ProgressBar).
So I expanded his class to reduce the amount of times the ProgressBar actually redraws itself. But ONLY IF the "original" Max value is greater than MIN_TO_REWORK_PCTS (I settled on 5000 here).
If so, the ProgressBar only updates itself HUNDO times (here I started with and pretty much settled on 100, hence the "HUNDO" name).
I accounted for some quirkiness at the Max value as well:
if Abs(FOriginalMax - value) <= 1 then
pct := HUNDO
I tested this against my original 9.8m Max. And, with this standalone test app:
:
uses
:
ProgressBarFix;
const
PROGRESS_PTS = 500001;
type
TForm1 = class(TForm)
Label1: TLabel;
PB: TProgressBar;
Button1: TButton;
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
x: integer;
begin
PB.Min := 0;
PB.Max := PROGRESS_PTS;
PB.Position := 0;
for x := 1 to PROGRESS_PTS do
begin
//let's do something
//
Label1.Caption := Format('%d of %d',[x,PROGRESS_PTS]);
Update;
PB.Position := x;
end;
PB.Position := 0;
end;
end.
with PROGRESS_PTS values of:
10
100
1,000
10,000
100,000
1,000,000
It's smooth and "accurate" for all of these values - without really slowing anything down.
In testing, I was able to toggle my compiler directive DEF_USE_MY_PROGRESS_BAR to test both ways (this TProgressBar replacement vs the original).
Note that you might want to uncomment the call to Application.ProcessMessages.
Here is the (my "enhanced") ProgressBarFix source:
unit ProgressBarFix;
interface
uses
Vcl.ComCtrls;
type
TProgressBar = class(Vcl.ComCtrls.TProgressBar)
const
HUNDO = 100;
MIN_TO_REWORK_PCTS = 5000;
private
function GetMax: integer;
procedure SetMax(value: integer);
function GetPosition: integer;
procedure SetPosition(value: integer);
published
property Max: integer read GetMax write SetMax default 100;
property Position: integer read GetPosition write SetPosition default 0;
private
FReworkingPcts: boolean;
FOriginalMax: integer;
FLastPct: integer;
end;
implementation
function TProgressBar.GetMax: integer;
begin
result := inherited Max;
end;
procedure TProgressBar.SetMax(value: integer);
begin
FOriginalMax := value;
FLastPct := 0;
FReworkingPcts := FOriginalMax > MIN_TO_REWORK_PCTS;
if FReworkingPcts then
inherited Max := HUNDO
else
inherited Max := value;
end;
function TProgressBar.GetPosition: integer;
begin
result := inherited Position;
end;
procedure TProgressBar.SetPosition(value: integer);
var
pct: integer;
begin
//Application.ProcessMessages;
if value = inherited Position then
exit;
if FReworkingPcts then
begin
if Abs(FOriginalMax - value) <= 1 then
pct := HUNDO
else
pct := Trunc((value / FOriginalMax) * HUNDO);
if pct = FLastPct then
exit;
FLastPct := pct;
value := pct;
end;
if value < Max then
begin
inherited Position := Succ(value);
inherited Position := value;
end
else
begin
Max := Succ(Max);
inherited Position := Max;
inherited Position := value;
Max := Pred(Max);
end;
end;
end.