Vichingo455-RePacks
/
xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity
xtool/contrib/mORMot/SQLite3/mORMotUILogin.pas

1040 lines
32 KiB
ObjectPascal
Raw Blame History

/// some common User Interface functions and dialogs for mORMot
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit mORMotUILogin;
(*
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2022
the Initial Developer. All Rights Reserved.
Contributor(s):
- igors233
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
Version 1.4 - February 8, 2010
- whole Synopse SQLite3 database framework released under the GNU Lesser
General Public License version 3, instead of generic "Public Domain"
Version 1.5 - February 18, 2010
- allow to pickup the User Name from a Combo Box
Version 1.9
- improved Delphi 2009/2010 UnicodeString compatibility
- new PassWord method to enter a password e.g. for Cypher (i.e. with no UserName)
Version 1.13
- now use TMS component pack only if USETMSPACK global conditional is defined
- introducing new TSynButton, mapping either to the default TBitButton,
either to TAdvGlowButton (if USETMSPACK conditional is defined)
- introducing a new TTaskDialog record/object, to access the new Vista/Seven
TaskDialog, with a fallback dialog written in Delphi under XP
- use a best available font (Calibri or Tahoma), and useful bitmaps
Version 1.15
- new InputBox global function
- new QueryMasked parameter to display * in InputBox/InputQuery editor field
Version 1.16
- InputBox function will now focus the input field component by default
Version 1.18
- renamed SQLite3UILogin.pas to mORMotUILogin.pas
- added ShowLastClientError() and ShowException() functions
- added TLoginForm.OnIdleProcess and OnIdleProcessForm callback events,
ready to be assigned to TSQLRestClientURI.OnIdle property
*)
interface
{$I Synopse.inc} // define HASINLINE CPU32 CPU64
uses
{$ifdef MSWINDOWS}
Windows,
CommCtrl,
{$endif}
{$ifdef FPC}
//LCLProc, LCLIntf, LCLType,
LCLType,
LCLIntf,
LResources,
SynTaskDialog, Controls, StdCtrls, ExtCtrls, Classes in '.\Samples\ThirdPartyDemos\Ondrej\SynTaskDialog4Lazarus\SynTaskDialog.pas',
{$else}
Consts,
PsAPI,
SynTaskDialog,
{$endif FPC}
Messages,
SysUtils,
Classes,
Graphics,
Controls,
Forms,
StdCtrls,
ExtCtrls,
Buttons,
{$ifdef USETMSPACK}
AdvGlowButton,
TaskDialog,
TaskDialogEx,
AdvToolBarStylers,
AdvToolBar,
{$endif USETMSPACK}
SynGdiPlus,
SynCommons,
SynTable,
mORMot,
mORMotUI;
type
/// Form used to Log User and enter its password
TLoginForm = class(TForm)
Label1: TLabel;
Label2: TLabel;
Edit2: TEdit;
Image1: TImage;
Label3: TLabel;
Bevel1: TBevel;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
protected
Edit: TWinControl;
function EditText: string;
class procedure HandleApplicationException(Sender: TObject; E: Exception);
public
/// display the Login dialog window
class function Login(const aTitle, aText: string; var aUserName, aPassWord: string;
AllowUserNameChange: boolean; const CSVComboValues: string): boolean;
/// display the password dialog window
class function PassWord(const aTitle, aText: string; var aPassWord: string): boolean;
public
/// TOnIdleSQLRestClient-like event to process Windows Messages
// - to be assigned e.g. to TSQLRestClientURI.OnIdle property
// - global OnIdleProcessCursorChangeTimeout variable is used to display
// the crHourGlass cursor after a given time elapsed
class procedure OnIdleProcess(Sender: TSynBackgroundThreadAbstract; ElapsedMS: Integer);
/// TOnIdleSQLRestClient-like event to process Windows Messages and write a
// temporary form on screen if it takes too long
// - to be assigned e.g. to TSQLRestClientURI.OnIdle property
// - global OnIdleProcessCursorChangeTimeout variable is used to display
// the crHourGlass cursor after a given time elapsed
// - global OnIdleProcessTemporaryFormTimeout variable is used to display
// a temporary form after a given time elapsed
class procedure OnIdleProcessForm(Sender: TSynBackgroundThreadAbstract; ElapsedMS: Integer);
end;
var
/// define when TLoginForm.OnIdleProcess() has to display the crHourGlass cursor
// after a given time elapsed, in milliseconds
// - default is 100 ms
OnIdleProcessCursorChangeTimeout: integer = 100;
/// define when TLoginForm.OnIdleProcessForm() has to display the temporary
// form after a given time elapsed, in milliseconds
// - default is 2000 ms, i.e. 2 seconds
OnIdleProcessTemporaryFormTimeout: integer = 2000;
/// define the message text displayed by TLoginForm.OnIdleProcessForm()
// - default is sOnIdleProcessFormMessage resourcestring, i.e. 'Please wait...'
OnIdleProcessTemporaryFormMessage: string;
{$ifdef USETMSPACK}
/// create a temporary AdvTaskDialog component, with the current style
function CreateAdvTaskDialog: TAdvTaskDialogEx;
/// create a temporary AdvInputTaskDialog component, with the current style
function CreateAdvInputTaskDialog: TAdvInputTaskDialogEx;
/// retrieve the main toolbar from main form
function GetMainPager: TAdvToolBarPager;
/// retrieve the main styler from main form
function GetMainStyler: TAdvToolBarOfficeStyler;
/// set the style for a form and a its buttons
// - return the toolbar styler found, if any
function SetStyle(Form: TComponent; Styler: TAdvToolBarOfficeStyler=nil): TAdvToolBarOfficeStyler;
{$else}
/// set the style for a form and a its buttons
// - set the Default Font for all components, i.e. Calibri if available
procedure SetStyle(Form: TComponent);
{$endif USETMSPACK}
/// show an (error) message, using a Vista-Style dialog box
procedure ShowMessage(const Msg: string; Error: boolean=false); overload;
/// convert an error message into html compatible equivalency
// - allow to display < > & correctly
function HtmlEscape(const Msg: string): string;
/// show an (error) message, using a Vista-Style dialog box
procedure ShowMessage(const Msg, Inst: string; Error: boolean=false); overload;
/// show an error dialog box, with the corresponding Client-Side information
// - retrieve last error message from Client.LastError* values
function ShowLastClientError(Client: TSQLRestClientURI; const ContextMessage: string='';
CommonButtons: TCommonButtons=[cbOk]): integer;
/// show an error dialog box, corresponding to a specified exception
function ShowException(E: Exception; CommonButtons: TCommonButtons=[cbOk];
const ContextMessage: string=''): integer;
/// ask the User to choose Yes or No [and Cancel], using a Vista-Style dialog box
function YesNo(const aQuestion: string; const aConfirm: string =''; withCancel: boolean=true;
Warning: boolean=false): integer;
/// ask the User to enter some string value
// - if QueryMasked=TRUE, will mask the prompt with '*' chars (e.g. for entering
// a password)
function InputQuery(const ACaption, APrompt: string; var Value: string;
QueryMasked: boolean=false): Boolean;
/// ask the User to enter some string value
// - if QueryMasked=TRUE, will mask the prompt with '*' chars (e.g. for entering
// a password)
function InputBox(const ACaption, APrompt, ADefault: string; QueryMasked: boolean=false): string;
/// ask the User to select one item from an array of strings
// - return the selected index, -1 if Cancel button was pressed
function InputSelect(const ACaption, APrompt, AItemsText, ASelectedText: string): integer;
/// ask the User to select one enumerate item
// - use internally TEnumType.GetCaption() to retrieve the text to be displayed
// - Index must be an instance of this enumeration type (internaly mapped to a PByte)
function InputSelectEnum(const ACaption, APrompt: string; EnumTypeInfo: PTypeInfo;
var Index): boolean;
/// ask the User to choose between some Commands
// - return the selected command index, starting numerotation at 100
function Choose(const aTitle, aContent, aFooter: string; const Commands: array of string;
aFooterIcon: TTaskDialogFooterIcon=tfiInformation): integer; overload;
/// ask the User to choose between some Commands
// - return the selected command index, starting numerotation at 100
// - this overloaded function expect the Content and the Commands to be
// supplied as CSV string (Content as first CSV, then commands)
function Choose(const aTitle, aCSVContent: string): integer; overload;
resourcestring
sClientServerError = 'An error occured during Client-Server process';
sOnIdleProcessFormMessage = 'Please wait...';
/// ensure that the program is launched once
// - the main project .dpr source file must contain:
// !begin
// ! Application.Initialize;
// ! EnsureSingleInstance; // program is launched once
// ! Application.CreateForm(TMainForm, MainForm);
// ! ....
procedure EnsureSingleInstance;
type
PTPanel = ^TPanel;
/// popup a temporary form with a message over all forms
// - caller should execute result.Free and reset the cursor if needed
function CreateTempForm(const aCaption: string;
aPanelReference: PTPanel=nil; ScreenCursorHourGlass: boolean=false;
aCaptionColor: integer=clNavy; aCaptionSize: integer=12): TForm;
implementation
{$ifdef FPC}
{$R *.lfm}
{$else}
{$R *.dfm}
{$endif}
{$R SQLite3UILogin.res}
/// popup a temporary form with a message over all forms
function CreateTempForm(const aCaption: string;
aPanelReference: PTPanel=nil; ScreenCursorHourGlass: boolean=false;
aCaptionColor: integer=clNavy; aCaptionSize: integer=12): TForm;
var P: TPanel;
begin
if ScreenCursorHourGlass then
Screen.Cursor := crHourGlass;
Result := TForm.Create(nil);
Result.Width := 400; Result.Height := 100;
Result.Position := poScreenCenter;
Result.FormStyle := fsStayOnTop;
Result.BorderStyle := bsNone;
P := TPanel.Create(Result);
with P do begin
Color := clWhite;
BorderStyle := bsSingle;
Parent := Result;
Font.Name := 'Tahoma'; Font.Size := aCaptionSize;
Font.Color := aCaptionColor; Font.Style := [fsBold];
Caption := aCaption;
Align := alClient;
end;
if aPanelReference<>nil then
aPanelReference^ := P;
{ with TImage.Create(Result) do begin
Parent := P;
Transparent := true;
Picture.Bitmap.LoadFromResourceName(hInstance,'ROC');
SetBounds((330-156)div 2,20,156,73);
end;
with TLabel.Create(Result) do begin
Parent := P;
Font.Name := 'Tahoma'; Font.Size := 11;
Font.Color := clNavy; Font.Style := [fsBold];
Alignment := taCenter;
Caption := aCaption;
SetBounds(0,120,330,100);
end; }
Result.Show;
Application.ProcessMessages;
end;
procedure ShowMessage(const Msg: string; Error: boolean=false);
begin
if Error then
ShowMessage(HtmlEscape(Msg),SMsgDlgError,Error) else
ShowMessage(HtmlEscape(Msg),SMsgDlgInformation,Error);
end;
function HtmlEscape(const Msg: string): string;
{$ifdef USETMSPACK}
var i: integer;
ins: string;
{$endif}
begin
result := Msg;
{$ifdef USETMSPACK}
for i := length(Msg) downto 1 do begin
case Msg[i] of
'"': ins := '&quot';
'&': ins := '&amp';
'<': ins := '&lt';
'>': ins := '&gt';
else Continue;
end;
result[i] := ';';
insert(ins,result,i);
end;
{$endif}
end;
{$ifdef USETMSPACK}
function CreateAdvTaskDialog: TAdvTaskDialogEx;
var Style: TAdvToolBarOfficeStyler;
begin
result := TAdvTaskDialogEx.Create(Application);
if Application.MainForm=nil then
result.Title := Application.Title else
result.Title := Application.MainForm.Caption;
result.Options := result.Options+[doHyperlinks];
result.NonNativeDialog := nndAlways; // we need hyperlinks=HTML -> non native!
Style := GetMainStyler;
if Style<>nil then
result.Appearance := Style.GlowButtonAppearance;
end;
function Choose(const aTitle, aContent, aFooter: string; const Commands: array of string;
aFooterIcon: TTaskDialogFooterIcon=tfiInformation): integer;
var i: integer;
begin
with TAdvTaskDialog(CreateAdvTaskDialog) do
try
Instruction := aTitle;
Content := aContent;
Icon := tiQuestion;
CustomButtons.Clear;
for i := 0 to high(Commands) do
CustomButtons.Add(Commands[i]);
DefaultButton := 100;
Options := Options+[doCommandLinks];
if aFooter<>'' then begin
FooterIcon := aFooterIcon;
if aFooterIcon=tfiWarning then
Footer := '<b>'+SMsgDlgWarning+'</b>:'#13+aFooter else
Footer := aFooter;
end;
result := Execute;
finally
Free;
end;
end;
type
/// we definitively NEED these properties
TAdvInputTaskDialogPublished = class(TAdvInputTaskDialogEx)
published
property Options;
property NonNativeDialog;
end;
function CreateAdvInputTaskDialog: TAdvInputTaskDialogEx;
var Style: TAdvToolBarOfficeStyler;
begin
result := TAdvInputTaskDialogPublished.Create(Application);
result.Title := Application.MainForm.Caption;
TAdvInputTaskDialogPublished(result).Options := TAdvInputTaskDialogPublished(result).Options+[doHyperlinks];
TAdvInputTaskDialogPublished(result).NonNativeDialog := nndAlways; // we need hyperlinks=HTML -> non native!
Style := GetMainStyler;
if Style<>nil then
result.Appearance := Style.GlowButtonAppearance;
end;
function InputQuery(const ACaption, APrompt: string; var Value: string;
QueryMasked: boolean=false): Boolean;
begin
with CreateAdvInputTaskDialog do
try
Instruction := ACaption;
Content := APrompt;
InputType := itEdit;
CommonButtons := [cbOk,cbCancel];
InputText := Value;
result := false;
if Execute<>mrOk then
exit;
result := true;
Value := InputText;
finally
Free;
end;
end;
function InputSelect(const ACaption, APrompt, AItemsText, ASelectedText: string): integer;
var Items: TStringList;
begin
result := -1;
if AItemsText<>'' then
with CreateAdvInputTaskDialog do
try
Instruction := ACaption;
Content := APrompt;
InputType := itComboList;
CommonButtons := [cbOk,cbCancel];
Items := TStringList.Create;
try
Items.Text := AItemsText;
InputItems := Items;
InputText := ASelectedText;
if Execute<>mrOk then
exit;
result := Items.IndexOf(InputText);
finally
Items.Free;
end;
finally
Free;
end;
end;
function Choose(const aTitle, aCSVContent: string): integer; overload;
var Commands: array of string;
Content: string;
P: PChar;
begin
P := pointer(aCSVContent);
Content := GetNextItemString(P);
while P<>nil do begin
SetLength(Commands,length(Commands)+1);
Commands[high(Commands)] := GetNextItemString(P);
end;
result := Choose(aTitle,Content,'',Commands);
end;
{$else}
function Choose(const aTitle, aContent, aFooter: string; const Commands: array of string;
aFooterIcon: TTaskDialogFooterIcon=tfiInformation): integer;
var Task: TTaskDialog;
i: integer;
begin
Task.Inst := aTitle;
Task.Content := aContent;
Task.Footer := aFooter;
for i := 0 to high(Commands) do
Task.Buttons := Task.Buttons+Commands[i]+#10;
result := Task.Execute([],100,[tdfUseCommandLinks],tiQuestion,aFooterIcon);
if result<100 then
result := -1 else
dec(result,100);
end;
function InputQuery(const ACaption, APrompt: string; var Value: string;
QueryMasked: boolean=false): Boolean;
const FLAGS: array[boolean] of TTaskDialogFlags = (
[tdfQuery,tdfQueryFieldFocused],[tdfQuery,tdfQueryMasked,tdfQueryFieldFocused]);
var Task: TTaskDialog;
begin
Task.Inst := ACaption;
Task.Content := APrompt;
Task.Query := Value;
result := Task.Execute([cbOk,cbCancel],0,FLAGS[QueryMasked],tiQuestion)=mrOk;
if result then
Value := Task.Query;
end;
function InputSelect(const ACaption, APrompt, AItemsText, ASelectedText: string): integer;
var Task: TTaskDialog;
begin
result := -1;
if AItemsText='' then
exit;
Task.Inst := ACaption;
Task.Content := APrompt;
Task.Selection := AItemsText;
Task.Query := ASelectedText;
if Task.Execute([cbOk,cbCancel],0,[],tiQuestion)=mrOk then
result := Task.SelectionRes;
end;
function Choose(const aTitle, aCSVContent: string): integer; overload;
var Task: TTaskDialog;
P: PChar;
begin
Task.Inst := aTitle;
P := pointer(aCSVContent);
Task.Content := GetNextItemString(P);
while P<>nil do
Task.Buttons := Task.Buttons+GetNextItemString(P)+#10;
result := Task.Execute([],100,[tdfUseCommandLinks],tiQuestion);
if result<100 then
result := -1 else
dec(result,100);
end;
{$endif USETMSPACK}
function InputBox(const ACaption, APrompt, ADefault: string; QueryMasked: boolean=false): string;
begin
result := ADefault;
if not InputQuery(ACaption,APrompt,Result,QueryMasked) then
result := ADefault;
end;
function InputSelectEnum(const ACaption, APrompt: string; EnumTypeInfo: PTypeInfo;
var Index): boolean;
var i: integer;
begin
result := false;
if (EnumTypeInfo<>nil) and (EnumTypeInfo^.Kind=tkEnumeration) then begin
i := InputSelect(ACaption,APrompt,EnumTypeInfo^.EnumBaseType^.GetCaptionStrings,
EnumTypeInfo^.EnumBaseType^.GetCaption(PByte(@Index)^));
if i>=0 then begin
PByte(@Index)^ := i;
result := true;
end;
end;
end;
procedure ShowMessage(const Msg, Inst: string; Error: boolean=false);
const
IconError: array[boolean] of TTaskDialogIcon = (tiInformation, tiError);
{$ifndef USETMSPACK}
var Task: TTaskDialog;
{$endif}
begin
{$ifdef USETMSPACK}
with CreateAdvTaskDialog do
try
Instruction := Inst;
Icon := IconError[Error];
Content := Msg;
CommonButtons := [cbOk];
Execute;
finally
Free;
end;
{$else}
Task.Inst := Inst;
Task.Content := Msg;
Task.Execute([cbOK],mrOk,[],IconError[Error]);
{$endif}
end;
function ShowLastClientError(Client: TSQLRestClientURI; const ContextMessage: string='';
CommonButtons: TCommonButtons=[cbOk]): integer;
var details: string;
{$ifndef USETMSPACK}
Task: TTaskDialog;
{$endif}
begin
if Client<>nil then begin
if Client.LastErrorMessage<>'' then
details := UTF8ToString(Client.LastErrorMessage)+#13#10;
if Client.LastErrorException<>nil then
details := Format('%sException %s raised - ErrorCode=%d',
[details,Client.LastErrorException.ClassName,Client.LastErrorCode]);
end;
{$ifdef USETMSPACK}
with CreateAdvTaskDialog do
try
Instruction := sClientServerError;
Content := ContextMessage;
Icon := tiError;
CommonButtons := [cbOk];
result := Execute;
finally
Free;
end;
{$else}
if ContextMessage='' then
Task.Content := sClientServerError else
Task.Content := ContextMessage;
Task.Info := details;
result := Task.Execute([cbOK],mrOk,[],tiError);
{$endif}
end;
function ShowException(E: Exception; CommonButtons: TCommonButtons;
const ContextMessage: string): integer;
var details: string;
{$ifndef USETMSPACK}
Task: TTaskDialog;
{$endif}
begin
if E=nil then begin
ShowMessage(ContextMessage,true);
result := mrNone;
exit;
end;
details := UTF8ToString(ObjectToJSONDebug(E));
{$ifdef USETMSPACK}
with CreateAdvTaskDialog do
try
Instruction := sClientServerError;
Content := ContextMessage;
Icon := tiError;
CommonButtons := [cbOk];
result := Execute;
finally
Free;
end;
{$else}
Task.Content := E.Message;
Task.Inst := ContextMessage;
Task.Info := details;
result := Task.Execute(CommonButtons,mrOk,[],tiError);
{$endif}
end;
function YesNo(const aQuestion, aConfirm: string; withCancel: boolean; Warning: boolean): integer;
var Confirm: string;
{$ifndef USETMSPACK}
Task: TTaskDialog;
{$endif}
const
IconWarning: array[boolean] of TTaskDialogIcon = (
tiQuestion, tiWarning);
BtsCancel: array[boolean] of TCommonButtons = (
[cbYes, cbNo], [cbYes, cbNo, cbCancel]);
begin
if aConfirm='' then
Confirm := SMsgDlgConfirm else
Confirm := aConfirm;
{$ifdef USETMSPACK}
with CreateAdvTaskDialog do
try
Instruction := Confirm;
Icon := IconWarning[Warning];
Content := aQuestion;
CommonButtons := BtsCancel[withCancel];
result := Execute;
finally
Free;
end;
{$else}
Task.Inst := Confirm;
Task.Content := aQuestion;
result := Task.Execute(BtsCancel[withCancel],0,[],IconWarning[Warning]);
{$endif}
end;
{$ifdef Crazy}
function FileNameFromWndMatch(const Wnd: HWnd; const AppFileName: string): boolean;
var ProcessID: DWORD;
hProc: THandle;
tmp: array[0..MAX_PATH] of char;
begin
GetWindowThreadProcessId(Wnd, @ProcessId);
hProc := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, ProcessId);
if hProc <> 0 then begin
{$ifdef FPC}
if GetModuleFileName(hProc, tmp, MAX_PATH) = 0 then
{$else}
if GetModuleFileNameEx(hProc, 0, tmp, MAX_PATH) = 0 then
{$endif}
tmp[0] := #0;
CloseHandle(hProc);
result := ExtractFileName(string(tmp)) = AppFileName;
end else
result := false;
end;
{$endif Crazy}
procedure EnsureSingleInstance;
var Wnd: HWnd;
ToFindClass, WndClass, AppFileName: string;
tmp: array[byte] of char;
function FileNameFromWndMatch: boolean;
var ProcessID: DWORD;
hProc: THandle;
tmp: array[0..MAX_PATH] of char;
begin
GetWindowThreadProcessId(Wnd, @ProcessId);
hProc := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, ProcessId);
if hProc <> 0 then begin
{$ifdef FPC}
if GetModuleFileName(hProc, tmp, MAX_PATH) = 0 then
{$else}
if GetModuleFileNameEx(hProc, 0, tmp, MAX_PATH) = 0 then
{$endif}
tmp[0] := #0;
CloseHandle(hProc);
result := ExtractFileName(string(tmp)) = AppFileName;
end else
result := false;
end;
begin
if Application = nil then
exit;
{ Try and create a semaphore. If we succeed, then check if the semaphore was
already present. If it was then a previous instance is floating around.
Note the OS will free the returned semaphore handle when the app shuts
so we can forget about it }
AppFileName := ExtractFileName(ExeVersion.ProgramFileName);
if (CreateSemaphore(nil, 0, 1, Pointer(AppFileName)) <> 0) and
(GetLastError = ERROR_ALREADY_EXISTS) then begin
if GetClassName({$ifdef FPC}Application.MainFormHandle{$else}Application.Handle{$endif}, tmp, high(tmp)) = 0 then
exit;
ToFindClass := tmp;
Wnd := GetWindow({$ifdef FPC}Application.MainFormHandle{$else}Application.Handle{$endif}, GW_HWNDFIRST);
while Wnd <> 0 do begin
{ Look for the other TApplication window out there }
if Wnd <> {$ifdef FPC}Application.MainFormHandle{$else}Application.Handle{$endif} then begin
{ Check if got the same class and filename }
if GetClassName(Wnd, tmp, high(tmp)) = 0 then
tmp[0] := #0;
WndClass := tmp;
if (ToFindClass = WndClass) and FileNameFromWndMatch then begin
{ This technique is used by the VCL: post a message then bring the
window to the top, before the message gets processed }
PostMessage(Wnd, WM_SYSCOMMAND, SC_RESTORE, 0);
SetForegroundWindow(Wnd);
break;
end
end;
Wnd := GetWindow(Wnd, GW_HWNDNEXT);
end;
AppFileName := ''; // avoid memory leak due to Halt brutal execution
WndClass := '';
ToFindClass := '';
Halt; // Stop this new instance
end
end;
procedure TLoginForm.FormCreate(Sender: TObject);
var P: TSynPicture;
begin
SetStyle(self);
TSynButton.CreateKind(Self,cbOK,136,163,75,30).Anchors := [akLeft,akBottom];
TSynButton.CreateKind(Self,cbCancel,224,163,75,30).Anchors := [akLeft,akBottom];
P := TSynPicture.Create;
try
P.LoadFromResourceName(HInstance,'UILogin'); // SQLite3uilogin.png
Image1.Picture.Assign(P);
finally
P.Free;
end;
end;
class function TLoginForm.PassWord(const aTitle, aText: string;
var aPassWord: string): boolean;
var LoginForm: TLoginForm;
begin
Application.CreateForm(TLoginForm,LoginForm);
try
with LoginForm do begin
Label1.Hide;
Label3.Caption := aText;
Label3.Width := LoginForm.ClientWidth;
Bevel1.Hide;
ClientHeight := 180;
LoginForm.Caption := ' '+aTitle;
result := (LoginForm.ShowModal=mrOk);
if result then
aPassWord := SysUtils.trim(LoginForm.Edit2.Text);
end;
finally
LoginForm.Free;
end;
end;
class function TLoginForm.Login(const aTitle, aText: string; var aUserName, aPassWord: string;
AllowUserNameChange: boolean; const CSVComboValues: string): boolean;
var T: string;
i: integer;
LoginForm: TLoginForm;
begin
Application.CreateForm(TLoginForm,LoginForm);
with LoginForm do
try
Label3.Caption := aText;
Label3.Width := LoginForm.ClientWidth;
Bevel1.Visible := aText<>'';
Height := 240+Label3.Height;
Bevel1.Height := Label3.Height;
if not AllowUserNameChange or (CSVComboValues='') then begin
Edit := TEdit.Create(LoginForm);
Edit.Parent := LoginForm;
TEdit(Edit).Text := aUserName;
end else begin
Edit := TComboBox.Create(LoginForm);
Edit.Parent := LoginForm;
with TComboBox(Edit) do begin
Text := aUserName;
Style := csDropDownList;
Items.Text := StringReplace(CSVComboValues,',',#13#10,[rfReplaceAll]);
ItemIndex := Items.IndexOf(aUserName);
end;
end;
{$ifdef FPC}
// strange, but needed
Edit.SetBounds(104,Height-Edit2.Height-84,193,22);
{$else}
Edit.SetBounds(104,Edit2.Top-32,193,22);
{$endif}
Edit.Anchors := [akLeft,akBottom];
Edit.Enabled := AllowUserNameChange;
Edit2.Text := '';
if aTitle='' then
if Application.MainForm=nil then
T := Application.Title else
T := Application.MainForm.Caption else begin
T := aTitle;
for i := 1 to length(T) do
if T[i]<' ' then
T[i] := ' ';
end;
Caption := ' '+T;
result := (ShowModal=mrOk);
if result then begin
aPassWord := SysUtils.trim(Edit2.Text);
if Edit.Enabled then
aUserName := SysUtils.trim(EditText);
end;
finally
LoginForm.Free;
end;
end;
{$ifdef USETMSPACK}
function GetMainPager: TAdvToolBarPager;
var C: integer;
begin
with Application.MainForm do
for C := 0 to ComponentCount-1 do begin
result := pointer(Components[C]);
if result.InheritsFrom(TAdvToolBarPager) then
exit;
end;
result := nil;
end;
var
fMainStyler: TAdvToolBarOfficeStyler = nil;
function GetMainStyler: TAdvToolBarOfficeStyler;
var C: integer;
begin
result := fMainStyler;
if (result<>nil) or (Application.MainForm=nil) then
exit;
with Application.MainForm do
for C := 0 to ComponentCount-1 do begin
result := pointer(Components[C]);
if result.InheritsFrom(TAdvToolBarOfficeStyler) then begin
fMainStyler := result;
exit;
end;
end;
result := nil;
end;
function SetStyle(Form: TComponent; Styler: TAdvToolBarOfficeStyler=nil): TAdvToolBarOfficeStyler;
var i: integer;
C: TComponent;
begin
if Styler=nil then
result := GetMainStyler else
result := Styler;
if (result=nil) or (Form=nil) then
exit;
for i := 0 to Form.ComponentCount-1 do begin
C := Form.Components[i];
{ if C.InheritsFrom(TAdvToolBarOfficeStyler) then // buggy: TMS :(
TAdvToolBarOfficeStyler(C).Assign(Style) else }
if C.InheritsFrom(TAdvGlowButton) then
TAdvGlowButton(C).Appearance := result.GlowButtonAppearance;
SetStyle(C,result);
end;
if Form.InheritsFrom(TCustomForm) then
TCustomForm(Form).Color := result.PageAppearance.Color;
if Form.InheritsFrom(TAdvGlowButton) then
TAdvGlowButton(Form).Appearance := result.GlowButtonAppearance;
end;
{$else}
procedure SetStyle(Form: TComponent);
var i, f: integer;
C: TComponent;
Ctrl: TControl absolute C;
CL: TClass;
P: PPropInfo;
Obj: TObject;
begin
if Form=nil then
exit;
// set form font to global Default Font
if Form.InheritsFrom(TCustomForm) then
TCustomForm(Form).Font := DefaultFont;
// for any component with ParentFont=false, force Calibri if necessary
if DefaultFont.Name='Calibri' then
for i := 0 to Form.ComponentCount-1 do begin
C := Form.Components[i];
if C.InheritsFrom(TControl) then
if not TButton(C).ParentFont then begin // trick to access TControl.FParentFont
CL := PPointer(C)^;
while (CL<>nil) and (CL<>TComponent) and (CL<>TObject) do begin
for f := 1 to InternalClassPropInfo(CL,P) do begin
with P^.PropType^{$ifndef HASDIRECTTYPEINFO}^{$endif} do
if (Kind=tkClass) and ClassType^.InheritsFrom(TFont) then begin
Obj := P^.GetObjProp(C);
if Obj<>nil then
with TFont(Obj) do
if Name<>DefaultFont.Name then begin
Name := DefaultFont.Name;
Height := Height+(Height div 5);
end;
end;
P := P^.Next;
end;
CL := CL.ClassParent; // handle parent published properties
end;
end;
end;
end;
{$endif USETMSPACK}
procedure TLoginForm.FormShow(Sender: TObject);
begin
if (Edit<>nil) and Edit.Enabled and (EditText='') then
Edit.SetFocus else
Edit2.SetFocus;
SetStyle(self);
end;
function TLoginForm.EditText: string;
begin
if Edit.InheritsFrom(TComboBox) then
result := TComboBox(Edit).Text else
result := TEdit(Edit).Text;
result := SysUtils.trim(result);
end;
class procedure TLoginForm.HandleApplicationException(Sender: TObject; E: Exception);
begin // so that exception will be shown with new User Interface
ShowMessage(E.Message,true);
end;
var
OnIdleProcessCursor: TCursor = crNone;
OnIdleProcessTempForm: TForm;
class procedure TLoginForm.OnIdleProcess(Sender: TSynBackgroundThreadAbstract; ElapsedMS: Integer);
begin
Application.ProcessMessages;
if (ElapsedMS>OnIdleProcessCursorChangeTimeout) and (OnIdleProcessCursor=crNone) then begin
OnIdleProcessCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
end else
if (ElapsedMS<0) and (OnIdleProcessCursor<>crNone) then begin
Screen.Cursor := OnIdleProcessCursor;
OnIdleProcessCursor := crNone;
end;
end;
class procedure TLoginForm.OnIdleProcessForm(Sender: TSynBackgroundThreadAbstract; ElapsedMS: Integer);
var msg: string;
begin
TLoginForm.OnIdleProcess(Sender,ElapsedMS);
if (ElapsedMS>OnIdleProcessTemporaryFormTimeout) and
not Assigned(OnIdleProcessTempForm) then begin
if OnIdleProcessTemporaryFormMessage='' then
msg := sOnIdleProcessFormMessage else
msg := OnIdleProcessTemporaryFormMessage;
OnIdleProcessTempForm := CreateTempForm(msg);
end else
if (ElapsedMS<0) and Assigned(OnIdleProcessTempForm) then
FreeAndNil(OnIdleProcessTempForm);
end;
initialization
Gdip.RegisterPictures; // will initialize the Gdip library if necessary
Application.OnException := TLoginForm.HandleApplicationException;
end.
Reference in New Issue View Git Blame Copy Permalink