cleaner.pas

特别方便的工具程序

unit Cleaner;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  IniFiles, Dialogs, StdCtrls, ComCtrls, Buttons, ExtCtrls, ActiveX, ShlObj, Menus,
  ActnList, ImgList;

type
  TDirDialog = class
    Handle: THandle;
    Title: string;
    Directory: string;
    function Execute: Boolean;
  end;

  TCleanForm = class(TForm)
    SB: TStatusBar;
    GroupBox1: TGroupBox;
    POP1: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    Panel1: TPanel;
    ListView1: TListView;
    Bevel1: TBevel;
    ImageList1: TImageList;
    Dcus: TCheckBox;
    Exes: TCheckBox;
    DSKs: TCheckBox;
    Usua: TCheckBox;
    Defs: TCheckBox;
    SubDirs: TCheckBox;
    Label2: TLabel;
    Edit1: TEdit;
    Label1: TLabel;
    DirEdit: TEdit;
    GetDirBtn: TSpeedButton;
    SrBtn: TButton;
    DelBtn: TButton;
    Button1: TButton;
    procedure FindAFile(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure GetDirBtnClick(Sender: TObject);
    procedure Findfiles(P: string);
    procedure Finddires(P: string);
    procedure BreakApart;
    procedure DelBtnClick(Sender: TObject);
    procedure SelectAll(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure DirEditDblClick(Sender: TObject);
    procedure DirEditKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    { Private-Deklarationen }
    NFile: integer;
  public
    CurPtn, Pattern: string;
    Kinds: TStrings;
  end;

var
  CleanForm: TCleanForm;
  Sizes: Longint;
  RecurseDir: Boolean;
  Cancel: Boolean;

implementation

{$R *.DFM}

function TDirDialog.Execute: Boolean;
var
  iList,
    Root: PItemIDList;
  BInfo: BrowseInfo;
  DispName: string;
  Malloc: IMalloc;

  function FNBFFCallBack(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
  var Dir: string;
  begin
    with TDirDialog(lpData) do
      case uMsg of
        BFFM_INITIALIZED:
          try
            Handle := Wnd;
            if Directory = '' then Directory := 'C:\';
            if (Directory <> '') and (Directory[Length(Directory)] = '\')
            then Delete(Directory, Length(Directory), 1);
            if (Directory <> '') and (Handle <> 0) then
              SendMessage(Handle, BFFM_SETSELECTION, Integer(LongBool(True)), Integer(pChar(Directory)));
          except
            on E: Exception do ShowMessage(E.Message);
          end;
        BFFM_SELCHANGED:
          try
            SetString(Dir, nil, MAX_PATH);
            if SHGetPathFromIDList(PItemIDList(lParam), PChar(Dir)) then Directory := Dir;
          except
            on E: Exception do ShowMessage(E.Message);
          end;
      end;
    Result := 0;
  end;

begin
  Result := False;
  if SHGetSpecialFolderLocation(Handle, CSIDL_DESKTOP, Root) = NOERROR then
  try
    SHGetMalloc(Malloc);
    SetString(DispName, nil, MAX_PATH);

    BInfo.hwndOwner := GetActiveWindow;
    BInfo.pidlRoot := Root;
    BInfo.pszDisplayName := PChar(DispName);
    BInfo.lpszTitle := PChar(Title);
    BInfo.ulFlags := BIF_RETURNONLYFSDIRS;
    BInfo.lpfn := @FNBFFCallBack;
    BInfo.lParam := Integer(Self);

    iList := SHBrowseForFolder(BInfo);
    Handle := 0;

    if iList <> nil then
    try
      if SHGetPathFromIDList(iList, PChar(DispName)) then
      begin
        Directory := DispName;
        Result := True;
      end;
    finally
      Malloc.Free(iList);
    end;
  finally
    Malloc.Free(Root);
  end;
end;

procedure TCleanForm.FormCreate(Sender: TObject);
var
  F: TIniFile;
begin
  F := TIniFile.Create('MYTool.ini');
  DirEdit.Text := F.ReadString('参数', '目录', '');
  F.Free;
  Cancel := True;
  Kinds := TStringList.Create;
  ListView1.Align := alClient;
  Edit1.Text := '';
end;

procedure TCleanForm.Findfiles(P: string);
const
  ExtPtn = '*.PAS*.DPR';
var
  SR: TSearchRec;
  L, I: integer;
  NewItem: TListItem;
  DosError: Integer;
  SchFile: string;
  IsFind: Boolean;
begin
  SB.Panels[0].Text := P;
  for i := 0 to Kinds.Count - 1 do begin
    CurPtn := Kinds[i];
    DosError := Findfirst(P + CurPtn, faAnyfile - 8 - faDirectory, SR);
    while DosError = 0 do begin
      L := Pos(CurPtn, '*.DCU*.EXE');
      if L > 0 then begin
        SchFile := Copy(SR.Name, 1, Length(SR.Name) - 3) + Copy(ExtPtn, L + 2, 3);
        IsFind := FileExists(P + SchFile);
      end else IsFind := True;
      if IsFind then begin
        NewItem := ListView1.Items.Add;
        NewItem.Caption := SR.Name;
        NewItem.SubItems.Add(P);
        NewItem.SubItems.Add(Format('%10.0n', [SR.Size * 1.0]));
        NewItem.SubItems.Add(DateTimeToStr(FileDateToDateTime(SR.Time)));
        NewItem.Checked := True; //选择吗？
        Sizes := Sizes + SR.Size;
        NFile := NFile + 1;
        if NFile mod 10 = 0 then
          SB.Panels[1].Text :=
            Format('共 %d 文件，%d 字节', [NFile, Sizes]);
      end;
      DosError := Findnext(SR);
    end;
    FindClose(SR);
  end;
  SB.Panels[1].Text := Format('共 %d 文件，%0.0n 字节', [NFile, Sizes * 1.0]);
  if NFile mod 10 = 0 then SB.Update;
end;

procedure TCleanForm.Finddires(P: string);
var
  SR: TSearchrec;
  DosError: Integer;
begin
  Findfiles(P);
  if not RecurseDir then Exit;
  DosError := Findfirst(P + '*.*', faDirectory, SR);
  while (DosError = 0) do with SR do begin
      Application.ProcessMessages;
      if Cancel then Exit;
      if (Name[1] <> '.') and (Attr and faDirectory = faDirectory) then begin
        Finddires(ExpandFileName(P) + SR.Name + '\');
      end;
      DosError := Findnext(SR);
    end;
  FindClose(SR);
end;

procedure TCleanForm.BreakApart;
const
  FBreakStr = ';';
var
  EndOfCurStr: Integer;
  TmpStr, TmpBaseStr: string;
begin // 得到 Kinds
  Kinds.Clear;
  TmpBaseStr := Pattern;
  repeat
    EndOfCurStr := Pos(FBreakStr, TmpBaseStr);
    if EndOfCurStr = 0 then TmpStr := TmpBaseStr else
      TmpStr := Copy(TmpBaseStr, 1, EndOfCurStr - 1);
    if (TmpStr = '') or (TmpStr <> '') then Kinds.add(TmpStr);
    TmpBaseStr := Copy(TmpBaseStr, EndOfCurStr +
      length(FBreakStr), length(TmpBaseStr) - EndOfCurStr);
  until EndOfCurStr = 0;
end;

procedure TCleanForm.FindAFile(Sender: TObject);
var
  P, C: string;
  SS: PChar;
  F: TIniFile;
begin
  C := SB.Panels[0].Text;
  NFile := 0;
  if Trim(Edit1.Text) = '' then
    DEFS.State := cbunChecked
  else DEFS.State := cbChecked;
  P := DirEdit.text;
  F := TIniFile.Create('MYTool.ini');
  F.WriteString('参数', '目录', P);
  F.Free;
  if P[Length(P)] = '\' then else P := P + '\';

  Pattern := '';
  if DCUs.Checked then Pattern := Pattern + '*.DCU;';
  if EXEs.Checked then Pattern := Pattern + '*.EXE;';
  if DSKs.Checked then Pattern := Pattern + '*.DSK;';

  if DEFS.Checked then begin
    Pattern := Pattern + Trim(Edit1.Text);
    if Edit1.Text[Length(Edit1.Text)] <> ';' then
      Pattern := Pattern + ';';
  end;
  if USUA.Checked then Pattern := Pattern +
    '*.~*;*.$$$;*.BAK;*.CHK;*.CPS;' +
      '*.ERR;*.FXP;*.LST;*.MS;TBK;*.TMP;*.DDP';
  if Pattern = '' then Exit;
  RecurseDir := SubDirs.Checked;

  SrBtn.Caption := '停止';
  Cancel := not Cancel;
  if Cancel then begin
    SrBtn.Caption := '查找';
    Exit;
  end;
  GetMem(SS, Length(Pattern) + 1);
  StrPCopy(SS, Pattern);
  SB.Panels[0].Text := '正在查找文件...';
  SB.Hint := '删除类型：' + Pattern;
  DelBtn.Enabled := False;
  BreakApart;
  ListView1.Items.BeginUpdate;
  ListView1.Items.Clear;
  Screen.Cursor := crHourGlass;
  Sizes := 0;
  FindDires(P);
  ListView1.Items.EndUpdate;
  Screen.Cursor := crDefault;
  DelBtn.Enabled := True;
  SrBtn.Caption := '查找';
  Cancel := True;
  SB.Panels[0].Text := C;
  DelBtn.SetFocus;
end;

procedure TCleanForm.FormDestroy(Sender: TObject);
begin
  Kinds.Free;
end;

procedure TCleanForm.GetDirBtnClick(Sender: TObject);
var
  DirDialog: TDirDialog;
begin
  DirDialog := TDirDialog.Create;
  DirDialog.Directory := DirEdit.Text;
  if not DirDialog.Execute then Exit;
  DirEdit.Text := DirDialog.Directory;
  DirDialog.Free;
  FindAFile(nil);
end;

procedure TCleanForm.SelectAll(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to ListView1.Items.Count - 1 do
    ListView1.Items[i].Checked := True;
  SB.Panels[1].Text := '选择文件...';
end;

procedure TCleanForm.DelBtnClick(Sender: TObject);
var
  i: Integer;
  S: string;
begin
  if ID_YES <> MessageBox(Handle, '确实要删除以下所选的那些文件吗？',
    '删除文件', MB_YESNOCANCEL or MB_ICONQUESTION) then Exit;
  ListView1.Items.BeginUpdate;
  with ListView1 do
    for i := Items.Count - 1 downto 0 do
      if Items[I].Checked then begin
        S := Items[i].SubItems.Strings[0] + Items[i].Caption;
        if not SameText(S, Paramstr(0)) then begin
          if DeleteFile(S) then begin
            SB.Panels[1].Text := '删除文件' + S;
            Items[i].Delete;
          end;
        end;
      end;
  ListView1.Items.EndUpdate;
  Button1.SetFocus;
end;

procedure TCleanForm.N2Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to ListView1.Items.Count - 1 do
    ListView1.Items[i].Checked := False;
  SB.Panels[1].Text := '选择文件...';
end;

procedure TCleanForm.DirEditDblClick(Sender: TObject);
begin
  DirEdit.SelectAll;
end;

procedure TCleanForm.DirEditKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = vk_Return then FindAFile(Self);
end;

end.