main.pas

文件搜索的代码

unit main;

interface

uses
  Windows, Messages, SysUtils, Forms, Classes, Controls, ExtCtrls, StdCtrls,
  CoolTrayIcon, jpeg, JvPanel, ShellApi, Menus, JvExExtCtrls, JvComponent,
  JvThread, JvZlibMultiple;

type
  TFormMain = class(TForm)
    Timer1: TTimer;
    Panel: TJvPanel;
    imgLogo: TImage;
    TrayIcon: TCoolTrayIcon;
    lblUpdate: TLabel;
    btnReindex: TButton;
    btnClose: TButton;
    PopupMenu1: TPopupMenu;
    RunTheFileSeeker1: TMenuItem;
    Manualindexing1: TMenuItem;
    btnRun: TButton;
    Close1: TMenuItem;
    Thread: TJvThread;
    Zlib: TJvZlibMultiple;
    procedure ThreadExecute(Sender: TObject; Params: Pointer);
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure TrayIconDblClick(Sender: TObject);
    procedure btnReindexClick(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure RunTheFileSeeker1Click(Sender: TObject);
    procedure Manualindexing1Click(Sender: TObject);
    procedure btnRunClick(Sender: TObject);
    procedure Close1Click(Sender: TObject);
  private
    procedure OnQueryEndSession(var Msg: TMessage); message WM_QUERYENDSESSION;
  public
    Database, Config: TextFile;
    HD: TStringList;
    Update: TDateTime;

    procedure GetDrives;
    procedure FileIndexing(const Drive: string);
    procedure BeginUpdate;
  end;

var
  FormMain: TFormMain;
  IndexFile, ZipFile: string;
  Visible: boolean;

implementation

{$R *.dfm}

procedure TFormMain.OnQueryEndSession(var Msg: TMessage);
var
 tmp: string;
begin
 if Msg.Msg = WM_TRAYNOTIFY then begin
  case Msg.lParam of
   WM_LBUTTONDOWN: tmp := 'Left button';
   WM_RBUTTONDOWN: tmp := 'Right button';
  end;
 end else
  case Msg.Msg of
   WM_QUERYENDSESSION: Msg.Result := 1;
  else
   Msg.Result := DefWindowProc(TrayIcon.Handle, Msg.Msg, Msg.wParam, Msg.lParam);
  end;
end;

function quickconv(s: string): real;
var
 e: integer;
 j: real;
begin
 try
  val(s,j,e);
  quickconv := j;
 except
  quickconv := 0;
 end;
end;

function convfloat(i: real): string;
begin
 convfloat := FloatToStrf(i,ffFixed,6,2);
end;

procedure TFormMain.GetDrives;
const
 DRIVE_UNKNOWN = 0;
 DRIVE_NO_ROOT_DIR = 1;
 DRIVE_REMOVABLE = 2;
 DRIVE_FIXED = 3;
 DRIVE_REMOTE = 4;
 DRIVE_CDROM = 5;
 DRIVE_RAMDISK = 6;
var
 r: LongWord;
 Drives: array[0..128] of char;
 pDrive: PChar;
begin
 HD := TStringList.Create;
 r := GetLogicalDriveStrings(SizeOf(Drives), Drives);
 if r = 0 then Exit;
 if r > SizeOf(Drives) then
   raise Exception.Create(SysErrorMessage(ERROR_OUTOFMEMORY));
 pDrive := Drives;
 while pDrive^ <> #0 do begin
  if GetDriveType(pDrive) = DRIVE_FIXED then
   HD.Add(pDrive);
  Inc(pDrive, 4);
 end;
end;

procedure TFormMain.FileIndexing(const Drive: string);
var
 Rec: TSearchRec;
begin
 if SysUtils.FindFirst(Drive + '*.*', faArchive, Rec) = 0 then
 try
  WriteLn(Database, '<' + Drive + '>');
  repeat
   if (Rec.Name <> '.') and (Rec.Name <> '..') then
    WriteLn(Database, ExtractFileName(Rec.Name));
  until SysUtils.FindNext(Rec) <> 0;
 finally
  SysUtils.FindClose(Rec);
 end;

 if SysUtils.FindFirst(Drive + '*.*', faDirectory, Rec) = 0 then
 try
  repeat
   if ((Rec.Attr and faDirectory) > 0) and (Rec.Name <> '.') and (Rec.Name <> '..') then
    FileIndexing(IncludeTrailingBackslash(Drive + Rec.Name));
  until SysUtils.FindNext(Rec) <> 0;
 finally
  SysUtils.FindClose(Rec);
 end;
end;

procedure TFormMain.BeginUpdate;
var
 Zip: TFileStream;
 IFile: TStrings;
 i: integer;
begin
 // Open database file
 AssignFile(Database, IndexFile);
 ReWrite(Database);

 // Write comments
 WriteLn(Database, '# "The File Seeker" Database');
 WriteLn(Database, '# Database version: 0.99');
 WriteLn(Database, '# Create date: ' + DateTimeToStr(Now));
 WriteLn(Database, '');
 WriteLn(Database, '# Created with "The File Seeker Updater"');
 WriteLn(Database, '');

 // Find files a create database
 for i:=0 to HD.Count-1 do FileIndexing(HD.Strings[i]);

 // Close database file
 CloseFile(Database);

 // Compress database to ZIP and delete file
 IFile := TStrings.Create;
 IFile.Add(IndexFile);
 Zlib.CompressFiles(IFile, ZipFile);
 IFile.Free;
 DeleteFile(IndexFile);

 // Update date
 Update := Now;
 lblUpdate.Caption := 'Last update: ' + DateTimeToStr(Update);

 // Enable buttons
 btnReindex.Enabled := True;
 Manualindexing1.Enabled := True;
end;

procedure TFormMain.Timer1Timer(Sender: TObject);
var
 Year, Month, Day: word;
 Year1, Month1, Day1: word;
 Hour, Min, Sec, MSec: word;
 Hour1, Min1, Sec1, MSec1: word;
begin
 DecodeDate(Update, Year, Month, Day);
 DecodeDate(Now, Year1, Month1, Day1);
 DecodeTime(Update, Hour, Min, Sec, MSec);
 DecodeTime(Now, Hour1, Min1, Sec1, MSec1);
 if Year1 <> Year then btnReindex.Click
 else
  if Month1 <> Month then btnReindex.Click
  else
   if Day1 <> Day then begin
    if Day1-Day > 1 then btnReindex.Click;
    if Day1-Day = 1 then
     if Hour1 >= Hour then btnReindex.Click;
   end;
end;

procedure TFormMain.FormCreate(Sender: TObject);
var
 Str: string;
begin
 IndexFile := ExtractFilePath(Application.ExeName) + 'database.bdd';
 ZipFile := ExtractFilePath(Application.ExeName) + 'database.zip';
 Visible := False;
 GetDrives;

 if FileExists(ZipFile) = False then begin
  Application.MessageBox('No database found. Creating new database.','No database found!');
  btnReindex.Click;
 end;

 if FileExists(ExtractFilePath(Application.ExeName) + 'update.dat') then begin
  AssignFile(Config, ExtractFilePath(Application.ExeName) + 'update.dat');
  Reset(Config);
  ReadLn(Config, Str);
  if Str = '30/12/1899' then
   lblUpdate.Caption := 'Last update: Never'
  else begin
   Update := StrToDateTime(Str);
   lblUpdate.Caption := 'Last update: ' + DateTimeToStr(Update);
  end;
  CloseFile(Config);
 end else
  lblUpdate.Caption := 'Last update: Never';
end;

procedure TFormMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
 CanClose := False;
 TrayIcon.HideMainForm;
end;

procedure TFormMain.TrayIconDblClick(Sender: TObject);
begin
 if Visible then begin
  TrayIcon.HideMainForm;
  Visible := False;
 end else begin
  TrayIcon.ShowMainForm;
  Visible := True;
 end;
end;

procedure TFormMain.btnReindexClick(Sender: TObject);
begin
 // Deactivating buttons
 btnReindex.Enabled := False;
 Manualindexing1.Enabled := False;

 // Commencing database update
 Thread.Execute(Self);
end;

procedure TFormMain.btnCloseClick(Sender: TObject);
begin
 Close1.Click;
end;

procedure TFormMain.RunTheFileSeeker1Click(Sender: TObject);
begin
 if FileExists(ExtractFilePath(Application.ExeName) + 'fileseeker.exe') then
  try
   ShellExecute(Handle, 'open', PChar(ExtractFilePath(Application.ExeName) + 'fileseeker.exe'), nil, nil, SW_SHOW);
  except
   Application.MessageBox('Error executing "The File Seeker"!','Error');
  end
 else
  Application.MessageBox('"fileseeker.exe" not exists!!','Error');
end;

procedure TFormMain.Manualindexing1Click(Sender: TObject);
begin
 btnReindex.Click;
end;

procedure TFormMain.btnRunClick(Sender: TObject);
begin
 RunTheFileSeeker1.Click;
end;

procedure TFormMain.Close1Click(Sender: TObject);
begin
 AssignFile(Config, ExtractFilePath(Application.ExeName) + 'update.dat');
 ReWrite(Config);
 WriteLn(Config, DateTimeToStr(Update));
 CloseFile(Config);
 Application.Terminate;
end;

procedure TFormMain.ThreadExecute(Sender: TObject; Params: Pointer);
begin
 lblUpdate.Caption := 'Updating...';
 BeginUpdate;
end;

end.