ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/iblocaldb/gui/IBXCreateDatabaseFromSQLDlgUnit.pas
Revision: 272
Committed: Mon Feb 4 13:34:37 2019 UTC (5 years, 10 months ago) by tony
Content type: text/x-pascal
File size: 3363 byte(s)
Log Message:
Fixes merged

File Contents

# User Rev Content
1 tony 209 (*
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) 2015 Tony Whyman, MWA Software
19     * (http://www.mwasoftware.co.uk).
20     *
21     * All Rights Reserved.
22     *
23     * Contributor(s): ______________________________________.
24     *
25     *)
26    
27     unit IBXCreateDatabaseFromSQLDlgUnit;
28    
29     {$mode objfpc}{$H+}
30    
31     interface
32    
33     uses
34     Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
35     StdCtrls, ComCtrls, ibxscript, IB, IBDatabase;
36    
37     type
38    
39     { TIBXCreateDatabaseFromSQLDlg }
40    
41     TIBXCreateDatabaseFromSQLDlg = class(TForm)
42     Bevel1: TBevel;
43 tony 272 IBTransaction1: TIBTransaction;
44 tony 209 IBXScript: TIBXScript;
45     Label1: TLabel;
46     ProgressBar: TProgressBar;
47     procedure FormShow(Sender: TObject);
48     procedure IBXScriptCreateDatabase(Sender: TObject;
49     var DatabaseFileName: string);
50     procedure IBXScriptProgressEvent(Sender: TObject; Reset: boolean;
51     value: integer);
52     private
53     FDatabasePath: string;
54     FFileName: string;
55 tony 272 FCompletedOK: integer;
56 tony 209 procedure DoRunScript(Data: PtrInt);
57     public
58     property FileName: string read FFileName write FFileName;
59     property DatabasePath: string read FDatabasePath write FDatabasePath;
60     end;
61    
62     var
63     IBXCreateDatabaseFromSQLDlg: TIBXCreateDatabaseFromSQLDlg;
64    
65     function CreateNewDatabase(aDatabase: TIBDatabase; DBArchive: string): boolean;
66    
67     implementation
68    
69     uses IBErrorCodes;
70    
71     function CreateNewDatabase(aDatabase: TIBDatabase;
72     DBArchive: string): boolean;
73     begin
74     with TIBXCreateDatabaseFromSQLDlg.Create(Application) do
75     try
76     FileName := DBArchive;
77     IBXScript.Database := aDatabase;
78 tony 272 IBTransaction1.DefaultDatabase := aDatabase;
79     IBXScript.Transaction := IBTransaction1;
80     DatabasePath := aDatabase.Attachment.GetConnectString;
81     ShowModal;
82     Result := FCompletedOK <> 0;
83 tony 209 finally
84     Free
85     end
86     end;
87    
88     {$R *.lfm}
89    
90     { TIBXCreateDatabaseFromSQLDlg }
91    
92     procedure TIBXCreateDatabaseFromSQLDlg.IBXScriptProgressEvent(Sender: TObject;
93     Reset: boolean; value: integer);
94     begin
95     if Reset then
96     ProgressBar.Max := value
97     else
98 tony 272 ProgressBar.StepBy(Value);
99 tony 209 Application.ProcessMessages;
100     end;
101    
102     procedure TIBXCreateDatabaseFromSQLDlg.DoRunScript(Data: PtrInt);
103     begin
104     try
105 tony 272 if IBXScript.RunScript(FileName) then
106     FCompletedOK := 1;
107 tony 209 with IBXScript.Transaction do
108     if InTransaction then Commit;
109     except on E:Exception do
110     begin
111     MessageDlg(E.Message,mtError,[mbOK],0);
112     end;
113     end;
114 tony 272 Close;
115 tony 209 end;
116    
117     procedure TIBXCreateDatabaseFromSQLDlg.FormShow(Sender: TObject);
118     begin
119     ProgressBar.Position := 0;
120     Application.QueueAsyncCall(@DoRunScript,0);
121     end;
122    
123     procedure TIBXCreateDatabaseFromSQLDlg.IBXScriptCreateDatabase(Sender: TObject;
124     var DatabaseFileName: string);
125     begin
126     DatabaseFileName := DatabasePath;
127     end;
128    
129     end.
130