612 lines
16 KiB
ObjectPascal
612 lines
16 KiB
ObjectPascal
(*
|
|
Simple Almost-Real-Life example of the Synopse mORMot Framework.
|
|
Written by Michal Gajek, http://migajek.com/
|
|
|
|
The demo doesn't depend on any 3rd party libraries nor components.
|
|
|
|
ToDO:
|
|
[ ] in each ListBox / ComboBox "Object", instead of ID, keep RecordRef ?
|
|
*)
|
|
|
|
unit Unit1;
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
|
Dialogs, ComCtrls, StdCtrls, CheckLst, Grids,
|
|
|
|
SynCommons, mORMotUI, mORMot,
|
|
SynSQLite3Static,
|
|
|
|
uCustomer;
|
|
|
|
type
|
|
TForm1 = class(TForm)
|
|
PageControl1: TPageControl;
|
|
TabSheet1: TTabSheet;
|
|
TabSheet2: TTabSheet;
|
|
lbCustomers: TListBox;
|
|
GroupBox1: TGroupBox;
|
|
Label1: TLabel;
|
|
Label2: TLabel;
|
|
lblName: TLabel;
|
|
lblSurname: TLabel;
|
|
btnAddCustomer: TButton;
|
|
lbTasks: TListBox;
|
|
btnNewTask: TButton;
|
|
cbCustomers: TComboBox;
|
|
lbCustomerTasks: TListBox;
|
|
Label3: TLabel;
|
|
gbEditTask: TGroupBox;
|
|
cbTaskPriority: TComboBox;
|
|
CheckListBox1: TCheckListBox;
|
|
TabSheet3: TTabSheet;
|
|
Label4: TLabel;
|
|
Label5: TLabel;
|
|
Label6: TLabel;
|
|
Label7: TLabel;
|
|
TabSheet4: TTabSheet;
|
|
dgTable: TDrawGrid;
|
|
edtQuery: TComboBox;
|
|
tbUsers: TTabSheet;
|
|
Label8: TLabel;
|
|
lbUsers: TListBox;
|
|
GroupBox2: TGroupBox;
|
|
clbRoles: TCheckListBox;
|
|
btnAddUser: TButton;
|
|
dtRoleExpires: TDateTimePicker;
|
|
Label9: TLabel;
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure btnAddCustomerClick(Sender: TObject);
|
|
procedure lbCustomersClick(Sender: TObject);
|
|
procedure btnNewTaskClick(Sender: TObject);
|
|
procedure cbCustomersClick(Sender: TObject);
|
|
procedure lbTasksClick(Sender: TObject);
|
|
procedure cbTaskPriorityChange(Sender: TObject);
|
|
procedure CheckListBox1ClickCheck(Sender: TObject);
|
|
procedure Label7Click(Sender: TObject);
|
|
procedure edtQueryKeyDown(Sender: TObject; var Key: Word;
|
|
Shift: TShiftState);
|
|
procedure btnAddUserClick(Sender: TObject);
|
|
procedure lbUsersClick(Sender: TObject);
|
|
procedure clbRolesClickCheck(Sender: TObject);
|
|
procedure clbRolesClick(Sender: TObject);
|
|
procedure dtRoleExpiresChange(Sender: TObject);
|
|
procedure PageControl1Change(Sender: TObject);
|
|
private
|
|
{ Private declarations }
|
|
function LoadCustomer(const ACustomerID: integer): TSQLCustomer;
|
|
procedure DisplayCustomerInfo(const ACustomer: TSQLCustomer); overload;
|
|
procedure DisplayCustomerInfo(const ACustomerID: integer); overload;
|
|
procedure FillCustomersList(const AList: TStrings; const AClear: boolean = true);
|
|
|
|
function LoadTask(const ATaskID: integer): TSQLTask;
|
|
procedure FillTasksList(const AList: TStrings; ATasks: TSQLTask);
|
|
procedure LoadTasksForCustomer(const ACustomer: TSQLCustomer; const AList: TStrings);
|
|
|
|
procedure LoadQueryHistory();
|
|
|
|
procedure FillRolesList(const AList: TStrings);
|
|
procedure FillUsersList(const AList: TStrings; const AClear: boolean = true);
|
|
public
|
|
{ Public declarations }
|
|
end;
|
|
|
|
var
|
|
Form1: TForm1;
|
|
|
|
implementation
|
|
|
|
uses ShellApi, DateUtils, uQueryHistory, Math;
|
|
|
|
{$R *.dfm}
|
|
|
|
// loads customer data into "Details" box. Pass nil in order to clear the box.
|
|
procedure TForm1.DisplayCustomerInfo(const ACustomer: TSQLCustomer);
|
|
begin
|
|
if ACustomer <> nil then
|
|
begin
|
|
lblName.Caption:= UTF8ToString(ACustomer.Firstname);
|
|
lblSurname.Caption:= UTF8ToString(ACustomer.Surname);
|
|
LoadTasksForCustomer(ACustomer, lbCustomerTasks.Items);
|
|
end
|
|
else
|
|
begin
|
|
lblName.Caption:= '';
|
|
lblSurname.Caption:= '';
|
|
end;
|
|
end;
|
|
|
|
procedure TForm1.DisplayCustomerInfo(const ACustomerID: integer);
|
|
var
|
|
cust: TSQLCustomer;
|
|
begin
|
|
cust:= LoadCustomer(ACustomerID);
|
|
try
|
|
DisplayCustomerInfo(cust);
|
|
finally
|
|
FreeAndNil(cust);
|
|
end;
|
|
end;
|
|
|
|
function TForm1.LoadCustomer(const ACustomerID: integer): TSQLCustomer;
|
|
begin
|
|
result:= TSQLCustomer.Create(globalClient, ACustomerID);
|
|
end;
|
|
|
|
// loads a list of customers to a AList
|
|
procedure TForm1.FillCustomersList(const AList: TStrings; const AClear: boolean = true);
|
|
var
|
|
cust: TSQLCustomer;
|
|
begin
|
|
// load all the customers
|
|
try
|
|
AList.BeginUpdate();
|
|
if AClear then
|
|
AList.Clear();
|
|
cust:= TSQLCustomer.CreateAndFillPrepare(globalClient, '');
|
|
while cust.FillOne do
|
|
AList.AddObject(Format('%s, %s', [UTF8ToString(cust.Surname), UTF8ToString(cust.Firstname)]), Pointer(cust.ID)); // we keep integer ID as "Data" object
|
|
|
|
finally
|
|
AList.EndUpdate();
|
|
FreeAndNil(cust);
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TForm1.FillTasksList(const AList: TStrings; ATasks: TSQLTask);
|
|
var
|
|
freeAfter: boolean;
|
|
begin
|
|
freeAfter:= ATasks = nil;
|
|
if freeAfter then
|
|
ATasks:= TSQLTask.CreateAndFillPrepare(globalClient, '');
|
|
|
|
try
|
|
AList.BeginUpdate();
|
|
AList.Clear();
|
|
while ATasks.FillOne do
|
|
AList.AddObject(Format('%s', [UTF8ToString(ATasks.Text)]), Pointer(ATasks.ID));
|
|
finally
|
|
AList.EndUpdate();
|
|
if freeAfter then
|
|
FreeAndNil(ATasks);
|
|
end;
|
|
end;
|
|
|
|
procedure TForm1.LoadTasksForCustomer(const ACustomer: TSQLCustomer; const AList: TStrings);
|
|
var
|
|
task: TSQLTask;
|
|
fIds: TIDDynArray;
|
|
begin
|
|
ACustomer.Tasks.DestGet(globalClient, ACustomer.ID, fIds);
|
|
task:= TSQLTask.CreateAndFillPrepare(globalClient, TInt64DynArray(fIds));
|
|
AList.BeginUpdate();
|
|
AList.Clear();
|
|
try
|
|
while task.FillOne do
|
|
AList.AddObject(Format('%s', [UTF8ToString(task.Text)]), Pointer(task.id));
|
|
finally
|
|
AList.EndUpdate();
|
|
FreeAndNil(task);
|
|
end;
|
|
end;
|
|
|
|
function TForm1.LoadTask(const ATaskID: integer): TSQLTask;
|
|
begin
|
|
result:= TSQLTask.Create(globalClient, ATaskID);
|
|
end;
|
|
|
|
procedure TForm1.FormCreate(Sender: TObject);
|
|
begin
|
|
// clear all the fields.
|
|
DisplayCustomerInfo(nil);
|
|
FillCustomersList(lbCustomers.Items);
|
|
cbCustomers.AddItem('<Any customer>', nil);
|
|
cbCustomers.ItemIndex:= 0;
|
|
FillCustomersList(cbCustomers.Items, false);
|
|
cbCustomersClick(nil);
|
|
|
|
LoadQueryHistory();
|
|
|
|
FillRolesList(clbRoles.Items);
|
|
FillUsersList(lbUsers.Items);
|
|
|
|
dtRoleExpires.DateTime:= IncMonth(Now(), 1);
|
|
end;
|
|
|
|
procedure TForm1.btnAddCustomerClick(Sender: TObject);
|
|
var
|
|
cust: TSQLCustomer;
|
|
begin
|
|
|
|
cust:= TSQLCustomer.Create;
|
|
try
|
|
cust.Firstname:= StringToUTF8(InputBox('First name', 'Customer first name', 'John'));
|
|
cust.Surname:= StringToUTF8(InputBox('Surname', 'Customer surname', 'Doe'));
|
|
if (cust.Firstname <> '') and (cust.Surname <> '') then
|
|
globalClient.Add(cust, true);
|
|
finally
|
|
FreeAndNil(cust);
|
|
FillCustomersList(lbCustomers.Items);
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TForm1.lbCustomersClick(Sender: TObject);
|
|
var
|
|
cust: TSQLCustomer;
|
|
begin
|
|
if lbCustomers.ItemIndex <> -1 then
|
|
begin
|
|
// since we store record ID as object, now we can load it
|
|
if lbCustomers.Items.Objects[lbCustomers.ItemIndex] <> nil then
|
|
begin
|
|
cust:= LoadCustomer( Integer(lbCustomers.Items.Objects[lbCustomers.ItemIndex]) );
|
|
DisplayCustomerInfo(cust);
|
|
FreeAndNil(cust);
|
|
end
|
|
end
|
|
else
|
|
DisplayCustomerInfo(nil);
|
|
|
|
end;
|
|
|
|
procedure TForm1.btnNewTaskClick(Sender: TObject);
|
|
var
|
|
task: TSQLTask;
|
|
begin
|
|
|
|
task:= TSQLTask.Create();
|
|
try
|
|
task.Text:= StringToUTF8(InputBox('Text', 'Task description', ''));
|
|
task.Priority:= tpNormal;
|
|
if (task.Text <> '') then
|
|
globalClient.Add(task, true);
|
|
finally
|
|
FreeAndNil(task);
|
|
FillTasksList(lbTasks.Items, nil);
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TForm1.cbCustomersClick(Sender: TObject);
|
|
var
|
|
cust: TSQLCustomer;
|
|
begin
|
|
gbEditTask.Visible:= false;
|
|
if cbCustomers.ItemIndex <> -1 then
|
|
begin
|
|
// since we store record ID as object, now we can load it
|
|
if cbCustomers.Items.Objects[cbCustomers.ItemIndex] <> nil then
|
|
begin
|
|
cust:= LoadCustomer( Integer(cbCustomers.Items.Objects[cbCustomers.ItemIndex]) );
|
|
LoadTasksForCustomer(cust, lbTasks.Items);
|
|
FreeAndNil(cust);
|
|
end
|
|
else
|
|
FillTasksList(lbTasks.Items, nil);
|
|
end
|
|
else
|
|
FillTasksList(lbTasks.Items, nil);
|
|
end;
|
|
|
|
procedure TForm1.lbTasksClick(Sender: TObject);
|
|
var
|
|
task: TSQLTask;
|
|
cust: TSQLCustomer;
|
|
clientsIds: TIDDynArray;
|
|
i, j: integer;
|
|
begin
|
|
gbEditTask.Visible:= lbTasks.ItemIndex <> -1;
|
|
if not gbEditTask.Visible then
|
|
exit;
|
|
|
|
gbEditTask.Visible:= lbTasks.Items.Objects[lbTasks.ItemIndex] <> nil;
|
|
if not gbEditTask.Visible then
|
|
exit;
|
|
|
|
task:= LoadTask(integer(lbTasks.Items.Objects[lbTasks.ItemIndex]));
|
|
cbTaskPriority.ItemIndex:= Ord(task.Priority);
|
|
cbTaskPriority.Tag:= task.ID;
|
|
|
|
FillCustomersList(CheckListBox1.Items, true);
|
|
CheckListBox1.Tag:= task.ID;
|
|
// load list of customers assigned to the given task
|
|
cust:= TSQLCustomer.Create();
|
|
try
|
|
cust.Tasks.SourceGet(globalClient, task.ID, clientsIds);
|
|
for i:= low(clientsIds) to high(clientsIds) do
|
|
begin
|
|
|
|
// find the client on the list (by ID)
|
|
for j:= 0 to CheckListBox1.Count -1 do
|
|
if Integer(CheckListBox1.Items.Objects[j]) = clientsIds[i] then
|
|
CheckListBox1.Checked[j]:= true;
|
|
end;
|
|
finally
|
|
cust.Free();
|
|
FreeAndNil(task);
|
|
end;
|
|
end;
|
|
|
|
procedure TForm1.cbTaskPriorityChange(Sender: TObject);
|
|
var
|
|
task: TSQLTask;
|
|
begin
|
|
if cbTaskPriority.Tag > 0 then
|
|
begin
|
|
task:= LoadTask(cbTaskPriority.Tag);
|
|
if task <> nil then
|
|
begin
|
|
task.Priority:= TSQLTaskPriority(cbTaskPriority.ItemIndex);
|
|
globalClient.Update(task);
|
|
task.Free;
|
|
end;
|
|
end
|
|
end;
|
|
|
|
procedure TForm1.CheckListBox1ClickCheck(Sender: TObject);
|
|
var
|
|
task: TSQLTask;
|
|
cust: TSQLCustomer;
|
|
begin
|
|
// first, load the Task based on ID (stored in TAG property)
|
|
if (sender as TComponent).Tag > 0 then
|
|
begin
|
|
task:= LoadTask((sender as TComponent).Tag);
|
|
if task <> nil then
|
|
begin
|
|
|
|
// now load the customer from the list
|
|
if CheckListBox1.ItemIndex > - 1 then
|
|
begin
|
|
cust:= LoadCustomer(Integer(CheckListBox1.Items.Objects[CheckListBox1.ItemIndex]));
|
|
if cust <> nil then
|
|
begin
|
|
if CheckListBox1.Checked[CheckListBox1.ItemIndex] then
|
|
cust.Tasks.ManyAdd(globalClient, cust.ID, task.ID, true)
|
|
else
|
|
cust.Tasks.ManyDelete(globalClient, cust.ID, task.ID);
|
|
|
|
FreeAndNil(cust);
|
|
end;
|
|
end;
|
|
FreeAndNil(task);
|
|
end;
|
|
end
|
|
|
|
end;
|
|
|
|
procedure TForm1.Label7Click(Sender: TObject);
|
|
begin
|
|
ShellExecute(0, 'open', 'http://code.google.com/p/synopse-sqlite-demo/', '', '', SW_SHOWNORMAL);
|
|
end;
|
|
|
|
procedure TForm1.edtQueryKeyDown(Sender: TObject; var Key: Word;
|
|
Shift: TShiftState);
|
|
var
|
|
data: TSQLTable;
|
|
hist: TSQLQueryHistory;
|
|
begin
|
|
if Key = VK_RETURN then
|
|
begin
|
|
Key:= 0;
|
|
|
|
// we don't have to worry for freeing the data nor the "previously" created instance of TSQLTableToGrid
|
|
// as the Framework takes care of everything.
|
|
data:= globalClient.ExecuteList([], StringToUTF8(edtQuery.Text));
|
|
TSQLTableToGrid.Create(dgTable, data, globalClient);
|
|
|
|
hist:= TSQLQueryHistory.Create(globalClient, 'SQL = ?', [edtQuery.Text]);
|
|
try
|
|
if hist.ID = 0 then
|
|
hist.SQL:= StringToUTF8(edtQuery.Text);
|
|
hist.LastUsed:= Now();
|
|
if hist.ID > 0 then
|
|
globalClient.Update(hist)
|
|
else
|
|
globalClient.Add(hist, true);
|
|
finally
|
|
FreeAndNil(hist);
|
|
LoadQueryHistory();
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
procedure TForm1.LoadQueryHistory();
|
|
var
|
|
hist: TSQLQueryHistory;
|
|
begin
|
|
hist:= TSQLQueryHistory.Create();
|
|
edtQuery.Items.BeginUpdate();
|
|
edtQuery.Items.Clear();
|
|
try
|
|
hist.FillHistory();
|
|
while hist.FillOne do
|
|
edtQuery.AddItem(UTF8ToString(hist.SQL), nil);
|
|
finally
|
|
edtQuery.Items.EndUpdate();
|
|
FreeAndNil(hist);
|
|
end;
|
|
end;
|
|
|
|
procedure TForm1.FillRolesList(const AList: TStrings);
|
|
var
|
|
role: TSQLUserRole;
|
|
begin
|
|
role:= TSQLUserRole.CreateAndFillPrepare(globalClient, '');
|
|
AList.BeginUpdate();
|
|
AList.Clear();
|
|
try
|
|
while role.FillOne do
|
|
AList.AddObject(UTF8ToString(role.RoleName), Pointer(role.id));
|
|
finally
|
|
FreeAndNil(role);
|
|
AList.EndUpdate();
|
|
end;
|
|
end;
|
|
|
|
procedure TForm1.FillUsersList(const AList: TStrings; const AClear: boolean = true);
|
|
var
|
|
user: TSQLUser;
|
|
begin
|
|
// load all the customers
|
|
try
|
|
AList.BeginUpdate();
|
|
if AClear then
|
|
AList.Clear();
|
|
user:= TSQLUser.CreateAndFillPrepare(globalClient, '');
|
|
while user.FillOne do
|
|
AList.AddObject(Format('%s (%s, %s)', [UTF8ToString(user.login), UTF8ToString(user.Surname), UTF8ToString(user.Firstname)]), Pointer(user.ID)); // we keep integer ID as "Data" object
|
|
|
|
finally
|
|
AList.EndUpdate();
|
|
FreeAndNil(user);
|
|
end;
|
|
|
|
end;
|
|
|
|
|
|
procedure TForm1.btnAddUserClick(Sender: TObject);
|
|
var
|
|
user: TSQLUser;
|
|
begin
|
|
|
|
user:= TSQLUser.Create;
|
|
try
|
|
user.Firstname:= StringToUTF8( InputBox('First name', 'User first name', '') );
|
|
user.Surname:= StringToUTF8( InputBox('Surname', 'User surname', '') );
|
|
user.Login:= StringToUTF8( InputBox('Login', 'User login', '') );
|
|
user.Password:= StringToUTF8( InputBox('Password', 'User password', '') );
|
|
if (user.Firstname <> '') and (user.Surname <> '') and (user.Password <> '') and (user.Login <> '') then
|
|
globalClient.Add(user, true)
|
|
else
|
|
MessageBox(handle, 'None of the data can be empty!', 'Wrong', MB_ICONEXCLAMATION);
|
|
finally
|
|
FreeAndNil(user);
|
|
FillUsersList(lbUsers.Items);
|
|
end;
|
|
|
|
|
|
end;
|
|
|
|
procedure TForm1.lbUsersClick(Sender: TObject);
|
|
var
|
|
i, rowID: integer;
|
|
user: TSQLUser;
|
|
roles: TSQLUserRoles;
|
|
date: TTimeLog;
|
|
begin
|
|
clbRoles.Enabled:= (lbUsers.ItemIndex > -1) and (lbUsers.Items.Objects[lbUsers.ItemIndex] <> nil);
|
|
FillRolesList(clbRoles.Items); // clear names, dates and selections
|
|
|
|
if clbRoles.Enabled then
|
|
begin
|
|
user:= TSQLUser.Create(globalClient, integer(lbUsers.Items.Objects[lbUsers.ItemIndex]));
|
|
|
|
try
|
|
for i:= 0 to clbRoles.Items.Count -1 do
|
|
if user.HasRole('', integer(clbRoles.Items.Objects[i]), rowID) then
|
|
begin
|
|
clbRoles.Checked[i]:= true;
|
|
try
|
|
roles:= TSQLUserRoles.Create();
|
|
// load the actual data (ValidUntil field)
|
|
globalClient.Retrieve(rowID, roles);
|
|
date := roles.ValidUntil;
|
|
clbRoles.Items.Strings[i]:= clbRoles.Items.Strings[i] + Format(' [valid until %s]',
|
|
[TTimeLogBits(date).Text(true)]);
|
|
finally
|
|
FreeAndNil(roles);
|
|
end;
|
|
end;
|
|
finally
|
|
FreeAndNil(user);
|
|
end;
|
|
end
|
|
end;
|
|
|
|
procedure TForm1.clbRolesClickCheck(Sender: TObject);
|
|
var
|
|
user: TSQLUser;
|
|
roleID: integer;
|
|
begin
|
|
if clbRoles.ItemIndex = -1 then
|
|
exit;
|
|
|
|
user:= TSQLUser.Create(globalClient, integer(lbUsers.Items.Objects[lbUsers.ItemIndex]));
|
|
|
|
try
|
|
roleID:= Integer(clbRoles.Items.Objects[clbRoles.ItemIndex]);
|
|
user.Roles.ValidUntil:= TimeLogFromDateTime( IncMonth(Now(), 1) );
|
|
if user.HasRole('', roleID) then
|
|
user.Roles.ManyDelete(globalClient, user.ID, roleID)
|
|
else
|
|
user.Roles.ManyAdd(globalClient, user.ID, roleID, true);
|
|
finally
|
|
FreeAndNil(user);
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TForm1.clbRolesClick(Sender: TObject);
|
|
var
|
|
roles: TSQLUserRoles;
|
|
roleID: integer;
|
|
begin
|
|
if clbRoles.ItemIndex = -1 then
|
|
exit;
|
|
|
|
roleID:= integer(clbRoles.Items.Objects[clbRoles.ItemIndex]);
|
|
roles:= TSQLUserRoles.Create();
|
|
try
|
|
//globalClient.Retrieve(rolesID, roles);
|
|
roles.ManySelect(globalClient, integer(lbUsers.Items.Objects[lbUsers.ItemIndex]),roleID);
|
|
if roles.id <> 0 then
|
|
dtRoleExpires.DateTime:= TTimeLogBits(roles.ValidUntil).ToDate;
|
|
finally
|
|
FreeAndNil(roles);
|
|
end;
|
|
end;
|
|
|
|
procedure TForm1.dtRoleExpiresChange(Sender: TObject);
|
|
var
|
|
roles: TSQLUserRoles;
|
|
roleID: integer;
|
|
begin
|
|
if clbRoles.ItemIndex = -1 then
|
|
exit;
|
|
|
|
roleID:= integer(clbRoles.Items.Objects[clbRoles.ItemIndex]);
|
|
roles:= TSQLUserRoles.Create();
|
|
try
|
|
// select the record which associates currently selected user with currently selected role
|
|
roles.ManySelect(globalClient, integer(lbUsers.Items.Objects[lbUsers.ItemIndex]), roleID);
|
|
if roles.id <> 0 then
|
|
begin
|
|
roles.ValidUntil:= TimeLogFromDateTime(dtRoleExpires.DateTime);
|
|
globalClient.Update(roles)
|
|
end;
|
|
finally
|
|
FreeAndNil(roles);
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TForm1.PageControl1Change(Sender: TObject);
|
|
begin
|
|
if PageControl1.ActivePage = tbUsers then
|
|
if currentUser <> nil then
|
|
if not currentUser.HasRole('admin') then
|
|
begin
|
|
PageControl1.ActivePage:= TabSheet3;
|
|
MessageBox(handle, 'You are not allowed to edit this content', 'Please sign-in as admin!', MB_ICONEXCLAMATION)
|
|
end;
|
|
end;
|
|
|
|
end.
|