How to make GIF animate on "please, wait form"? - delphi

I would like make a quick non-closable modal dialog, that pops up while do some tasks and goes away when tasks finish.
There are some inherent difficulties:
Don't block the main UI thread;
Don't leave system ghosts windows;
Move tasks to running into a separate thread;
Allow update the waiting message to the user;
Handling exceptions from thread to the application;
Show animated GIF in the dialog;
How to get around these pitfalls?
Below, a practical example of how I would use it:
TWaiting.Start('Waiting, loading something...');
try
Sleep(2000);
TWaiting.Update('Making something slow...');
Sleep(2000);
TWaiting.Update('Making something different...');
Sleep(2000);
finally
TWaiting.Finish;
end;

type
TWaiting = class(TForm)
WaitAnimation: TImage;
WaitMessage: TLabel;
WaitTitle: TLabel;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
strict private
class var FException: Exception;
private
class var WaitForm : TWaiting;
class procedure OnTerminateTask(Sender: TObject);
class procedure HandleException;
class procedure DoHandleException;
public
class procedure Start(const ATitle: String; const ATask: TProc);
class procedure Status(AMessage : String);
end;
implementation
{$R *.dfm}
procedure TWaiting.FormCreate(Sender: TObject);
begin
TGIFImage(WaitAnimation.Picture.Graphic).Animate := True;
end;
procedure TWaiting.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
class procedure TWaiting.Start(const ATitle: String; const ATask: TProc);
var
T : TThread;
begin
if (not Assigned(WaitForm))then
WaitForm := TWaiting.Create(nil);
T := TThread.CreateAnonymousThread(
procedure
begin
try
ATask;
except
HandleException;
end;
end);
T.OnTerminate := OnTerminateTask;
T.Start;
WaitForm.WaitTitle.Caption := ATitle;
WaitForm.ShowModal;
DoHandleException;
end;
class procedure TWaiting.Status(AMessage: String);
begin
TThread.Synchronize(TThread.CurrentThread,
procedure
begin
if (Assigned(WaitForm)) then
begin
WaitForm.WaitMessage.Caption := AMessage;
WaitForm.Update;
end;
end);
end;
class procedure TWaiting.OnTerminateTask(Sender: TObject);
begin
if (Assigned(WaitForm)) then
begin
WaitForm.Close;
WaitForm := nil;
end;
end;
class procedure TWaiting.HandleException;
begin
FException := Exception(AcquireExceptionObject);
end;
class procedure TWaiting.DoHandleException;
begin
if (Assigned(FException)) then
begin
try
if (FException is Exception) then
raise FException at ReturnAddress;
finally
FException := nil;
ReleaseExceptionObject;
end;
end;
end;
end.
Usage:
procedure TFSales.FinalizeSale;
begin
TWaiting.Start('Processing Sale...',
procedure
begin
TWaiting.Status('Sending data to database');
Sleep(2000);
TWaiting.Status('Updating Inventory');
Sleep(2000);
end);
end;

Related

How to automatically execute FreeAndNill() after thread termination

