DirMerge is a Windows tool that can be used to copy one folder to another with a number of extra options that you don’t have in Windows explorer or in most other programs that can copy files.
Features include:
- Copies directories with or without entire subdirectory structure
- Optional source file deletion after copying (only if it was copied OR even if the file was skipped)
- Overwrites file never, always OR only if a file is (that much) larger, smaller, older or newer than the existing file.
- Or just ask the user what to do when a file already exists.
I’ve published this under the GPL license.
Download the executable: DirMerge.exe (for Windows 95/98/2000/XP/Vista)
And view the source code here:
unit DirMergeMainForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, FileCtrl, ExtCtrls, ComCtrls, IniFiles, DateUtils;
type
TfrmDirMerge = class(TForm)
GroupBox1: TGroupBox;
edSource: TEdit;
edTarget: TEdit;
btnSource: TSpeedButton;
btnTarget: TSpeedButton;
StaticText1: TStaticText;
StaticText2: TStaticText;
btnStart: TSpeedButton;
rgOverwrite: TRadioGroup;
cbCondition: TComboBox;
edAtLeast: TEdit;
cbSize: TComboBox;
cbTime: TComboBox;
StaticText3: TStaticText;
edFilter: TEdit;
cbSubdirs: TCheckBox;
ProgressBar1: TProgressBar;
RichEdit1: TRichEdit;
rgDelete: TRadioGroup;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnStartClick(Sender: TObject);
procedure cbConditionSelect(Sender: TObject);
procedure btnTargetClick(Sender: TObject);
procedure btnSourceClick(Sender: TObject);
private
function CopyFiles(const sourcePath, targetPath, filter: String;
IncludeSubDir:boolean; atLeast:Integer): boolean;
function CopyWithProgress(sSource, sDest: string): Boolean;
procedure ColorLastLine(AColor: TColor);
procedure AddLineWithColor(aText:String; AColor: TColor);
procedure AppendWithColor(aText:String; AColor: TColor);
public
{ Public declarations }
end;
var
frmDirMerge: TfrmDirMerge;
FCancelled: boolean;
implementation
{$R *.dfm}
procedure TfrmDirMerge.btnSourceClick(Sender: TObject);
var
dir : string;
begin
dir := edSource.Text;
if SelectDirectory('Select source directory', '', dir) then
edSource.Text := dir;
end;
function CopyFileWithProgressBar2(TotalFileSize,
TotalBytesTransferred,
StreamSize,
StreamBytesTransferred: LARGE_INTEGER;
dwStreamNumber,
dwCallbackReason: DWORD;
hSourceFile,
hDestinationFile: THandle;
lpData: Pointer): DWORD; stdcall;
begin
// just set size at the beginning
if dwCallbackReason = CALLBACK_STREAM_SWITCH then
TProgressBar(lpData).Max := TotalFileSize.QuadPart;
TProgressBar(lpData).Position := TotalBytesTransferred.QuadPart;
Application.ProcessMessages;
Result := PROGRESS_CONTINUE;
end;
procedure TfrmDirMerge.ColorLastLine(AColor: TColor);
begin
with RichEdit1 do
begin
SelStart := SendMessage(Handle, EM_LINEINDEX, Lines.Count - 1, 0);
SelLength := Length(Lines[Lines.Count - 1]);
SelAttributes.Color := AColor;
SelLength := 0;
end;
end;
procedure TfrmDirMerge.AddLineWithColor(aText:String; AColor: TColor);
begin
RichEdit1.Lines.Append(aText);
ColorLastLine(AColor);
end;
procedure TfrmDirMerge.AppendWithColor(aText:String; AColor: TColor);
begin
with RichEdit1 do
begin
Lines[Lines.Count-1] := Lines[Lines.Count-1]+aText;
ColorLastLine(AColor);
end;
end;
function TfrmDirMerge.CopyWithProgress(sSource, sDest: string): Boolean;
begin
// set this FCancelled to true, if you want to cancel the copy operation
FCancelled := False;
Result := CopyFileEx(PChar(sSource), PChar(sDest), @CopyFileWithProgressBar2,
ProgressBar1, @FCancelled, 0);
end;
procedure TfrmDirMerge.FormCreate(Sender: TObject);
begin
with TIniFile.Create(ExtractFilePath(Application.ExeName)+'DirMerge.ini') do
begin
edSource.Text := ReadString('LastSettings','SourceDir', '');
edFilter.Text := ReadString('LastSettings','Filter', '*.*');
cbSubdirs.Checked := ReadBool('LastSettings','Subdirs', False);
edTarget.Text := ReadString('LastSettings','TargetDir','');
rgDelete.ItemIndex := ReadInteger('LastSettings','DeleteOption', 0);
rgOverwrite.ItemIndex := ReadInteger('LastSettings','OverwriteOption', 3);
cbCondition.ItemIndex := ReadInteger('LastSettings','ConditionOption', 0);
edAtLeast.Text:= ReadString('LastSettings','AtLeast', '0');
cbSize.ItemIndex := ReadInteger('LastSettings','SizeOption', 0);
cbTime.ItemIndex := ReadInteger('LastSettings','TimeOption', 0);
Free;
end;
end;
procedure TfrmDirMerge.FormDestroy(Sender: TObject);
begin
with TIniFile.Create(ExtractFilePath(Application.ExeName)+'DirMerge.ini') do
begin
WriteString('LastSettings','SourceDir', edSource.Text);
WriteString('LastSettings','Filter', edFilter.Text);
WriteBool('LastSettings','Subdirs', cbSubdirs.Checked);
WriteString('LastSettings','TargetDir', edTarget.Text);
WriteInteger('LastSettings','DeleteOption', rgDelete.ItemIndex);
WriteInteger('LastSettings','OverwriteOption', rgOverwrite.ItemIndex);
WriteInteger('LastSettings','ConditionOption', cbCondition.ItemIndex);
WriteString('LastSettings','AtLeast', edAtLeast.Text);
WriteInteger('LastSettings','SizeOption', cbSize.ItemIndex);
WriteInteger('LastSettings','TimeOption', cbTime.ItemIndex);
Free;
end;
end;
function TfrmDirMerge.CopyFiles(const sourcePath, targetPath, filter: String;
IncludeSubDir:boolean; atLeast:Integer): boolean;
var
searchResult, targetResult : TSearchRec;
overwrite, delete, yesToAll, noToAll: Boolean;
choiceResult: integer;
timeDif: double;
sourceDate, targetDate: TDateTime;
sn, tn: String;
begin
yesToAll := false;
noToAll := false;
if not DirectoryExists(targetPath) then CreateDir(targetPath);
if not DirectoryExists(targetPath) then begin
AddLineWithColor('Could not create directory '+targetPath, clRed);
Result := false;
exit;
end;
if FindFirst(sourcePath+'\'+filter, faAnyFile-faDirectory, searchResult) = 0 then
begin
repeat
sn := sourcePath+'\'+searchResult.Name;
tn := targetPath+'\'+searchResult.Name;
overwrite := true;
delete := true;
if FindFirst(tn, faAnyFile-faDirectory, targetResult) = 0
then begin
sourceDate :=FileDateToDateTime(searchResult.Time);
targetDate :=FileDateToDateTime(targetResult.Time);
//File exists -> overwrite?
case rgOverwrite.ItemIndex of
0: ; // overwrite = true
1: begin
case cbCondition.ItemIndex of
0: if searchResult.Size+atleast>targetResult.Size then
overwrite := false;
1: if searchResult.Size-atleast<targetResult.Size then
overwrite := false;
2,3: begin
case cbTime.ItemIndex of
0: timeDif := SecondSpan(sourceDate,targetDate);
1: timeDif := MinuteSpan(sourceDate,targetDate);
2: timeDif := HourSpan(sourceDate,targetDate);
3: timeDif := DaySpan(sourceDate,targetDate);
4: timeDif := MonthSpan(sourceDate,targetDate);
5: timeDif := WeekSpan(sourceDate,targetDate);
6: timeDif := YearSpan(sourceDate,targetDate);
end;
if ((cbTime.ItemIndex=2) and (timeDif<atLeast)) or
((cbTime.ItemIndex=3) and (timeDif>atLeast)) then
overwrite := false;
end;
end;
end;
2: overwrite := false;
3: begin
if not (noToAll or yesToAll) then begin
choiceResult := MessageDlgPos(
'Do you want to overwrite '#13#13' '+tn+#13+
' '+IntToStr(targetResult.Size)+' bytes'#13+
' Last modified '+DateToStr(targetDate)+#13+
#13+' with '+#13#13' '+sn+#13+
' '+IntToStr(searchResult.Size)+' bytes'#13+
' Last modified '+DateToStr(sourceDate),
mtConfirmation, mbYesAllNoAllCancel, 0, 20, 100);
if choiceResult = mrYesToAll then yesToAll := true
else if choiceResult = mrNoToAll then noToAll := true
else if choiceResult = mrCancel then begin
addLineWithColor('Canceled',clRed);
result := true;
exit;
end;
end;
if noToAll then choiceResult := mrNo;
if yesToAll then choiceResult := mrYes;
if choiceResult = mrNo then overwrite := false;
end; //ask
end;
FindClose(targetResult);
if overwrite then begin
AddLineWithColor('Overwriting '+sn+'...', clBlue);
if CopyWithProgress(sn, tn) then AppendWithColor('done',clBlue)
else begin //if failed, we don't want to delete the source in any case
AppendWithColor('failed',clRed);
delete := false;
end;
end
else begin
AddLineWithColor('Skipped '+sn, clBlack);
end;
end
else begin
//File doesn't exists in target -> regular copy
AddLineWithColor('Copying '+sn+'...',clGreen);
if CopyWithProgress(sn, tn) then AppendWithColor('done',clGreen)
else begin //if failed, we don't want to delete the source in any case
AppendWithColor('failed',clRed);
delete := false;
end;
end;
//If selected, delete the source file
if delete and
(((rgDelete.ItemIndex=1) and overwrite) or (rgDelete.ItemIndex=2))
then
if DeleteFile(sn)
then AppendWithColor('Deleted '+sn, clPurple)
else AppendWithColor('Failed deleting '+sn, clRed);
until FindNext(searchResult) <> 0;
FindClose(searchResult);
end
else showMessage('No files found ('+sourcePath+'\'+filter+')');
if not IncludeSubDir then begin
Result := true;
Exit;
end;
if FindFirst(SourcePath+'\'+filter, faDirectory, searchResult) = 0 then
begin
repeat
if (SearchResult.Name <> '.') and (SearchResult.Name <> '..') then begin
if not CopyFiles (SourcePath + '\' + SearchResult.Name,
TargetPath + '\' + SearchResult.Name, Filter, TRUE, atLeast)
then begin
Result := false;
FindClose(searchResult);
Exit;
end;
end;
until FindNext(searchResult) <> 0;
FindClose(searchResult);
end;
Result := True;
end;
procedure TfrmDirMerge.btnStartClick(Sender: TObject);
var
sourcepath, targetpath: String;
atLeast: Integer;
begin
atLeast:=0;
//Determine the at least value (only if option 1 is selected)
if rgOverwrite.ItemIndex=1 then begin
try
atLeast := StrToInt(edAtLeast.Text);
except on EConvertError do
begin
showMessage('Invalid value in the ''at least'' box');
exit;
end;
end;
case cbCondition.ItemIndex of
0,1: case cbSize.ItemIndex of
1: atLeast := atLeast*1024; //kB
2: atLeast := atLeast*1024*1024; //MB
3: atLeast := atLeast*1024*1024*1024 //GB
end;
end;
end;
sourcePath := edSource.Text;
if Copy(sourcePath,Length(sourcePath),1)='\' then
sourcePath := Copy(sourcePath,1,Length(sourcePath)-1);
targetPath := edTarget.Text;
if Copy(targetPath,Length(targetPath),1)='\' then
targetPath := Copy(targetPath,1,Length(targetPath)-1);
if UpperCase(sourcePath)=UpperCase(targetPath) then begin
AddLineWithColor('Directories are the same', clRed);
exit;
end;
if CopyFiles(sourcePath, targetPath, edFilter.Text, cbSubdirs.Checked, atLeast)
then AddLineWithColor('Finished', clGreen)
else AddLineWithColor('Finished - with errors', clRed);
end;
procedure TfrmDirMerge.btnTargetClick(Sender: TObject);
var
dir : string;
begin
dir := edTarget.Text;
if SelectDirectory('Select target directory', '', dir) then
edTarget.Text := dir;
end;
procedure TfrmDirMerge.cbConditionSelect(Sender: TObject);
begin
if (cbCondition.ItemIndex=0) or (cbCondition.ItemIndex=1) then begin
cbSize.Visible := true;
cbTime.Visible := false;
end
else begin
cbSize.Visible := false;
cbTime.Visible := true;
end;
end;
end.
object frmDirMerge: TfrmDirMerge
Left = 0
Top = 0
Caption = 'DirMerge (Beta) by Bart Groot'
ClientHeight = 494
ClientWidth = 529
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object GroupBox1: TGroupBox
AlignWithMargins = True
Left = 5
Top = 5
Width = 519
Height = 289
Margins.Left = 5
Margins.Top = 5
Margins.Right = 5
Margins.Bottom = 5
Align = alTop
Constraints.MinHeight = 289
Constraints.MinWidth = 519
TabOrder = 0
DesignSize = (
519
289)
object btnSource: TSpeedButton
Left = 239
Top = 15
Width = 23
Height = 22
Caption = '...'
OnClick = btnSourceClick
end
object btnTarget: TSpeedButton
Left = 240
Top = 80
Width = 23
Height = 22
Caption = '...'
OnClick = btnTargetClick
end
object btnStart: TSpeedButton
Left = 430
Top = 229
Width = 78
Height = 42
Caption = '&Start copying'
OnClick = btnStartClick
end
object edSource: TEdit
Left = 72
Top = 16
Width = 161
Height = 21
TabOrder = 0
end
object edTarget: TEdit
Left = 73
Top = 80
Width = 161
Height = 21
TabOrder = 3
end
object StaticText1: TStaticText
Left = 10
Top = 20
Width = 56
Height = 17
Caption = 'Source dir:'
TabOrder = 10
end
object StaticText2: TStaticText
Left = 11
Top = 84
Width = 55
Height = 17
Caption = 'Target dir:'
TabOrder = 11
end
object rgOverwrite: TRadioGroup
Left = 11
Top = 118
Width = 497
Height = 105
Caption =
'If a file already exists in the target dir with the same name as' +
' a source file, then'
ItemIndex = 3
Items.Strings = (
'Always overwrite'
'Only overwrite if source file is than ta' +
'rget file by at least'
'Never overwrite'
'Ask me what to do')
TabOrder = 5
end
object cbCondition: TComboBox
Left = 184
Top = 153
Width = 63
Height = 21
Style = csDropDownList
ItemHeight = 13
ItemIndex = 0
TabOrder = 6
Text = 'larger'
OnSelect = cbConditionSelect
Items.Strings = (
'larger'
'smaller'
'newer'
'older')
end
object edAtLeast: TEdit
Left = 384
Top = 153
Width = 42
Height = 21
TabOrder = 7
Text = '0'
end
object cbTime: TComboBox
Left = 432
Top = 153
Width = 63
Height = 21
Style = csDropDownList
ItemHeight = 13
ItemIndex = 0
TabOrder = 9
Text = 'seconds'
Items.Strings = (
'seconds'
'minutes'
'hours'
'days'
'weeks'
'months'
'years')
end
object cbSize: TComboBox
Left = 432
Top = 153
Width = 63
Height = 21
Style = csDropDownList
ItemHeight = 13
ItemIndex = 0
TabOrder = 8
Text = 'bytes'
Items.Strings = (
'bytes'
'KBytes'
'MBytes'
'GBytes')
end
object StaticText3: TStaticText
Left = 17
Top = 47
Width = 49
Height = 17
Caption = 'File filter:'
TabOrder = 12
end
object edFilter: TEdit
Left = 72
Top = 43
Width = 64
Height = 21
Anchors = [akLeft, akTop, akRight]
TabOrder = 1
Text = '*.*'
end
object cbSubdirs: TCheckBox
Left = 142
Top = 45
Width = 147
Height = 17
Caption = 'Include subdirectories'
TabOrder = 2
end
object ProgressBar1: TProgressBar
Left = 19
Top = 248
Width = 405
Height = 23
TabOrder = 13
end
object rgDelete: TRadioGroup
Left = 280
Top = 15
Width = 228
Height = 87
Caption = 'When done with source file'
ItemIndex = 0
Items.Strings = (
'Do nothing (regular copy)'
'Delete it if it was copied'
'Delete it')
TabOrder = 4
end
end
object RichEdit1: TRichEdit
Left = 0
Top = 299
Width = 529
Height = 195
Align = alClient
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 1
end
end