unit ads_DlgUserPreferences;
{Copyright(c)2016 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
dickmaley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to dickmaley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
(*UnitIndex Master Index Implementation Section Download UnitsDescription: ads_DlgUserPreferences.pas This unit contains the following routines.
TfrmUserPreferences.btnCancelClick TfrmUserPreferences.btnOKClick TfrmUserPreferences.CheckListBoxDrawItem TfrmUserPreferences.FormActivate TfrmUserPreferences.FormClose TfrmUserPreferences.FormCreate TfrmUserPreferences.FormDestroy TfrmUserPreferences.OptionsDrawItem TfrmUserPreferences.OptionsInit TfrmUserPreferences.Reset TfrmUserPreferences.UpdateOptionsFromFile UserPreferencesDlgDetail UserPreferencesEdit UserPreferencesInit UserPreferencesReset
*)
interface
Uses ActnList;
Type
TUserPreferences=class
Public
Constructor Create();
destructor Destroy();override;
class Function Edit (var a:TActionList): Boolean;
class Function Init (var a:TActionList): Boolean;
class Function Reset(var a:TActionList): Boolean;
End;
Var
UserPreferences: TUserPreferences;
{ Description:
- This unit facilitates the integration of Action Items into a user
preferences system. The objective is that it is simple and easy
to use.
- Each ActionItem should have a unique caption and icon.
- The Tag value of the ActionItem tells the system how to present
the action to the user for their user preference selection.
Tag =0: This Action Item is available for user enabling/disabling
Tag =2: This Action Item is not optional.
Tag>=3: This Action Item is not visible ever.
- User preferences are written to and read from file. A separate file
is created for each user.
- Add ads_DlgUserPreferences to the uses clause of the application
and any unit that calls TUserPreferences routines.
- In the project file (*.dpr) add a call to UserPreferences.Init just
before Application.Run.
example:
...
UserPreferences.Init(???????.ActionList);
Application.Run;
end.
The assumption is that by this time all gui elements have been
created and default to visible=True. Only visible=false ActionItems
are saved to file and persist between user sessions. This entry
in the project file restores saved user preferences.
- To give the user the opportunity to set their user preferences
use the following code:
UserPreferences.Edit(???????.ActionList);
If the user presses the OK button the values are automatically updated
and saved to file.
- To restore default settings call:
UserPreferences.Reset(???????.ActionList);
- In the examples above replace ???????.ActionList with the appropriate
reference to your ActionList. For example, Form1.ActionList1.
- UserPreferences: TUserPreferences does not have to be created or destroyed
because that is being handled in the initialization and finalization
sections of this unit.
}
implementation
Uses
Windows,
ads_Exception,
ads_File,
Buttons,
CheckLst,
Classes,
Controls,
Dialogs,
ExtCtrls,
Forms,
Graphics,
StdCtrls,
SysUtils
;
Var
UnitName : String='ads_DlgUserPreferences';
type
TfrmUserPreferences = Class(TScrollingWinControl)
Public
Constructor Create(AOwner: TComponent); Override;
Destructor Destroy; Override;
Public
Panel1: TPanel;
Panel2: TPanel;
btnCancel: TBitBtn;
btnOK: TBitBtn;
CheckListBox: TCheckListBox;
//procedure Loaded;override;
procedure FormCreate(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CheckListBoxDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure FormDestroy(Sender: TObject);
protected
{ Protected declarations }
ActionList : TActionList;
DirLocalApp : String;
DirLocalThisApp: String;
ExeName : String;
ExePath : String;
FilePersist : String;
List : TStringList;
procedure OptionsDrawItem(ActionList:TActionList;Mask:TColor;Control:TWinControl;Index:Integer;Rect:TRect;State:TOwnerDrawState);
public
{ Public declarations }
Success : Boolean;
procedure OptionsInit();
procedure Reset(var ActionLst: TActionList);
procedure UpdateOptionsFromFile(var ActionLst: TActionList);
end;
//Unit Description UnitIndex Master Index
procedure TfrmUserPreferences.FormCreate(Sender: TObject);
Var
ProcName: String;
begin
ProcName := 'TfrmUserPreferences.FormCreate'; Try
inherited;
Success:=False;
If List=nil Then List:= TStringList.Create();
List.Duplicates:=dupIgnore;
List.Sorted:=True;
ExeName := ExtractFileName(ParamStr(0));
ExeName := LowerCase(Copy(ExeName,1,Length(ExeName)-4));
ExeName := UpperCase(Copy(ExeName,1,1))+Copy(ExeName,2,Length(ExeName)-1);
ExePath := ExtractFilePath(ParamStr(0));
DirLocalApp := PathOfAppDataLocal();
DirLocalThisApp := DirLocalApp+ExeName+'\';
If Not DirectoryExists(DirLocalThisApp) Then
ForceDirectories(DirLocalThisApp);
FilePersist := DirLocalThisApp+ExeName+'.Options.txt';
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//Unit Description UnitIndex Master Index
procedure TfrmUserPreferences.FormActivate(Sender: TObject);
Var
ProcName: String;
begin
ProcName := 'TfrmUserPreferences.FormActivate'; Try
If Tag=0 Then
Begin
Success:=False;
List.Clear;
OptionsInit();
End;
btnCancel.Refresh;
Application.ProcessMessages();
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//Unit Description UnitIndex Master Indexprocedure TfrmUserPreferences.btnCancelClick(Sender: TObject); Var ProcName: String; begin ProcName := 'TfrmUserPreferences.btnCancelClick'; Try Tag:=0; Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; end; //Unit Description UnitIndex Master Index
procedure TfrmUserPreferences.btnOKClick(Sender: TObject);
Var
i : Integer;
inIndex : Integer;
ActionItem: TAction;
sgCaption : String;
sgPersist : String;
ProcName : String;
begin
ProcName := 'TfrmUserPreferences.btnOKClick'; Try
Success:=True;
Tag:=0;
sgPersist := '';
For i:=0 To CheckListBox.Count-1 Do
Begin
sgCaption:=CheckListBox.Items[i];
If sgCaption='' Then Continue;
If CheckListBox.State[i]=cbUnchecked Then
Begin
sgPersist:=sgPersist+sgCaption+#13+#10;
End;
inIndex:=List.IndexOf(sgCaption);
If List.Objects[inIndex]=nil Then Continue;
ActionItem:=TAction(List.Objects[inIndex]);
If CheckListBox.State[i]=cbUnchecked Then
Begin
ActionItem.Visible:=False;
End
Else
Begin
If CheckListBox.State[i]=cbChecked Then
Begin
ActionItem.Visible:=True;
End;
End;
End;
StrToFile(sgPersist,FilePersist);
UpdateOptionsFromFile(ActionList);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//Unit Description UnitIndex Master Indexprocedure TfrmUserPreferences.FormClose(Sender: TObject; var Action: TCloseAction); Var ProcName: String; begin ProcName := 'TfrmUserPreferences.FormClose'; Try Tag:=0; Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; end; //Unit Description UnitIndex Master Index
procedure TfrmUserPreferences.CheckListBoxDrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
Var
Mask : TColor;
ProcName : String;
begin
ProcName := 'TfrmUserPreferences.CheckListBoxDrawItem'; Try
Mask := clNone;
OptionsDrawItem(
ActionList , //ActionList : TActionList;
Mask , //Mask : TColor;
Control , //Control : TWinControl;
Index , //Index : Integer;
Rect , //Rect : TRect;
State ); //State : TOwnerDrawState);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//Unit Description UnitIndex Master Index
procedure TfrmUserPreferences.OptionsDrawItem(ActionList: TActionList;
Mask: TColor; Control: TWinControl; Index: Integer; Rect: TRect;
State: TOwnerDrawState);
Var
Bitmap : TBitmap;
Offset : Integer;
inCounter : Integer;
inMax : Integer;
sgText : String;
Images : TImageList;
Action : TAction;
ProcName : String;
begin
ProcName := 'TfrmUserPreferences.OptionsDrawItem'; Try
Bitmap := TBitmap.Create();
inMax := ActionList.ActionCount - 1;
Try
Images := TImageList(ActionList.Images);
Bitmap.Mask(Mask);
With (Control as TCheckListBox).Canvas Do
Begin
FillRect(Rect); { clear the rectangle }
Offset := 2; { provide default offset }
{ get the bitmap }
sgText := (Control as TCheckListBox).Items[Index];
For inCounter := 0 To inMax Do
Begin
Action := TAction(ActionList.Actions[inCounter]);
If sgText = Action.Caption Then
Begin
Try Images.GetBitmap(Action.ImageIndex,Bitmap); Except End;
Break;
End;
End;
If Bitmap <> nil Then
Begin
BrushCopy(
Bounds(Rect.Left + 2,
Rect.Top,
Bitmap.Width,
Bitmap.Height),
Bitmap,
Bounds(0, 0,
Bitmap.Width,
Bitmap.Height),
clRed); {render bitmap}
{add four pixels between bitmap and text}
Offset := Bitmap.Width + 6;
End;
{display the text}
TextOut(
Rect.Left + Offset,
Rect.Top,
(Control as TCheckListBox).Items[Index])
End;
Finally
Bitmap.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//Unit Description UnitIndex Master Index
procedure TfrmUserPreferences.OptionsInit();
Var
Action : TAction;
inActions : Integer;
inActMax : Integer;
inActTag : Integer;
inIndex : Integer;
ProcName : String;
sgCaption : String;
Begin
ProcName := 'TfrmUserPreferences.OptionsInit'; Try
CheckListBox.Items.Clear;
CheckListBox.Sorted := True;
inActMax := ActionList.ActionCount-1;
For inActions := 0 To inActMax Do
Begin
Action := TAction(ActionList.Actions[inActions]);
inActTag := Action.Tag;
//A tag = 2 means this action is not optional
If inActTag = 2 Then Continue;
If inActTag > 2 Then
Begin
//These actions are disabled in this application.
Action.Visible := False;
Continue;
End;
sgCaption := Trim(Action.Caption);
If sgCaption='' Then Continue;
sgCaption:=StringReplace(sgCaption,'&','',[rfReplaceAll]);
If List=nil Then List:=TStringList.Create();
List.Add(sgCaption);
inIndex:=List.IndexOf(sgCaption);
List.Objects[inIndex]:=TAction(ActionList.Actions[inActions]);
CheckListBox.Items.Add(sgCaption);
CheckListBox.Refresh;
inIndex := CheckListBox.Items.IndexOf(sgCaption);
Try CheckListBox.Checked[inIndex] := Action.Visible;Except End;
End;
Tag:=1;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
//Unit Description UnitIndex Master Indexprocedure TfrmUserPreferences.FormDestroy(Sender: TObject); Var ProcName: String; begin ProcName := 'TfrmUserPreferences.FormDestroy'; Try FreeAndNil(List); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; end; //Unit Description UnitIndex Master Index
procedure TfrmUserPreferences.UpdateOptionsFromFile(var ActionLst: TActionList);
Var
i,j : Integer;
sgCaption : String;
inActMax : Integer;
Action : TAction;
ProcName: String;
begin
ProcName := 'TfrmUserPreferences.UpdateOptionsFromFile'; Try
ActionList:=ActionLst;
If FilePersist='' Then
Begin
ExeName := ExtractFileName(ParamStr(0));
ExeName := LowerCase(Copy(ExeName,1,Length(ExeName)-4));
ExeName := UpperCase(Copy(ExeName,1,1))+Copy(ExeName,2,Length(ExeName)-1);
ExePath := ExtractFilePath(ParamStr(0));
DirLocalApp := PathOfAppDataLocal();
DirLocalThisApp := DirLocalApp+ExeName+'\';
If Not DirectoryExists(DirLocalThisApp) Then
ForceDirectories(DirLocalThisApp);
FilePersist := DirLocalThisApp+ExeName+'.Options.txt';
End;
If Not FileExists(FilePersist) Then Exit;
If List=nil Then List:=TStringList.Create();
List.LoadFromFile(FilePersist);
If ActionList=nil Then Exit;
inActMax := ActionList.ActionCount-1;
For j:=0 To inActMax Do
Begin
Action:=TAction(ActionList.Actions[j]);
If Action.Tag<3 Then Action.Visible:=True;
End;
For i:=0 To List.Count-1 Do
Begin
sgCaption := List[i];
For j:=0 To inActMax Do
Begin
Action:=TAction(ActionList.Actions[j]);
If Trim(Action.Caption)='' Then Continue;
If Trim(Action.Caption)=sgCaption Then
Begin
Action.Visible:=False;
End;
End;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//Unit Description UnitIndex Master Index
procedure TfrmUserPreferences.Reset(var ActionLst: TActionList);
Var
ProcName: String;
s : String;
begin
ProcName := 'TfrmUserPreferences.Reset'; Try
s := '';
If FilePersist='' Then
Begin
ExeName := ExtractFileName(ParamStr(0));
ExeName := LowerCase(Copy(ExeName,1,Length(ExeName)-4));
ExeName := UpperCase(Copy(ExeName,1,1))+Copy(ExeName,2,Length(ExeName)-1);
ExePath := ExtractFilePath(ParamStr(0));
DirLocalApp := PathOfAppDataLocal();
DirLocalThisApp := DirLocalApp+ExeName+'\';
If Not DirectoryExists(DirLocalThisApp) Then
ForceDirectories(DirLocalThisApp);
FilePersist := DirLocalThisApp+ExeName+'.Options.txt';
End;
StrToFile(s,FilePersist);
UpdateOptionsFromFile(ActionLst);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
Constructor TfrmUserPreferences.Create(AOwner: TComponent);
Function IsControl(Obj: TObject): Boolean;
Begin
Result := (Obj is TControl);
End;
Var
ProcName: String;
Begin
ProcName := 'TfrmUserPreferences.Create'; Try
inherited;
Self.Parent := TWincontrol(AOwner);
Panel1 := TPanel.Create(AOwner);
With Panel1 Do
Begin
If IsControl(Panel1) Then
Begin
Parent := Self;
End;
Left := 0;
Top := 423;
Width := 210;
Height := 30;
Align := alBottom;
BevelOuter := bvNone;
Caption := ' ';
TabOrder := 0;
End;
Panel2 := TPanel.Create(AOwner);
With Panel2 Do
Begin
Parent := Panel1;
Left := 46;
Top := 0;
Width := 164;
Height := 30;
Align := alRight;
BevelOuter := bvNone;
Caption := ' ';
TabOrder := 0;
End;
btnCancel := TBitBtn.Create(AOwner);
With btnCancel Do
Begin
Parent := Panel2;
Left := 82;
Top := 2;
Width := 75;
Height := 25;
Hint := 'Make no changes.';
TabOrder := 0;
OnClick := btnCancelClick;
Kind := bkCancel;
End;
btnOK := TBitBtn.Create(AOwner);
With btnOK Do
Begin
Parent := Panel2;
Left := 2;
Top := 2;
Width := 75;
Height := 25;
Hint := 'Implement changes';
TabOrder := 1;
OnClick := btnOKClick;
Kind := bkOK;
End;
CheckListBox := TCheckListBox.Create(AOwner);
With CheckListBox Do
Begin
If IsControl(CheckListBox) Then
Begin
Parent := Self;
End;
Left := 0;
Top := 0;
Width := 210;
Height := 423;
Hint := 'Check to enable, uncheck to disable.';
Align := alClient;
ItemHeight := 18;
Style := lbOwnerDrawVariable;
TabOrder := 1;
OnDrawItem := CheckListBoxDrawItem;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
Destructor TfrmUserPreferences.Destroy;
Var
ProcName: String;
Begin
ProcName := 'TfrmUserPreferences.Destroy'; Try
CheckListBox .Free;
btnOK .Free;
btnCancel .Free;
Panel2 .Free;
Panel1 .Free;
inherited Destroy;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
//Unit Description UnitIndex Master Index
Function UserPreferencesDlgDetail(var ActionLst: TActionList;Init:Boolean;Reset:Boolean): Boolean;
Var
Dialog : TForm;
Form : TfrmUserPreferences;
ProcName: String;
Begin
Result := False;
Dialog := nil;
ProcName := 'UserPreferencesDlg'; Try
Try
Dialog := TForm.Create(nil);
Form := TfrmUserPreferences.Create(Dialog);
Form.Parent:= Dialog;
Form.Align := alClient;
With Dialog Do
Begin
Left := 359;
Top := 152;
Width := 218;
Height := 480;
Caption := 'User Preferences';
Color := clBtnFace;
Font.Color := clWindowText;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [];
OldCreateOrder:= False;
Position := poScreenCenter;
ShowHint := True;
OnActivate := Form.FormActivate;
OnClose := Form.FormClose;
OnCreate := Form.FormCreate;
OnDestroy := Form.FormDestroy;
PixelsPerInch := 96;
End;
If Reset Then
Begin
Form.Reset(ActionLst);
Result:=True;
Exit;
End;
Form.UpdateOptionsFromFile(ActionLst);
Form.OptionsInit();
If Init Then
Begin
Result:=True;
Exit;
End;
Form.FormCreate(Dialog);
Application.ProcessMessages();
Dialog.ShowModal;
Result:=Form.Success;
Finally
Dialog.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
//Unit Description UnitIndex Master IndexFunction UserPreferencesEdit(var ActionLst: TActionList): Boolean; Var ProcName: String; Begin Result := False; ProcName := 'UserPreferencesEdit'; Try Result:= UserPreferencesDlgDetail(ActionLst,False,False); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
Function UserPreferencesInit(var ActionLst: TActionList): Boolean; Var ProcName: String; Begin Result := False; ProcName := 'UserPreferencesInit'; Try Result:= UserPreferencesDlgDetail(ActionLst,True,False); Except On E : Exception Do RaiseError(UnitName,ProcName,E); End; End; //Unit Description UnitIndex Master Index
Function UserPreferencesReset(var ActionLst: TActionList): Boolean;
Var
ProcName: String;
Begin
Result := False;
ProcName := 'UserPreferencesReset'; Try
Result:= UserPreferencesDlgDetail(ActionLst,False,True);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
{ TUserPreferences }
class function TUserPreferences.Edit(var a: TActionList): Boolean;
Var
ProcName: String;
Begin
Result := False;
ProcName := 'TUserPreferences.Edit'; Try
Result:= UserPreferencesDlgDetail(a,False,False);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
class function TUserPreferences.Init(var a: TActionList): Boolean;
Var
ProcName: String;
Begin
Result := False;
ProcName := 'TUserPreferences.Init'; Try
Result:= UserPreferencesDlgDetail(a,True,False);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
class function TUserPreferences.Reset(var a: TActionList): Boolean;
Var
ProcName: String;
Begin
Result := False;
ProcName := 'TUserPreferences.Reset'; Try
Result:= UserPreferencesDlgDetail(a,False,True);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
constructor TUserPreferences.Create;
begin
inherited;
end;
destructor TUserPreferences.Destroy;
begin
inherited;
end;
Initialization
UserPreferences:=TUserPreferences.Create;
Finalization
FreeAndNil(UserPreferences);
End.
//