runtime/gui/IBDialogs.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{************************************************************************}

unit IBDialogs;

{$mode objfpc}{$H+}

interface

uses
{$IFDEF WINDOWS }
  Windows,
{$ELSE}
  unix,
{$ENDIF}
  SysUtils, Classes,  Controls, Forms, StdCtrls, ExtCtrls, IB, IBInternals;

type

  { TIBLCLInterface }

  TIBLCLInterface = class(TInterfacedObject,IIBGUIInterface)
    private
      FSetCursorDepth: integer;
  public
    function ServerLoginDialog(var AServerName: string;
                               var AUserName, APassword: string): Boolean;  virtual;
    function LoginDialogEx(var ADatabaseName: string;
                               var AUserName, APassword: string;
                               NameReadOnly: Boolean): Boolean; virtual;
    procedure SetCursor;
    procedure RestoreCursor;
    function CreateTimer: IIBTimerInf;
  end;

implementation

{$R IBDialogs.lfm}

uses CustomTimer;

type
  { TIBXLoginDlg }

  TIBXLoginDlg = class(TForm)
    Bevel1: TBevel;
    Button1: TButton;
    Button2: TButton;
    DatabaseName: TLabel;
    TargetCaption: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Password: TEdit;
    UserName: TEdit;
  private
    { private declarations }
  public
    { public declarations }
  end;

  { TIBTimer }

  TIBTimer = class(TInterfacedObject,IIBTimerInf)
  private
    FTimer: TCustomTimer;
  public
    constructor Create;
    destructor Destroy; override;
    function GetEnabled: boolean;
    procedure SetEnabled(Value: Boolean);
    function GetInterval: Cardinal;
    procedure SetInterval(Value: Cardinal);
    function GetOnTimer: TNotifyEvent;
    procedure SetOnTimer(Value: TNotifyEvent);
    function GetOnStartTimer: TNotifyEvent;
    procedure SetOnStartTimer(Value: TNotifyEvent);
    function GetOnStopTimer: TNotifyEvent;
    procedure SetOnStopTimer(Value: TNotifyEvent);
end;

{ TIBTimer }

constructor TIBTimer.Create;
begin
  inherited Create;
  FTimer := TCustomTimer.Create(nil);
end;

destructor TIBTimer.Destroy;
begin
  if FTimer <> nil then FTimer.Free;
  inherited Destroy;
end;

function TIBTimer.GetEnabled: boolean;
begin
  Result := FTimer.Enabled;
end;

procedure TIBTimer.SetEnabled(Value: Boolean);
begin
  FTimer.Enabled := Value;
end;

function TIBTimer.GetInterval: Cardinal;
begin
  Result := FTimer.Interval;
end;

procedure TIBTimer.SetInterval(Value: Cardinal);
begin
  FTimer.Interval := Value;
end;

function TIBTimer.GetOnTimer: TNotifyEvent;
begin
  Result := FTimer.OnTimer;
end;

procedure TIBTimer.SetOnTimer(Value: TNotifyEvent);
begin
  FTimer.OnTimer := Value;
end;

function TIBTimer.GetOnStartTimer: TNotifyEvent;
begin
  Result := FTimer.OnStartTimer;
end;

procedure TIBTimer.SetOnStartTimer(Value: TNotifyEvent);
begin
  FTimer.OnStartTimer := Value;
end;

function TIBTimer.GetOnStopTimer: TNotifyEvent;
begin
  Result := FTimer.OnStopTimer;
end;

procedure TIBTimer.SetOnStopTimer(Value: TNotifyEvent);
begin
  FTimer.OnStopTimer := Value;
end;

function TIBLCLInterface.ServerLoginDialog(var AServerName: string;
  var AUserName, APassword: string): Boolean;
var ActiveForm: TCustomForm;
begin
  ActiveForm := Screen.ActiveCustomForm;
  with TIBXLoginDlg.Create(nil) do
  try
    Caption := 'Firebird Server Login';
    TargetCaption.Caption := 'Server Name: ';
    DatabaseName.Caption := AServerName;
    UserName.Text := AUserName;
    Result := False;
    if AUserName = '' then ActiveControl := UserName;
    if ShowModal = mrOk then
    begin
      AUserName := UserName.Text;
      APassword := Password.Text;
      Result := True;
    end;
  finally
    Free;
  end;
  if ActiveForm <> nil then
  begin
    ActiveForm.SetFocus;
    Application.ProcessMessages;
  end;
end;

function TIBLCLInterface.LoginDialogEx(var ADatabaseName: string;
  var AUserName, APassword: string; NameReadOnly: Boolean): Boolean;
