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, IBTypes;

type

  { TIBLCLInterface }

  TIBLCLInterface = class(TInterfacedObject,TIBGUIInterface)
    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;
  end;

implementation

{$R IBDialogs.lfm}

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;

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;

initialization
  IBGUIInterface :=  TIBLCLInterface.Create;

end.
Revision:	209
Committed:	Wed Mar 14 12:48:51 2018 UTC (6 years, 8 months ago) by tony
Content type:	text/x-pascal
File size:	5127 byte(s)
Log Message:	Fixes Merged
#	User	Rev	Content
1	tony	209	{************************************************************************}
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,
42			Forms, StdCtrls, ExtCtrls, IB, IBTypes;
43
44			type
45
46			{ TIBLCLInterface }
47
48			TIBLCLInterface = class(TInterfacedObject,TIBGUIInterface)
49			private
50			FSetCursorDepth: integer;
51			public
52			function ServerLoginDialog(var AServerName: string;
53			var AUserName, APassword: string): Boolean; virtual;
54			function LoginDialogEx(var ADatabaseName: string;
55			var AUserName, APassword: string;
56			NameReadOnly: Boolean): Boolean; virtual;
57			procedure SetCursor;
58			procedure RestoreCursor;
59			end;
60
61			implementation
62
63			{$R IBDialogs.lfm}
64
65			type
66			{ TIBXLoginDlg }
67
68			TIBXLoginDlg = class(TForm)
69			Bevel1: TBevel;
70			Button1: TButton;
71			Button2: TButton;
72			DatabaseName: TLabel;
73			TargetCaption: TLabel;
74			Label2: TLabel;
75			Label3: TLabel;
76			Password: TEdit;
77			UserName: TEdit;
78			private
79			{ private declarations }
80			public
81			{ public declarations }
82			end;
83
84			function TIBLCLInterface.ServerLoginDialog(var AServerName: string;
85			var AUserName, APassword: string): Boolean;
86			var ActiveForm: TCustomForm;
87			begin
88			ActiveForm := Screen.ActiveCustomForm;
89			with TIBXLoginDlg.Create(nil) do
90			try
91			Caption := 'Firebird Server Login';
92			TargetCaption.Caption := 'Server Name: ';
93			DatabaseName.Caption := AServerName;
94			UserName.Text := AUserName;
95			Result := False;
96			if AUserName = '' then ActiveControl := UserName;
97			if ShowModal = mrOk then
98			begin
99			AUserName := UserName.Text;
100			APassword := Password.Text;
101			Result := True;
102			end;
103			finally
104			Free;
105			end;
106			if ActiveForm <> nil then
107			begin
108			ActiveForm.SetFocus;
109			Application.ProcessMessages;
110			end;
111			end;
112
113			function TIBLCLInterface.LoginDialogEx(var ADatabaseName: string;
114			var AUserName, APassword: string; NameReadOnly: Boolean): Boolean;
115			var ActiveForm: TCustomForm;
116			begin
117			ActiveForm := Screen.ActiveCustomForm;
118			with TIBXLoginDlg.Create(Application) do
119			try
120			DatabaseName.Caption := ADatabaseName;
121			UserName.Text := AUserName;
122			Result := False;
123			if NameReadOnly then
124			UserName.Enabled := False
125			else
126			if AUserName = '' then ActiveControl := UserName;
127			if ShowModal = mrOk then
128			begin
129			AUserName := UserName.Text;
130			APassword := Password.Text;
131			Result := True;
132			end
133			finally
134			Free;
135			end;
136			if (ActiveForm <> nil) and ActiveForm.CanFocus then
137			begin
138			ActiveForm.SetFocus;
139			Application.ProcessMessages;
140			end;
141			end;
142
143			procedure TIBLCLInterface.SetCursor;
144			begin
145			if (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault) then
146			begin
147			if FSetCursorDepth = 0 then
148			Screen.Cursor := crHourGlass;
149			Inc(FSetCursorDepth);
150			end;
151			end;
152
153			procedure TIBLCLInterface.RestoreCursor;
154			begin
155			if FSetCursorDepth > 0 then
156			begin
157			Dec(FSetCursorDepth);
158			if FSetCursorDepth = 0 then
159			Screen.Cursor := crDefault
160			end;
161			end;
162
163			initialization
164			IBGUIInterface := TIBLCLInterface.Create;
165
166			end.