📄 screenfilecheck.pas
字号:
// FileCheck of Directories for Controlling Magnetic Media (especially CD-ROMs)
// efg, July-Sep 1999
//
// Thanks to Miroslav Vancl for pointing out that the statement
//
// CalcCRC32 (@CRCValueHex[1], SizeOf(CRCValueHex), CRCTemp);
//
// should have been:
//
// CalcCRC32 (@CRCValueHex[1], Length(CRCValueHex), CRCTemp);
//
// This change was made in the April 2001 version.
unit ScreenFileCheck;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, FileCtrl, ExtCtrls, ComCtrls, Buttons,
DBT_H, // TWMDeviceChange
CRC32; // TInteger8, CalcFileCRC32
type
// Trick to call protected method of TDriveCombobox
TMyDriveComboBox = CLASS(TDriveComboBox)
END;
// Trick to call protected method of TDirectoryListbox
TMyDirectoryListBox = CLASS(TDirectoryListbox)
END;
TFormFileList = class(TForm)
OpenDialog: TOpenDialog;
PageControl1: TPageControl;
TabSheetScan: TTabSheet;
TabSheetVerify: TTabSheet;
SaveDialog: TSaveDialog;
GroupBoxOutputFiles: TGroupBox;
LabelFileList: TLabel;
EditScanFileListFile: TEdit;
SpeedButtonScanFileList: TSpeedButton;
LabelScanCRCVerifyFIle: TLabel;
EditScanCRCVerifyFile: TEdit;
SpeedButtonScanVerifyList: TSpeedButton;
GroupBoxScanLog: TGroupBox;
LabelDirectory: TLabel;
LabelFilename: TLabel;
MemoScanLog: TMemo;
GroupBoxTarget: TGroupBox;
LabelVolume: TLabel;
DriveComboBox: TDriveComboBox;
SpeedButtonRefresh: TSpeedButton;
LabelDirHeading: TLabel;
DirectoryListBox: TDirectoryListBox;
LabelFileScan: TLabel;
FileListBox: TFileListBox;
BitBtnScanDirectory: TBitBtn;
CheckBoxAllSubdirectories: TCheckBox;
BitBtnScanFile: TBitBtn;
BitBtnScanVolume: TBitBtn;
BitBtnCancelScan: TBitBtn;
LabelDir: TLabel;
LabelFile: TLabel;
LabelByte: TLabel;
LabelCRC32: TLabel;
CheckBoxCRC: TCheckBox;
RadioGroupShow: TRadioGroup;
LabelCRC32Value: TLabel;
LabelByteCount: TLabel;
LabelFileCount: TLabel;
LabelDirCount: TLabel;
LabelScanElapsedTime: TLabel;
LabelScanElapsed: TLabel;
AnimateScan: TAnimate;
BitBtnPrintLog: TBitBtn;
SpeedButtonNew: TSpeedButton;
SpeedButtonAppend: TSpeedButton;
LabelVerifyCRCVerifyFile: TLabel;
EditVerifyCRCVerifyFile: TEdit;
SpeedButtonVerifyVerifyList: TSpeedButton;
BitBtnVerifyFile: TBitBtn;
MemoVerifyLog: TMemo;
BitBtnPrint: TBitBtn;
BitBtnCancelVerify: TBitBtn;
AnimateVerify: TAnimate;
LabelVerifyFileName: TLabel;
LabelVerifyElapsed: TLabel;
LabelVerifyElapsedTime: TLabel;
ProgressBar: TProgressBar;
LabelLabURL1: TLabel;
LabelLabURL2: TLabel;
procedure CheckBoxCRCClick(Sender: TObject);
procedure BitBtnScanClick(Sender: TObject);
procedure BitBtnCancelScanClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure SpeedButtonScanFileListClick(Sender: TObject);
procedure SpeedButtonRefreshClick(Sender: TObject);
procedure SpeedButtonScanVerifyListClick(Sender: TObject);
procedure BitBtnPrintLogClick(Sender: TObject);
procedure SpeedButtonVerifyVerifyListClick(Sender: TObject);
procedure BitBtnVerifyFileClick(Sender: TObject);
procedure BitBtnCancelVerifyClick(Sender: TObject);
procedure RadioGroupShowClick(Sender: TObject);
procedure LabelLabURL2Click(Sender: TObject);
private
AllByteCount : TInteger8;
AllCRC32 : DWORD;
AllDirCount : INTEGER;
AllFileCount : INTEGER;
ContinueVerify : BOOLEAN;
CRCVerifyFile : TextFile;
DirByteCount : TInteger8;
DirCRC32 : DWORD;
DirFileCount : INTEGER;
ErrorCount : INTEGER;
FileListFile : TextFile;
StartTime : DWORD; // to keep GetTickCount happy in D3/D4
WriteFlagCRCVerify: BOOLEAN;
WriteFlagFileList : BOOLEAN;
PROCEDURE ResetScanValues;
PROCEDURE WmDeviceChange(VAR Msg: TWMDeviceChange); MESSAGE WM_DeviceChange;
public
{ Public declarations }
end;
var
FormFileList: TFormFileList;
implementation
{$R *.DFM}
USES
Printers,
TokenLibrary, // TTokens
FileListLibrary, // ScanDirectory
ShellAPI; // ShellExecute
CONST
FormatBytesString ='#############0';
// When filename has embedded space(s), put quotes around it.
// This allows tokenizer to treat filename as single token.
FUNCTION FormatFileName(CONST name: STRING): STRING;
BEGIN
IF POS(' ',name) > 0
THEN RESULT := '"' + name + '"'
ELSE RESULT := name
END;
// Callback routine used by List.Sort in ScanDirectory
FUNCTION OrderByFilename(Node1, Node2: POINTER): INTEGER;
BEGIN
// Case insensitive comparison
RESULT := StrIComp(pChar(TSearchRec(Node1^).Name),
pChar(TSearchRec(Node2^).Name));
END {CompareSearchRecs};
PROCEDURE ProcessDirectory(CONST sequence: TSequence; CONST directory: STRING);
VAR
Line : STRING;
VerifyLine: STRING;
BEGIN
WITH FormFileList DO
BEGIN
CASE sequence OF
sqBegin:
BEGIN
// Blank line between directories if files are shown
IF WriteFlagFileList AND (RadioGroupShow.ItemIndex = 1)
THEN WRITELN(FileListFile, '');
// Display directory
IF WriteFlagFileList AND (RadioGroupShow.ItemIndex >= 0)
THEN WRITELN(FileListFile, directory);
LabelDirectory.Caption := 'Directory: ' + directory;
DirFileCount := 0;
DirByteCount := 0;
DirCRC32 := $FFFFFFFF
END;
sqEnd:
BEGIN
AllDirCount := AllDirCount + 1;
LabelDirCount.Caption := FormatFloat('###,##0', AllDirCount);
Line := ' ' +
'------------' + ' ';
IF CheckBoxCRC.Checked
THEN Line := Line + '--------';
IF WriteFlagFileList
THEN WRITELN(FileListFile, Line);
Line := ' ' +
Format('%17s', [
FormatFloat('##,###,###,###', DirByteCount) ]) + ' ';
IF CheckBoxCRC.Checked
THEN BEGIN
Line := Line + IntToHex(NOT DirCRC32,8) + ' ';
VerifyLine := Format('D %14s %s %s %d',
[FormatFloat(FormatBytesString, DirByteCount),
IntToHex(NOT DirCRC32,8),
FormatFileName(directory), DirFileCount]);
TRY
IF WriteFlagCRCVerify
THEN WRITELN(CRCVerifyFile, VerifyLine);
EXCEPT
ON EInOutError DO
MessageDlg('Error writing CRCVerifyFile file.', mtError, [mbOK], 0)
END
END;
Line := Line + IntToStr(DirFileCount) + ' files';
IF WriteFlagFileList
THEN WRITELN(FileListFile, Line)
END
END
END
END {ProcessDirectory};
// Callback routine used by ScanDirectory
FUNCTION ProcessFile(CONST Path: STRING; CONST Node: pSearchRec): DWORD;
VAR
CRCTemp : DWORD;
CRCValue : DWORD;
CRCValueHex: STRING;
Error : WORD;
Line : STRING;
TotalBytes : TInteger8;
VerifyLine : STRING;
BEGIN
RESULT := 0;
// Allow "continue" to be set in FileListLibrary
Application.ProcessMessages;
WITH FormFileList DO
BEGIN
// Only look at non-directory entries
IF Node^.Attr AND faDirectory > 0
THEN CRCVAlue := 0
ELSE BEGIN
LabelFilename.Caption := 'Filename: ' + Node^.Name;
DirFileCount := DirFileCount + 1;
AllFileCount := AllFileCount + 1;
LabelFileCount.Caption := FormatFloat('###,###,##0', AllFileCount);
DirByteCount := DirByteCount + Node^.Size;
AllByteCount := AllByteCount + Node^.Size;
LabelByteCount.Caption := FormatFloat('###,###,###,##0', AllByteCount);
IF CheckBoxCRC.Checked
THEN BEGIN
CalcFileCRC32(Path + '\' + Node^.Name, CRCValue, TotalBytes, Error);
IF Error <> 0 // Ignore errors
THEN BEGIN
INC (ErrorCount);
MemoScanLog.Lines.Add(IntToStr(ErrorCount) + '. ' + 'Error Code ' +
IntToStr(Error) +
' reading file ' + Path + '\' + Node^.Name);
CRCValue := 0; // but make CRC-32 predictable
END;
RESULT := CRCValue; // return this value in case caller cares
// Make CRC value an 8-byte string
CRCValueHex := IntToHex(CRCvalue, 8);
// Update Directory "CRC"
CRCTemp := DirCRC32;
CalcCRC32 (@CRCValueHex[1], Length(CRCValueHex), CRCTemp); // 1 Apr 2001
DirCRC32 := CRCTemp;
// Update All "CRC"
CRCTemp := AllCRC32;
CalcCRC32 (@CRCValueHex[1], Length(CRCValueHex), CRCTemp); // 1 Apr 2001
AllCRC32 := CRCTemp;
LabelCRC32Value.Caption := IntToHex(NOT AllCRC32, 8);
END;
LabelScanElapsedTime.Caption := Format('%.1f', [0.001*(GetTickCount-StartTime)]);
END;
IF FormFileList.RadioGroupShow.ItemIndex = 1 {i.e., Files}
THEN BEGIN
IF Node^.Attr AND faDirectory > 0
THEN // Format Directory Entry
Line := FormatDateTime('mm/dd/yyy hh:nn:ss',
FileDateToDateTime(Node^.Time)) + ' ' +
FormatAttributes(Node^.Attr) + ' ' + ' ' + ' '
ELSE // Format File Entry
Line := FormatDateTime('mm/dd/yyy hh:nn:ss',
FileDateToDateTime(Node^.Time)) + ' ' +
FormatAttributes(Node^.Attr) + ' ' +
Format('%11s', [
FormatFloat('###,###,##0', Node^.Size) ]) + ' ';
IF CheckBoxCRC.Checked
THEN BEGIN
IF Node^.Attr AND faDirectory = 0
THEN BEGIN
Line := Line + IntToHex(CRCValue,8) + ' ' ;
VerifyLine := Format('F %14s %s %s',
[FormatFloat(FormatBytesString, Node^.Size),
IntToHex(CRCValue,8),
FormatFileName(Path + '\' + Node^.Name)]);
TRY
IF WriteFlagCRCVerify
THEN WRITELN(CRCVerifyFile, VerifyLine);
EXCEPT
ON EInOutError DO
MessageDlg('Error writing CRCVerifyFile file.', mtError, [mbOK], 0)
END
END
ELSE Line := Line + ' '; // Don't bother with directories
END;
Line := Line + Node^.Name;
IF WriteFlagFileList
THEN WRITELN(FileListFile, Line)
END;
END
END {ProcessFile};
procedure TFormFileList.CheckBoxCRCClick(Sender: TObject);
begin
IF RadioGroupShow.ItemIndex = 0
THEN CheckBoxCRC.Checked := FALSE;
EditScanCRCVerifyFile.Visible := CheckBoxCRC.Checked;
LabelScanCRCVerifyFile.Visible := CheckBoxCRC.Checked;
SpeedButtonScanVerifyList.Visible := CheckBoxCRC.Checked;
LabelCRC32.Visible := CheckBoxCRC.Checked;
LabelCRC32Value.Visible := CheckBoxCRC.Checked
end;
FUNCTION GetVolumeInfoString(CONST DriveLetter: CHAR): STRING;
VAR
NotUsed : DWORD; // Use DWORD for D3/D4 compatibility
VolumeFlags : DWORD;
VolumeInfo : ARRAY[0..MAX_PATH] OF CHAR;
VolumeSerialNumber: DWORD;
BEGIN
GetVolumeInformation(pChar(DriveLetter + ':\'),
VolumeInfo, SizeOf(VolumeInfo),
@VolumeSerialNumber, NotUsed, VolumeFlags, NIL, 0);
RESULT := Format('Label = %s VolSer = %8.8X', [VolumeInfo, VolumeSerialNumber])
END {GetVolumeInfoString};
procedure TFormFileList.BitBtnScanClick(Sender: TObject);
VAR
Code1 : WORD;
Code2 : WORD;
DirectoryPath : STRING;
DirectoryScope: TDirectoryScope;
FileCRC32 : DWORD;
ReturnCode : INTEGER;
SearchRec : TSearchRec;
Target : STRING;
VerifyLine : STRING;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -