ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/iblocaldb/IBXSaveDatabaseDlg.pas
Revision: 37
Committed: Mon Feb 15 14:44:25 2016 UTC (8 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 2301 byte(s)
Log Message:
Committing updates for Release R1-4-0

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 IBXSaveDatabaseDlg;
27
28 interface
29
30 {$mode objfpc}{$H+}
31
32 uses
33 LCLIntf, LCLType, SysUtils, Variants, Classes, Graphics, Controls, Forms,
34 Dialogs, IBServices, StdCtrls, ExtCtrls;
35
36 type
37
38 { TSaveDatabaseDlg }
39
40 TSaveDatabaseDlg = class(TForm)
41 Panel1: TPanel;
42 Status: TLabel;
43 Label1: TLabel;
44 SaveDialog1: TSaveDialog;
45 IBBackupService1: TIBBackupService;
46 Timer1: TTimer;
47 procedure FormShow(Sender: TObject);
48 procedure Timer1Timer(Sender: TObject);
49 private
50 { Private declarations }
51 procedure DoBackup(Data: PtrInt);
52 public
53 { Public declarations }
54 end;
55
56 var
57 SaveDatabaseDlg: TSaveDatabaseDlg;
58
59 implementation
60
61 {$R *.lfm}
62
63 { TSaveDatabaseDlg }
64
65 procedure TSaveDatabaseDlg.FormShow(Sender: TObject);
66 begin
67 Status.Caption := '';
68 Application.QueueAsyncCall(@DoBackup,0);
69 end;
70
71 procedure TSaveDatabaseDlg.Timer1Timer(Sender: TObject);
72 begin
73 Timer1.Interval := 0;
74 if FileExists(IBBackupService1.BackupFile[0]) then
75 ModalResult := mrOK
76 else
77 ModalResult := mrCancel
78 end;
79
80 procedure TSaveDatabaseDlg.DoBackup(Data: PtrInt);
81 begin
82 try
83 IBBackupService1.Active := true;
84 IBBackupService1.ServiceStart;
85 try
86 while not IBBackupService1.Eof do
87 begin
88 Status.Caption := IBBackupService1.GetNextLine;
89 Application.ProcessMessages
90 end;
91 finally
92 IBBackupService1.Active := false
93 end;
94 except
95 ModalResult := mrCancel;
96 raise
97 end;
98 Timer1.Interval := 500;
99 end;
100
101 end.