不用控件自已写行吗?压缩至软盘
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.