将 update.xml 放到服务器上后,通过一个程序读取,并获得更新文件的列表。进行版本比较后,对版本不同的文件进行更新。
- 更新程序的代码:
- unit frmMain;
- interface
- uses
- Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
- Dialogs, xmldom, XMLIntf, RzStatus, ExtCtrls, RzPanel, msxmldom, XMLDoc,
- StdCtrls, CheckLst, IdBaseComponent, IdComponent, IdTCPConnection,
- IdTCPClient, IdHTTP, StrUtils, DHibernateThread, DHibernateBase,
- MD5Real, ActiveX, IdExplicitTLSClientServerBase, IdFTP, untUtils,
- DHibernatePodoList, HTTPGet, ComCtrls, DHibernateSQLThread, ShellAPI,
- WinSkinData, IniFiles;
- type
- TDownFileRec = class
- public
- FName: string;
- FSize: Integer;
- FDir: string;
- FCRC: string;
- FTrueName: string;
- end;
- type
- TFormMain = class(TForm)
- HTTPXML: TIdHTTP;
- Label1: TLabel;
- edtUpdateXml: TEdit;
- Label2: TLabel;
- lstFiles: TCheckListBox;
- btnDownload: TButton;
- XML: TXMLDocument;
- RzStatusBar1: TRzStatusBar;
- spStat: TRzStatusPane;
- thrdSF: TDHibernateThread;
- HTTPGet1: THTTPGet;
- pb: TProgressBar;
- SkinData1: TSkinData;
- btnGetXml: TButton;
- btnSetting: TButton;
- spProc: TRzStatusPane;
- chkSelAll: TCheckBox;
- procedure btnGetXmlClick(Sender: TObject);
- procedure FormCreate(Sender: TObject);
- procedure btnDownloadClick(Sender: TObject);
- procedure HTTPXMLStatus(ASender: TObject; const AStatus: TIdStatus;
- const AStatusText: string);
- // procedure DHibernateThread1Execute(Sender: TObject; params: IMap);
- procedure HTTPXMLWork(ASender: TObject; AWorkMode: TWorkMode;
- AWorkCount: Integer);
- // procedure DHibernateThread1Finish(Sender: TObject);
- procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
- // procedure SFFound(Sender: TObject; Path: string);
- // procedure SFEnded(Sender: TObject);
- procedure thrdSFExecute(Sender: TObject; params: IMap);
- procedure thrdSFbegin(Sender: TObject);
- procedure thrdSFFinish(Sender: TObject);
- procedure HTTPXMLWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
- AWorkCountMax: Integer);
- procedure HTTPGet1Progress(Sender: TObject; TotalSize, Readed: Integer);
- procedure HTTPGet1DoneFile(Sender: TObject; FileName: string;
- FileSize: Integer);
- procedure btnSettingClick(Sender: TObject);
- procedure chkSelAllClick(Sender: TObject);
- procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
- private
- AbortTransfer: Boolean;
- isUpdating: boolean;
- downloadStr: string;
- public
- function GetFileSize(aFileName: string): integer;
- procedure HttpDownLoad(aURL, aFile: string; bResume: Boolean);
- procedure CmdStopService;
- procedure CmdStopProcess;
- procedure CmdFileOperation;
- procedure CmdStartProcess;
- procedure CmdStartService;
- procedure CmdReboot;
- procedure LoadFromIni;
- procedure SaveToIni;
- end;
- var
- FormMain : TFormMain;
- FileCode : string;
- FileName : string;
- found : integer;
- FileList : TPodoList;
- commandList : TStringList;
- implementation
- {$R *.dfm}
- function TFormMain.GetFileSize(aFileName: string): integer;
- var
- sr : TSearchRec;
- begin
- if FindFirst(aFileName, faAnyFile, sr) = 0 then
- Result := sr.Size
- else
- Result := 0;
- FindClose(sr);
- end;
- procedure TFormMain.HttpDownLoad(aURL, aFile: string; bResume: Boolean);
- var
- tStream : TFileStream;
- begin //Http方式下载
- if FileExists(aFile) then //如果文件已经存在
- tStream := TFileStream.Create(aFile, fmOpenWrite)
- else
- tStream := TFileStream.Create(aFile, fmCreate);
- if bResume then //续传方式
- begin
- HTTPXML.Request.ContentRangeStart := tStream.Size - 1;
- tStream.Position := tStream.Size - 1; //移动到最后继续下载
- HTTPXML.Head(aURL);
- // HTTPXML.Request.ContentRangeEnd := HTTPXML.Response.ContentLength;
- end
- else //覆盖或新建方式
- begin
- HTTPXML.Request.ContentRangeStart := 0;
- end;
- try
- HTTPXML.Get(aURL, tStream); //开始下载
- finally
- tStream.Free;
- end;
- end;
- procedure TFormMain.btnDownloadClick(Sender: TObject);
- var
- i : Integer;
- furl : string;
- path : string;
- saveFile : string;
- begin
- if isUpdating then
- begin
- AbortTransfer := not AbortTransfer;
- if AbortTransfer then
- begin
- // 暂停下载
- HTTPGet1.Abort;
- btnDownload.Caption := '续传';
- end
- else
- begin
- HTTPGet1.GetFile;
- btnDownload.Caption := '暂停';
- // DHibernateThread1Execute(Self, nil);
- end;
- end
- else
- begin
- if lstFiles.Items.Count = 0 then
- Exit;
- // btnDownload.Enabled := false;
- btnDownload.Caption := '暂停';
- btnGetXml.Enabled := false;
- btnSetting.Enabled := False;
- lstFiles.Enabled := False;
- isUpdating := True;
- // 执行脚本
- // stop service
- CmdStopService;
- // stop process
- CmdStopProcess;
- // download
- path := edtUpdateXml.Text;
- for i := 0 to lstFiles.Items.Count - 1 do
- begin
- if lstFiles.Checked[i] then
- begin
- furl := path + '/' + TDownFileRec(FileList.Objects[i]).FName;
- saveFile := ExtractFilePath(ParamStr(0)) + '/' + TDownFileRec(FileList.Objects[i]).FDir + '/' +
- TDownFileRec(FileList.Objects[i]).FTrueName;
- if not FileExists(saveFile + '.ini') then
- DeleteFile(saveFile);
- downloadStr := '正在下载:' + lstFiles.Items[i];
- HTTPGet1.FileName := saveFile;
- HTTPGet1.URL := furl;
- HTTPGet1.GetFile;
- end;
- end;
- // file operation
- CmdFileOperation;
- // start process
- CmdStartProcess;
- // start service
- CmdStartService;
- // reboot?
- CmdReboot;
- isUpdating := false;
- btnDownload.Caption := '下载并更新';
- spStat.Caption := '下载完毕!';
- spproc.Caption := EmptyStr;
- btnGetXml.Enabled := True;
- btnSetting.Enabled := True;
- lstFiles.Enabled := True;
- self.thrdSF.Execute(nil);
- pb.Position := 0;
- end;
- end;
- procedure TFormMain.btnGetXmlClick(Sender: TObject);
- begin
- self.thrdSF.Execute(nil);
- end;
- procedure TFormMain.btnSettingClick(Sender: TObject);
- var
- str : string;
- begin
- str := edtUpdateXml.Text;
- str := InputBox('输入网址', '输入更新服务器的所在地址: ', str);
- if str <> EmptyStr then
- edtUpdateXml.Text := str;
- end;
- procedure TFormMain.chkSelAllClick(Sender: TObject);
- var
- i : Integer;
- begin
- for i := 0 to lstFiles.Items.Count - 1 do
- lstFiles.Checked[i] := chkSelAll.Checked;
- end;
- procedure TFormMain.CmdFileOperation;
- var
- i : Integer;
- cmd : string;
- begin
- // todo: file operation
- for i := 0 to commandList.Count - 1 do
- begin
- cmd := commandList[i];
- if Pos('copy', cmd) > 0 then
- begin
- DoCopyUpdateFile(cmd);
- end;
- if Pos('rename', cmd) > 0 then
- begin
- DoRenameUpdateFile(cmd);
- end;
- if Pos('delete', cmd) > 0 then
- begin
- DoDeleteUpdateFile(cmd);
- end;
- end;
- end;
- procedure TFormMain.CmdReboot;
- var
- i : Integer;
- begin
- // todo: reboot
- for i := 0 to commandList.Count - 1 do
- begin
- if commandList[i] = '/reboot' then
- begin
- rebootWindows;
- Exit;
- end;
- end;
- end;
- procedure TFormMain.CmdStartProcess;
- var
- i : Integer;
- cmd : string;
- begin
- // todo: start process
- for i := 0 to commandList.Count - 1 do
- begin
- Application.ProcessMessages;
- // fmt: /run "process Name"
- if Pos('run', commandList[i]) > 0 then
- begin
- cmd := commandList[i];
- // 去掉 run
- cmd := RightStr(cmd, Length(cmd) - 4);
- cmd := StringReplace(cmd, '"', EmptyStr, [rfReplaceAll, rfIgnoreCase]);
- cmd := Trim(cmd);
- SetCurrentDir(ExtractFilePath(ParamStr(0)));
- ShellExecute(0, 'open', PChar(ExtractFilePath(ParamStr(0)) + '/' + cmd), nil,
- PChar(ExtractFilePath(ExtractFilePath(ParamStr(0)) + '/' + cmd)), SW_SHOW);
- end;
- end;
- end;
- procedure TFormMain.CmdStartService;
- var
- i : Integer;
- cmd : string;
- begin
- // todo: start service
- for i := 0 to commandList.Count - 1 do
- begin
- Application.ProcessMessages;
- // fmt: /start "service name"
- if Pos('start', commandList[i]) > 0 then
- begin
- cmd := commandList[i];
- // 去掉 /,添加 net
- cmd := 'net ' + RightStr(cmd, Length(cmd) - 1);
- cmd := StringReplace(cmd, '"', EmptyStr, [rfReplaceAll, rfIgnoreCase]);
- ServicesOperation(cmd);
- end;
- end;
- end;
- procedure TFormMain.CmdStopProcess;
- var
- i : Integer;
- cmd : string;
- begin
- // todo: stop process
- for i := 0 to commandList.Count - 1 do
- begin
- Application.ProcessMessages;
- // fmt: /kill "process Name"
- if Pos('kill', commandList[i]) > 0 then
- begin
- cmd := commandList[i];
- // 去掉 kill
- cmd := RightStr(cmd, Length(cmd) - 5);
- cmd := StringReplace(cmd, '"', EmptyStr, [rfReplaceAll, rfIgnoreCase]);
- cmd := Trim(cmd);
- KillTask(cmd);
- end;
- end;
- end;
- procedure TFormMain.CmdStopService;
- var
- i : Integer;
- cmd : string;
- begin
- // todo: stop service
- for i := 0 to commandList.Count - 1 do
- begin
- Application.ProcessMessages;
- // fmt: /stop "service name"
- if Pos('stop', commandList[i]) > 0 then
- begin
- cmd := commandList[i];
- // 去掉 /,添加 net
- cmd := 'net ' + RightStr(cmd, Length(cmd) - 1);
- cmd := StringReplace(cmd, '"', EmptyStr, [rfReplaceAll, rfIgnoreCase]);
- ServicesOperation(cmd);
- end;
- end;
- end;
- procedure TFormMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
- begin
- if isUpdating then
- begin
- // MessageBox(Handle, '正在更新中,不能关闭!', '提示', MB_OK or
- // MB_ICONINFORMATION);
- // CanClose := False;
- HTTPGet1.Abort;
- end;
- SaveToIni;
- end;
- procedure TFormMain.FormCreate(Sender: TObject);
- begin
- LoadFromIni;
- if edtUpdateXml.Text <> EmptyStr then
- btnGetXmlClick(self);
- isUpdating := False;
- end;
- procedure TFormMain.FormKeyDown(Sender: TObject; var Key: Word;
- Shift: TShiftState);
- var
- path : string;
- begin
- if Key = VK_F1 then
- begin
- path := ExtractFilePath(ParamStr(0)) + '/Help/';
- ShellExecute(0, 'open', PChar(path + 'help_index.html'), nil, PChar(path), SW_SHOW);
- end;
- end;
- procedure TFormMain.HTTPGet1DoneFile(Sender: TObject; FileName: string;
- FileSize: Integer);
- var
- iniName : string;
- begin
- ininame := HTTPGet1.FileName + '.ini';
- DeleteFile(iniName);
- isUpdating := false;
- btnDownload.Caption := '下载并更新';
- spStat.Caption := '下载完毕!';
- spproc.Caption := EmptyStr;
- btnGetXml.Enabled := True;
- btnSetting.Enabled := True;
- lstFiles.Enabled := True;
- self.thrdSF.Execute(nil);
- pb.Position := 0;
- end;
- procedure TFormMain.HTTPGet1Progress(Sender: TObject; TotalSize,
- Readed: Integer);
- begin
- Application.ProcessMessages;
- spstat.Caption := downloadStr;
- spProc.Caption := Format('%d / %d B', [Readed, TotalSize]);
- pb.Max := TotalSize;
- pb.Position := Readed;
- end;
- procedure TFormMain.HTTPXMLStatus(ASender: TObject; const AStatus: TIdStatus;
- const AStatusText: string);
- begin
- // spStat.Caption := Format(downloadStr,[AStatusText]);
- end;
- procedure TFormMain.HTTPXMLWork(ASender: TObject; AWorkMode: TWorkMode;
- AWorkCount: Integer);
- begin
- if AbortTransfer then
- begin //中断下载
- HTTPXML.Disconnect;
- end;
- Application.ProcessMessages;
- spStat.Caption := Format(downloadStr, [AWorkCount]);
- end;
- procedure TFormMain.HTTPXMLWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
- AWorkCountMax: Integer);
- begin
- AbortTransfer := False;
- end;
- procedure TFormMain.LoadFromIni;
- var
- iniName : string;
- ini : TIniFile;
- begin
- iniName := ExtractFilePath(ParamStr(0)) + 'update.ini';
- ini := TIniFile.Create(iniName);
- edtUpdateXml.Text := ini.ReadString('Server', 'Address', EmptyStr);
- ini.Free;
- end;
- procedure TFormMain.SaveToIni;
- var
- iniName : string;
- ini : TIniFile;
- begin
- iniName := ExtractFilePath(ParamStr(0)) + 'update.ini';
- ini := TIniFile.Create(iniName);
- ini.WriteString('Server', 'Address', edtUpdateXml.Text);
- ini.Free;
- end;
- procedure TFormMain.thrdSFExecute(Sender: TObject; params: IMap);
- var
- furl : string;
- xmlstr : string;
- node : IXMLNode;
- detail : IXMLNode;
- fileRec : TDownFileRec;
- fn : string;
- // ms : TMemoryStream;
- begin
- ActiveX.CoInitialize(nil);
- furl := edtUpdateXml.Text + 'update.xml';
- xmlstr := HTTPXML.Get(furl);
- // ms.ReadBuffer(xmlstr, ms.Size);
- // xmlstr := leftstr(xmlstr, Pos('-', xmlstr) - 1);
- // ShowMessage(xmlstr);
- XML.Active := false;
- XML.XML.Text := xmlstr;
- xml.Active := true;
- node := XML.DocumentElement;
- lstFiles.Items.Clear;
- FileList.Clear;
- if { 3 } node <> nil then
- begin
- node := XML.DocumentElement.ChildNodes.First;
- while node <> nil do
- begin
- if { 2 } node.NodeName = 'file' then
- begin
- filerec := TDownFileRec.Create;
- // name
- detail := node.ChildNodes[0];
- fileRec.FName := detail.NodeValue;
- // size
- detail := node.ChildNodes[1];
- fileRec.FSize := detail.NodeValue;
- // dir
- detail := node.ChildNodes[2];
- if detail.NodeValue = null then
- fileRec.FDir := EmptyStr
- else
- fileRec.FDir := detail.NodeValue;
- // crc
- detail := node.ChildNodes[3];
- fileRec.FCRC := detail.NodeValue;
- // true name
- detail := node.ChildNodes[4];
- fileRec.FTrueName := detail.NodeValue;
- // check whether need update
- fn := ExtractFilePath(ParamStr(0)) + '/' + filerec.FDir + '/' + filerec.FTrueName;
- if { 1 } MD5Real.RivestFile(fn) <> fileRec.FCRC then
- begin
- // add to list
- FileList.Add(fileRec);
- // FileName := detail.NodeValue;
- lstFiles.Items.Add(fileRec.FTrueName);
- end; { if 1 }
- end; { if 2 }
- if node.NodeName = 'command' then
- begin
- if node.NodeValue <> null then
- commandList.Add(node.NodeValue);
- end;
- // lstFiles.Items.Add(node.NodeValue);
- node := node.NextSibling;
- end; { while }
- end;
- chkSelAllClick(self); { if 3 }
- ActiveX.CoUninitialize;
- end;
- procedure TFormMain.thrdSFbegin(Sender: TObject);
- begin
- spStat.Caption := '获取更新文件列表';
- btnGetXml.Enabled := False;
- btnDownload.Enabled := False;
- lstFiles.Enabled := False;
- end;
- procedure TFormMain.thrdSFFinish(Sender: TObject);
- begin
- btnGetXml.Enabled := True;
- btnDownload.Enabled := True;
- lstFiles.Enabled := True;
- spStat.Caption := '准备就绪';
- if lstFiles.Items.Count = 0 then
- begin
- btnDownload.Caption := '下载并更新';
- btnDownload.Enabled := False;
- end;
- end;
- initialization
- FileList := TPodoList.Create;
- commandList := TStringList.Create;
- finalization
- FileList.Free;
- commandList.Free;
- end.
- 更新的原理很简单,先执行 xml 中包含的脚本,然后下载文件,最后再执行脚本,完成整个更新。
- 用到的控件是 HttpGet,用它来进行断点续传。
- 程序截图: