文件萃取器-針對VTK、ITK等軟件工程設置，以及文件提取

難得在家閒時，發現以前用VC寫的文件萃取軟件用起來很不爽；剛剛學會Delphi，練習一下。

.pas 文件：

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Mask, Buttons, ExtCtrls, DBCtrls, DB, ADODB,FileCtrl,
  Menus;

type
  TForm1 = class(TForm)
    ADOConnection1: TADOConnection;
    ADOQuery1: TADOQuery;
    DataSource1: TDataSource;
    ADOQuery1ID: TAutoIncField;
    ADOQuery1Type: TWideStringField;
    ADOQuery1Path: TWideStringField;
    ADOQuery1FileExt: TWideStringField;
    ADOQuery1Split: TWideStringField;
    ADOQuery1ObjFile: TWideStringField;
    Panel7: TPanel;
    Memo1: TMemo;
    Panel8: TPanel;
    GroupBox1: TGroupBox;
    DBRadioGroup2: TDBRadioGroup;
    GroupBox2: TGroupBox;
    FNListBox: TListBox;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    BitBtn3: TBitBtn;
    Panel4: TPanel;
    Panel5: TPanel;
    DBText1: TDBText;
    DriveComboBox1: TDriveComboBox;
    Panel6: TPanel;
    DirectoryListBox1: TDirectoryListBox;
    DBRadioGroup1: TDBRadioGroup;
    GroupBox3: TGroupBox;
    DBRadioGroup3: TDBRadioGroup;
    DBRadioGroup4: TDBRadioGroup;
    BitBtn1: TBitBtn;
    BitBtn4: TBitBtn;
    BitBtn5: TBitBtn;
    BitBtn2: TBitBtn;
    ListBox1: TListBox;
    BitBtn6: TBitBtn;
    BitBtn7: TBitBtn;
    EditPre: TEdit;
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure DBRadioGroup1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure DirectoryListBox1Change(Sender: TObject);
    procedure BitBtn3Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn4Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn5Click(Sender: TObject);
    procedure BitBtn6Click(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure BitBtn7Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure MakeTree;
    procedure ChangUIStyle();
    procedure   CopyFilesToClipboard(FileList:   string);
  end;

var
  Form1: TForm1;
  // Tree ...
  TreeCount,FilesCount,DirsCount:integer;
  TreeSize,FilesSize,DirsSize:comp;
  const
    SELDIRHELP   =   10000;



  var
    Namestr:String;

    CurType:Integer;
    CurFileEx:Integer;
    CurSplit:Integer;
    CurTaget:Integer;

    CurIcon:Integer;

implementation

uses Exchange,shlobj,activex,clipbrd,shellapi;
{$R *.dfm}

procedure TForm1.MakeTree;
var  _Sr : TSearchRec;
  I: Integer;
     _Error,CurCount : integer;
     TrSize, FilePath, FileEx, FileEx1,FullName : string;
     CurPath :String;
     bRep:Boolean;
Begin
 bRep:=false;
 _Error:=FindFirst( '*.*',$37,_Sr) ;
 While (_Error = 0) do
  begin
   if _Sr.Name[1]<>'.' then
   begin
     FilePath:=ExpandFileName(_Sr.Name);
     TreeSize:=TreeSize+_Sr.Size;
     TrSize:=FloatToStr(TreeSize);
     Form1.Caption:=DirectoryListBox1.Directory+'  '+IntToStr(TreeCount)
                   +'  files and folders    Size: '+TrSize;


     if (_Sr.Attr and faDirectory)=0 then
        begin
          FilesSize:=FilesSize+_Sr.Size;
          inc(FilesCount);

          // 分析文件擴展名
          FileEx := DBRadioGroup2.Items[DBRadioGroup2.ItemIndex];
          FileEx1 := ExtractFileExt( _Sr.Name);
          if CompareStr( FileEx, FileEx1 ) = 0 then
          begin
              // FullName:= DirectoryListBox1.Directory + '/'+ _Sr.Name;
              CurPath := GetCurrentDir();
              FullName:= CurPath + '/'+ _Sr.Name;

              CurCount:=FNListBox.Items.Count;
              for I := 0 to CurCount-1 do    // Iterate
              begin
                  if CompareStr( FullName,FNListBox.Items.Strings[I]) = 0 then
                    bRep:=true;
              end;    // for

              if bRep = false then
              begin
                  FNListBox.Items.Add(FullName);
                  ListBox1.Items.Add( _Sr.Name );
              end;
          end;

          //ShowMessage(DirectoryListBox1.Directory + '/' + _Sr.Name );
        end;
     inc(TreeCount);
   end;

   { Begin Recursion }
   If ((_Sr.Attr and faDirectory)<>0)AND(_Sr.Name[1] <> '.') then
   begin
     DirsSize:=DirsSize+_Sr.Size;
     inc(DirsCount);
     ChDir(_Sr.Name) ;
     MakeTree ;
     ChDir('..') ;
   end ;
   { End Recursion }
   _Error:=FindNext(_Sr) ;
  end ;
End;


(*var
    f1:File;

  begin
    AssignFile(f1,'c:/test.dat');
    try
      reset(f1);
      seek(f1,pos0);   //定位到第200個字節處，位置你可以自己定
      read(f1,aa);   //讀出一個字節，賦值給aa
      aa:=mValue;   //修改aa的值
      seek(f1,pos0);   //重新定位，因爲讀數據後，指針指向了下一個字節
      write(f1,aa);   //將修改後的值寫回原位
    finally
      closeFile(f1);
  end;   //end   of   try
end;
*)


procedure TForm1.Button1Click(Sender: TObject) ;
var
    Dir:   string;
begin
    Dir   :=   ExtractFilepath(Application.Exename);
    if   SelectDirectory(Dir,   [sdAllowCreate,   sdPerformCreate,   sdPrompt],SELDIRHELP)   then
    begin
        DataSource1.Edit;
        DataSource1.DataSet.FieldByName('Path').Value := Dir;
    end;
   //    DBText1.Caption := Dir;
end;

(*begin
  //
  OpenDialog1.InitialDir:=ExtractFilepath(Application.Exename);
  OpenDialog1.Filter:='文本文件(*.dat;*.DAT)|*.dat;*.DAT';
  OpenDialog1.Title:='請選擇二進制文件';

  if( OpenDialog1.Execute = true ) then
  begin
     Namestr := OpenDialog1.FileName;

     Label_Name.Caption := Namestr;
  end;
 
end;
*)



procedure TForm1.ChangUIStyle();
var
  s1: string;
  i:integer;
begin
  s1:=DBRadioGroup1.Items[DBRadioGroup1.ItemIndex];

  if Pos('VTK', s1)>0 then
  begin
    CurType := 1;
  end
  else if Pos('ITK',s1)>0 then
  begin
     CurType := 2;
  end else begin
     CurType := 3;
  end;

  //
  DBText1.Caption:=DataSource1.DataSet.FieldByName('Path').AsString;

  DirectoryListBox1.Directory :=  DataSource1.DataSet.FieldByName('Path').AsString;

end;



procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.Title := '文件萃取';

  CurIcon := 1;
  Application.Icon.LoadFromFile( ExtractFilePath(Application.ExeName) + '1.ico');

  TRy
       // 動態建立連接
       ADOConnection1.ConnectionString:='Provider=MSDASQL.1;Password="";Persist Security Info=True;User ID=Admin;'
                      + 'Data Source=MS Access Database;User ID=Admin;Data Source=MS Access Database;Initial Catalog='
                      + ExtractFilePath(Application.ExeName)
                      + 'NameExtracter.mdb';
       ADOConnection1.Open();

       ADOConnection1.Connected:=False;
       ADOConnection1.Connected:=True;

       ADOQuery1.Open; ADOQuery1.Requery;

       if DataSource1.State in [dsEdit, dsInsert] then ADOQuery1.Post;
  except
       ShowMessage('數據庫連接出現錯誤');
       exit;
  end;

  CurType:=0;
  CurFileEx:=0;
  CurSplit:=0;
  CurTaget:=0;

  ChangUIStyle;
end;

procedure TForm1.DBRadioGroup1Click(Sender: TObject);
begin
    ChangUIStyle;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if DataSource1.State in [dsEdit, dsInsert] then ADOQuery1.Post;

  ADOConnection1.Connected := false;
end;

procedure TForm1.DirectoryListBox1Change(Sender: TObject);
begin
   DBText1.Caption := DirectoryListBox1.Directory;
   DataSource1.Edit;
   DataSource1.DataSet.FieldByName('Path').Value := DirectoryListBox1.Directory;
end;

procedure TForm1.BitBtn3Click(Sender: TObject);
begin
    TreeCount:=1;
    FilesCount:=0;
    DirsCount:=0;
    TreeSize:=0;
    FilesSize:=0;
    DirsSize:=0;
    ChDir(DirectoryListBox1.Directory);

    FNListBox.Clear;
    ListBox1.Clear;
    MakeTree;

    ///////
    Memo1.Lines.Clear;
    Memo1.Lines.Add(FloatToStr(DirsCount)+' folders ');
    Memo1.Lines.Add(FloatToStr(FilesCount)+' files '
                  +FloatToStr(FilesSize)+' bytes');
    Memo1.Lines.Add(FloatToStrF(FilesSize/1024, ffNumber, 12, 2)+' kilobytes');
    Memo1.Lines.Add('In tree '+DirectoryListBox1.Directory);

end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var
  I: Integer;
begin

    for I := 0 to FNListBox.Count - 1 do    // Iterate
    begin
        ListBox1.Items.Strings[I] := FNListBox.Items.Strings[I];
    end;    // for
end;

procedure TForm1.BitBtn4Click(Sender: TObject);
var
  I: Integer;
  PreS:String;
begin
    PreS := EditPre.Text;
    for I := 0 to FNListBox.Count - 1 do    // Iterate
    begin
      //  if PreS<>'' then
            ListBox1.Items.Strings[I] := PreS + ExtractFileName( FNListBox.Items.Strings[I] );

    end;    // for
end;


procedure TForm1.BitBtn2Click(Sender: TObject);
var
  I: Integer;
  FileList,strT:String;
begin
  FileList := '';
  for I := 0 to FNListBox.Count - 1 do    // Iterate
  begin
      strT := FNListBox.Items.Strings[I];
      if I = 0 then
          FileList := strT
      else
          FileList := FileList + ''#0''+ strT;
  end;    // for

   CopyFilesToClipboard( FileList );
   // 'C:/Downloads/Movie/aaaa.dll'#0'C:/log2.txt' );
   // FileList ); // 'C:/log2.txt'#0'C:/test.dat');
end;

procedure   TForm1.CopyFilesToClipboard(FileList:   string);
var
    DropFiles:   PDropFiles;
    hGlobal:   THandle;
    iLen:   Integer;
begin
    iLen   :=   Length(FileList)   +   2;
    FileList   :=   FileList   +   #0#0;
    hGlobal   :=   GlobalAlloc(GMEM_SHARE   or   GMEM_MOVEABLE   or   GMEM_ZEROINIT,
        SizeOf(TDropFiles)   +   iLen);
    if   (hGlobal   =   0)   then   raise   Exception.Create('Could   not   allocate   memory.');
    begin
        DropFiles   :=   GlobalLock(hGlobal);
        DropFiles^.pFiles   :=   SizeOf(TDropFiles);
        Move(FileList[1],   (PChar(DropFiles)   +   SizeOf(TDropFiles))^,   iLen);
        GlobalUnlock(hGlobal);
        Clipboard.SetAsHandle(CF_HDROP,   hGlobal);
    end;
end;

procedure TForm1.BitBtn5Click(Sender: TObject);
var
  I: Integer;
  FSpit,FormatStr:String;
begin
    FormatStr:='';
    case DBRadioGroup3.ItemIndex of     //
      0: FSpit:=';';
      1: FSpit:=',';
      2: FSpit:=' ';
      3: FSpit:=';';
    end;    // case

    for I := 0 to ListBox1.Count - 1 do    // Iterate
    begin
        if I=0 then
            FormatStr:=FormatStr+ ListBox1.Items.Strings[I]
        else
            FormatStr:=FormatStr+ FSpit + ListBox1.Items.Strings[I]

    end;    // for

    Memo1.Clear;
    Memo1.Enabled:=true;
    Memo1.Text := FormatStr;
end;


procedure TForm1.BitBtn6Click(Sender: TObject);
begin                                                                                                              
    ShellExecute(Handle,'open',   'mailto:[email protected]?Subject=點擊發送即可&body=不必寫內容，除非你想寫'   ,nil,nil,SW_SHOW);
end;

procedure TForm1.N1Click(Sender: TObject);
begin
  ListBox1.Clear;
  FNListBox.Clear;
end;

procedure TForm1.BitBtn7Click(Sender: TObject);
begin
//
   PostMessage(Form1.handle, WM_Close, 0, 0);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
    Inc( CurIcon );
    CurIcon := CurIcon mod 9;
    Application.Icon.LoadFromFile( ExtractFilePath(Application.ExeName) + IntToStr(CurIcon+1) +'.ico');
end;

end.


http://dl2.csdn.net/down4/20070801/01235621549.rar