var ActiveForm: TCustomForm;
begin
  ActiveForm := Screen.ActiveCustomForm;
  with TIBXLoginDlg.Create(Application) do
  try
    DatabaseName.Caption := ADatabaseName;
    UserName.Text := AUserName;
    Result := False;
    if NameReadOnly then
      UserName.Enabled := False
    else
      if AUserName = '' then ActiveControl := UserName;
    if ShowModal = mrOk then
    begin
      AUserName := UserName.Text;
      APassword := Password.Text;
      Result := True;
    end
  finally
    Free;
  end;
  if (ActiveForm <> nil) and ActiveForm.CanFocus then
  begin
    ActiveForm.SetFocus;
    Application.ProcessMessages;
  end;
end;

procedure TIBLCLInterface.SetCursor;
begin
  if (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault) then
  begin
    if FSetCursorDepth = 0 then
      Screen.Cursor := crHourGlass;
    Inc(FSetCursorDepth);
  end;
end;

procedure TIBLCLInterface.RestoreCursor;
begin
  if FSetCursorDepth > 0 then
  begin
     Dec(FSetCursorDepth);
     if FSetCursorDepth = 0 then
       Screen.Cursor := crDefault
  end;
end;

function TIBLCLInterface.CreateTimer: IIBTimerInf;
begin
  Result := TIBTimer.Create;
end;

initialization
  IBGUIInterface :=  TIBLCLInterface.Create;

