screenfilecheck.pas

crc32 算法的delphi实现。并且可以对指定文件进行校验。

  // FLAG = FALSE to start Scan; TRUE when Scan finished
  PROCEDURE SetState (CONST Flag:  BOOLEAN);
  BEGIN
    AnimateScan.Active := NOT Flag;
    AnimateScan.Visible := NOT Flag;
    BitBtnCancelScan.Enabled := NOT Flag;

    BitBtnPrintLog.Enabled := Flag;
    BitBtnScanDirectory.Enabled   := Flag;
    BitBtnScanFile.Enabled := Flag;
    BitBtnScanVolume.Enabled := Flag;
    CheckBoxAllSubdirectories.Enabled := Flag;
    CheckBoxCRC.Enabled := Flag;
    DirectoryListBox.Enabled := Flag;
    DriveComboBox.Enabled := Flag;
    FileListBox.Enabled := Flag;
    GroupBoxOutputFiles.Enabled := Flag;
    RadioGroupShow.Enabled := Flag;
    SpeedButtonRefresh.Enabled := Flag;
  END {SetState};


  PROCEDURE ScanDirectoryTarget (CONST Info:  STRING);
    VAR
      DirectoryList :  TStringList;
      Line          :  STRING;
      Path          :  STRING;
      s             :  STRING;
  BEGIN
    IF   WriteFlagFileList
    THEN BEGIN
      WRITELN(FileListFile,
        'FileCheck:  ' + Target + ' ' +
        FormatDateTime('mm/dd/yyyy hh:nn', Now));
      IF   LENGTH(Info) > 0
      THEN WRITELN(FileListFile, Info);
      WRITELN(FileListFile, '')
    END;

    Line := '   Date      Time   Attrib    Bytes   ' + ' ';
    IF   CheckBoxCRC.Checked
    THEN Line := Line + ' CRC-32 ' + ' ';
    Line := Line + 'Filename';

    IF   WriteFlagFileList
    THEN WRITELN(FileListFile, Line);

    Line := '---------- -------- ------ -----------' + ' ';
    IF   CheckBoxCRC.Checked
    THEN Line := Line + '--------' + ' ';

    Line := Line + '--------';

    IF   WriteFlagFileList
    THEN WRITELN(FileListFile, Line);

    IF   LENGTH(Target) > 0
    THEN BEGIN
      DirectoryList := TStringList.Create;
      TRY
        DirectoryList.Sorted     := TRUE;
        DirectoryList.Duplicates := dupError;
        Path := Trim(Target);

        // Strip off any trailing '\'
        IF   Path[LENGTH(Path)] = '\'
        THEN SetLength(Path, LENGTH(Path)-1);

        IF   CheckBoxCRC.Checked
        THEN BEGIN
          IF   RadioGroupShow.ItemIndex = 0
          THEN BEGIN
            VerifyLine := Format('* %14s %8s %s',
                            [' ', ' ', 'Directories Only']);
            TRY
              IF   WriteFlagCRCVerify
              THEN WRITELN(CRCVerifyFile, VerifyLine);
            EXCEPT
              ON EInOutError DO
                MessageDlg('Error writing CRCVerifyFile file.', mtError, [mbOK], 0)
            END
          END;

          IF   LENGTH(Info) > 0
          THEN BEGIN
            VerifyLine := Format('V %14s %8s %s',
                            [' ', ' ', Info]);
            TRY
              IF   WriteFlagCRCVerify
              THEN WRITELN(CRCVerifyFile, VerifyLine);
            EXCEPT
              ON EInOutError DO
                MessageDlg('Error writing CRCVerifyFile file.', mtError, [mbOK], 0)
            END
          END;

          VerifyLine := Format('P %14s %8s %s',
                          [' ', ' ', Path]);
          TRY
            IF   WriteFlagCRCVerify
            THEN WRITELN(CRCVerifyFile, VerifyLine);
          EXCEPT
            ON EInOutError DO
              MessageDlg('Error writing CRCVerifyFile file.', mtError, [mbOK], 0)
          END;

        END;

        DirectoryList.Add(Path);
        StartTime := GetTickCount;
        ScanDirectory(DirectoryList,
                      DirectoryScope,
                      ProcessDirectory,
                      ProcessFile,
                      OrderByFileName)
      FINALLY
        DirectoryList.Clear;
        DirectoryList.Free
      END
    END;

    IF  CheckBoxCRC.Checked
    THEN BEGIN
      LabelCRC32Value.Caption := IntToHex(NOT AllCRC32, 8);
      LabelCRC32Value.Update
    END;

    IF   WriteFlagFileList AND FileListLibrary.ContinueScan
    THEN BEGIN
      WRITELN(FileListFile, '');
      WRITELN(FileListFile,'Summary of ' + Target);
      WRITELN(FileListFile,'  Directories = ' + Format('%15s', [LabelDirCount.Caption]));
      WRITELN(FileListFile,'  Files       = ' + Format('%15s', [LabelFileCount.Caption]));
      WRITELN(FileListFile,'  Bytes       = ' + Format('%15s', [LabelByteCount.Caption]));

      IF   CheckBoxCRC.Checked
      THEN BEGIN
        IF   WriteFlagFileList
        THEN WRITELN(FileListFile,'  Meta CRC-32 = ' + Format('%15s', [LabelCRC32Value.Caption]));

        VerifyLine := Format('S %14s %s %d %d',
                            [FormatFloat(FormatBytesString, AllBytecount),
                             IntToHex(NOT AllCRC32,8),
                             AllFileCount, AllDirCount]);
        TRY
          IF   WriteFlagCRCVerify
          THEN WRITELN(CRCVerifyFile, VerifyLine);
        EXCEPT
          ON EInOutError DO
            MessageDlg('Error writing CRCVerifyFile file.', mtError, [mbOK], 0)
        END

      END
    END;

    s := Format('%s = %s, %s = %s, %s = %s',
                [LabelDir.Caption,
                 LabelDirCount.Caption,
                 LabelFile.Caption,
                 LabelFileCount.Caption,
                 LabelByte.Caption,
                 LabelByteCount.Caption]);
    IF   CheckBoxCRC.Checked
    THEN s := s + Format(', %s = %s',
                [LabelCRC32.Caption,
                 LabelCRC32Value.Caption]);
    MemoScanLog.Lines.Add(s);
    MemoScanLog.Lines.Add('Scan time = ' + LabelScanElapsedTime.Caption +
                          ' sec  (' +
                          FormatDateTime('d mmm yyyy  h:nn:ss', Now) + ')');

  END {ScanDirectoryTarget};