At the moment I'm using additional thread to nicely free memory after thread.
Before you ask. No I can't use FreeOnTerminate:=true because I need .waitfor.
I also need FreeAndNil() because only in this way I can check if thread is running using Assigned(). Example code.
procedure TForm1.Button1Click(Sender: TObject);
begin
SupervisorThread:= TSupervisorThread.Create(True);
SupervisorThread.FreeOnTerminate:=false; //MUST BE FALSE!
SupervisorThread.Priority := tpNormal;
SupervisorThread.Resume;
end;
procedure TSupervisorThread.Execute;
begin
CleaningThread:= TCleaningThread.Create(True);
CleaningThread.FreeOnTerminate:=true;
CleaningThread.Priority := tpNormal;
CleaningThread.Resume;
//some loops here
end;
procedure TCleaningThread.Execute;
begin
if Assigned(SupervisorThread)=true then
begin
SupervisorThread.WaitFor;
FreeAndNil(SupervisorThread);
end;
end;
procedure TForm2.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if Assigned(SupervisorThread)=false then CanClose:=true
else
begin
CanClose:=false;
ShowMessage('Cannot close form because SiupervisorThread is still working');
end;
end;
Use the TThread.OnTerminate event:
private
procedure DoTerminateEvent(Sender: TObject);
var
isRunning: Boolean;
procedure TForm2.DoTerminateEvent(Sender: TObject);
begin
isRunning := False;
end;
procedure TForm2.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if (isRunning) then
begin
CanClose := false;
ShowMessage('Cannot close form because SupervisorThread is still working')
end else
CanClose := true;
end;
Set the OnTerminate handler when creating the Thread:
SupervisorThread := TSupervisorThread.Create(True);
...
SupervisorThread.OnTerminate := DoTerminateEvent;
SupervisorThread.Resume;
Or, pass it as a parameter to the Thread's constructor:
TSupervisorThread = class(TThread)
public
constructor Create(OnTerminatEvent: TNotifyEvent);
end;
procedure TThreadCustom.Create(OnTerminateEvent: TNotifyEvent);
begin
inherited Create(True);
OnTerminate := OnTerminateEvent;
end;
SupervisorThread := TSupervisorThread.Create(DoTerminateEvent);
You can use the TThread.OnTerminate event to detect when a thread has finished running, eg:
procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(SupervisorThread) then
begin
SupervisorThread:= TSupervisorThread.Create(True);
SupervisorThread.FreeOnTerminate := False;
SupervisorThread.Priority := tpNormal;
SupervisorThread.OnTerminate := SupervisorThreadTerminated;
SupervisorThread.Resume;
end;
end;
procedure TForm1.SupervisorThreadTerminated(Sender: TObject);
begin
SupervisorThread := nil;
end;
However, this creates some problems. It creates a race condition, since the cleaning thread acts on the SupervisorThread pointer, which could disappear at any time while the cleaning thread is still running. And it creates a memory leak, as you still need to free the SupervisorThread object after it has terminated, but you can't do that in the OnTerminate handler directly.
A better solution would not rely on the SupervisorThread pointer at all.
var
SupervisorTerminated: TEvent;
procedure TForm1.FormCreate(Sender: TObject);
begin
SupervisorTerminated := TEvent.Create(nil, True, True, '');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(SupervisorThread) then
begin
SupervisorThread.Terminate;
while SupervisorTerminated.WaitFor(1000) = wrTimeout do
CheckSynchronize;
end;
SupervisorTerminated.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(SupervisorThread) then
begin
SupervisorThread := TSupervisorThread.Create(True);
SupervisorThread.FreeOnTerminate := True;
SupervisorThread.Priority := tpNormal;
SupervisorThread.OnTerminate := SupervisorThreadTerminated;
SupervisorTerminated.ResetEvent;
SupervisorThread.Resume;
end;
end;
procedure TForm1.SupervisorThreadTerminated(Sender: TObject);
begin
SupervisorThread := nil;
SupervisorTerminated.SetEvent;
end;
procedure TCleaningThread.Execute;
begin
SupervisorTerminated.WaitFor(INFINITE);
end;
procedure TForm2.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := (SupervisorTerminated.WaitFor(0) = wrSignaled);
if not CanClose then
ShowMessage('Cannot close form because Supervisor Thread is still working');
end;

Delphi FireDac application blocking with unavailable host

