ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/iblocaldb/IBXCreateDatabaseDlg.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: 3677 byte(s)
Log Message:
Fixes merged into public release

File Contents

# Content
1 (*
2 * IBX For Lazarus (Firebird Express)
3 *
4 * The contents of this file are subject to the Initial Developer's
5 * Public License Version 1.0 (the "License"); you may not use this
6 * file except in compliance with the License. You may obtain a copy
7 * of the License here:
8 *
9 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
10 *
11 * Software distributed under the License is distributed on an "AS
12 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13 * implied. See the License for the specific language governing rights
14 * and limitations under the License.
15 *
16 * The Initial Developer of the Original Code is Tony Whyman.
17 *
18 * The Original Code is (C) 2014 Tony Whyman, MWA Software
19 * (http://www.mwasoftware.co.uk).
20 *
21 * All Rights Reserved.
22 *
23 * Contributor(s): ______________________________________.
24 *
25 *)
26 unit IBXCreateDatabaseDlg;
27
28 {$mode objfpc}{$H+}
29
30 interface
31
32 uses
33 LCLIntf, LCLType, SysUtils, Variants, Classes, Graphics, Controls, Forms,
34 Dialogs, IBServices, StdCtrls, ExtCtrls;
35
36 type
37
38 { TCreateDatabaseDlg }
39
40 TCreateDatabaseDlg = class(TForm)
41 IBRestoreService1: TIBRestoreService;
42 Panel1: TPanel;
43 Status: TLabel;
44 Label1: TLabel;
45 OpenDialog1: TOpenDialog;
46 Timer1: TTimer;
47 procedure FormShow(Sender: TObject);
48 procedure Timer1Timer(Sender: TObject);
49 private
50 { Private declarations }
51 procedure DoRestore(Data: PtrInt);
52 public
53 { Public declarations }
54 end;
55
56 var
57 CreateDatabaseDlg: TCreateDatabaseDlg;
58
59 function RestoreDatabaseFromArchive(DBName: string; DBParams: TStrings; aFilename: string): boolean;
60
61 function CreateNewDatabase(DBName: string; DBParams: TStrings; DBArchive: string): boolean;
62
63 implementation
64
65 function RestoreDatabaseFromArchive(DBName: string; DBParams: TStrings;
66 aFilename: string): boolean;
67 begin
68 with TCreateDatabaseDlg.Create(Application) do
69 try
70 if (aFilename = '') or not FileExists(aFileName) then
71 begin
72 OpenDialog1.InitialDir := GetUserDir;
73 if OpenDialog1.Execute then
74 aFilename := OpenDialog1.FileName
75 else
76 Exit;
77 end;
78 IBRestoreService1.SetDBParams(DBParams);
79 IBRestoreService1.BackupFile.Clear;
80 IBRestoreService1.DatabaseName.Clear;
81 IBRestoreService1.Options := [replace];
82 IBRestoreService1.BackupFile.Add(aFilename);
83 IBRestoreService1.DatabaseName.Add(DBName);
84 Result := ShowModal = mrOK;
85 finally
86 Free
87 end;
88 end;
89
90 function CreateNewDatabase(DBName: string; DBParams: TStrings; DBArchive: string
91 ): boolean;
92 begin
93 with TCreateDatabaseDlg.Create(Application) do
94 try
95 IBRestoreService1.SetDBParams(DBParams);
96 IBRestoreService1.BackupFile.Clear;
97 IBRestoreService1.DatabaseName.Clear;
98 IBRestoreService1.Options := [CreateNewDB];
99 IBRestoreService1.BackupFile.Add(DBArchive);
100 IBRestoreService1.DatabaseName.Add(DBName);
101 Result := ShowModal = mrOK;
102 finally
103 Free
104 end
105 end;
106
107 {$R *.lfm}
108
109 procedure TCreateDatabaseDlg.FormShow(Sender: TObject);
110 begin
111 Status.Caption := '';
112 Application.QueueAsyncCall(@DoRestore,0)
113 end;
114
115 procedure TCreateDatabaseDlg.Timer1Timer(Sender: TObject);
116 begin
117 Timer1.Interval := 0;
118 if FileExists(IBRestoreService1.DatabaseName[0]) then
119 begin
120 ModalResult := mrOK
121 end
122 else
123 ModalResult := mrCancel
124 end;
125
126 procedure TCreateDatabaseDlg.DoRestore(Data: PtrInt);
127 begin
128 try
129 IBRestoreService1.Active := true;
130 IBRestoreService1.ServiceStart;
131 try
132 while not IBRestoreService1.Eof do
133 begin
134 Status.Caption := Trim(IBRestoreService1.GetNextLine);
135 Application.ProcessMessages
136 end;
137 finally
138 IBRestoreService1.Active := false
139 end;
140 Timer1.Interval := 500;
141 except on E:Exception do
142 raise
143 end;
144 end;
145
146 end.