unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, Math;
type
{ TForm1 }
TForm1 = class(TForm)
NextBtn: TButton;
LastBtn: TButton;
Edit1: TEdit;
Msg: TLabel;
procedure ButtonClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
type
TFileErr = (fnOK, fnInv, fnNonEx, fnNotWrit);
var
aPath, aExtension: rawbytestring;
function IsDirectoryWritable: TFileErr;
var
Chk_FileName, S: rawbytestring;
Chk_H: THandle;
begin
if (aPath <> '') and not DirectoryExists(aPath) then
exit(fnNonEx);// folder not found
Chk_FileName := aPath + 'chkazz3456.czz';
Chk_H := FileCreate(PChar(Chk_FileName), fmCreate, 438);
if Chk_H = feInvalidHandle then
exit(fnNotWrit) // Folder Not Writeable
else
begin
// check if file can be written to
s := 'WriteSomeText';
if FileWrite(Chk_H, S[1], Length(S)) > 0 then Result := fnOK
else
exit(fnNotWrit); // Folder Not Writeable
end;
FileClose(Chk_H);
DeleteFile(Chk_FileName);
Result := fnOK;
end;
function CreateUniqueFileName(InFile: rawbytestring; var OutFile: rawbytestring;
LowNum: boolean = True): TFileErr;
function LastFile: rawbytestring;
var
RetVar: boolean;
Last, L, R: integer;
SearchRec: TSearchRec;
s, Num: string;
begin // Recursive Dir Search
s := UpperCase(InFile);
RetVar := False;
Last := 0;
if FindFirst(aPath + '*' + aExtension, faAnyFile, SearchRec) = 0 then
if UpperCase(SearchRec.Name) <> s then
while not RetVar and (FindNext(SearchRec) = 0) do
begin
s := SearchRec.Name;
L := pos('(', s);
R := pos(')', s);
if (L > 0) and (R - L > 1) then
begin
Num := copy(s, 1, R - 1);
Num := copy(Num, L + 1);
Last := max(Last, strtointDef(Num, 0));
end;
s := s;
end; // while
FindClose(SearchRec); { *Converted from FindClose* }
Result := aPath + InFile + ' (' + IntToStr(Last + 1) + ')' + aExtension;
end;
function NextAvailableFile: rawbytestring;
var
k: integer;
begin // file exists so scan until first available is found;
k := 0;
repeat
Inc(k);
Result := aPath + InFile + ' (' + IntToStr(k) + ')' + aExtension;
until not FileExists(Result);
end;
var
fn: TFileErr;
begin
Result := fnOK;
if not fileexists(InFile) then
OutFile := InFile
else
begin
OutFile := '';
aPath := ExtractFilePath(InFile);
aExtension := ExtractFileExt(InFile);
InFile := ExtractFileName(ExcludeTrailingPathDelimiter(InFile));
InFile := copy(InFile, 1, length(InFile) - length(aExtension));
if InFile = '' then exit(fnInv);// invalid file name
fn := IsDirectoryWritable;
if fn = fnNotWrit then exit(fn)
else if LowNum then
OutFile := NextAvailableFile
else
OutFile := LastFile;
end;
end;
procedure TForm1.ButtonClick(Sender: TObject);
const
ErrMess: array[tFileErr] of string =
('OK', 'Invalid file', 'Non-existent folder', 'File unwritable');
var
aFileName, newFile: rawbytestring;
f: textfile;
b: boolean;
fn: TFileErr;
begin
aFileName := Edit1.Text;
b := TButton(Sender).tag = 0;
fn := CreateUniqueFileName(aFileName, NewFile, b);
if fn = fnOK then // gets new file name
begin
Msg.Caption := NewFile;
Assignfile(F, NewFile);
rewrite(f);
closefile(f);
end
else
Msg.Caption := ErrMess[fn];
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Msg.Caption := '';
Edit1.Text := 'test.txt';
end;
end.