Source: Delphi XE10; Os: W10; Database server: FB 2_5_1;
I created client application to connect more than one database. My application create TSource->Create TThread -> create DataModule with FDConnection.
Every TSource have own TThread which have own DataModule;
To tests I have two definitions: HostLocal and HostRemote;
My Test:
a)Run: Connection.Open for HostRemote;
b)Next Run: Connection.Open for HostLocal;
When HostRemote is unavailable than HostLocal wait for I dont know for what.
Why unavailable connection blocked another correct connection?
EDIT:
Database Server was updated to 3.0.0
Code:
begin
Application.Initialize;
Application.CreateForm(TFormMain, FormMain);
Application.Run;
end.
unit UnitFormMain;
procedure TFormMain.FormCreate(Sender: TObject);
begin
Source0 := TFormSource.Create(Self);
Source1 := TFormSource.Create(Self);
end;
procedure TFormMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeAndNil( Source0 );
FreeAndNil( Source1 );
end;
procedure TFormMain.Button1Click(Sender: TObject);
begin
Source0.Show;
Source1.Show;
Source0.ThStart( 0 );
Source1.ThStart( 1 );
end;
unit UnitFormSource;
TFormSource = class(TForm)
Memo: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
th: TMyThread;
public
procedure ThStart( value: Integer );
procedure MyTerminate( Sender: TObject );
end;
...
procedure TFormSource.FormCreate(Sender: TObject);
begin
th := TMyThread.Create( TRUE );
th.OnTerminate := MyTerminate;
th.Priority := TThreadPriority.tpLower;
th.FreeOnTerminate := TRUE;
end;
procedure TFormSource.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeAndNil( th );
Action := TCloseAction.caFree;
end;
procedure TFormSource.ThStart(value: Integer);
begin
th.SetSwitch( value );
th.Resume;
Memo.Lines.Add( TimeToStr(Now) + ' Start' );
end;
procedure TFormSource.MyTerminate(Sender: TObject);
begin
Memo.Lines.Add( TimeToStr(Now) + ' Terminate' );
end;
unit UnitThread;
TMyThread = class(TThread)
private
Switch: Integer;
dm: TDMFireBird;
protected
procedure Execute; override;
public
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
procedure SetSwitch(value: Integer);
end;
...
constructor TMyThread.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
dm := TDMFireBird.Create(nil);
Switch := -1;
end;
destructor TMyThread.Destroy;
begin
FreeAndNil(dm);
inherited;
end;
procedure TMyThread.Execute;
begin
with dm.FDConnection.Params do
begin
Clear;
Add('DriverID=FB');
end;
case Switch of
0:
with dm.FDConnection.Params do
Add('Protocol=Local');
1:
with dm.FDConnection.Params do
begin
Add('Protocol=TCPIP');
Add('Server=10.0.0.1'); // unavailable connection - server not exist
Add('Port=3050');
end;
end;
with dm.FDConnection.Params do
begin
Add('Database=D:\temp\test.fdb');
Add('User_Name=SYSDBA');
Add('Password=masterkey');
end;
try
dm.FDConnection.Open;
except
// to-do: update error message
end;
end;
procedure TMyThread.SetSwitch(value: Integer);
begin
Switch := value;
end;
unit UnitDMFireBird;
TDMFireBird = class(TDataModule)
FDConnection: TFDConnection;
FDTransaction: TFDTransaction;
private
{ Private declarations }
public
{ Public declarations }
end;
Test no.1
Code:
Source0.ThStart( 0 );
// Source1.ThStart( 1 );
Result for Source0:
14:46:20 Start
14:46:20 Terminate
Result for Source1: no result
Comment: At the same time first connection was opened;
Test no.2
Code:
Source0.ThStart( 0 );
Source1.ThStart( 1 );
Result for Source0:
14:48:16 Start
14:48:40 Terminate
Result for Source1:
14:48:16 Start
14:48:40 Terminate
Comment: Terminate for both at the same time.
My question. Why one blocked another ? Why (for test no.2) first correct connection wait for second unavailable connection? In test no.2 first connection should to open like in test no.1 -> fast, without wait.

Delphi Thread doesn't run [duplicate]

