ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDialogs.pas
Revision: 80
Committed: Mon Jan 1 11:31:07 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 5127 byte(s)
Log Message:
Fixes merged into public release

File Contents

# 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,
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.