?? main.pas
字號:
unit main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics
, Controls, Forms,
Dialogs
, UrlMon
, StrUtils
, autoupdate
, Gauges
, ComCtrls
, StdCtrls
, FileCtrl
, ExtActns
, ActiveX
;
type
// TCallback = class (TInterfacedObject,IBindStatusCallback);
MD5Digest = array[0..15] of Byte;
TForm1 = class(TForm)
Label1: TLabel;
cbb1: TComboBox;
Label2: TLabel;
lv1: TListView;
g1: TGauge;
Label3: TLabel;
lblCount: TLabel;
Label4: TLabel;
lblSpeed: TLabel;
chk1: TCheckBox;
chk2: TCheckBox;
btn1: TButton;
btn2: TButton;
procedure FormShow(Sender: TObject);
procedure chk1Click(Sender: TObject);
procedure chk2Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure btn1Click(Sender: TObject);
procedure btn2Click(Sender: TObject);
private
xmlHash:string;
remoteUrl:string;
LocalPath:string;
isdowning:Boolean;
filePathList:TStringList;
UpdateString:TStringList;
{ Private declarations }
// function downloadFile(aURL,apath:string): boolean;
function adjustPath(apath:string): string;
function checkFiles(): boolean;
procedure intLV(lv:TListView);
procedure intCbb(Cbb:TCombobox);
function intUpdate(lv:TListView): boolean;
function DownloadFile(SourceFile, DestFile: string): Boolean;
procedure URL_OnDownloadProgress(Sender: TDownLoadURL;
Progress, ProgressMax: Cardinal;
StatusCode: TURLDownloadStatus;
StatusText: String; var Cancel: Boolean) ;
public
{ Public declarations }
end;
const
FILENOTEXIST='File doesn''t exist!';
DOWNERROR='Download file error!';
var
Form1: TForm1;
myCfg:IXMLConfigType;
implementation
function MD5String(M: string): MD5Digest;stdcall;external 'md5hash.dll';
function MD5File(N: string): MD5Digest;stdcall;external 'md5hash.dll';
function MD5Print(D: MD5Digest): string;stdcall;external 'md5hash.dll';
function MD5Match(D1, D2: MD5Digest): boolean;stdcall; external 'md5hash.dll';
{$R *.dfm}
{ TForm1 }
function TForm1.adjustPath(apath: string): string;
begin
apath:=StringReplace(apath,'/','\',[rfReplaceAll]);
while RightStr(apath,1)='\' do
begin
apath:=Copy(apath,1,Length(apath)-1);
end;
Result:=apath;
end;
procedure TForm1.btn1Click(Sender: TObject);
var
i,n,j,k:Integer;
s,s1,tmp:string;
// fs:TFileStream;
begin
if (cbb1.Items.Count=0)or(lv1.Items.Count=0) then
begin
ShowMessage('null');
Exit;
end;
if intUpdate(lv1) then
begin
if Trim(UpdateString.Text)='' then
begin
ShowMessage('請選擇一個(gè)');
Exit;
end;
btn2.Enabled:=True;
j:=1;
for I := 0 to UpdateString.Count - 1 do
begin
lblCount.Caption:='當(dāng)前進(jìn)度'+IntToStr(j)+'/'+inttostr(UpdateString.Count);
n:=Pos('!',UpdateString[i]);
s1:=Copy(UpdateString[i],1,n-1);
tmp:=Copy(UpdateString[i],n+1,Length(UpdateString[i])-n);
n:=Pos('!',tmp);
s:=Copy(tmp,1,n-1);
k:=StrToInt(Copy(tmp,n+1,Length(tmp)-n));
if FileExists(s) then
DeleteFile(s);
// fs:=TFileStream.Create(s,fmCreate);
if not DirectoryExists(ExtractFileDir(s)) then
ForceDirectories(ExtractFileDir(s));
Sleep(100);
if DownloadFile(s1,s) then
begin
Sleep(200);
Inc(j);
lv1.Items.Delete(k);
// fs.Free;
end
else
Exit;
end;
ShowMessage('所有更新下載完成');
btn1.Enabled:=lv1.Items.Count<>0;
btn2.Enabled:=isdowning;
end
else
begin
ShowMessage('必須升級的選項(xiàng),必須被勾選上');
Exit;
end;
end;
procedure TForm1.btn2Click(Sender: TObject);
begin
isdowning:=False;
// Self.Enabled:=False;
close;
end;
function TForm1.checkFiles: boolean;
var
i:Integer;
newItem:TListItem;
begin
Result:=False;
filePathList:=TStringList.Create;
myCfg:=Loadconfig(LocalPath+'\autoupdate.xml');
with myCfg.FileList do
begin
for I := 0 to Count - 1 do
begin
if (FileInfo[i].FileHash
<>
MD5Print(MD5File(LocalPath+'\'+FileInfo[i].FilePath)))
or
(not FileExists(LocalPath+'\'+fileinfo[i].FilePath))
then
begin
Result:=True;
newItem:=lv1.Items.Add;
newItem.Caption:='';
newItem.SubItems.Add(FileInfo[i].FileName);
newItem.SubItems.Add(FileInfo[i].FileVersion);
newItem.SubItems.Add(FileInfo[i].FileLevel);
filePathList.Add(FileInfo[i].FilePath);
end;
end;
end;
end;
procedure TForm1.chk1Click(Sender: TObject);
var
i:Integer;
begin
for I := 0 to lv1.Items.Count - 1 do
begin
lv1.Items[i].Checked:=chk1.Checked;
end;
chk2.Checked:=chk1.Checked;
end;
procedure TForm1.chk2Click(Sender: TObject);
var
i:Integer;
begin
with lv1 do
begin
for I := 0 to Items.Count - 1 do
begin
if StrToBool(Items[i].SubItems[2]) then
Items[i].Checked:=chk2.Checked;
// ShowMessage(Items[i].SubItems[1]);
end;
end;
end;
function TForm1.DownloadFile(SourceFile, DestFile: string): Boolean;
var
hasError: boolean;
begin
hasError:=false;
with TDownloadURL.Create(self) do
try
URL:=SourceFile;
FileName := DestFile;
isdowning:=True;
OnDownloadProgress := URL_OnDownloadProgress;
ExecuteTarget(nil) ;
except on e: Exception do
begin
ShowMessage(e.Message);
Free;
hasError:=true;
end;
end;
Result := not hasError;
end;
//function TForm1.downloadFile(aURL,apath: string): boolean;
//begin
// try
// Result:=URLDownloadToFile(nil,PChar(aURL),PChar(apath),0,nil)=0;
// except
// Result:=False;
// end;
//end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
filePathList.Free;
UpdateString.Free;
// xmlHash.Free;
end;
procedure TForm1.FormShow(Sender: TObject);
var
// F1:TextFile;
s1:TStringList;
s:string;
begin
remoteUrl:='ftp://savagers:19860702@go3.icpcn.com/update';
LocalPath:=adjustPath(ExtractFilePath(Application.ExeName));
//-----------------------------------------------------------------
if DownloadFile(remoteUrl+'/xmlCode.txt',LocalPath+'\xmlCode.txt') then
begin
try
//read the xmlhash code;
s1:=TStringList.Create;
s1.LoadFromFile(LocalPath+'\xmlCode.txt');
xmlHash:=Trim(s1.Text);
// s1.Free;
//need to download autoupdate.xml or not
if (not FileExists(LocalPath+'\autoupdate.xml'))
or
(xmlHash<>MD5Print(MD5File(LocalPath+'\autoupdate.xml')))
then
begin
DownloadFile(remoteUrl+'/autoupdate.xml',LocalPath+'\autoupdate.xml')
end
finally
s1.Free
end;
intLV(lv1);
//return while or not
if not checkFiles then
Close;
intCbb(cbb1);
end
else //download xmlCode.txt error
ShowMessage(DOWNERROR);
// ShowMessage(xmlHash);
end;
procedure TForm1.intCbb(Cbb: TCombobox);
var
i:Integer;
begin
with Cbb do
begin
Items.Clear;
with myCfg do
begin
for I := 0 to SrvList.Count - 1 do
begin
Items.Append(SrvList.SrvInfo[i].SrvName);
end;
end;
ItemIndex:=0;
end;
end;
procedure TForm1.intLV(lv: TListView);
var
// CaptionArr:array[0..2] of string;
// nwidth,i:Integer;
nwidth:Integer;
newItem:TListColumn;
begin
lv.Items.Clear;
lv.ViewStyle:=vsReport;
lv.Checkboxes:=True;
nwidth:=Round((lv.Width-50)/3);
//-------------------------
with lv do
begin
newItem:=Columns.Add;
newItem.Caption:='升級';
newItem.Width:=50;
newItem:=Columns.Add;
newItem.Caption:='文件名';
newItem.Width:=nwidth;
newItem:=Columns.Add;
newItem.Caption:='版本號';
newItem.Width:=nwidth;
newItem:=Columns.Add;
newItem.Caption:='必須';
newItem.Width:=nwidth;
end;
lv.AlphaSort;
end;
function TForm1.intUpdate(lv: TListView): boolean;
var
i:Integer;
s,s1:string;
srvURL:string;
begin
Result:=True;
UpdateString:=TStringList.Create;
UpdateString.Clear;
srvURL:=myCfg.SrvList.SrvInfo[cbb1.ItemIndex].SrvPath;
for I := 0 to lv.Items.Count - 1 do
begin
s:='';
if lv.Items[i].Checked then
begin
s:=StringReplace(srvURL+'/'+filepathList[i],'\','/',[rfReplaceAll]);
s1:=StringReplace(LocalPath+'\'+filepathlist[i],'/','\',[rfReplaceAll]);
s:=s+'!'+s1+'!'+inttostr(i);
UpdateString.Add(s);
end;
if (not lv.Items[i].Checked)and(StrToBool(lv.Items[i].SubItems[2])) then
begin
Result:=False;
Exit;
end;
end;
end;
procedure TForm1.URL_OnDownloadProgress(Sender: TDownLoadURL; Progress,
ProgressMax: Cardinal; StatusCode: TURLDownloadStatus; StatusText: String;
var Cancel: Boolean);
begin
g1.MaxValue:=ProgressMax;
g1.Progress:=Progress;
// if not isdowning then
// Sender.Enabled:=False;
Application.ProcessMessages;
Cancel:=not isdowning;
// Caption:=StatusText;
end;
end.
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -