filepas.pas

特别方便的工具程序

unit FilePas;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, Buttons, ExtCtrls, ActiveX, ShlObj, Menus,
  Variants, ActnList, ImgList, DB, ADODB, Grids, DBGridEh, ShellCtrls,
  ToolWin;

type
{  TDirDialog = class
    Handle: THandle;
    Title: string;
    Directory: string;
    function Execute: Boolean;
  end;
}
  TFileForm = class(TForm)
    SB: TStatusBar;
    GroupBox1: TGroupBox;
    MYDire: TADOQuery;
    MYFile: TADOQuery;
    Panel1: TGroupBox;
    DBGridEh1: TDBGridEh;
    MYFileS: TDataSource;
    FindDire: TADOQuery;
    CoolBar1: TCoolBar;
    ToolBar1: TToolBar;
    tbFind: TToolButton;
    ToolButton4: TToolButton;
    tbLoad: TToolButton;
    ToolButton8: TToolButton;
    ToolButton12: TToolButton;
    ToolButton3: TToolButton;
    ToolButton9: TToolButton;
    ToolButton7: TToolButton;
    ImageList1: TImageList;
    Splitter1: TSplitter;
    FileTypeS: TDataSource;
    FileType: TADOQuery;
    tbSett: TToolButton;
    List1: TShellTreeView;
    procedure FindAFile(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure GetDirBtnClick(Sender: TObject);
    procedure FindFiles(P: string);
    procedure FindDires(P: string);
    procedure DirEditKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure DBGridEh1DblClick(Sender: TObject);
    procedure ToolButton7Click(Sender: TObject);
    procedure tbSettClick(Sender: TObject);
  private
    { Private-Deklarationen }
    NFile: integer;
    FMode: Boolean;
  public
    CurPtn: string;
  end;

var
  FileForm: TFileForm;
  Sizes: Longint;
  RecurseDir: Boolean;
  Cancel: Boolean;

implementation

uses Xeduser, SettPas;

{$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 TFileForm.FormCreate(Sender: TObject);
begin
  SettForm := TSettForm.Create(Application);
  FMode := False;
  Cancel := True;
  MYDire.Open;
  MYFile.Open;
end;

procedure TFileForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  MYDire.Close;
  MYFile.Close;
  SettForm.Free;
end;

procedure TFileForm.FindFiles(P: string);
var
  SR: TSearchRec;
  L, I: integer;
  NewItem: TListItem;
  DosError: Integer;
  SchFile: string;
  FFind: Boolean;
  DDID: integer;
  FName: string;
begin
  CurPtn := '*.*';
  P := UpperCase(P);
  SB.Panels[0].Text := P;
  if MYDire.Locate('目录名称', P, []) then begin
    MYDire.Edit;
  end else begin
    MYDire.Append;
    MYDire['目录名称'] := P;
  end;
  MYDire['读取日期'] := Date;
  MYDire.Post;
  DDID := MYDire['DDID'];
  DosError := FindFirst(P + CurPtn, faAnyfile - 8 - faDirectory, SR);
//  Showmessage(P + CurPtn);
//  Showmessage(inttostr(DosError));
  while DosError = 0 do 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]);}
    FFind := MYFile.Locate('DDID;文件名称', VarArrayOf([DDID, SR.Name]), []);
    if FMode and not FFind then begin
      MYFile.Append;
      MYFile[(('DDID'))] := DDID;
      MYFile['文件名称'] := SR.Name;
      MYFile['文件大小'] := SR.Size;
      MYFile['文件日期'] := FileDateToDateTime(SR.Time);
      MYFile['读取日期'] := Now;
      MYFile.Post;
    end;
    DosError := FindNext(SR);
  end;
  FindClose(SR);
  SB.Panels[1].Text := Format('共 %d 文件，%0.0n 字节', [NFile, Sizes * 1.0]);
  if NFile mod 10 = 0 then SB.Update;
end;

procedure TFileForm.FindDires(P: string);
var
  SR: TSearchrec;
  DosError: Integer;
begin
  FindFiles(P);
//  Showmessage(P + CurPtn);
  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 TFileForm.FindAFile(Sender: TObject);
var
  P, C: string;
  SS: PChar;
begin
  FMode := Sender = tbLoad;
  Cancel := False;
  P := List1.Path;
  if P[3] <> '\' then begin
    TellME('《' + P + '》不是一个可接受的目录');
    List1.SetFocus;
    Exit;
  end;
  if P[Length(P)] = '\' then else P := P + '\';
  C := SB.Panels[0].Text;
  NFile := 0;
  RecurseDir := SettForm.SubDirs.Checked;

{  SrBtn.Caption := '停止';
  Cancel := not Cancel;
  if Cancel then begin
    SrBtn.Caption := '查找';
    Exit;
  end;}
  MYFile.DisableControls;
  SB.Panels[0].Text := '正在查找文件...';
  Screen.Cursor := crHourGlass;
  Sizes := 0;
  FindDires(P);
  Screen.Cursor := crDefault;
  Cancel := True;
  SB.Panels[0].Text := C;
  MYFile.EnableControls;
end;

procedure TFileForm.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 TFileForm.DirEditKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = vk_Return then FindAFile(Self);
end;

procedure TFileForm.DBGridEh1DblClick(Sender: TObject);
begin
  FindDire.Parameters.ParamByName('ID').Value := MYFile['DDID'];
  FindDire.Open;
  TellME('文件所在目录是:'#13#13 + FindDire.FieldByName('目录名称').AsString);
  FindDire.Close;
end;

procedure TFileForm.ToolButton7Click(Sender: TObject);
begin
  Close;
end;

procedure TFileForm.tbSettClick(Sender: TObject);
begin
  SettForm.Show;
end;

end.