ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBDialogs.pas
Revision: 39
Committed: Tue May 17 08:14:52 2016 UTC (7 years, 10 months ago) by tony
Content type: text/x-pascal
File size: 4759 byte(s)
Log Message:
Committing updates for Release R1-4-1

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, Graphics, Controls,
42 Forms, StdCtrls, ExtCtrls, IB;
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 begin
87 with TIBXLoginDlg.Create(nil) do
88 try
89 Caption := 'Firebird Server Login';
90 TargetCaption.Caption := 'Server Name: ';
91 DatabaseName.Caption := AServerName;
92 UserName.Text := AUserName;
93 Result := False;
94 if AUserName = '' then ActiveControl := UserName;
95 if ShowModal = mrOk then
96 begin
97 AUserName := UserName.Text;
98 APassword := Password.Text;
99 Result := True;
100 end;
101 finally
102 Free;
103 end;
104 end;
105
106 function TIBLCLInterface.LoginDialogEx(var ADatabaseName: string;
107 var AUserName, APassword: string; NameReadOnly: Boolean): Boolean;
108 begin
109 with TIBXLoginDlg.Create(Application) do
110 try
111 DatabaseName.Caption := ADatabaseName;
112 UserName.Text := AUserName;
113 Result := False;
114 if NameReadOnly then
115 UserName.Enabled := False
116 else
117 if AUserName = '' then ActiveControl := UserName;
118 if ShowModal = mrOk then
119 begin
120 AUserName := UserName.Text;
121 APassword := Password.Text;
122 Result := True;
123 end
124 finally
125 Free;
126 end;
127 end;
128
129 procedure TIBLCLInterface.SetCursor;
130 begin
131 if (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault) then
132 begin
133 if FSetCursorDepth = 0 then
134 Screen.Cursor := crHourGlass;
135 Inc(FSetCursorDepth);
136 end;
137 end;
138
139 procedure TIBLCLInterface.RestoreCursor;
140 begin
141 if FSetCursorDepth > 0 then
142 begin
143 Dec(FSetCursorDepth);
144 if FSetCursorDepth = 0 then
145 Screen.Cursor := crDefault
146 end;
147 end;
148
149 initialization
150 IBGUIInterface := TIBLCLInterface.Create;
151
152 end.