I'm a beginner with threads in delphi. I wrote this code and it works very well.
It starts with opening ClientDataSet1 until it is completed and then opening ClientDataSet2 and so on.
My question is: how to start opening them at the same time.
TTHread.CreateAnonymousThread(
procedure
begin
TTHread.Synchronize(nil,
procedure
begin
with ClientDataSet1 do
try
ProgressBar1.Max := 2000; // number of records of ClientDataSet1
PacketRecords := 50;
Open;
DisableControls;
while not Eof do
begin
ProgressBar1.Position := ProgressBar1.Position + 1;
Label1.Caption := ClientDataSet1.RecordCount.ToString;
Next;
Application.ProcessMessages;
end;
EnableControls;
except
// ShowMessage(Msg);
end;
end);
TTHread.Synchronize(nil,
procedure
begin
with ClientDataSet2 do
try
ProgressBar2.Max := 2330; // number of records of ClientDataSet2
PacketRecords := 80;
Open;
DisableControls;
while not Eof do
begin
ProgressBar2.Position := ProgressBar2.Position + 1;
Label2.Caption := ClientDataSet2.RecordCount.ToString;
Next;
Application.ProcessMessages;
end;
EnableControls;
except
// ShowMessage(Msg);
end;
end);
end).Start;
Please help me.
Related
I'm writing MITM ssl proxy using indy. i use IdHTTPserver component with self signed certificate for proxy server, and on event of CommandOther i do TcpCleint request to site and return data in HTTPServer. But problem is, some scripts, especially JS and some pictures from web pages not being loaded at all, or load after timeout, so i recieve html code in browser, but crippled by not working js (mostly). Here's my code for CommandOther:
procedure TForm3.IdHTTPServer1CommandOther(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
client: TIdTCPClient;
Headers, headers1: TIdHeaderList;
s, ResponseCode, ResponseText: string;
req,req2:string;
Size: Int64;
Strm,strm2: TIdTCPStream;
ssl: TIdSSLIOHandlerSocketOpenSSL;
clientcount:integer;
begin
Memo3.lines.Add('start');
client := TIdtCPClient.Create(nil);
ssl := TIdSSLIOHandlerSocketOpenSSL.Create(client);
client.IOHandler := ssl;
s := ARequestInfo.URI;
client.Host := Fetch(s, ':', True);
client.Port := StrToIntDef(s, 443);
client.ConnectTimeout := 2000;
s := '';
Memo3.lines.Add('connecting');
client.UseNagle:=true;
client.Connect;
//here i handle CONNECT command
AResponseInfo.ResponseNo := 200;
AResponseInfo.ResponseText := 'Connection established';
aresponseinfo.WriteHeader;
// activate SSL between this proxy and the client
TIdSSLIOHandlerSocketOpenSSL(AContext.Connection.Socket).PassThrough
:= false;
Memo3.lines.Add('connected');
while AContext.Connection.Connected and Client.Connected do
begin
try
memo4.Lines.Add('---start header-------');
headers1 := TIdHeaderList.Create(QuoteHTTP);
headers1.FoldLength := MaxInt;
repeat
s := AContext.Connection.IOHandler.ReadLn;
Memo4.lines.Add(s);
headers1.Add(s);
if s = '' then
Break;
until False;
client.WriteHeader(headers1);
memo4.Lines.Add('-----header written-----');
memo5.Lines.Add('----------');
if Headers1.IndexOfName('Content-Length') <> -1 then
begin
strm2:=TIdTCPStream.Create(client);
memo5.Lines.Add('post');
Size := StrToInt64(Headers1.Values['Content-Length']);
if Size > 0 then
AContext.Connection.IOHandler.ReadStream(Strm2, Size, False);
end;
memo4.Lines.Add('---response headers-------');
Headers := TIdHeaderList.Create(QuoteHTTP);
try
Headers.FoldLength := MaxInt;
repeat
s := client.IOHandler.ReadLn;
Memo4.lines.Add(s);
acontext.Connection.IOHandler.WriteLn(s);
Headers.Add(s);
if s = '' then
Break;
until False;
memo4.Lines.Add('---respone headers read-------');
Strm := TIdTCPStream.Create(AContext.Connection);
try
if Pos('chunked', Headers.Values['Transfer-Encoding']) <> 0 then
begin
memo4.Lines.Add('chunked');
repeat
s := client.IOHandler.ReadLn;
AContext.Connection.IOHandler.WriteLn(s);
Size := StrToInt64('$' + Fetch(s, ';'));
if Size = 0 then
Break;
client.IOHandler.ReadStream(Strm, Size, False);
s := client.IOHandler.ReadLn;
AContext.Connection.IOHandler.WriteLn(s);
until False;
repeat
s := client.IOHandler.ReadLn;
AContext.Connection.IOHandler.WriteLn(s);
until s = '';
end
else if Headers.IndexOfName('Content-Length') <> -1 then
begin
Size := StrToInt64(Headers.Values['Content-Length']);
end;
if Size > 0 then
client.IOHandler.ReadStream(Strm, Size, False);
end
else
begin
memo5.Lines.Add('big read(');
AResponseInfo.CloseConnection := true;
try
client.IOHandler.ReadStream(Strm, -1, True);
except
on E: EIdSocketError do
begin
raise;
end;
end;
end;
finally
Strm.Free;
end;
finally
Headers.Free;
strm2.Free;
headers1.Free;
end;
finally
client.Disconnect;
end;
client.Free;
end;
end;
I have an app that allows my users to turn on and off a timer to track their time spent on a certain task. The timer runs a clock used to show the elapsed time to the user, much like a stopwatch.
The code below has worked as I thought it should for a few years now. However, when the app is run on Win 10, sometimes the "time" rate speeds up by 2 or 3 times during a session. If the user restarts the app, it may run at normal speed.
Win 10 Delphi 10.3
procedure TfmTimeCard.btnTimerClick(Sender: TObject);
begin
if btnTimer.Caption = 'Start &Timer' then
begin
btnTimer.Down := True;
btnTimer.Caption := 'Stop &Timer';
pnlTimer.Color := clPurple;
btnResume.Enabled := True;
btnAssign.Enabled := False;
Timer1.Enabled := true;
UpdateTimer.Enabled := True;
ElapsedTime := ElapsedTime;
//btnPostRecord.Enabled := False;
btnCancel.Enabled := False;
btnDeleteTimeCard.Enabled := False;
end
else
begin
btnTimer.Down := False;
btnTimer.Caption := 'Start &Timer';
pnlTimer.ParentColor := True;
btnResume.Enabled := False;
btnAssign.Enabled := True;
pnlTimer.Color := clMoneyGreen;
end;
end;
procedure TfmTimeCard.Timer1Timer(Sender: TObject);
begin
if btnTimer.Caption = 'Stop &Timer' then
begin
ElapsedTime := ElapsedTime + 0.0000115740;
cxClock1.time := ElapsedTime;
cxTimeEditTimer.Time := ElapsedTime;
end;
end;
This is a terrible way to keep track of elapsed time with a TTimer. TTimer is not a real-time timer, or even an accurate timer. It is based on the WM_TIMER window message, which is
a low-priority message. The GetMessage and PeekMessage functions post this message only when no other higher-priority messages are in the thread's message queue.
Don't calculate your ElapsedTime based on how often the TTimer fires its OnTimer event. Keep track of the current time when starting the TTimer, and then subtract that value from the next current time whenever the OnTimer event is eventually generated. That will give you a more real elapsed time.
Try something more like this:
uses
..., System.DateUtils;
private
StartTime: TDateTime;
ElapsedSecs: Int64;
procedure TfmTimeCard.btnTimerClick(Sender: TObject);
begin
if btnTimer.Tag = 0 then
begin
btnTimer.Tag := 1;
...
ElapsedSecs := 0;
StartTime := Now;
Timer1.Enabled := true;
...
end
else
begin
btnTimer.Tag := 0;
...
ElapsedSecs := SecondsBetween(Now, StartTime);
Timer1.Enabled := false;
...
end;
end;
procedure TfmTimeCard.Timer1Timer(Sender: TObject);
begin
if btnTimer.Tag = 1 then
begin
ElapsedSecs := SecondsBetween(Now, StartTime);
// use ElapsedSecs as needed ...
end;
end;
Or:
uses
..., Winapi.Windows;
private
StartTime: DWORD;
ElapsedSecs: Integer;
procedure TfmTimeCard.btnTimerClick(Sender: TObject);
begin
if btnTimer.Tag = 0 then
begin
btnTimer.Tag := 1;
...
ElapsedSecs := 0;
StartTime := GetTickCount;
Timer1.Enabled := true;
...
end
else
begin
btnTimer.Tag := 0;
...
ElapsedSecs := (GetTickCount - StartTime) div 1000;
Timer1.Enabled := false;
...
end;
end;
procedure TfmTimeCard.Timer1Timer(Sender: TObject);
begin
if btnTimer.Tag = 1 then
begin
ElapsedSecs := (GetTickCount - StartTime) div 1000;
// use ElapsedSecs as needed ...
end;
end;
Or:
uses
..., System.Diagnostics;
private
SW: TStopwatch;
ElapsedSecs: Integer;
procedure TfmTimeCard.btnTimerClick(Sender: TObject);
begin
if not SW.IsRunning then
begin
...
ElapsedSecs := 0;
SW := TStopWatch.Start;
Timer1.Enabled := true;
...
end
else
begin
...
SW.Stop;
ElapsedSecs := Trunc(SW.Elapsed.TotalSeconds);
Timer1.Enabled := false;
...
end;
end;
procedure TfmTimeCard.Timer1Timer(Sender: TObject);
begin
if SW.IsRunning then
begin
ElapsedSecs := Trunc(SW.Elapsed.TotalSeconds);
// use ElapsedSecs as needed ...
end;
end;
I'm building a custom panel in Delphi XE5 and I'm having a hard time simulating a new "Gravity" property where I can combine two coordinates (like Right + Bottom) and the effect is similar to "Align" however, it does not resize the object, direction. The main problem I encountered is to simulate this behavior. My initial intention was to create a panel in memory with the same "Parent" in my custom panel and then align to the position defined in "Gravity" overwriting the "SetBounds" method. It's working, but a bit precarious, especially in "Design Time". Could someone suggest me how to more effectively simulate this alignment using VCL?
function TZPanel.GetPosition: TCustomPanel;
var
sid: TZSide;
anch: TAnchors;
panTest: TPanel;
function getGravity(al: TAlign): TRect;
var
panGravity: TPanel;
I: Integer;
begin
try
//Self.Visible := False;
panGravity:= TPanel.Create(Self);
panGravity.BevelInner := panTest.BevelInner;
panGravity.BevelOuter := panTest.BevelOuter;
panGravity.BevelWidth := panTest.BevelWidth;
panGravity.BorderWidth := panTest.BorderWidth;
panGravity.ParentBackground := True;
panGravity.SetBounds(panTest.Left, panTest.Top, panTest.Width, panTest.Height);
panGravity.Parent:= Self.Parent;
panGravity.Align := al;
Result:= panGravity.BoundsRect;
finally
panGravity.Destroy;
Self.Visible := True;
end;
end;
begin
panTest := TPanel.Create(Self);
panTest.Align := Align;
panTest.Anchors := Anchors;
panTest.BevelInner := BevelInner;
panTest.BevelOuter := BevelOuter;
panTest.BevelWidth := BevelWidth;
panTest.BorderWidth := BorderWidth;
panTest.SetBounds(Left, Top, Width, Height);
if (FGravity = []) then
begin
//
end
else
begin
panTest.Align := alCustom;
anch := [];
for sid in FGravity do
begin
case sid of
sTop:
begin
panTest.Top := getGravity(alTop).Top;
anch := anch + [akTop];
end;
sRight:
begin
panTest.Left := getGravity(alRight).Left;
anch := anch + [akRight];
end;
sBottom:
begin
panTest.Top := getGravity(alBottom).Top;
anch := anch + [akBottom];
end;
sLeft:
begin
panTest.Left := getGravity(alLeft).Left;
anch := anch + [akLeft];
end;
end;
end;
panTest.Anchors := anch;
end;
Result := panTest;
end;
I am a delphi learner. I am having one Delphi Progect with "MainForm", "MinimizeTimer" and "RestoreTimer". I have defined the following codes.
Minimize Timer :
if MainForm.AlphaBlendValue >= 225 then
begin
MinimizeTimer.Enabled := true;
MainForm.AlphaBlendValue := MainForm.AlphaBlendValue - 5;
end;
Restore Timer :
if MainForm.AlphaBlendValue >= 0 then
begin
RestoreTimer.Enabled := true;
MainForm.AlphaBlendValue := MainForm.AlphaBlendValue + 5;
end;
My requirement is that the MainForm will be first fadeout using "MinimizeTimer" and then will be minimized when "_" Button on Caption Bar is pressed. And also be fadein using "RestoreTimer" and then will be restored after clicking on taskbar. So I defined again the following codes:
private
{ Private declarations }
procedure WMSysCommand(var Msg: TWMSysCommand) ; message WM_SYSCOMMAND;
..
..
..
..
..
procedure TMainForm.WMSysCommand(var Msg: TWMSysCommand) ;
begin
if Msg.CmdType = SC_MINIMIZE then MinimizeTimer.Enabled := true;
DefaultHandler(Msg);
if Msg.CmdType = SC_RESTORE then RestoreTimer.Enabled := true;
DefaultHandler(Msg);
end;
But I am not getting the expected result. The MainForm is Minimized and Restored as in regular way. Please remember in my project I have one "FormCloseQuery" event also.
Please help me.
You are using the wrong logic for your requirements. Try this instead:
procedure TMainForm.MinimizeTimerTimer(Sender: TObject);
begin
if AlphaBlendValue > 0 then
begin
AlphaBlendValue := AlphaBlendValue - 5;
end
else
begin
MinimizeTimer.Enabled := False;
Perform(WM_SYSCOMMAND, SC_MINIMIZE, 0);
end;
end;
procedure TMainForm.RestoreTimerTimer(Sender: TObject);
begin
if AlphaBlendValue < 255 then
begin
AlphaBlendValue := AlphaBlendValue + 5;
end else begin
RestoreTimer.Enabled := False;
end;
end;
procedure TMainForm.WMSysCommand(var Msg: TWMSysCommand);
begin
case Msg.CmdType of
SC_MINIMIZE: begin
if AlphaBlendValue > 0 then
begin
MinimizeTimer.Enabled := True;
Exit;
end;
end;
SC_RESTORE: begin
if AlphaBlendValue < 255 then begin
RestoreTimer.Enabled := True;
end;
end;
end;
inherited;
end;
I'm trying to make a progress bar that starts at 0%, and takes 5 seconds to get to 100%. The progress bar will begin to go up as soon as Button1 is clicked. Any advice? I looked on Google, but that gave me nothing good on this sort of thing.
Also, at 0%, there should be a label that says Waiting..., when the progress bar starts, it should go to Working..., and when it's done, it should say Done!.
You can use a timer with interval 50 and firstly set enabled to false.
procedure TForm1.Button1Click(Sender: TObject);
begin
timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
const
cnt: integer = 1;
begin
ProgressBar1.Position := cnt;
if cnt = 1 then Label1.Caption := 'Waiting...'
else if cnt = 100 then begin
Label1.Caption := 'Done!';
Timer1.Enabled := False;
end else
Label1.Caption := 'Working...';
Inc(cnt);
end;
Using GetTickCount() and initializing variables:
uses Windows;
var mseconds, starttime: integer;
procedore TForm1.FormCreate()
begin
starttime := GetTickCount();
mseconds := 0;
Timer1.Enabled := false;
Label1.Caption := '';
ProgressBar1.Position := 0;
Label1.Caption := 'Waiting...';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ProgressBar1.Min := 0;
ProgressBar.Max := 100;
ProgressBar1.Position := 0;
timer1.Enabled := True;
Label1.Caption := 'Working...';
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
mseconds := GetTickCount() - starttime;
if mseconds < 5000 then
ProgressBar1.Position := Trunc(mseconds / 50)
else begin
ProgressBar1.Position := 100;
Label1.Caption := 'Done!';
Timer1.Enabled := false;
end;
end;