begin
  ErrorCount := 0;

  Code1 := 0;  // in case files are never opened
  Code2 := 0;

  ResetScanValues;

  // The "New" button affects output files and the ErrorLog
  IF   SpeedButtonNew.Down
  THEN MemoScanLog.Lines.Clear;

  // WriteFlagFileList will be TRUE if filename is non-blank
  WriteFlagFileList := (Trim(EditScanFileListFile.Text) <> '');
  IF   WriteFlagFileList
  THEN BEGIN
    AssignFile(FileListFile, EditScanFileListFile.Text);

    {$I-}
    IF   SpeedButtonNew.Down
    THEN BEGIN
      // For "New" always rewrite new file
      Rewrite(FileListFile);
    END
    ELSE BEGIN
      // Append button must be down:  Append if file already exists,
      // otherwise rewrite new file
      IF   SysUtils.FileExists(EditScanFileListFile.Text)
      THEN Append(FileListFile)
      ELSE Rewrite(FileListFile)
    END;
    {$I+}

    Code1 := IORESULT;
    IF   Code1 <> 0
    THEN ShowMessage('Cannot open FileList File <' + EditScanFileListFile.Text + '.');
  END;

  WriteFlagCRCVerify := (Trim(EditScanCRCVerifyFile.Text) <> '');
  IF   WriteFlagCRCVerify
  THEN BEGIN
    AssignFile(CRCVerifyFile, EditScanCRCVerifyFile.Text);

    {$I-}
    IF   SpeedButtonNew.Down
    THEN BEGIN
      // For "New" always rewrite new file
      Rewrite(CRCVerifyFile);
    END
    ELSE BEGIN
      // Append button must be down:  Append if file already exists,
      // otherwise rewrite new file
      IF   SysUtils.FileExists(EditScanCRCVerifyFile.Text)
      THEN Append(CRCVerifyFile)
      ELSE Rewrite(CRCVerifyFile)
    END;
    {$I+}

    Code2 := IORESULT;
    IF   Code2 <> 0
    THEN ShowMessage('Cannot open CRC Verify File <' + EditScanCRCVerifyFile.Text + '.');
  END;

  // Continue only if there is no problem opening file(s)
  IF   (Code1 + Code2) = 0
  THEN BEGIN
    SetState (FALSE);
    TRY
      Screen.Cursor := crHourGlass;
      TRY
      
        CASE (Sender AS TBitBtn).Tag OF
          1:  BEGIN
                DirectoryScope := dsAllDirectories;
                Target := DriveComboBox.Drive + ':\';

                MemoScanLog.Lines.Add(GetVolumeInfoString(DriveComboBox.Drive));
                MemoScanLog.Lines.Add('Volume ' + Target);
                LabelCRC32.Caption := 'Meta CRC32';
                ScanDirectoryTarget (GetVolumeInfoString(DriveComboBox.Drive));
              END;

          2:  BEGIN
                IF   CheckBoxAllSubdirectories.Checked
                THEN DirectoryScope := dsAllDirectories
                ELSE DirectoryScope := dsSingleDirectory;
                Target := DirectoryListBox.Directory;
                MemoScanLog.Lines.Add('Directory ' + Target);
                LabelCRC32.Caption := 'Meta CRC32';
                ScanDirectoryTarget ('');
              END;

          3:  BEGIN
                Target := FileListBox.FileName;
                StartTime := GetTickCount;   // Reset this for files only
                MemoScanLog.Lines.Add('File ' + Target);

                // This is somewhat of a kludge just to use ProcessFile routine
                ReturnCode := FindFirst(Target, faAnyFile, SearchRec);
                TRY
                  IF   ReturnCode = 0   // should always be TRUE
                  THEN BEGIN
                    DirectoryPath := ExtractFilePath(Target);

                    // get rud if '\' at end (if present)
                    IF   DirectoryPath[LENGTH(DirectoryPath)] = '\'
                    THEN SetLength(Directorypath, LENGTH(DirectoryPath)-1);

                    FileCRC32 := ProcessFile(DirectoryPath, @SearchRec);

                    LabelCRC32.Caption := 'CRC32';

                    // The normal CRC value displayed is a "meta-CRC" in
                    // AllCRC32.  When only a single file is scanned, let's
                    // replace with actual file CRC32
                    LabelCRC32Value.Caption := IntToHex(FileCRC32, 8)
                  END
                  ELSE BEGIN
                    LabelCRC32Value.Caption := '';
                    LabelCRC32.Caption := ''
                  END
                FINALLY
                  FindClose(SearchRec)
                END

              END;

        END;

      FINALLY
        Screen.Cursor := crDefault
      END
    FINALLY
      SetState(TRUE)
    END
  END;

  IF   WriteFlagFileList
  THEN CloseFile(FileListFile);

  IF   WriteFlagCRCVerify
  THEN CloseFile(CRCVerifyFile)
