文件压缩(50分)

jxgawjf · 2002-08-05

请教一个问题：我想把一个目录里的所有文件压缩到一个文件中 去

代码:

[?]应该怎么做。请指教

hbezwwl · 2002-08-05

有个控件,什么vclzip之类的就行了.

koyochen · 2002-08-05

用 vclzip

哈利波特 · 2002-08-05

以下程序调试通过！我将所有文件都压缩成1.36M！（你可以修改大小） unit Unit1; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, Math, StdCtrls, ComCtrls; type   TForm1 = class(TForm)     Button1: TButton;     Button2: TButton;     Label1: TLabel;     Edit1: TEdit;     Button3: TButton;     ProgressBar1: TProgressBar;     Button4: TButton;     procedure Button1Click(Sender: TObject);     procedure Button2Click(Sender: TObject);     procedure Button3Click(Sender: TObject);     procedure Button4Click(Sender: TObject);   private     { Private declarations }     procedure InitPack(ss:string);  //初始化打包文件     procedure PackFile(ss:string);  //将文件打包。即文件名为ss的文件复制到打包文件中     procedure DePackFile(ss:string);     procedure BackUpto(ss:string);     function chkdisk(drive:byte;bbsize:longint):boolean;     function chkfile(ss:string):boolean;   public     { Public declarations }   end; var   Form1: TForm1; implementation uses Unit2; {$R *.dfm} function Tform1.chkfile(ss:string):boolean; var bn:integer; begin   result:=true;   while fileexists(ss)=false do   begin     bn:=messagedlg('备份文件不存在！继续吗？',mtwarning,[mbyes,mbno],0);     if bn<>mryes then     begin       result:=false;       break;     end;   end; end; procedure Tform1.InitPack(ss:string); //初始化打包文件 var vf:File; begin assignfile(vf,ss); rewrite(vf,1); closefile(vf); end; procedure Tform1.packfile(ss:string);//将文件打包。即文件名为ss的文件复制到打包文件中 var rf,pf:File;     fsize:longint;     numread,numwrite:integer;     ss1,ss2,ss3:string[100];     buf:array[1..2048]of char; begin assignfile(pf,'d:/mypack.pak');//分配打包文件 assignfile(rf,ss);             //分配被打包文件 reset(pf,1);                   //打开打包文件 reset(rf,1);                   //打开被打包文件 fsize:=filesize(pf);           //获取打包文件尺寸 seek(pf,fsize);                //文件指针移至文件尾 fsize:=filesize(rf);           //获取被打包文件尺寸 seek(rf,0);                    //文件指针移至文件尾 ss1:='CHANGE';                 //标志 ss2:=ss; str(fsize,ss3); blockwrite(pf,ss1,10); blockwrite(pf,ss2,30); blockwrite(pf,ss3,20); form1.Canvas.TextOut(50,200,'文件 '+ss+' 正在打包！');     //****** repeat                   //复制文件   blockread(rf,buf,sizeof(buf),numread);   blockwrite(pf,buf,numread,numwrite); until (numread=0)or(numwrite<>numread); closefile(pf); closefile(rf); end; procedure Tform1.BackUpto(ss:string);//打包文件ss复制到备份目录,mysize var sf,df:File;     nnn,nn,basesize,srcfilesize:longint;     dnum,vi,bn:integer;     ss1:string[200];     ssdnum,sste,ssattr:string[20];     vbyte:char;     buf:array[1..2048]of char; begin assignfile(sf,ss); reset(sf,1); srcfilesize:=filesize(sf); basesize:=1430000;  //定义软盘的大小 dnum:=ceil(srcfilesize/basesize);  //计算所需的软盘数量 str(dnum,ssdnum); randomize;     //启动随机数产生器 vi:=random(1000);     //产生一个随机数 str(vi,ssattr); for vi:=1 to dnum do   //复制到软盘或其他目录  begin    str(vi,sste);    sste:=trim(sste);    if (edit1.text='A:') or (edit1.text='A:/') or (edit1.text='a:') or (edit1.text='a:/') then       begin         ss1:='共需'+ssdnum+'张盘，请插入第'+sste+'张盘。';         bn:=messagedlg(ss1,mtinformation,[mbyes,mbno],0);         if bn<>mryes then break;       end;    ss1:=uppercase(trim(edit1.text));    vbyte:=ss1[1];    bn:=ord(vbyte)-ord('A')+1;    if chkdisk(bn,basesize)=false then break;    ss1:=trim(edit1.text)+'/xx'+sste+'disk.bak';    assignfile(df,ss1);    rewrite(df,1);    ss1:='XXSOFT001';    blockwrite(df,ss1,16);    blockwrite(df,ssdnum,16);    blockwrite(df,ssattr,16);    srcfilesize:=basesize;    repeat      if srcfilesize>2040 then      begin        nn:=2040;        srcfilesize:=srcfilesize-2040;      end      else      begin        nn:=srcfilesize;        srcfilesize:=0;      end;      blockread(sf,buf,nn,nnn);      blockwrite(df,buf,nnn);    until(srcfilesize<=0);    closefile(df);    progressbar1.StepBy(floor(70/dnum));  end;  closefile(sf); end; procedure Tform1.DePackFile(ss:string);  //解包 var sf,df:file;     ss1,ss2,ss3:string[40];     fsize:longint;     numread,numwrite,nn:integer;     buf:array[1..2048]of char; begin   assignfile(sf,ss);   reset(sf,1);   while not eof(sf) do   begin     blockread(sf,ss1,10,nn);     blockread(sf,ss2,30,nn);     blockread(sf,ss3,20,nn);     if nn<20 then     begin       showmessage('No size');       closefile(sf);       exit;     end;     fsize:=strtoint(ss3);     if ss1<>'CHANGE' then     begin       showmessage('No CHANGE');       closefile(sf);       exit;     end;     assignfile(df,ss2);     rewrite(df,1);     repeat       if fsize>2000 then       begin         nn:=2000;         fsize:=fsize-2000;       end       else       begin         nn:=fsize;         fsize:=0;       end;       blockread(sf,buf,nn,numread);       blockwrite(df,buf,numread,numwrite);     until (fsize=0)or(numwrite<>numread);     closefile(df);     end;     closefile(sf); end; procedure TForm1.Button1Click(Sender: TObject); begin progressbar1.Min:=0; progressbar1.Max:=100; initpack('d:/mypack.pak'); packfile('d:/1.XLs'); packfile('d:/2.XLs'); packfile('d:/3.XLs'); packfile('d:/4.XLs'); packfile('d:/5.XLs'); packfile('d:/6.XLs'); packfile('d:/7.XLs'); packfile('d:/8.XLs'); packfile('d:/9.XLs'); packfile('d:/10.XLs'); packfile('d:/11.XLs'); packfile('d:/12.XLs'); backupto('d:/mypack.pak'); form1.Canvas.TextOut(50,200,'                                              '); button2.SetFocus; end; function Tform1.chkdisk(drive:byte;bbsize:longint):boolean;//软盘检查，成功返回真。 var bn,chk:integer;     mysize,sup:longint; begin   result:=true;     chk:=0;     while chk=0 do     begin       mysize:=diskfree(drive);       if mysize=-1 then       begin         bn:=messagedlg('未插入盘，请插入！',mtwarning,[mbyes,mbno],0);         if bn=mryes then continue         else         begin           result:=false;           break;         end;       end       else       begin         sup:=diskfree(drive) div 1000000;         if sup<1.36 then         begin           bn:=messagedlg('磁盘空间不够，请插入另一张盘！',mtwarning,[mbyes,mbno],0);           if bn=mryes then continue           else           begin             result:=false;             break;           end;         end         else           break;       end;     end;   end; procedure TForm1.Button2Click(Sender: TObject); begin close; end; procedure TForm1.Button3Click(Sender: TObject); begin form2.Show; end; procedure TForm1.Button4Click(Sender: TObject); var sf,df:file;     ss:string[200];     ss1,ssattr:string[30];     numread,numwrite,bn,nn:integer;     buf:array[1..2048]of char; begin ss:=trim(edit1.Text)+'/xx1disk.bak'; if fileexists(ss)=false then  begin    messagedlg('备份文件不存在！',mtwarning,[mbok],0);    exit;  end; assignfile(df,'d:/mypack.pak'); rewrite(df,1); assignfile(sf,ss); reset(sf,1); blockread(sf,ss1,16); if ss1<>'XXSOFT001' then  begin    messagedlg('不是该系统的备份文件！',mtwarning,[mbok],0);    closefile(sf);    exit;  end; blockread(sf,ss1,16); nn:=strtoint(ss1); blockread(sf,ssattr,16); repeat   blockread(sf,buf,sizeof(buf),numread);   blockwrite(df,buf,numread,numwrite); until (numread=0)or(numwrite<>numread); closefile(sf);  if nn>1 then    begin      for bn:=2 to nn do      begin        if (edit1.text='A:') or (edit1.text='A:/') or (edit1.text='a:') or (edit1.text='a:/') then           messagedlg('请插入第'+inttostr(bn)+'张盘！',mtinformation,[mbok],0);        ss:=trim(edit1.Text)+'/xx'+trim(inttostr(bn))+'disk.bak';        if chkfile(ss)=false then break;        assignfile(sf,ss);        reset(sf,1);        blockread(sf,ss1,16);        if ss1<>'XXSOFT001' then        begin          messagedlg('不是该系统的备份文件！',mtwarning,[mbok],0);          closefile(sf);          closefile(df);          exit;        end;        blockread(sf,ss1,16);        blockread(sf,ss1,16);        if ss1<>ssattr then        begin           messagedlg('文件xx'+inttostr(bn)+'disk.bak与其它文件不是同一次的备份文件！',mtwarning,[mbok],0);           closefile(sf);           closefile(df);           exit;        end;        repeat          blockread(sf,buf,sizeof(buf),numread);          blockwrite(df,buf,numread,numwrite);        until (numread=0)or(numwrite<>numread);        closefile(sf);      end;     end; closefile(df); depackfile('d:/mypack.pak'); button2.SetFocus; end; end.

文件压缩(50分)

jxgawjf

Unregistered / Unconfirmed

hbezwwl

Unregistered / Unconfirmed

koyochen

Unregistered / Unconfirmed

哈利波特

Unregistered / Unconfirmed

Similar threads