Mega Code Archive
Utility to archive files based on a date range
<![CDATA[
Title: Utility to archive files based on a date range
Question: Archiving files based on a date range
Answer:
Ive built a small utility in Delphi to archive files based on a date range using Abbrevia components from TurboPower. You may find some more info on these components from http://swiss.torry.net/compresspacks.htm.
With this tool, you can:
1. Archive a single file by selecting a file from the File List box
2. Archive multiple files (Ctrl + Click)
3. Given a date range, you can archive all the files within that date range
4. Type in a directory to browse thru and archive
Here is the complete source code:
pZipUnZip.dpr
program pZipUnZip;
uses
Forms,
uZipUnZip in 'uZipUnZip.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
uZipUnZip.dfm
object Form1: TForm1
Left = 166
Top = 15
Width = 565
Height = 513
BorderIcons = [biSystemMenu, biMinimize]
Caption = 'Zip Files'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 557
Height = 486
Align = alClient
BevelInner = bvLowered
Caption = 'Panel1'
TabOrder = 0
object Label1: TLabel
Left = 3
Top = 75
Width = 80
Height = 13
Caption = 'Directory List:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
end
object Label2: TLabel
Left = 281
Top = 39
Width = 49
Height = 13
Caption = 'File List:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
end
object Label3: TLabel
Left = 2
Top = 2
Width = 56
Height = 13
Caption = 'Directory:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
end
object Label4: TLabel
Left = 281
Top = 2
Width = 89
Height = 13
Caption = 'File Type Filter:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
end
object Label9: TLabel
Left = 4
Top = 40
Width = 35
Height = 13
Caption = 'Drive:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
end
object Label5: TLabel
Left = 4
Top = 377
Width = 63
Height = 13
Caption = 'From Date:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
end
object Label6: TLabel
Left = 130
Top = 377
Width = 51
Height = 13
Caption = 'To Date:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
end
object FilterComboBox1: TFilterComboBox
Left = 279
Top = 17
Width = 275
Height = 21
Hint = 'Select the File Filter'
FileList = FileListBox1
Filter =
'All files (*.*)|*.*|XML Files(*.xml)|*.xml|Text Files(*.txt)|*.t' +
'xt|MSOffice(*.doc,*.rtf,*.xls,*.csv)|*.doc;*.rtf;*.csv;*.xls'
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnEnter = Edit1Enter
end
object FileListBox1: TFileListBox
Left = 278
Top = 53
Width = 275
Height = 324
Hint = 'Press F10 to Select All Files'
ItemHeight = 16
MultiSelect = True
ParentShowHint = False
ShowHint = True
TabOrder = 4
OnClick = FileListBox1Click
OnEnter = Edit1Enter
OnKeyDown = FileListBox1KeyDown
end
object DirectoryListBox1: TDirectoryListBox
Left = 1
Top = 88
Width = 275
Height = 287
Hint = 'Directory Browser'
FileList = FileListBox1
ItemHeight = 16
ParentShowHint = False
ShowHint = True
TabOrder = 3
OnEnter = Edit1Enter
end
object Edit1: TEdit
Left = 1
Top = 17
Width = 275
Height = 21
Hint = 'Type in the Directory to Browse'
ParentShowHint = False
ShowHint = True
TabOrder = 0
Text = 'Type in Directory Name'
OnEnter = Edit1Enter
OnExit = Edit1Exit
OnKeyDown = Edit1KeyDown
end
object Edit2: TEdit
Left = 3
Top = 415
Width = 244
Height = 21
Hint = 'Enter or Browse the Zip File Name'
ParentShowHint = False
ShowHint = True
TabOrder = 7
OnEnter = Edit1Enter
end
object Button1: TButton
Left = 322
Top = 414
Width = 75
Height = 25
Caption = '&Archive'
TabOrder = 9
OnClick = Button1Click
end
object Button2: TButton
Left = 247
Top = 439
Width = 75
Height = 25
Caption = '&Browse'
TabOrder = 11
Visible = False
OnClick = Button2Click
end
object DriveComboBox1: TDriveComboBox
Left = 3
Top = 54
Width = 270
Height = 19
Hint = 'Drive List'
DirList = DirectoryListBox1
ParentShowHint = False
ShowHint = True
TabOrder = 2
OnEnter = Edit1Enter
end
object StatusBar1: TStatusBar
Left = 2
Top = 465
Width = 553
Height = 19
Panels =
SimplePanel = True
SimpleText = 'Ready'
end
object Button3: TButton
Left = 322
Top = 439
Width = 75
Height = 25
Caption = '&UnZip'
TabOrder = 12
Visible = False
end
object Edit3: TEdit
Left = 3
Top = 440
Width = 244
Height = 21
Hint = 'Enter or Browse the Zip File Name to UnZip'
ParentShowHint = False
ShowHint = True
TabOrder = 10
Visible = False
OnEnter = Edit1Enter
end
object Button4: TButton
Left = 247
Top = 414
Width = 75
Height = 25
Caption = '&Browse'
TabOrder = 8
OnClick = Button4Click
end
object Edit4: TEdit
Left = 3
Top = 391
Width = 121
Height = 21
Hint = 'Date Range'
ParentShowHint = False
ShowHint = True
TabOrder = 5
OnEnter = Edit1Enter
end
object Edit5: TEdit
Left = 129
Top = 391
Width = 121
Height = 21
Hint = 'Date Range'
ParentShowHint = False
ShowHint = True
TabOrder = 6
OnEnter = Edit1Enter
end
object ProgressBar1: TProgressBar
Left = 89
Top = 235
Width = 380
Height = 34
BorderWidth = 1
Min = 0
Max = 100
Step = 1
TabOrder = 14
Visible = False
end
object Panel2: TPanel
Left = 158
Top = 194
Width = 241
Height = 41
BevelInner = bvLowered
Caption = 'Please Wait... '
Font.Charset = DEFAULT_CHARSET
Font.Color = clMaroon
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 15
Visible = False
end
end
object Button5: TButton
Left = 397
Top = 414
Width = 75
Height = 25
Caption = 'E&xit'
TabOrder = 1
OnClick = Button5Click
end
object OpenDialog1: TOpenDialog
DefaultExt = '*.zip'
InitialDir = 'C:\'
Left = 444
Top = 224
end
object AbZipper1: TAbZipper
AutoSave = True
DOSMode = False
Left = 364
Top = 246
end
end
uZipUnZip.pas
unit uZipUnZip;
{
--------------------------------------------------------------------------------
Unit Name : uZipUnzip.pas
Purpose : Zipping Files based on a date range
Developed By : S S B Magesh Puvananthiran
Date Created : September 20, 2004
Last Modified : September 20, 2004
Last Modified By : S S B Magesh Puvananthiran
--------------------------------------------------------------------------------
}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, FileCtrl, AbArcTyp, AbZBrows, AbZipper, DateUtils,
ExtCtrls, ComCtrls, Mask;
type
TForm1 = class(TForm)
Panel1: TPanel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
FilterComboBox1: TFilterComboBox;
FileListBox1: TFileListBox;
DirectoryListBox1: TDirectoryListBox;
Edit1: TEdit;
Edit2: TEdit;
Button1: TButton;
Button2: TButton;
OpenDialog1: TOpenDialog;
AbZipper1: TAbZipper;
Label9: TLabel;
DriveComboBox1: TDriveComboBox;
StatusBar1: TStatusBar;
Button3: TButton;
Edit3: TEdit;
Button4: TButton;
Edit4: TEdit;
Label5: TLabel;
Edit5: TEdit;
Label6: TLabel;
ProgressBar1: TProgressBar;
Panel2: TPanel;
Button5: TButton;
procedure FileListBox1Click(Sender: TObject);
procedure Edit1Exit(Sender: TObject);
procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure Button2Click(Sender: TObject);
procedure FileListBox1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure Button4Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Edit1Enter(Sender: TObject);
procedure Button5Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FileListBox1Click(Sender: TObject);
begin
if FileListBox1.SelCount 0 then
begin
StatusBar1.SimpleText := IntToStr(FileListBox1.SelCount) + ' File(s) Selected';
Edit4.Clear;
Edit5.Clear;
end;
end;
procedure TForm1.Edit1Exit(Sender: TObject);
begin
if DirectoryExists(Edit1.Text) then
DirectoryListBox1.Directory := Edit1.Text;
end;
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_Return then
if DirectoryExists(Edit1.Text) then
DirectoryListBox1.Directory := Edit1.Text;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if OpenDialog1.Execute then
Edit3.Text := OpenDialog1.FileName;
end;
procedure TForm1.FileListBox1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Key = VK_F10) then
begin
FileListBox1.SelectAll;
StatusBar1.SimpleText := IntToStr(FileListBox1.SelCount) + ' File(s) Selected';
end;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
if OpenDialog1.Execute then
Edit2.Text := OpenDialog1.FileName;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
LoopCount : Integer;
YearSelected, MonthSelected, DateSelected : String;
FileYear, FileMonth, FileDate : String;
SelectedFileDate : String;
NoOfFilesAdded : Integer;
begin
if Trim(Edit2.Text) '' then
begin
NoOfFilesAdded := 0;
AbZipper1.FileName := Edit2.Text;
for LoopCount := 0 to FileListBox1.Count - 1 do
begin
StatusBar1.SimpleText := 'Please wait... Archiving in Progress...';
Panel2.Visible := True;
Panel2.Caption := 'Please Wait...';
ProgressBar1.Visible := True;
ProgressBar1.Position := ProgressBar1.Step + LoopCount;
if (Edit5.Text '') and (Edit4.Text '') then
begin
if FileExists(FileListBox1.Items.Strings[LoopCount]) then
begin
FileDate := DateTimeToStr(DateOf(FileDateToDateTime(FileAge(FileListBox1.Items.Strings[LoopCount]))));
if (StrToDate(FileDate) = StrToDate(Edit4.Text)) and (StrToDate(FileDate) begin
NoOfFilesAdded := NoOfFilesAdded + 1;
AbZipper1.AddFiles(FileListBox1.Items.Strings[LoopCount],0);
end;
end;
end
else
begin
if FileListBox1.Selected[LoopCount] then
begin
if FileExists(FileListBox1.Items.Strings[LoopCount]) then
begin
NoOfFilesAdded := NoOfFilesAdded + 1;
AbZipper1.AddFiles(FileListBox1.Items.Strings[LoopCount],0);
end;
end;
end;
Application.ProcessMessages;
end;
AbZipper1.CloseArchive;
StatusBar1.SimpleText := IntToStr(NoOfFilesAdded) + ' files added to the Archive successfully';
Panel2.Visible := False;
ProgressBar1.Visible := False;
ProgressBar1.Position := 0;
end
else
begin
MessageDlg('Please enter a valid Zip File Name',mtWarning,[mbOk],0);
Edit2.SetFocus;
end;
end;
procedure TForm1.Edit1Enter(Sender: TObject);
begin
StatusBar1.SimpleText := 'Ready';
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
Close;
end;
end.
Again, please feel free to share your thoughts and comments. As Im having trouble sending the source code as zipped file to the webmaster, you may not be able to download the source code immediately.
]]>