-
Notifications
You must be signed in to change notification settings - Fork 0
/
MAINFM.PAS
1313 lines (1109 loc) · 46.8 KB
/
MAINFM.PAS
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
unit MainFm;
{===========================================================
DESCRIPTION: Xceed Zip 32-bit Delphi 3.0 Demo v3.0
COPYRIGHT: © Copyright 1995-1997 Xceed Software Inc.,
All Rights Reserved.
===========================================================}
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, FileCtrl,
Forms, Dialogs, Menus, ExtCtrls, StdCtrls, Gauges, Buttons, ComCtrls, XcdZipD3;
type
TMainFormFm = class(TForm)
FilesLb: TListBox;
MainMn: TMainMenu;
FileMn: TMenuItem;
FileNewMn: TMenuItem;
FileOpenMn: TMenuItem;
FileCloseMn: TMenuItem;
N1: TMenuItem;
FileExitMn: TMenuItem;
HelpMn: TMenuItem;
HelpAboutMn: TMenuItem;
EditMn: TMenuItem;
EditAddMn: TMenuItem;
EditDeleteMn: TMenuItem;
EditExtractMn: TMenuItem;
N2: TMenuItem;
EditSelectAllMn: TMenuItem;
AddFilesDg: TOpenDialog;
NewZipDg: TSaveDialog;
OpenZipDg: TOpenDialog;
N3: TMenuItem;
EditUpdateMn: TMenuItem;
N4: TMenuItem;
EditUpdateZIPDateMn: TMenuItem;
FileDeleteMn: TMenuItem;
FileTestMn: TMenuItem;
FileFixMn: TMenuItem;
OptionsMn: TMenuItem;
OptionsUseTempFileMn: TMenuItem;
Fastestcompression: TMenuItem;
N5: TMenuItem;
Normalcompression: TMenuItem;
Bestcompression: TMenuItem;
FixNormal1: TMenuItem;
FixAgressive1: TMenuItem;
MultidiskmodeMn: TMenuItem;
N6: TMenuItem;
ClearDisksMn: TMenuItem;
NoCompression: TMenuItem;
FilesHd: THeaderControl;
StatusPn: TPanel;
Bevel1: TBevel;
StatusLb: TLabel;
HintLb: TLabel;
SpacePn: TPanel;
Panel1: TPanel;
Panel2: TPanel;
AbortSb: TSpeedButton;
ProgressBar1: TProgressBar;
MainXz: TXceedZip;
N7: TMenuItem;
SelfExtractingMnu: TMenuItem;
SelfextractorOptionsmnu: TMenuItem;
procedure FilesLbDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure FilesLbMeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure FileNewMnClick(Sender: TObject);
procedure FileOpenMnClick(Sender: TObject);
procedure FileCloseMnClick(Sender: TObject);
procedure FileExitMnClick(Sender: TObject);
procedure EditAddMnClick(Sender: TObject);
procedure EditDeleteMnClick(Sender: TObject);
procedure EditExtractMnClick(Sender: TObject);
procedure EditSelectAllMnClick(Sender: TObject);
procedure HelpAboutMnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure MainXzAdding(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
procedure MainXzDeleting(XceedZip: TXceedZip;
const FileName: String);
procedure MainXzFixing(XceedZip: TXceedZip;
const FileName: String);
procedure MainXzStatus(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
procedure MainXzUpdating(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
procedure AbortSbClick(Sender: TObject);
procedure EditMnClick(Sender: TObject);
procedure FileMnClick(Sender: TObject);
procedure EditUpdateMnClick(Sender: TObject);
procedure EditUpdateZIPDateMnClick(Sender: TObject);
procedure MainXzListing(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
procedure FileDeleteMnClick(Sender: TObject);
procedure FileTestMnClick(Sender: TObject);
procedure MainXzTesting(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
procedure MainXzExtracting(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
procedure OptionsMnClick(Sender: TObject);
procedure OptionsUseTempFileMnClick(Sender: TObject);
procedure MainXzSkippingFile(XceedZip: TXceedZip;
const Skipping: TXcdSkipping);
procedure MainXzReplace(XceedZip: TXceedZip; var Replace: TXcdReplace);
procedure FastestcompressionClick(Sender: TObject);
procedure NormalcompressionClick(Sender: TObject);
procedure BestcompressionClick(Sender: TObject);
procedure FixNormal1Click(Sender: TObject);
procedure FixAgressive1Click(Sender: TObject);
procedure MainXzNewdisk(XceedZip: TXceedZip;
const Disknumber: Integer);
procedure MultidiskmodeMnClick(Sender: TObject);
procedure NoCompressionClick(Sender: TObject);
procedure ClearDisksMnClick(Sender: TObject);
procedure FilesHdSectionResize(HeaderControl: THeaderControl;
Section: THeaderSection);
procedure MainXzGlobalStatus(XceedZip: TXceedZip;
const GlobalStats: TXcdGlobalStats);
procedure SelfExtractingMnuClick(Sender: TObject);
procedure SelfextractorOptionsmnuClick(Sender: TObject);
private
{ Private declarations }
MinWidth: Integer;
TotalSize,
TotalZipSize: LongInt;
FilesLbBytes: LongInt;
Testing: Boolean;
procedure WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
message WM_GETMINMAXINFO;
procedure StatusBarShowHint(Sender: TObject);
procedure EnableInterface(Enable: Boolean);
procedure SetSfxConfiguration;
procedure LoadFileList;
public
{ Public declarations }
end;
var
MainFormFm: TMainFormFm;
implementation
uses SFXOptFm;
{$R *.DFM}
procedure FileFix(Agressive: Boolean); forward;
{ The ParseTab function extracts a field from a string containing tab-separated
fields. For example, this function can extract the third item in a string that
was assigned the value of an item in a multi-column listbox, since items in
each column of a listbox are separated by tabs. Pass the column number in the
FieldIndex parameter. The variable passed in the FieldIndex parameter will be
incremented. The return value of ParseTab is the extracted string. }
function ParseTab(const Str: String; var FieldIndex: Integer): String;
var
I: Integer;
begin
Result := '';
if (FieldIndex > 0) and (FieldIndex <= Length(Str)) then
begin
for I := FieldIndex to Length(Str) + 1 do
if (I <= Length(Str)) and (Str[I] = #9) then
Break;
if (I <= Length(Str)) then
begin
Result := Copy(Str, FieldIndex, I - FieldIndex);
FieldIndex := I + 1;
end
else
begin
Result := Copy(Str, FieldIndex, SizeOf(String));
FieldIndex := 0;
end;
end
else
FieldIndex := 0;
end;
{ The AssignFromLb procedure takes all the entries in the first column of a
listbox and places them in a TStringList. In this demo, AssignFromLb is used
to take all the path and filenames and place them in a TStringList. When the
demo is running, it may look as if only filenames appear in the first column,
and the pathnames are in column 7, but that is only on screen. In reality,
the data in column 1 contains paths and filenames. }
procedure AssignFromLb(SourceLb: TListBox; DestList: TStringList);
var
I, C: Integer;
begin
if (SourceLb.SelCount > 0) then
for I := 0 to SourceLb.Items.Count - 1 do
if SourceLb.Selected[I] then
begin
C := 1;
DestList.Add(ParseTab(SourceLb.Items[I], C));
end;
end;
{ The HandleError function is a sample error handling routine for the purposes
of this demo, but can be used in your own programs as well. When an error
occurs, it displays a message box indicating the nature of the error. If a
warning occurs, an information message box will be shown. The function also
returns a result of 0 if ErrorCode was 0, 1 if a warning occured, or 2 if an
error occured. }
function HandleError(ErrorCode: Integer; DoingWhat: String): Integer;
var
EDesc: String;
InfoOnly: Boolean;
ErrorType: Integer;
begin
EDesc := '';
InfoOnly := False;
ErrorType := 2;
if ErrorCode > XcdSuccess then
case ErrorCode of
XcdWarningGeneral,
XcdWarningNoZipFile,
XcdErrorNothingToDo:
{ Do not show a message box for these three warning codes. }
begin
EDesc := '';
ErrorType := 1;
end;
XcdWarningFilesSkipped:
begin
EDesc := 'Some files were skipped while ' + DoingWhat + '.';
InfoOnly := True;
ErrorType := 1;
end;
XcdWarningEmptyZipfile:
begin
EDesc := 'The Zip file is empty.';
InfoOnly := True;
ErrorType := 1;
end;
XcdErrorUserAbort:
begin
EDesc := 'The ' + DoingWhat + ' operation was aborted.';
InfoOnly := True;
end;
XcdErrorNoZipFile:
EDesc := 'Could not find the archive file.';
XcdErrorEOF,
XcdErrorZipStruct:
EDesc := 'The archive file is corrupted. Try using the Fix option on it.';
XcdErrorMemory:
EDesc := 'Ran out of memory while ' + DoingWhat + '.';
XcdErrorDiskFull:
EDesc := 'Disk full while ' + DoingWhat + '.';
XcdErrorTestFailed:
EDesc := 'Test failed - Errors in the archive.';
XcdErrorZeroTested:
EDesc := 'No files ended up being tested in the archive.';
XcdErrorDLLNotFound:
EDesc := 'The XCDZIP32.DLL or the XCDUNZ32.DLL file could not be found.';
XcdErrorTempFile:
EDesc := 'Problem with the temporary file.';
XcdErrorLatest:
EDesc := 'Could not update the Zip archive date. Archive only contains ' +
'directories or is empty.';
XcdErrorLibInUse:
EDesc := 'Another application is currently performing a similar task. ' +
'Wait until the other application has completed its operation.';
XcdErrorParentDir:
EDesc := 'Attempt to remove parent directory.';
XcdErrorDosError:
EDesc := 'Could not access the Zip file or one of the files to process.';
XcdErrorNameRepeat:
EDesc := 'Names repeated in archive after discarding pathnames.';
XcdErrorMultidisk:
EDesc := 'Attempt to work with a multiple-disk Zip archive, but not in multidisk mode.';
XcdErrorWrongDisk:
EDesc := 'Wrong disk was inserted too many times.';
XcdErrorMultidiskBadCall:
EDesc := 'Function not supported in multidisk mode.';
XcdErrorCantOpenBinary:
EDesc := 'Could not open the self-extractor binary.';
XcdErrorCantOpenSFXConfig:
EDesc := 'Could not open the self-extractor configuration file';
XcdErrorInvalidEventParam:
EDesc := 'Invalid command parameter passed to an Xceed Zip event.';
XcdErrorCantWriteSfx:
EDesc := 'Not enough space on first disk to write self-extractor.';
XcdErrorRead:
EDesc := 'Problem reading from file while ' + DoingWhat + '.';
XcdErrorWrite:
EDesc := 'Problem writing to file while ' + DoingWhat + '.';
XcdErrorBinaryVersion:
EDesc := 'Invalid self-extractor binary version.';
XcdErrorCantCreateDir:
EDesc := 'Problem creating destination directory while ' + DoingWhat + '.';
XcdErrorBadCall: { Programming error in this application }
EDesc := 'Invalid property settings. Programming error.';
else
EDesc := 'An error occured while '+ DoingWhat + ' the specified files.';
end
else
ErrorType := 0;
if EDesc <> '' then
if InfoOnly then
MessageDlg(EDesc, mtInformation, [mbOK], 0)
else
MessageDlg(EDesc, mtError, [mbOK], 0);
Result := ErrorType;
end;
{ TMainFormFm }
procedure TMainFormFm.FormCreate(Sender: TObject);
begin
Application.OnHint := StatusBarShowHint;
MinWidth := Width;
Caption := 'Untitled - Xceed Zip Demo';
Application.Title := Caption;
SetSfxConfiguration;
end;
procedure TMainFormFm.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
begin
if Visible then
Message.MinMaxInfo^.ptMinTrackSize.X := MinWidth;
end;
procedure TMainFormFm.StatusBarShowHint(Sender: TObject);
begin
StatusLb.Visible := (Application.Hint = '');
HintLb.Visible := (Application.Hint <> '');
HintLb.Caption := Application.Hint;
end;
{ The EnableInterface procedure is used to 'shut down' parts of the graphical
interface of this demo while the TXceedZip component is working. It turns off
menus, changes the cursor to an hourglass, etc. It can also be called to turn
everything back on. }
procedure TMainFormFm.EnableInterface(Enable: Boolean);
const
DisableCount: Integer = 0;
begin
if Enable then
{ Keep track of multiple disables/enables, and enable interface only when
there are as many 'enables' as there were 'disables'. }
DisableCount := DisableCount - 1
else
DisableCount := DisableCount + 1;
if (DisableCount < 0) then
DisableCount := 0;
FileMn.Enabled := (DisableCount = 0);
EditMn.Enabled := (DisableCount = 0);
OptionsMn.Enabled := (DisableCount = 0);
HelpMn.Enabled := (DisableCount = 0);
FilesLb.Enabled := (DisableCount = 0);
{ Do not allow abort when not using a temp file, it can corrupt the archive. }
AbortSb.Enabled := (DisableCount <> 0) and (MainXz.UseTempFile = True);
if (DisableCount = 0) then
Cursor := crDefault
else
Cursor := crHourglass;
if Enable then
begin
ProgressBar1.Position := 0;
StatusLb.Caption := IntToStr(FilesLb.Items.Count) + ' Entries, ' +
FloatToStrF(TotalSize, ffNumber, 10, 0) + ' Bytes, ' +
FloatToStrF(TotalZipSize, ffNumber, 10, 0) + ' Bytes.';
end;
HintLb.Caption := '';
{ The HintLb and StatusLb labels are one on top of the other. }
HintLb.Visible := (DisableCount = 0);
StatusLb.Visible := (DisableCount <> 0);
end;
{ The LoadFileList procedure asks the TXceedZip component for a list of files
contained in the current archive. It calls the List method and expects to
receive all the information via the OnListing event. See the MainXzListing
procedure to see how the information is placed into the demo's main listbox. }
procedure TMainFormFm.LoadFileList;
var
Err: Integer;
NumberOfFiles: Integer;
begin
TotalSize := 0;
TotalZipSize := 0;
FilesLb.Items.Clear;
FilesLbBytes := 0;
ProgressBar1.Position := 0;
NumberOfFiles := MainXz.FileCount;
ProgressBar1.Max := NumberOfFiles;
If NumberOfFiles > 100 then
StatusLb.Caption := 'Reading ' + IntToStr(NumberOfFiles) + ' items...';
FilesLb.Items.BeginUpdate;
Err := MainXz.List;
if (Err <> XcdErrorNoZipFile) then
HandleError(Err, 'reading archive contents');
FilesLb.Items.EndUpdate;
ProgressBar1.Position := 0;
ProgressBar1.Max := 100; { reset to usual maximum }
end;
{ The FileMnClick procedure makes sure that the proper items are enabled in the
File menu. }
procedure TMainFormFm.FileMnClick(Sender: TObject);
begin
FileCloseMn.Enabled := (MainXz.ZipFileName <> '');
FileFixMn.Enabled := (MainXz.ZipFileName = '') and (not MainXz.MultidiskMode);
FileDeleteMn.Enabled := (MainXz.ZipFileName = '');
FileTestMn.Enabled := (MainXz.ZipFileName = '');
end;
{ The FileNewMnClick procedure creates a new archive file, but the archive file
is not really created until files are added to it first. }
procedure TMainFormFm.FileNewMnClick(Sender: TObject);
begin
NewZipDg.FileName := '';
EnableInterface(False);
if NewZipDg.Execute then
begin
if FileExists(NewZipDg.FileName) then
DeleteFile(PChar(NewZipDg.FileName));
{ Inform the TXceedZip component of the zip file name to use. }
MainXz.ZipFileName := NewZipDg.FileName;
Caption := ExtractFileName(MainXz.ZipFileName) + ' - Xceed Zip Demo';
Application.Title := Caption;
FilesLb.Clear;
FilesLbBytes := 0;
TotalSize := 0;
TotalZipSize := 0;
StatusLb.Caption := '';
end;
EnableInterface(True);
end;
{ The FileOpenMnClick procedure opens an already existing archive, and calls
LoadFileList to list the archive's contents into the demo's main listbox. }
procedure TMainFormFm.FileOpenMnClick(Sender: TObject);
begin
OpenZipDg.Title := 'Open Archive';
OpenZipDg.FileName := '';
EnableInterface(False);
if OpenZipDg.Execute then
begin
{ Inform the TXceedZip component of the zip file name to use. }
MainXz.ZipFileName := OpenZipDg.FileName;
Caption := ExtractFileName(MainXz.ZipFileName) + ' - Xceed Zip Demo';
Application.Title := Caption;
{ Call procedure that will list the contents of the archive into the
demo's main listbox. }
LoadFileList;
end;
EnableInterface(True);
end;
{ The FileCloseMnClick procedure closes an archive. It does not really close the
archive because the archive is already closed when not being used. It only
clears the main listbox, the ZipFileName property of the TXceedZip component,
and the application title is reset. }
procedure TMainFormFm.FileCloseMnClick(Sender: TObject);
begin
MainXz.ZipFileName := '';
Caption := 'Untitled - Xceed Zip Demo';
Application.Title := Caption;
FilesLb.Clear;
FilesLbBytes := 0;
StatusLb.Caption := '';
end;
{ The FileDeleteMnClick procedure prompts the user for an archive file to
delete, then deletes it. }
procedure TMainFormFm.FileDeleteMnClick(Sender: TObject);
begin
OpenZipDg.Title := 'Delete Archive';
OpenZipDg.FileName := '';
EnableInterface(False);
if OpenZipDg.Execute and (MessageDlg('Are you sure you want to delete file'#13 + '"'
+ OpenZipDg.FileName + '"?', mtConfirmation, [mbYes, mbNo], 0) = mrYes) then
DeleteFile(PChar(OpenZipDg.FileName));
EnableInterface(True);
end;
{ The FileTestMnClick procedure tells the TXceedZip component to test the
contents of an archive file selected by the user. A dialog box is opened for
the user to select the archive file. Note: The Test method is used, but is not
passed a list of files to process. Without a list of files to process, the
TXceedZip component will test all the files in the archive. You can pass a
list of files to test in the same way that files are passed to the Extract
method in the EditExtractMnClick procedure in this demo. This way, you can
test specific files. }
procedure TMainFormFm.FileTestMnClick(Sender: TObject);
var
Err: Integer;
begin
OpenZipDg.Title := 'Test Archive';
OpenZipDg.FileName := '';
EnableInterface(False);
{ Open a dialog box to ask for the archive filename. }
if OpenZipDg.Execute then
begin
{ Inform the TXceedZip component of the filename. }
MainXz.ZipFileName := OpenZipDg.FileName;
{ Since it may take long before getting an OnTesting event so we can
display 'Testing file...' we will display 'Testing archive...' until then. }
StatusLb.Caption := 'Testing archive ' + MainXz.ZipFileName;
Testing := True; { used so that skipping messages are different }
{ Execute the Test method. Put return value in Err. }
Err := MainXz.Test;
Testing := False;
{ Since we are testing an archive file, XcdSuccess means that all the
files in the archive have passed the test. }
if (Err = XcdSuccess) then
MessageDlg('All files in the archive are OK.',
mtInformation, [mbOK], 0)
else if (Err = XcdWarningFilesSkipped) then
{ We can permit ourselves to say 'Some files were skipped', without
specifying which ones, because the OnSkippingFile event will have
already informed us about each file being skipped. }
MessageDlg('All files tested in the archive are OK.'#13 +
'(Some files were skipped)', mtInformation, [mbOK], 0)
else
{ Regular error handler. }
HandleError(Err, 'testing');
MainXz.ZipFileName := '';
end;
EnableInterface(True);
end;
procedure TMainFormFm.FileExitMnClick(Sender: TObject);
begin
Close;
end;
{ The EditMnClick procedure makes sure that the proper menu items in the Edit
menu are enabled. For example, when we are in Multidisk mode, the Update,
Delete and UpdateZIPDate commands cannot be used. }
procedure TMainFormFm.EditMnClick(Sender: TObject);
begin
EditAddMn.Enabled := (MainXz.ZipFileName <> '')
and ((MainXz.MultidiskMode = False) or (FilesLb.Items.Count = 0));
EditDeleteMn.Enabled := (FilesLb.SelCount > 0) and (not MainXz.MultidiskMode);
EditExtractMn.Enabled := (FilesLb.SelCount > 0);
EditUpdateMn.Enabled := (MainXz.ZipFileName <> '') and (not MainXz.MultidiskMode);
EditUpdateZIPDateMn.Enabled := (FilesLb.Items.Count > 0) and (not MainXz.MultidiskMode);
EditSelectAllMn.Enabled := (FilesLb.Items.Count > 0);
end;
{ The EditAddMnClick procedure adds files to the currently opened archive file.
A dialog box is opened to allow the user to select the files to be added to
the archive. Files selected in the demo's main listbox are not considered. }
procedure TMainFormFm.EditAddMnClick(Sender: TObject);
var
FilesToAdd: TStrings;
begin
AddFilesDg.FileName := '';
EnableInterface(False);
{ Allow user to select files to add with a dialog box. }
if AddFilesDg.Execute then
begin
FilesToAdd := AddFilesDg.Files;
{ Add all the files selected from the dialog box to the TXceedZip
component's list of files to process. }
MainXz.FilesToProcess.Assign(FilesToAdd);
StatusLb.Caption := 'Adding selected files.';
{ Add the files, handle return code. }
if HandleError(MainXz.Add(xecAll), 'adding') <> 2 then
begin
{ If in Multidisk mode, tell user the add was completed (so that
the user may understand that any further disk swapping is only
to read the contents of the archive. }
if (MainXz.MultidiskMode) then
MessageDlg('Add operation completed. To test the archive, you must' +
' close it first, then select the test option from the file menu.',
mtInformation, [mbOK], 0);
{ Update the demo's main listbox to reflect the new additions. }
LoadFileList;
end;
end;
EnableInterface(True);
end;
{ The EditDeleteMnClick procedure takes the selected files in the demo's listbox
and instructs the TXceedZip component to delete these files from the currently
opened archive. }
procedure TMainFormFm.EditDeleteMnClick(Sender: TObject);
begin
EnableInterface(False);
{ Add all the files that are selected in the demo's main listbox to the
TXceedZip component's list of files to process. Since the main listbox
contains a list of files already in the currently opened archive, only files
in the archive can be selected to delete. }
AssignFromLb(FilesLb, MainXz.FilesToProcess);
StatusLb.Caption := 'Deleting selected files.';
{ Delete the files, handle return code }
HandleError(MainXz.Delete, 'deleting');
{ Update the demo's main listbox to reflect the current contents of the
currently opened archive file. }
LoadFileList;
EnableInterface(True);
end;
{ The EditExtractMnClick procedure takes the selected files in the demo's
listbox and instructs the TXceedZip component to extract these files into the
user selected destination. A dialog box is opened to let the user select the
destination directory. }
procedure TMainFormFm.EditExtractMnClick(Sender: TObject);
var
Dir: String;
begin
GetDir(0, Dir);
if (FilesLb.SelCount > 0) then
{ Ask the user where to extract the files. }
if SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate, sdPrompt], 0) then
begin
EnableInterface(False);
{ Add all the files that are selected in the demo's main listbox to the
TXceedZip component's list of files to process. Since the main listbox
contains a list of files already in the currently opened archive, only
files in the archive can be selected to extract. }
AssignFromLb(FilesLb, MainXz.FilesToProcess);
{ Tell TXceedZip component where the user wants to extract the files. }
MainXz.ExtractDirectory := Dir;
StatusLb.Caption := 'Extracting selected files.';
{ Extract the files, handle return code. }
HandleError(MainXz.Extract(xecAll),'extracting');
{ No need to update the main listbox here - contents have not changed. }
EnableInterface(True);
end;
end;
{ The EditUpdateMnClick procedure updates files in the currently opened archive
file. A dialog box is opened to allow the user to select files to be updated
in the archive. Update means that only files newer than those already in the
archive file will be added or replaced into the archive.}
procedure TMainFormFm.EditUpdateMnClick(Sender: TObject);
begin
AddFilesDg.FileName := '';
EnableInterface(False);
{ Allow user to select files to update with a dialog box. }
if AddFilesDg.Execute then
begin
{ Add all the files selected from the dialog box to the TXceedZip
component's list of files to process. }
MainXz.FilesToProcess.Assign(AddFilesDg.Files);
StatusLb.Caption := 'Updating files.';
{ Update the files, handle error }
if HandleError(MainXz.Add(xecUpdate),'updating') <> 2 then
{ Update the demo's main listbox to reflect the new additions. }
LoadFileList;
end;
EnableInterface(True);
end;
{ The EditUpdateZipDateMnClick procedure tells the TXceedZip component to update
the date of an archive file to the date of the most recent file it contains.
A dialog box opens up to prompt the user for the name of the archive file. }
procedure TMainFormFm.EditUpdateZIPDateMnClick(Sender: TObject);
begin
EnableInterface(False);
StatusLb.Caption := 'Updating ZIP date.';
{ Update the zip date, handle error }
HandleError(MainXz.UpdateZIPDate, 'updating zip date');
EnableInterface(True);
end;
{ The EditSelectAllMnClick procedure selects all the items in the demo's main
listbox. }
procedure TMainFormFm.EditSelectAllMnClick(Sender: TObject);
begin
SendMessage(FilesLb.Handle, LB_SELITEMRANGE, 1, MakeLong(0, FilesLb.Items.Count - 1));
end;
procedure TMainFormFm.OptionsMnClick(Sender: TObject);
begin
OptionsUseTempFileMn.Checked := MainXz.UseTempFile and (not MainXz.MultidiskMode);
OptionsUseTempFileMn.Enabled := not MainXz.MultidiskMode;
ClearDisksMn.Checked := MainXz.ClearDisks and (MainXz.MultidiskMode);
ClearDisksMn.Enabled := MainXz.MultidiskMode;
MultidiskModeMn.Checked := MainXz.MultidiskMode;
NoCompression.Checked := (MainXz.Compression = 0);
FastestCompression.Checked := (MainXz.Compression = 1);
NormalCompression.Checked := (MainXz.Compression = 6);
BestCompression.Checked := (MainXz.Compression = 9);
end;
{ The OptionsUseTempFileMnClick procedure informs the TXceedZip component
whether or not to use a temporary file when adding files. }
procedure TMainFormFm.OptionsUseTempFileMnClick(Sender: TObject);
begin
MainXz.UseTempFile := Not MainXz.UseTempFile;
OptionsUseTempFileMn.Checked := MainXz.UseTempFile;
end;
procedure TMainFormFm.MultidiskmodeMnClick(Sender: TObject);
begin
MainXz.MultidiskMode := Not MainXz.MultidiskMode;
MultidiskModeMn.Checked := MainXz.MultidiskMode;
end;
{ The HelpAboutMnClick option opens an about box for this demo. }
procedure TMainFormFm.HelpAboutMnClick(Sender: TObject);
begin
MessageDlg('Xceed Zip Compression Library Demo - Delphi3 Version 3.0'#13 +
'Copyright ©1995-1997 Xceed Software, all rights reserved.'#13 +
'This demo was made with Borland Delphi 3.0', mtInformation, [mbOK], 0);
end;
{ The AbortSbClick procedure prompts the user (with a message box), if they want
to stop the current operation. This procedure is called when the user clicks
on the little stop sign in the bottom right corner of the demo's main form. }
procedure TMainFormFm.AbortSbClick(Sender: TObject);
begin
if (MessageDlg('Are you sure you want to abort the current process?',
mtWarning, mbOKCancel, 0) = mrOK) then
MainXz.Abort := True;
end;
{ The FilesLbDrawItem procedure draws the items contained in the demo's main
listbox using the proper format. For example, the filename and path are
separated into the 1st and 7th column when being displayed. Column widths
are set according to the FilesHd header control which can be resized by
the user at runtime }
procedure TMainFormFm.FilesLbDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
I: Integer;
R: TRect;
FileName,
ItemStr, Str: String;
begin
with (Control as TListBox) do
begin
if (odGrayed in State) or (odDisabled in State) then
Canvas.Font.Color := clGrayText;
ItemStr := Items[Index];
I := 1;
R := Rect;
R.Right := R.Left + FilesHd.Sections[0].Width;
FileName := ParseTab(ItemStr, I);
Canvas.TextRect(R, R.Left + 2, R.Top, ExtractFileName(FileName));
R.Left := R.Right;
R.Right := R.Left + FilesHd.Sections[1].Width;
Str := ParseTab(ItemStr, I);
Canvas.TextRect(R, R.Left + (R.Right - R.Left) - Canvas.TextWidth(Str)
- 2, R.Top, Str);
R.Left := R.Right;
R.Right := R.Left + FilesHd.Sections[2].Width;
Str := ParseTab(ItemStr, I);
Canvas.TextRect(R, R.Left + (R.Right - R.Left) - Canvas.TextWidth(Str)
- 2, R.Top, Str);
R.Left := R.Right;
R.Right := R.Left + FilesHd.Sections[3].Width;
Str := ParseTab(ItemStr, I);
Canvas.TextRect(R, R.Left + (R.Right - R.Left) - Canvas.TextWidth(Str)
- 2, R.Top, Str);
R.Left := R.Right;
R.Right := R.Left + FilesHd.Sections[4].Width;
Str := ParseTab(ItemStr, I);
Canvas.TextRect(R, R.Left + (R.Right - R.Left) - Canvas.TextWidth(Str)
- 2, R.Top, Str);
R.Left := R.Right;
R.Right := R.Left + FilesHd.Sections[5].Width;
Str := ParseTab(ItemStr, I);
Canvas.TextRect(R, R.Left + (((R.Right - R.Left) - Canvas.TextWidth(Str))
div 2), R.Top, Str);
R.Left := R.Right;
R.Right := Rect.Right;
Canvas.TextRect(R, R.Left + 2, R.Top,
RemoveBackSlash(ExtractFilePath(FileName)));
end;
end;
procedure TMainFormFm.FilesLbMeasureItem(Control: TWinControl;
Index: Integer; var Height: Integer);
begin
Height := (Control as TListBox).Canvas.TextHeight('W');
end;
{ MainXz events }
{ The MainXzAdding procedure is a handler for the OnAdding event generated by
the TXceedZip component whenever a new file is going to be added to an
archive. This particular handler simply displays which file is being added
into the demo's status label, and resets the progress bar to 0%. }
procedure TMainFormFm.MainXzAdding(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
begin
StatusLb.Caption := 'Adding "' + FileStats.Name + '".'+ '('+
FloatToStrF(Filestats.size div 1024, ffFixed, 10, 0)+'K, 0%)';
end;
{ The MainXzDeleting procedure is a handler for the OnDeleting event generated
by the TXceedZip component whenever a file is being deleted from an archive.
This particular handler simply displays which file is being deleted into the
demo's status label, and resets the progress bar to 0%. Note: The progress
bar will not be updated beyond 0% during the delete operation because the
delete operation does not generate OnStatus events. }
procedure TMainFormFm.MainXzDeleting(XceedZip: TXceedZip;
const FileName: String);
begin
StatusLb.Caption := 'Deleting "' + FileName + '".';
end;
{ See the note for the MainXzDeleting procedure/handler, because this handler is
identical except for replacing Deleting with Fixing. }
procedure TMainFormFm.MainXzFixing(XceedZip: TXceedZip;
const FileName: String);
begin
StatusLb.Caption := 'Fixing "' + FileName + '".';
end;
{ The MainXzListing procedure is an event handler for the OnListing event
generated by the TXceedZip component because the List method was called to
list files in an archive. This particular handler here takes information of
each file and adds it to the demo's main listbox. No more than 64000 bytes
of files and file information will be added to the listbox. }
procedure TMainFormFm.MainXzListing(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
var
NewListboxData: String;
begin
{ The FileStats parameter contains all of the file's information. }
with FileStats do
begin
NewListBoxData := Name + #9 + DateToStr(Time) + #9 + TimeToStr(Time) + #9
+ FloatToStrF(Size, ffNumber, 10, 0) + #9 +
FloatToStrF(PackedSize, ffNumber, 10, 0) + #9 + IntToStr(Ratio) + '%';
if FilesLbBytes < 64000 then
begin
FilesLb.Items.Add(NewListBoxData);
FilesLbBytes := FilesLbBytes + Length(NewListBoxData);
end;
if ProgressBar1.Max > 100 then
ProgressBar1.Position := ProgressBar1.Position + 1;
TotalSize := TotalSize + Size;
TotalZipSize := TotalZipSize + PackedSize;
end;
end;
{ The MainXzStatus procedure is an event handler for the OnStatus event
generated by the TXceedZip component to provide a progress report on the
current file being processed. This particular handler here simply updates a
gauge to reflect the current percentage of completion for a file. It does not
use any of the other information that can be obtained from the FileStats
parameter because the filename of the file currently being processed was
already displayed in the demo's status label by the handler for the OnAdding,
OnTesting, OnFixing, and OnExtracting events. In this demo we do not display
the amount of bytes processed for the file in text. }
procedure TMainFormFm.MainXzStatus(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
begin
StatusLb.Caption := copy(StatusLb.Caption,0,Pos(',',StatusLb.Caption));
StatusLb.Caption := StatusLb.Caption + ' '+IntToStr(FileStats.Completion)+'%)'
end;
{ See the note for the MainXzDeleting procedure/handler, because this handler is
identical except for replacing 'Deleting' with 'Testing'. }
procedure TMainFormFm.MainXzTesting(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
begin
StatusLb.Caption := 'Testing "' + FileStats.Name + '".' + '('+
FloatToStrF(Filestats.size div 1024, ffFixed, 10, 0)+'K, 0%)'
end;
{ The MainXzSkipping procedure is an event handler for the TXceedZip component's
OnSkippingFile event. A message box is displayed to inform the user that a
file is being skipped. The reason why is also indicated. }
procedure TMainFormFm.MainXzSkippingFile(XceedZip: TXceedZip;
const Skipping: TXcdSkipping);
var
SkipMsg: String;
begin
if not Testing then
SkipMsg := 'Skipping "' + Skipping.Name + '", '
else
SkipMsg := 'File "' + Skipping.Name +'" failed test: ';
case TxcdSkippingReason(Skipping.Reason) of
xsrFileNotFound:
SkipMsg := SkipMsg + 'file not found.';
xsrBadCrc:
SkipMsg := SkipMsg + 'CRC does not check out.';
xsrBadVersion:
SkipMsg := SkipMsg + 'unknown compression.';
xsrUnableToOpen:
SkipMsg := SkipMsg + 'unable to open file.';
xsrUpToDate:
SkipMsg := SkipMsg + 'file is already up to date.';
xsrBadPassword:
SkipMsg := SkipMsg + 'invalid or no password to decrypt file.';
xsrBadData:
SkipMsg := SkipMsg + 'file'#39's compressed data is corrupted.';
xsrOverwrite:
SkipMsg := SkipMsg + 'instructed not to overwrite.';
end;
MessageDlg(SkipMsg, mtWarning, [mbOK], 0);
end;
{ See the note for the MainXzDeleting procedure/handler, because this handler
is identical except for replacing Deleting with Updating. }
procedure TMainFormFm.MainXzUpdating(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
begin
StatusLb.Caption := 'Updating "' + FileStats.Name + '".'+ '('+
FloatToStrF(Filestats.size div 1024, ffFixed, 10, 0)+'K, 0%)';
end;
{ See the note for the MainXzDeleting procedure/handler, because this handler is
identical except for replacing Deleting with Extracting. }
procedure TMainFormFm.MainXzExtracting(XceedZip: TXceedZip;
const FileStats: TXcdFileStats);
begin
StatusLb.Caption := 'Extracting "' + FileStats.Name + '".'+ '('+
FloatToStrF(Filestats.size div 1024, ffFixed, 10, 0)+'K, 0%)';
end;
{ The MainXzReplace procedure is an event handler for the OnReplace event
generated by the TXceedZip component whenever a file that is being extracted
may overwrite an already existing file. This procedure displays a message box
to allow the user to decide to skip the file or not. Notes: The Overwrite
property must be set to xowAsk for the OnReplace event to occur. Also, the
choice to rename the file could also be given, as well as the choice of always
overwriting or never overwriting. See 'OnReplace' in the online help. }
procedure TMainFormFm.MainXzReplace(XceedZip: TXceedZip;