end.
Revision:	315
Committed:	Thu Feb 25 11:56:36 2021 UTC (3 years, 8 months ago) by tony
Content type:	text/x-pascal
File size:	6995 byte(s)
Log Message:	Updated for IBX 4 release
#	Content
1	{************************************************************************}
2	{ }
3	{ Borland Delphi Visual Component Library }
4	{ InterBase Express core components }
5	{ }
6	{ Copyright (c) 1998-2000 Inprise Corporation }
7	{ }
8	{ InterBase Express is based in part on the product }
9	{ Free IB Components, written by Gregory H. Deatz for }
10	{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11	{ Free IB Components is used under license. }
12	{ }
13	{ The contents of this file are subject to the InterBase }
14	{ Public License Version 1.0 (the "License"); you may not }
15	{ use this file except in compliance with the License. You }
16	{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	{ Software distributed under the License is distributed on }
18	{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19	{ express or implied. See the License for the specific language }
20	{ governing rights and limitations under the License. }
21	{ The Original Code was created by InterBase Software Corporation }
22	{ and its successors. }
23	{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24	{ Corporation. All Rights Reserved. }
25	{ Contributor(s): Jeff Overcash }
26	{ }
27	{************************************************************************}
28
29	unit IBDialogs;
30
31	{$mode objfpc}{$H+}
32
33	interface
34
35	uses
36	{$IFDEF WINDOWS }
37	Windows,
38	{$ELSE}
39	unix,
40	{$ENDIF}
41	SysUtils, Classes, Controls, Forms, StdCtrls, ExtCtrls, IB, IBInternals;
42
43	type
44
45	{ TIBLCLInterface }
46
47	TIBLCLInterface = class(TInterfacedObject,IIBGUIInterface)
48	private
49	FSetCursorDepth: integer;
50	public
51	function ServerLoginDialog(var AServerName: string;
52	var AUserName, APassword: string): Boolean; virtual;
53	function LoginDialogEx(var ADatabaseName: string;
54	var AUserName, APassword: string;
55	NameReadOnly: Boolean): Boolean; virtual;
56	procedure SetCursor;
57	procedure RestoreCursor;
58	function CreateTimer: IIBTimerInf;
59	end;
60
61	implementation
62
63	{$R IBDialogs.lfm}
64
65	uses CustomTimer;
66
67	type
68	{ TIBXLoginDlg }
69
70	TIBXLoginDlg = class(TForm)
71	Bevel1: TBevel;
72	Button1: TButton;
73	Button2: TButton;
74	DatabaseName: TLabel;
75	TargetCaption: TLabel;
76	Label2: TLabel;
77	Label3: TLabel;
78	Password: TEdit;
79	UserName: TEdit;
80	private
81	{ private declarations }
82	public
83	{ public declarations }
84	end;
85
86	{ TIBTimer }
87
88	TIBTimer = class(TInterfacedObject,IIBTimerInf)
89	private
90	FTimer: TCustomTimer;
91	public
92	constructor Create;
93	destructor Destroy; override;
94	function GetEnabled: boolean;
95	procedure SetEnabled(Value: Boolean);
96	function GetInterval: Cardinal;
97	procedure SetInterval(Value: Cardinal);
98	function GetOnTimer: TNotifyEvent;
99	procedure SetOnTimer(Value: TNotifyEvent);
100	function GetOnStartTimer: TNotifyEvent;
101	procedure SetOnStartTimer(Value: TNotifyEvent);
102	function GetOnStopTimer: TNotifyEvent;
103	procedure SetOnStopTimer(Value: TNotifyEvent);
104	end;
105
106	{ TIBTimer }
107
108	constructor TIBTimer.Create;
109	begin
110	inherited Create;
111	FTimer := TCustomTimer.Create(nil);
112	end;
113
114	destructor TIBTimer.Destroy;
115	begin
116	if FTimer <> nil then FTimer.Free;
117	inherited Destroy;
118	end;
119
120	function TIBTimer.GetEnabled: boolean;
121	begin
122	Result := FTimer.Enabled;
123	end;
124
125	procedure TIBTimer.SetEnabled(Value: Boolean);
126	begin
127	FTimer.Enabled := Value;
128	end;
129
130	function TIBTimer.GetInterval: Cardinal;
131	begin
132	Result := FTimer.Interval;
133	end;
134
135	procedure TIBTimer.SetInterval(Value: Cardinal);
136	begin
137	FTimer.Interval := Value;
138	end;
139
140	function TIBTimer.GetOnTimer: TNotifyEvent;
141	begin
142	Result := FTimer.OnTimer;
143	end;
144
145	procedure TIBTimer.SetOnTimer(Value: TNotifyEvent);
146	begin
147	FTimer.OnTimer := Value;
148	end;
149
150	function TIBTimer.GetOnStartTimer: TNotifyEvent;
151	begin
152	Result := FTimer.OnStartTimer;
153	end;
154
155	procedure TIBTimer.SetOnStartTimer(Value: TNotifyEvent);
156	begin
157	FTimer.OnStartTimer := Value;
158	end;
159
160	function TIBTimer.GetOnStopTimer: TNotifyEvent;
161	begin
162	Result := FTimer.OnStopTimer;
163	end;
164
165	procedure TIBTimer.SetOnStopTimer(Value: TNotifyEvent);
166	begin
167	FTimer.OnStopTimer := Value;
168	end;
169
170	function TIBLCLInterface.ServerLoginDialog(var AServerName: string;
171	var AUserName, APassword: string): Boolean;
172	var ActiveForm: TCustomForm;
173	begin
174	ActiveForm := Screen.ActiveCustomForm;
175	with TIBXLoginDlg.Create(nil) do
176	try
177	Caption := 'Firebird Server Login';
178	TargetCaption.Caption := 'Server Name: ';
179	DatabaseName.Caption := AServerName;
180	UserName.Text := AUserName;
181	Result := False;
182	if AUserName = '' then ActiveControl := UserName;
183	if ShowModal = mrOk then
184	begin
185	AUserName := UserName.Text;
186	APassword := Password.Text;
187	Result := True;
188	end;
189	finally
190	Free;
191	end;
192	if ActiveForm <> nil then
193	begin
194	ActiveForm.SetFocus;
195	Application.ProcessMessages;
196	end;
197	end;
198
199	function TIBLCLInterface.LoginDialogEx(var ADatabaseName: string;
200	var AUserName, APassword: string; NameReadOnly: Boolean): Boolean;
201	var ActiveForm: TCustomForm;
202	begin
203	ActiveForm := Screen.ActiveCustomForm;
204	with TIBXLoginDlg.Create(Application) do
205	try
206	DatabaseName.Caption := ADatabaseName;
207	UserName.Text := AUserName;
208	Result := False;
209	if NameReadOnly then
210	UserName.Enabled := False
211	else
212	if AUserName = '' then ActiveControl := UserName;
213	if ShowModal = mrOk then
214	begin
215	AUserName := UserName.Text;
216	APassword := Password.Text;
217	Result := True;
218	end
219	finally
220	Free;
221	end;
222	if (ActiveForm <> nil) and ActiveForm.CanFocus then
223	begin
224	ActiveForm.SetFocus;
225	Application.ProcessMessages;
226	end;
227	end;
228
229	procedure TIBLCLInterface.SetCursor;
230	begin
231	if (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault) then
232	begin
233	if FSetCursorDepth = 0 then
234	Screen.Cursor := crHourGlass;
235	Inc(FSetCursorDepth);
236	end;
237	end;
238
239	procedure TIBLCLInterface.RestoreCursor;
240	begin
241	if FSetCursorDepth > 0 then
242	begin
243	Dec(FSetCursorDepth);
244	if FSetCursorDepth = 0 then
245	Screen.Cursor := crDefault
246	end;
247	end;
248
249	function TIBLCLInterface.CreateTimer: IIBTimerInf;
250	begin
251	Result := TIBTimer.Create;
252	end;
253
254	initialization
255	IBGUIInterface := TIBLCLInterface.Create;
256
257	end.