unit10.pas

绝对一流的压缩解压程序

unit Unit10;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, SUIComboBox, ComCtrls, Buttons,filectrl,strutils, ShellCtrls,
  OleCtrls, SHDocVw, ExtCtrls, Menus;

type
  TFileVer=record
    Ver1:Integer;
    Ver2:Integer;
    Ver3:Integer;
    Ver4:Integer;
    VerStr:String[4];
  end;
  TForm10 = class(TForm)
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    GroupBox3: TGroupBox;
    GroupBox4: TGroupBox;
    cb1: TsuiComboBox;
    cb2: TsuiComboBox;
    Label1: TLabel;
    Label2: TLabel;
    BitBtn1: TBitBtn;
    cb3: TsuiComboBox;
    Label3: TLabel;
    Label4: TLabel;
    cb4: TsuiComboBox;
    BitBtn2: TBitBtn;
    lb1: TListBox;
    BitBtn3: TBitBtn;
    BitBtn4: TBitBtn;
    BitBtn5: TBitBtn;
    BitBtn6: TBitBtn;
    GroupBox5: TGroupBox;
    Memo1: TMemo;
    rb1: TRadioButton;
    rb2: TRadioButton;
    gp6: TGroupBox;
    BitBtn7: TBitBtn;
    BitBtn8: TBitBtn;
    shell1: TPanel;
    shell2: TWebBrowser;
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    Memo2: TMemo;
    Memo3: TMemo;
    SaveDialog1: TSaveDialog;
    procedure BitBtn3Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn4Click(Sender: TObject);
    procedure BitBtn6Click(Sender: TObject);
    procedure BitBtn5Click(Sender: TObject);
    procedure lb1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure lb1DblClick(Sender: TObject);
    procedure BitBtn7Click(Sender: TObject);
    procedure BitBtn8Click(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure lb1Click(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
     FileVer:TFileVer;
  public
   procedure getallfiles2(sourcepath,name:string);
   function getname(f_dir:string):string;
   procedure findfiles(apath:string);
   procedure ys_files1();
   procedure getallfiles(sourcepath:string);
   function getrootpath(fullpath:string):string;
  end;

var
  Form10: TForm10;
  ffilename:string;
  flag:boolean;
  dir:string;
implementation
uses unit1,UnitCompr;
{$R *.dfm}
procedure TFORM10.getallfiles(sourcepath:string);
var
 sr:tsearchrec;
begin
    sourcepath:=includetrailingbackslash(sourcepath);
      if findfirst(sourcepath+'\*.*',faanyfile,sr)=0 then
      begin
       repeat
       if(sr.Name<>'.')and(sr.Name<>'..')then
        begin
          if sr.Attr<>fadirectory then
           begin
            FORM10.Memo2.Lines.Add(sourcepath+sr.Name);
             end else
               begin
                  getallfiles(sourcepath+sr.Name);
                 END;
                 end;
                 until findnext(sr)<>0
                 end ;
                 findclose(sr);

                 end;
function TFORM10.getrootpath(fullpath:string):string;
var
patharray:array[0..200]of char;
rootpath:string;
i,num,m:integer;
begin
  m:=0;
  strpcopy(patharray,fullpath);
  num:=length(fullpath);
  for i:=num-1 downto 0 do
       if (patharray[i]='\')then
       begin
          m:=i;
          break;
       end;
      rootpath:=copy(fullpath,0,m);
       result:=rootpath;
end;
procedure tform10.ys_files1();
 Var MemStr,MemStr1,MemStr2:TMemoryStream;
  FileName:String;
  FileNameSize,DataSize:LongInt;
  i:Integer;
begin
  MemStr:=TMemoryStream.Create;
  MemStr1:=TMemoryStream.Create;
  MemStr2:=TMemoryStream.Create;
  try
    MemStr.Clear;
    MemStr1.Clear;
    MemStr2.Clear;
    with TCompressCtrl.Create(nil) do
    begin
      try
        begin
         form1.Label1.Caption:='你要压缩的文件是:';
         form1.Label2.Caption:=memo3.Lines[1]+'等文件';
         form1.ShowModal;
          FileVer.Ver1:=1;
          FileVer.Ver2:=0;
          FileVer.Ver3:=0;
          FileVer.Ver4:=0;
          FileVer.VerStr:='WAR';
          MemStr2.WriteBuffer(FileVer,sizeof(TFileVer)); //写入文件版本号。
          For i:=1 to memo3.Lines.Count-1 do
          begin

            MemStr1.Clear;
            MemStr.Clear;
            memo1.Lines.Add('装入文件：'+memo3.Lines[i]);
            MemStr.LoadFromFile(memo3.Lines[i]);            //装入第i个文件。
            memo1.Lines.Add('正在压缩文件：'+memo3.Lines[i]);
            Backup(MemStr,MemStr1);                               //压缩第i个文件。

            FileName:=memo3.Lines[i];
            FileNameSize:=Length(FileName);
            MemStr2.WriteBuffer(FileNameSize,sizeof(LongInt));    //写入第i个文件名长度。
            MemStr2.WriteBuffer(PChar(FileName)^,FileNameSize);   //写入第i个文件名。
            DataSize:=MemStr1.Size;
            MemStr2.WriteBuffer(DataSize,sizeof(LongInt));        //写入第i个文件压缩后的数据长度。
            MemStr2.CopyFrom(MemStr1,MemStr1.Size);               //写入第i个文件压缩后的数据。
            memo1.Lines.Add('文件'+memo3.Lines[i]+'已经压缩完毕!');
          end;
          memo1.Lines.Add('所有文件已经压缩完毕!');
          FileNameSize:=-1;
          MemStr2.WriteBuffer(FileNameSize,sizeof(LongInt));      //写入一个-1。
          memo3.Clear;
          if SaveDialog1.Execute then
           if savedialog1.FileName<>'' then
             begin
            MemStr2.SaveToFile(SaveDialog1.FileName);
            form1.Label1.Caption:='文件保存到:';
            form1.Label2.Caption:=SaveDialog1.FileName;
            form1.ShowModal;
            end;
        end;
      finally
        Free;
      end;
    end;
  finally
    MemStr.Free;
    MemStr1.Free;
    MemStr2.Free;
  end;
end;
procedure tform10.findfiles(apath:string);
var
 fsearchrec,dsearchrec:tsearchrec;
 findresult:integer;
 function isdir(adirname:string):boolean;
  begin
    result:=(adirname='.')or(adirname='..');
    end;
    begin
     apath:=getname(apath);
     findresult:=findfirst(apath+ffilename,faanyfile+fahidden+fasysfile+fareadonly,fsearchrec);
     try
       while findresult=0 do
         begin
            lb1.Items.Add(lowercase(apath+fsearchrec.Name));
            findresult:=findnext(fsearchrec);
            memo1.lines.add('正在处理'+apath+fsearchrec.Name);
            end;
            findresult:=findfirst(apath+'*.*',fadirectory,dsearchrec);
             while findresult=0 do
               begin
                 if ((dsearchrec.Attr and fadirectory)=fadirectory) and not isdir(dsearchrec.Name) then
                     findfiles(apath+dsearchrec.Name);
                     findresult:=findnext(dsearchrec);
                     memo1.lines.add('正在处理'+apath+dsearchrec.Name);
                     end;
                     finally
                      findclose(fsearchrec);
                      memo1.Clear;
                      memo1.Lines.Add('搜索完毕!共搜索到'+inttostr(lb1.Items.Count)+'个文件.');
                      end;
                      end;

 function tform10.getname(f_dir:string):string;
 begin
    if f_dir[length(f_dir)]<>'\'then
       result:=f_dir+'\'
       else
       result:=f_dir;
       end;
procedure Tform10.getallfiles2(sourcepath,name:string); //遍历文件
var
 sr:tsearchrec;
begin
    sourcepath:=includetrailingbackslash(sourcepath);
      if findfirst(sourcepath+'\*.*',faanyfile,sr)=0 then
      begin
       repeat
       if(sr.Name<>'.')and(sr.Name<>'..')then
        begin
          if sr.Attr<>fadirectory then
           begin
         memo1.lines.add('正在处理'+sourcepath+sr.name);
             end else
               begin
              memo1.lines.add('正在处理'+sourcepath+sr.name);
  if rb1.checked=true then
     begin
        if ansicomparestr(sr.Name,name)=0 then
               lb1.items.add(sourcepath+sr.name);
               end else
                     if rb2.checked=true then
                         if ansicomparetext(sr.Name,name)=0 then
                         lb1.items.add(sourcepath+sr.name);
                 getallfiles2(sourcepath+sr.Name,name);
                 end;;
                 end;
                 until findnext(sr)<>0
                 end ;
                 findclose(sr);
                 memo1.Clear;
                 memo1.Lines.Add('搜索完毕!共搜索到'+inttostr(lb1.Items.Count)+'个文件夹.');
                 end;

procedure TForm10.BitBtn3Click(Sender: TObject);
begin
flag:=true;
lb1.MultiSelect:=false;
  gp6.Visible:=false;
  lb1.Visible:=true;
  lb1.Clear;
  shell1.Visible:=false;
  cb1.Items.Add(cb1.Text);
  cb2.Items.Add(cb2.Text);
  getallfiles2(cb2.Text,cb1.Text);
end;

procedure TForm10.BitBtn1Click(Sender: TObject);
var
tj_dir:string;
begin
   if selectdirectory(tj_dir,[sdallowcreate,sdperformcreate,sdprompt],0) then
       cb2.Text:=getname(tj_dir);
end;

procedure TForm10.BitBtn2Click(Sender: TObject);
var
tj_dir:string;
begin
   if selectdirectory(tj_dir,[sdallowcreate,sdperformcreate,sdprompt],0) then
        cb4.Text:=getname(tj_dir);
end;

procedure TForm10.BitBtn4Click(Sender: TObject);
begin
  close;
end;

procedure TForm10.BitBtn6Click(Sender: TObject);
begin
 close;
end;

procedure TForm10.BitBtn5Click(Sender: TObject);
begin
flag:=false;
lb1.MultiSelect:=true;
  gp6.Visible:=false;
  lb1.Visible:=true;
  shell1.Visible:=false;
   cb3.Items.Add(cb3.Text);
    cb4.Items.Add(cb4.Text);
    lb1.Clear;
     screen.Cursor:=crhourglass;
       try
         ffilename:=cb3.text;
         findfiles(cb4.Text);
         finally
           screen.Cursor:=crdefault;

 end;
end;

procedure TForm10.lb1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
  var
  i:integer;
begin
  for i:=0 to lb1.Items.Count-1 do
     if lb1.Selected[i]then
        lb1.Hint:=lb1.Items[i];
end;

procedure TForm10.lb1DblClick(Sender: TObject);
var
i:integer;
path,path2:string;
begin
  for i:=0 to lb1.Items.Count-1do
    if lb1.Selected[i]then
      path:=lb1.Items[i];
      lb1.Visible:=false;
      shell1.Visible:=true;
      gp6.Visible:=true;
      shell2.Navigate(widestring(getrootpath(path)));
end;

procedure TForm10.BitBtn7Click(Sender: TObject);
begin
     lb1.Visible:=true;
     shell1.Visible:=false;
     gp6.Visible:=false;
end;

procedure TForm10.BitBtn8Click(Sender: TObject);
begin
try
  shell2.goBack;
except
    showmessage('已经到达顶端 不能再倒退!');
    end;
end;

procedure TForm10.N4Click(Sender: TObject);
begin
    close;
end;

procedure TForm10.N3Click(Sender: TObject);
var
i:integer;
path,path2:string;
begin
  for i:=0 to lb1.Items.Count-1do
    if lb1.Selected[i]then
      path:=lb1.Items[i];
      lb1.Visible:=false;
      shell1.Visible:=true;
      gp6.Visible:=true;
      shell2.Navigate(widestring(getrootpath(path)));
end;

procedure TForm10.lb1Click(Sender: TObject);
var
i:integer;
begin
   if flag=true then
     begin
      memo1.Lines.Add('双击选中的文件夹可以打开其所在的目录 右键可以选择压缩文件此文件夹.');
        for i:=0 to lb1.Items.Count-1do
          if lb1.Selected[i]then
              dir:=lb1.Items[i];
              end else
              memo1.Lines.Add('按住CTRL键可以选择多个文件 双击可以打开文件所在目录  右键选择压缩文件||已经选择【'+inttostr(lb1.SelCount)+'】个文件.');
end;

procedure TForm10.N1Click(Sender: TObject);
Var MemStr,MemStr1,MemStr2:TMemoryStream;
  FileName:String;
  FileNameSize,DataSize,rootpath_size:LongInt;
  i,j:Integer;
  rootpath:string;
begin
 if flag=true then
   begin
   MemStr:=TMemoryStream.Create;
  MemStr1:=TMemoryStream.Create;
  MemStr2:=TMemoryStream.Create;
  memo2.Clear;
  rootpath:=getrootpath(dir);
  getallfiles(dir);
  try
    MemStr.Clear;
    MemStr1.Clear;
    MemStr2.Clear;
    with TCompressCtrl.Create(nil) do
    begin
      try
   if messagedlg('您要压缩的目录为'+dir+'确认吗？',mtconfirmation,[mbok]+[mbcancel],0)=idok then
        begin
          FileVer.Ver1:=1;
          FileVer.Ver2:=0;
          FileVer.Ver3:=0;
          FileVer.Ver4:=0;
          FileVer.VerStr:='WAR';
          rootpath_size:=length(rootpath);
          memstr2.WriteBuffer(rootpath_size,sizeof(longint));//写入根目录长度
          memstr2.WriteBuffer(pchar(rootpath)^,length(rootpath));//写入根目录
          MemStr2.WriteBuffer(FileVer,sizeof(TFileVer)); //写入文件版本号。
          For i:=0 to memo2.Lines.Count-1 do
          begin
            MemStr1.Clear;
            MemStr.Clear;
            memo1.Lines.Add('装入文件：'+memo2.Lines[i]);
            MemStr.LoadFromFile(memo2.Lines[i]);            //装入第i个文件。
            memo1.Lines.Add('正在压缩文件：'+memo2.Lines[i]);
            Backup(MemStr,MemStr1);                               //压缩第i个文件。

            FileName:=memo2.Lines[i];
            FileNameSize:=Length(FileName);
            MemStr2.WriteBuffer(FileNameSize,sizeof(LongInt));    //写入第i个文件名长度。
            MemStr2.WriteBuffer(PChar(FileName)^,FileNameSize);   //写入第i个文件名。
            DataSize:=MemStr1.Size;
            MemStr2.WriteBuffer(DataSize,sizeof(LongInt));        //写入第i个文件压缩后的数据长度。
            MemStr2.CopyFrom(MemStr1,MemStr1.Size);               //写入第i个文件压缩后的数据。
            memo1.Lines.Add('文件'+memo2.Lines[i]+'已经压缩完毕!');
          end;
          memo1.Lines.Add('要求压缩的目录'+dir+'已经压缩完毕!');
          FileNameSize:=-1;
          MemStr2.WriteBuffer(FileNameSize,sizeof(LongInt));      //写入一个-1。
          if SaveDialog1.Execute then
            if savedialog1.FileName<>''then
            begin
            MemStr2.SaveToFile(SaveDialog1.FileName);
            form1.Label1.Caption:='文件保存到:';
            form1.Label2.Caption:=savedialog1.FileName;
            form1.ShowModal;
            end;
        end;
      finally
        Free;
      end;
    end;
  finally
    MemStr.Free;
    MemStr1.Free;
    MemStr2.Free;
  end;
end  else
   begin
       for j:=0 to lb1.Items.Count-1 do
            if lb1.Selected[j] then
                memo3.Lines.Add(lb1.Items[j]);
                 if memo3.Lines.Count>0 then
                    ys_files1() else
                     showmessage('未选择文件 请选择后再压缩!');

   end;
end;

procedure TForm10.FormCreate(Sender: TObject);
begin
  flag:=true;
end;

end.