home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Softwarová Záchrana 3
/
Softwarova-zachrana-3.bin
/
ArsClip
/
source.zip
/
UnitFrmPermanent.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2003-02-18
|
15KB
|
574 lines
unit UnitFrmPermanent;
{
NOTE:
This beast has gone BYE BYE. See UnitFrmPermanentNew for it's
replacement.
Purpose:
This unit stores/reads/edits the permanent items.
The form is not a dummy form.
Updates:
Display '&' without defining an accelerator key in text items
Improved error reporting for corrupt data file
New procedure to show the form with a new item added
Refresh dropdown when saving a new permanent item group.
Saves before group change and saves before closing.
Crapy, Crappy, Crappy code.
Changes where not saved before the group was changed.
Essentially, changes would not be saved at all in some cases.
CRLF wasn't used to count the number of lines in "Text to Paste".
}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
const DEFAULT_FOLDER = 'Default';
ADDNEW_FOLDER = '<add new>';
PERM0_FILE = 'perm0.ini';
PERM1_FILE = 'perm1.ini';
type
TfrmPermanentOld = class(TForm)
GroupBox1: TGroupBox;
txtItemName: TEdit;
Label1: TLabel;
mItemText: TMemo;
btnSave: TButton;
Panel1: TPanel;
lbItemName: TListBox;
lbItemText: TListBox;
btnUp: TButton;
btnDown: TButton;
Label2: TLabel;
btnDelete: TButton;
cbGroups: TComboBox;
labelx: TLabel;
btnDeleteGroup: TButton;
Label3: TLabel;
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure txtItemNameChange(Sender: TObject);
procedure mItemTextChange(Sender: TObject);
procedure btnSaveClick(Sender: TObject);
procedure lbItemNameClick(Sender: TObject);
procedure btnUpClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnDownClick(Sender: TObject);
procedure btnDeleteClick(Sender: TObject);
procedure cbGroupsCloseUp(Sender: TObject);
procedure btnDeleteGroupClick(Sender: TObject);
procedure cbGroupsClick(Sender: TObject);
private
{ Private declarations }
AppPath : string;
PermPath : string;
PermFolders : TStringList;
OverrideBlankItem : boolean;
function GetOldDataFilename (i: integer): string;
function GetDataFilename (i: integer): string;
procedure LoadPermanentItems;
procedure SavePermanentItems;
public
{ Public declarations }
{item enumeration API}
function GetCount: integer;
function GetItemName(i: integer): string;
function GetItemText(i: integer): string;
function GetTextFrom(name: string): string;
{permanent items group}
{for frmConfig}
procedure PermFoldersRefresh;
function PermFoldersGetCount : cardinal;
function PermFoldersGetItem(index : cardinal) : string;
function GetPermanentPath : string;
procedure SetPermanentPath( path : string );
procedure ShowWithNewItem(item : string);
end;
var
frmPermanentOld: TfrmPermanentOld;
implementation
{$R *.dfm}
uses INIFiles;
const PERM_ITEMS = 'Permanent Items';
{
--======================
-- // Public Inteface //
--======================
}
procedure TfrmPermanentOld.ShowWithNewItem(item : string);
begin
OverrideBlankItem := true;
mItemText.Text := item;
self.Show;
end;
function TfrmPermanentOld.GetCount: integer;
begin
result := lbItemName.Count;
end;
function TfrmPermanentOld.GetItemName(i: integer): string;
begin
result := lbItemName.Items[i];
end;
function TfrmPermanentOld.GetItemText(i: integer): string;
begin
result := lbItemText.Items[i];
end;
function TfrmPermanentOld.GetTextFrom(name: string): string;
var pos: integer;
i: integer;
begin
pos := -1;
for i := 0 to lbItemname.count - 1 do begin
if (name = lbItemName.items[i]) then begin
pos := i;
end;
end;
result := lbItemText.items[pos];
end;
//
//
//
function TfrmPermanentOld.GetPermanentPath : string;
begin
result := PermPath;
end;
procedure TfrmPermanentOld.SetPermanentPath( path : string );
begin
PermPath := path;
self.LoadPermanentItems;
end;
procedure TfrmPermanentOld.PermFoldersRefresh;
var rec : TSearchRec;
r : integer;
begin
//
// Load the permanent items group
// Select the current group
//
cbGroups.items.clear;
PermFolders.Clear;
cbGroups.items.Add(ADDNEW_FOLDER);
r := FindFirst(AppPath + '*.*', faDirectory, rec);
while (r = 0) do begin
if (rec.Attr and faDirectory) > 0 then begin
if (rec.name <> '.') and (rec.name <> '..') then begin
if fileexists(AppPath + rec.name + '\' + PERM0_FILE ) then begin
PermFolders.Add(rec.name);
cbGroups.Items.Add(rec.name);
end;
if lowercase(rec.name) = lowercase(PermPath) then begin
cbGroups.ItemIndex := cbGroups.Items.Count - 1;
end;
end;
end;
r := FindNext(rec);
end;
//
// If no permanent items found, insert the default folder name and select it
//
if cbGroups.Items.count = 1 then begin
cbGroups.Items.Add(DEFAULT_FOLDER);
cbGroups.ItemIndex := 1;
end;
end;
function TfrmPermanentOld.PermFoldersGetCount : cardinal;
begin
result := PermFolders.Count;
end;
function TfrmPermanentOld.PermFoldersGetItem(index : cardinal) : string;
begin
result := PermFolders.Strings[index];
end;
{
--======================
-- // Create/Destroy //
--======================
}
function TfrmPermanentOld.GetOldDataFilename(i: integer): string;
begin
result := self.AppPath + 'perm' + IntToStr(i) + '.ini';
end;
function TfrmPermanentOld.GetDataFilename(i: integer): string;
begin
case i of
0: result := IncludeTrailingPathDelimiter(self.AppPath + PermPath) + PERM0_FILE;
1: result := IncludeTrailingPathDelimiter(self.AppPath + PermPath) + PERM1_FILE;
end
end;
procedure TfrmPermanentOld.FormCreate(Sender: TObject);
var name: string;
begin
self.PermPath := DEFAULT_FOLDER;
self.AppPath := ExtractFilePath(application.ExeName);
self.PermFolders := TStringList.Create;
//
// make the new Default directory and import and
// current permanent items
//
if not DirectoryExists( self.AppPath + DEFAULT_FOLDER) then begin
mkdir(self.AppPath + DEFAULT_FOLDER);
name := GetOldDataFilename(0);
if FileExists(name) then
copyfile(pchar(name), PChar(GetDataFileName(0)), true);
name := GetOldDataFilename(1);
if fileExists(name) then
copyfile(pchar(name), PChar(GetDataFilename(1)), true);
end;
self.LoadPermanentItems;
self.PermFoldersRefresh;
end;
procedure TfrmPermanentOld.FormDestroy(Sender: TObject);
begin
//self.SavePermanentItems;
self.PermFolders.Free;
end;
{
--======================
-- // Show / Close //
--======================
}
procedure TfrmPermanentOld.FormShow(Sender: TObject);
begin
//
// blank out the edit window
//
if (lbItemname.ItemIndex = -1) then begin
txtItemName.Text := '';
if (not OverrideBlankItem) then begin
mItemText.Text := '';
end;
end;
//
// disable the up/down buttons (until an item is clicked in the list)
//
btnup.Enabled := (lbItemName.itemindex <> -1);
btndown.Enabled := btnup.enabled;
btndelete.Enabled := btnup.Enabled;
btnsave.Enabled := false;
self.PermFoldersRefresh;
end;
procedure TfrmPermanentOld.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
if Trim(cbGroups.Text) = '' then begin
if PermPath = '' then begin
cbGroups.Text := DEFAULT_FOLDER;
PermPath := cbGroups.Text;
end else begin
cbGroups.text := PermPath;
end;
self.LoadPermanentItems;
end else begin
PermPath := trim(cbGroups.text);
end;
self.SavePermanentItems;
self.PermFoldersRefresh;
self.ModalResult := 1;
end;
{
--==================================
-- // Load/Save Permanent Items //
--==================================
}
procedure TfrmPermanentOld.LoadPermanentItems;
var name, itemText, s : string;
lineCount : cardinal;
i : integer;
tf : textfile;
begin
//
// load permanent items
//
lbItemName.Items.Clear;
name := GetDataFilename(0);
if FileExists(name) then begin
lbItemName.Items.LoadFromFile(name);
end;
//
// abort reading and show message on error
// always close the file
//
lbItemText.Items.Clear;
name := GetDataFilename(1);
if FileExists(name) then begin
AssignFile(tf, name);
Reset(tf, name);
try
while not eof(tf) do begin
try
Readln(tf, s);
itemText := '';
lineCount := StrToInt(s);
for i := 0 to lineCount - 1 do begin
Readln(tf, s);
if (itemText = '') then begin
itemText := s;
end else begin
itemText := itemText + chr(13) + chr(10) + s;
end;
end;
lbItemText.Items.Add(itemText);
except
on E: Exception do begin
ShowMessage('The "Permanent Item" file for group ' + PermPath + ' is corrupted - ' + name + #13#10#13#10 +
'Error Message: ' + E.Message);
break;
end;
end;
end;
finally
CloseFile(tf);
end;
end;
end;
procedure TfrmPermanentOld.SavePermanentItems;
var name: string;
s : string;
cnt : cardinal;
i,j: longint;
tf: textfile;
DoRefresh : boolean;
begin
PermPath := trim(cbGroups.text);
if (PermPath = '') then
EXIT;
DoRefresh := false;
if not DirectoryExists(AppPath + PermPath) then begin
mkdir(AppPath + PermPath);
DoRefresh := true;
end;
//
// save items
//
name := GetDataFilename(0);
lbItemName.Items.SaveToFile(name);
name := GetDataFilename(1);
AssignFile(tf, name);
Rewrite(tf);
for i := 0 to lbItemText.Count - 1 do begin
s := lbItemText.Items[i];
cnt := 1;
for j := 1 to length(s) - 1 do begin
if (s[j] = #13) and (s[j+1]= #10) then inc(cnt);
end;
writeln(tf, cnt);
writeln(tf, s);
end;
CloseFile(tf);
if (DoRefresh) then begin
self.PermFoldersRefresh;
end;
end;
{
--
-- Only show the save button when an item name and some item text has been entered
--
}
procedure TfrmPermanentOld.txtItemNameChange(Sender: TObject);
begin
btnsave.Enabled := (trim(txtitemname.Text) <> '') and (mItemText.Text <> '');
end;
procedure TfrmPermanentOld.mItemTextChange(Sender: TObject);
begin
btnsave.Enabled := (trim(txtitemname.Text) <> '') and (mItemText.Text <> '');
end;
procedure TfrmPermanentOld.btnSaveClick(Sender: TObject);
var i: integer;
pos: integer;
begin
txtItemName.text := trim(txtItemName.text);
pos := -1;
for i := 0 to lbItemName.count -1 do begin
if (lbItemName.items[i] = txtItemName.Text) then begin
pos := i;
end;
end;
if (pos = -1) then begin
lbItemName.Items.Add( trim(txtItemName.Text) );
lbItemText.Items.Add( mItemText.Text );
end else begin
lbItemText.Items[pos] := mItemText.Text;
end;
txtItemName.Text := '';
mItemText.Text := '';
end;
{
Load the edit pane when an item is selected from the lsit
Enable position moving
}
procedure TfrmPermanentOld.lbItemNameClick(Sender: TObject);
begin
btnUp.Enabled := (lbItemName.Count > 0);
btnDown.Enabled := btnUp.Enabled;
btnDelete.Enabled := btnUp.Enabled;
txtItemName.text := lbItemName.items[ lbItemName.ItemIndex ];
mItemText.Text := lbItemText.Items[ lbItemName.ItemIndex ];
end;
{
move selected item up or down and keep selected
}
procedure TfrmPermanentOld.btnUpClick(Sender: TObject);
var i: integer;
begin
i := lbItemName.ItemIndex;
if (i <> 0) then begin
lbItemName.Items.Move(i, i - 1);
lbItemText.Items.Move(i, i - 1);
lbItemName.ItemIndex := i - 1;
end;
end;
procedure TfrmPermanentOld.btnDownClick(Sender: TObject);
var i: integer;
begin
i := lbItemName.ItemIndex;
if (i <> lbItemName.Count -1) then begin
lbItemName.Items.Move(i, i + 1);
lbItemText.Items.Move(i, i + 1);
lbItemName.ItemIndex := i + 1;
end;
end;
procedure TfrmPermanentOld.btnDeleteClick(Sender: TObject);
var i: integer;
begin
i := lbItemName.ItemIndex;
lbItemName.Items.Delete(i);
lbItemText.Items.Delete(i);
txtItemName.Text := '';
mItemText.Text := '';
end;
procedure TfrmPermanentOld.cbGroupsCloseUp(Sender: TObject);
begin
//
// load an existing group or get ready for a brand new group
//
if cbGroups.Items[cbGroups.ItemIndex] = ADDNEW_FOLDER then begin
lbItemName.Items.clear;
lbItemText.Items.Clear;
cbGroups.Text := '';
cbGroups.SelText := '';
end else begin
self.SavePermanentItems;
PermPath := cbGroups.items[cbGroups.ItemIndex];
self.LoadPermanentItems;
end;
end;
procedure TfrmPermanentOld.btnDeleteGroupClick(Sender: TObject);
begin
//
// get rid of the data files and remove the folder
// refresh to show changes
//
if DirectoryExists(AppPath + cbGroups.Text) then begin
deletefile( GetDataFilename(0) );
deleteFile( GetDataFilename(1) );
RmDir(AppPath + cbGroups.Text);
cbGroups.Text := '';
PermPath := '';
self.PermFoldersRefresh;
self.LoadPermanentItems;
end;
end;
procedure TfrmPermanentOld.cbGroupsClick(Sender: TObject);
begin
self.SavePermanentItems;
end;
end.