end;


procedure TFormFileList.BitBtnCancelScanClick(Sender: TObject);
begin
  FileListLibrary.ContinueScan := FALSE
end;

procedure TFormFileList.FormCreate(Sender: TObject);
begin
  LabelDirectory.Caption := '';
  LabelFilename.Caption  := '';
  ResetScanValues
end;


procedure TFormFileList.SpeedButtonScanFileListClick(Sender: TObject);
begin
  SaveDialog.Filename := EditScanFileListFile.Text;
  IF   SaveDialog.Execute
  THEN EditScanFileListFile.Text := SaveDialog.Filename
end;


procedure TFormFileList.SpeedButtonScanVerifyListClick(Sender: TObject);
begin
  SaveDialog.Filename := EditScanCRCVerifyFile.Text;
  IF   SaveDialog.Execute
  THEN EditScanCRCVerifyFile.Text := SaveDialog.Filename
end;


procedure TFormFileList.SpeedButtonRefreshClick(Sender: TObject);
  VAR
    SaveDrive:  CHAR;
begin
  SaveDrive := DriveComboBox.Drive;
  TMyDriveComboBox(DriveComboBox).BuildList;
  DriveComboBox.Drive := SaveDrive;
  TMyDirectoryListBox(DirectoryListBox).BuildList;
end;


PROCEDURE TFormFileList.ResetScanValues;
BEGIN
  AllByteCount := 0;
  AllCRC32     := $FFFFFFFF;
  AllDirCount  := 0;
  AllFileCount := 0;

  LabelDirCount.Caption := FormatFloat('###,##0', AllDirCount);
  LabelFileCount.Caption := FormatFloat('###,###,##0', AllFileCount);
  LabelByteCount.Caption := FormatFloat('###,###,###,##0', AllByteCount);

  LabelCRC32Value.Caption := '';
  LabelCRC32.Caption := '';

  Application.ProcessMessages   // force update (not always needed)
END {ResetScanValue};


PROCEDURE TFormFileList.WmDeviceChange(VAR Msg:  TWMDeviceChange);
  VAR
{$IFDEF DEBUG}
    p        :  pDevBroadcastVolume;
    s        :  STRING;
{$ENDIF}
    SaveDrive:  CHAR;
BEGIN
  SaveDrive := DriveComboBox.Drive;
  TMyDriveComboBox(DriveComboBox).BuildList;