ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/iblocaldb/IBXSaveDatabaseDlg.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: 3360 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 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 function SaveDatabaseToArchive(DBName: string; DBParams: TStrings; aFilename: string): boolean;
60
61 implementation
62
63 uses Registry;
64
65 {$IFDEF WINDOWS}
66 const
67 rgShellFolders = 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
68 rgPersonal = 'Personal';
69 {$ENDIF}
70
71 function SaveDatabaseToArchive(DBName: string; DBParams: TStrings;
72 aFilename: string): boolean;
73 begin
74 with TSaveDatabaseDlg.Create(Application) do
75 try
76 if aFilename = '' then
77 begin
78 SaveDialog1.InitialDir := GetUserDir;
79 {$IFDEF WINDOWS}
80 with TRegistry.Create do
81 try
82 if OpenKey(rgShellFolders,false) then
83 begin
84 SaveDialog1.InitialDir := ReadString(rgPersonal)
85 end;
86 finally
87 Free
88 end;
89 {$ENDIF}
90 if SaveDialog1.Execute then
91 aFilename := SaveDialog1.FileName
92 else
93 Exit;
94 end;
95 IBBackupService1.SetDBParams(DBParams);
96 IBBackupService1.BackupFile.Clear;
97 IBBackupService1.DatabaseName := DBName;
98 IBBackupService1.BackupFile.Add(aFilename);
99 Result := ShowModal = mrOK
100 finally
101 Free
102 end;
103 end;
104
105 {$R *.lfm}
106
107 { TSaveDatabaseDlg }
108
109 procedure TSaveDatabaseDlg.FormShow(Sender: TObject);
110 begin
111 Status.Caption := '';
112 Application.QueueAsyncCall(@DoBackup,0);
113 end;
114
115 procedure TSaveDatabaseDlg.Timer1Timer(Sender: TObject);
116 begin
117 Timer1.Interval := 0;
118 if FileExists(IBBackupService1.BackupFile[0]) then
119 ModalResult := mrOK
120 else
121 ModalResult := mrCancel
122 end;
123
124 procedure TSaveDatabaseDlg.DoBackup(Data: PtrInt);
125 begin
126 try
127 IBBackupService1.Active := true;
128 IBBackupService1.ServiceStart;
129 try
130 while not IBBackupService1.Eof do
131 begin
132 Status.Caption := IBBackupService1.GetNextLine;
133 Application.ProcessMessages
134 end;
135 finally
136 IBBackupService1.Active := false
137 end;
138 except
139 ModalResult := mrCancel;
140 raise
141 end;
142 Timer1.Interval := 500;
143 end;
144
145 end.