This question already has an answer here:
Delphi Access Violation when moving button on form
(1 answer)
Closed 7 years ago.
I'm trying to search for all files in all subfolders so it takes long time and application stop responding, so I used Thread (it's first time work with Threads) I read about it and I found this way to create and execute threads, but nothing happen when I call the thread, and I don't understand why I couldn't use the added components on the main form, I had to re-declare it again?
what I miss here?
type
TSearchThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
procedure AddAllFilesInDir(const Path: string; ListBox:TsListBox);
var
SR: TSearchRec;
I: Integer;
begin
if FindFirst(IncludeTrailingBackslash(Path) + '*.*', faAnyFile or faDirectory, SR) = 0 then
try
repeat
if (SR.Attr and faDirectory) = 0 then
ListBox.Items.Add(Path+'\'+SR.Name)
else if (SR.Name <> '.') and (SR.Name <> '..') then
AddAllFilesInDir(IncludeTrailingBackslash(Path) + SR.Name, ListBox);
Form1.sPanel2.Caption := Path+'\'+SR.Name;
Form1.sPanel2.Refresh;
ListBox.Refresh;
until FindNext(Sr) <> 0;
finally
FindClose(SR);
end;
end;
procedure TSearchThread.Execute;
var FileList: TsListBox;
I: Integer;
{Here I had to re-declare objects}
sDirectoryEdit1: TsDirectoryEdit;
sListBox1: TsListBox;
begin
FileList := TsListBox.Create(nil);
FileList.Parent := sListBox1;
FileList.Visible := False;
AddAllFilesInDir(sDirectoryEdit1.Text+'\', FileList);
for I := 0 to FileList.Count -1 do
if sListBox1.Items.IndexOf(FileList.Items.Strings[I]) = -1 then
sListBox1.Items.Add(FileList.Items.Strings[I]);
FileList.Clear;
end;
procedure TForm1.sDirectoryEdit1Change(Sender: TObject);
begin
TSearchThread.Create(False);
end;
Ok, let me give it a try:
First a new version of your thread:
uses
IOUtils;
type
TFileFoundEvent = procedure(const Path: string; const SearchRec: TSearchRec) of object;
TSearchThread = class(TThread)
private
FPath: string;
FSearchRec: TSearchRec;
FFileFoundEvent: TFileFoundEvent;
protected
procedure Execute; override;
public
Constructor Create(const aPath: string; aFileFoundEvent: TFileFoundEvent); reintroduce;
end;
{ TSearchThread }
constructor TSearchThread.Create(const aPath: string; aFileFoundEvent: TFileFoundEvent);
begin
// Create the Thread non suspended
inherited Create(false);
// Copy parameters to local members.
FFileFoundEvent := aFileFoundEvent;
FPath := aPath;
// Make the sure the thread frees itself after execution
FreeOnTerminate := True;
end;
procedure TSearchThread.Execute;
var
FilterPredicate: TDirectory.TFilterPredicate;
begin
// FilterPredicate is an in-place anonymous method to be called each time the TDirectory.GetFiles finds a file
FilterPredicate := function(const Path: string; const SearchRec: TSearchRec): Boolean
begin
// Since we can not access from within Synchronize we need to copy iot to a member of the class
FSearchRec := SearchRec;
// You cannot access VCL objects directly from a thread.
// So you need to call Syncronize
// For more info look in the online help
// http://docwiki.embarcadero.com/Libraries/Seattle/en/System.Classes.TThread.Synchronize
Synchronize(nil,
procedure
begin
FFileFoundEvent(FPath, FSearchRec);
end);
Result := True;
end;
// Do the search
TDirectory.GetFiles(FPath, TSearchOption.soTopDirectoryOnly, FilterPredicate)
end;
The main diffrence are that I pass a callback proceudre onto the constructor of the thread. And ofcause I uses TDirectory.GetFiles to search for files. You'll find TDirectory.GetFiles in IOUtils
Then you need to use it: Place a Listbox on your from and then call it like this :
Form definition:
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
private
procedure FileFoundEvent(const Path: string; const SearchRec: TSearchRec);
public
{ Public declarations }
end;
...
implementation
procedure TForm1.FileFoundEvent(const Path: string; const SearchRec: TSearchRec);
begin
ListBox1.Items.Add(SearchRec.Name);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
TSearchThread.Create(ExtractFilePath(Application.ExeName), FileFoundEvent);
end;
If you don't want to see the ongoing results of the searching, but rather want some speed you can create a version of the searchthread that gives you the result all at once:
uses
IOUtils;
type
TSearchThread = class(TThread)
private
FSearchPath: String;
FResultBuffer: TStrings;
protected
procedure Execute; override;
public
constructor Create(const aSearchPath: string; aResultBuffer: TStrings); overload;
end;
constructor TSearchThread.Create(const aSearchPath: string; aResultBuffer: TStrings);
begin
inherited Create(false);
FSearchPath := IncludeTrailingPathDelimiter(aSearchPath);
FResultBuffer := aResultBuffer;
FreeOnTerminate := True;
end;
procedure TSearchThread.Execute;
var
FBuffer: TStringlist;
Filename: String;
begin
Synchronize(nil,
procedure
begin
FResultBuffer.Text := 'Searching ' + FSearchPath;
end);
FBuffer := TStringlist.Create;
for Filename in TDirectory.GetFiles(FSearchPath, TSearchOption.soAllDirectories, nil) do
FBuffer.Add(Filename);
Synchronize(nil,
procedure
begin
FResultBuffer.Assign(FBuffer);
end);
FreeAndNil(FBuffer);
end;
This thread you have to call in a bit diffent way.
The form setup i still the same as before: A Listbox on a Form.
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
private
Stopwatch: TStopwatch;
procedure SearchThreadTerminate(Sender: TObject);
public
{ Public declarations }
end;
And then the implementation:
procedure TForm1.FormCreate(Sender: TObject);
begin
Stopwatch := TStopwatch.StartNew;
with TSearchThread.Create('C:\Program Files (x86)\Embarcadero\', ListBox1.Items) do
OnTerminate := SearchThreadTerminate;
end;
procedure TForm1.SearchThreadTerminate(Sender: TObject);
begin
Stopwatch.Stop;
Caption := 'Elapsed Milliseconds: ' + IntToStr(Stopwatch.ElapsedMilliseconds) + ' Files found: ' + IntToStr(ListBox1.Items.Count);
end;
The advantage of this version is speed. Updaing the screen is slow, and the first solution updated the screen for each file it found, while this one only updates the screen twice.
Try it out.

Can not press enter in more than one twebbrowser

I have seen the below msghandler code in several places now as the solution to not being able to press Enter in a twebbrowser. This solution does work as long as you're only dealing with one twebbrowser. I've provided a complete unit here for discussion. If you take two twebbrowsers and make one of them the "active" browser (see code) and navigate them each to a site for example that has a username, password and button you can enter the data in the "active" browser and press Enter successfully. If you try to use the non "active" browser not only can you not press Enter but use of tab fails as well. Whichever browser you press Enter in first is the one that will continue to work so it seems to have nothing to do with order of creation of the browsers.
How do I make my additional browsers function?
unit Main_Form;
interface
uses
Winapi.Windows, Winapi.Messages, Vcl.Controls, Vcl.Forms,
ActiveX, Vcl.OleCtrls, SHDocVw, System.Classes, Vcl.StdCtrls;
type
TForm1 = class(TForm)
NavigateBrowsers: TButton;
WebBrowser1: TWebBrowser;
WebBrowser2: TWebBrowser;
MakeBrowser1Active: TButton;
MakeBrowser2Active: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormDeactivate(Sender: TObject);
procedure NavigateBrowsersClick(Sender: TObject);
procedure MakeBrowser1ActiveClick(Sender: TObject);
procedure MakeBrowser2ActiveClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure MsgHandler(var Msg: TMsg; var Handled: Boolean);
end;
var
Form1: TForm1;
ActiveBrowser: TWebBrowser;
FOleInPlaceActiveObject: IOleInPlaceActiveObject;
SaveMessageHandler: TMessageEvent;
implementation
{$R *.dfm}
procedure TForm1.MakeBrowser1ActiveClick(Sender: TObject);
begin
ActiveBrowser := WebBrowser1;
end;
procedure TForm1.MakeBrowser2ActiveClick(Sender: TObject);
begin
ActiveBrowser := WebBrowser2;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Application.OnMessage := SaveMessageHandler;
FOleInPlaceActiveObject := nil;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
//Handle messages
SaveMessageHandler := Application.OnMessage;
Application.OnMessage := MsgHandler;
end;
procedure TForm1.FormDeactivate(Sender: TObject);
begin
Application.OnMessage := SaveMessageHandler;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FOleInPlaceActiveObject := nil;
end;
procedure TForm1.NavigateBrowsersClick(Sender: TObject);
begin
WebBrowser1.Navigate(''); //supply own
WebBrowser2.Navigate(''); //supply own
end;
procedure TForm1.MsgHandler(var Msg: TMsg; var Handled: Boolean);
const
StdKeys = [VK_BACK, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT];
var
IOIPAO: IOleInPlaceActiveObject;
Dispatch: IDispatch;
begin
//Exit if webbrowser object is nil
if ActiveBrowser = nil then
begin
Handled := False;
Exit;
end;
Handled:=(IsDialogMessage(ActiveBrowser.Handle, Msg) = True);
if (Handled) and (not ActiveBrowser.Busy) then
begin
if FOleInPlaceActiveObject = nil then
begin
Dispatch := ActiveBrowser.Application;
if Dispatch <>nil then
begin
Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
if iOIPAO <>nil then
FOleInPlaceActiveObject := iOIPAO;
end;
end;
if FOleInPlaceActiveObject <>nil then
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
(Msg.wParam in StdKeys) then
//nothing - do not pass on StdKeys
else
FOleInPlaceActiveObject.TranslateAccelerator(Msg);
end;
end;
initialization
OleInitialize(nil);
finalization
OleUninitialize;
end.
I faced the same problem as you and I use a similar message handler, FOleInPlaceActiveObject is not really needed:
procedure TForm1.MsgHandler(var Msg: TMsg; var Handled: Boolean);
const
StdKeys = [VK_BACK, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT];
var
IOIPAO: IOleInPlaceActiveObject;
begin
try
if Assigned(ActiveBrowser) then
begin
Handled:=(IsDialogMessage(ActiveBrowser.Handle, Msg) = True);
if Handled then
begin
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and (Msg.wParam in StdKeys) then
begin
//nothing - do not pass on Backspace, Left, Right, Up, Down arrows
end
else
begin
IOIPAO := (ActiveBrowser.Application as IOleInPlaceActiveObject);
if Assigned(IOIPAO)then
IOIPAO.TranslateAccelerator(Msg)
end;
end;
end;
except
Handled := False;
end;
end;
After days of searching for an answer it appears I have found something that works the same day I posted the question here. Go figure! For everyone's benefit, here is what worked.
All I had to do was assign the browser as the active control when either the user changed tabs or at the time of new tab creation. The reason for the count check in the pagecontrolchange procedure is to keep from getting a list index out of bounds on initial tab creation at startup. I do realize I probably need to change my ObjectLists over to Generics, ;)
procedure TForm1.PageControl1Change(Sender: TObject);
begin
if PageControl1.PageCount = MyBrowsersObjectList.Count then // Not adding a page
begin
ActiveBrowser := MyBrowsersObjectList[PageControl1.ActivePageIndex] as TWebBrowser;
ActiveControl := ActiveBrowser;
end;
end;
procedure TForm1.CreateBrowserTab(APage: TAdvOfficePage; NavigateTo: String);
begin
APage.Caption := 'Loading...';
ActiveBrowser := TWebBrowser.Create(nil);
MyBrowsersObjectList.Add(ActiveBrowser);
TControl(ActiveBrowser).Parent := APage;
ActiveBrowser.Align := alClient;
ActiveBrowser.RegisterAsBrowser := True;
ActiveBrowser.Tag := BrowserTabs.ActivePageIndex;
ActiveBrowser.Navigate(NavigateTo);
ActiveControl := ActiveBrowser;
end;

delphi component to animate show/hide controls during runtime

In Delphi I show/hide controls during runtime and it does not look good as controls suddenly appear or disappear , so any one know a component that can do the show/hide (using visible property) but with some sort of animation ?
thanks
Give it a go with AnimateWindow. Only for WinControls, well, it doesn't look stunning anyway:
procedure TForm1.Button1Click(Sender: TObject);
begin
if Button2.Visible then
AnimateWindow(Button2.Handle, 250, AW_HIDE or AW_VER_NEGATIVE or AW_SLIDE)
else
AnimateWindow(Button2.Handle, 250, AW_VER_POSITIVE or AW_SLIDE);
Button2.Visible := not Button2.Visible; // synch with VCL
end;
edit: A threaded version to hide show multiple controls simultaneously:
type
TForm1 = class(TForm)
..
private
procedure AnimateControls(Show: Boolean; Controls: array of TWinControl);
procedure OnAnimateEnd(Sender: TObject);
public
end;
implementation
..
type
TAnimateThr = class(TThread)
protected
procedure Execute; override;
public
FHWnd: HWND;
FShow: Boolean;
constructor Create(Handle: HWND; Show: Boolean);
end;
{ TAnimateThr }
constructor TAnimateThr.Create(Handle: HWND; Show: Boolean);
begin
FHWnd := Handle;
FShow := Show;
FreeOnTerminate := True;
inherited Create(True);
end;
procedure TAnimateThr.Execute;
begin
if FShow then
AnimateWindow(FHWnd, 250, AW_VER_POSITIVE or AW_SLIDE)
else
AnimateWindow(FHWnd, 250, AW_HIDE or AW_VER_NEGATIVE or AW_SLIDE);
end;
{ Form1 }
procedure TForm1.OnAnimateEnd(Sender: TObject);
begin
FindControl(TAnimateThr(Sender).FHWnd).Visible := TAnimateThr(Sender).FShow;
end;
procedure TForm1.AnimateControls(Show: Boolean; Controls: array of TWinControl);
var
i: Integer;
begin
for i := Low(Controls) to High(Controls) do
with TAnimateThr.Create(Controls[i].Handle, Show) do begin
OnTerminate := OnAnimateEnd;
Resume;
end;
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
AnimateControls(not Button1.Visible,
[Button1, Button2, Button3, Edit1, CheckBox1]);
end;
 

Resources