tutorials/lazarus-tutorials
1
0
Fork 0
Code Releases Activity

Merge remote-tracking branch 'origin/master'

Browse Source
This commit is contained in:
Timothy Warren 2021-11-11 15:16:15 -05:00
commit 4c0029ed4a
5 changed files with 275 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
filecopy/filecopy.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 134 KiB

76
filecopy/filecopy.lpi Normal file
View File

@ -0,0 +1,76 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="filecopy"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="filecopy.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="maincopy.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="filecopy"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

22
filecopy/filecopy.lpr Normal file
View File

@ -0,0 +1,22 @@
program filecopy;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, maincopy
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Scaled:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

57
filecopy/maincopy.lfm Normal file
View File

@ -0,0 +1,57 @@
object Form1: TForm1
Left = 353
Height = 240
Top = 214
Width = 680
ClientHeight = 240
ClientWidth = 680
LCLVersion = '2.0.0.4'
object lblCopyFrom: TLabel
Left = 20
Height = 19
Top = 20
Width = 118
Caption = 'Copy from file:'
ParentColor = False
end
object edtCopyFrom: TFileNameEdit
Left = 20
Height = 31
Top = 48
Width = 515
FileName = 'edtCopyFrom'
OnAcceptFileName = edtCopyFromAcceptFileName
FilterIndex = 0
HideDirectories = False
ButtonWidth = 23
NumGlyphs = 1
MaxLength = 0
TabOrder = 0
Text = 'edtCopyFrom'
end
object lblCopyToFile: TLabel
Left = 20
Height = 19
Top = 96
Width = 164
Caption = 'File will be copied to:'
ParentColor = False
end
object cbDate: TCheckBox
Left = 20
Height = 21
Top = 128
Width = 270
Caption = 'Copy original file''s date stamp.'
TabOrder = 1
end
object btnCopy: TButton
Left = 20
Height = 25
Top = 176
Width = 75
Caption = 'Copy file'
OnClick = btnCopyClick
TabOrder = 2
end
end

120
filecopy/maincopy.pas Normal file
View File

@ -0,0 +1,120 @@
unit maincopy;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, EditBtn,
FileUtil, LazUTF8, LazFileUtils;
type
{ TForm1 }
TForm1 = class(TForm)
btnCopy: TButton;
cbDate: TCheckBox;
edtCopyFrom: TFileNameEdit;
lblCopyToFile: TLabel;
lblCopyFrom: TLabel;
procedure btnCopyClick(Sender: TObject);
procedure edtCopyFromAcceptFileName(Sender: TObject; var Value: String);
private
SourceFileName: string;
CopiedFileName: string;
procedure CopyFile(sourceName, destinationName: string; copyDateToo: boolean);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.btnCopyClick(Sender: TObject);
var append: string;
begin
CopyFile(SourceFileName, CopiedFileName, cbDate.Checked);
btnCopy.Enabled := False;
edtCopyFrom.Text := EmptyStr;
case cbDate.Checked of
False: append := ' created with current date';
True: append := ' created with original date';
end;
lblCopyToFile.Caption := CopiedFileName + append;
end;
procedure TForm1.edtCopyFromAcceptFileName(Sender: TObject; var Value: String);
var path, fName: string;
begin
if (Value = EmptyStr) then Exit;
path := ExtractFilePath(Value);
fName := ExtractFileName(Value);
CopiedFileName := path + 'Copy of ' + fName;
case FileExistsUTF8(CopiedFileName) of
False: begin
lblCopyToFile.Caption := 'File will be copied to: '
+ CopiedFileName;
btnCopy.Enabled := True;
SourceFileName := Value;
end;
True: case QuestionDlg(
'Warning', CopiedFileName + ' already exists' + sLineBreak +
'Overwrite existing file?',
mtWarning,
[mrYes, 'Overwrite file', mrNo, 'Cancel file copy'],
0
) of
mrYes: begin
lblCopyToFile.Caption := 'File will be copied to: '
+ CopiedFileName;
btnCopy.Enabled := True;
SourceFileName := Value;
end;
else begin
Value := EmptyStr;
btnCopy.Enabled := False;
SourceFileName := EmptyStr;
CopiedFileName := EmptyStr;
end;
end;
end;
end;
procedure TForm1.CopyFile(sourceName, destinationName: string; copyDateToo: boolean);
var
src: TFileStream = nil;
dest: TFileStream = nil;
begin
if SameText(sourceName, destinationName) then Exit;
src := TFileStream.Create(UTF8ToSys(sourceName), fmOpenRead);
try
dest := TFileStream.Create(UTF8ToSys(destinationName), fmOpenWrite or fmCreate);
try
dest.CopyFrom(src, src.Size);
if CopyDateToo
then FileSetDate(dest.Handle, FileGetDate(src.Handle));
finally
dest.Free;
end;
finally
src.Free;
end;
end;
end.