Delphi - Indy TIdHTTP方式创建程序外壳 - 实现可执行程序的自动升级

Delphi 实现可执行程序的自动升级

准备工作：

1：Delphi调用TIdHTTP方式开发程序，生成程序打包外壳

说明：程序工程命名为ERP_Update

界面布局如下：

代码实现如下：

 unit Unit1;

 interface

 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, ExtCtrls,
   IdTCPConnection, SHELLAPI, ComCtrls, jpeg, IdHTTP,
   IdTCPClient, IdBaseComponent, IdComponent, Registry;

 type
   TFrm_FTP = class(TForm)
     Label4: TLabel;
     IdHTTP1: TIdHTTP;
     Image1: TImage;
     ProgressBar1: TProgressBar;
     Label1: TLabel;
     procedure RUN_START;
     procedure FormCreate(Sender: TObject);
     procedure IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
       const AWorkCount: Integer);
     procedure IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
       const AWorkCountMax: Integer);
     procedure IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
     function HttpDownLoad(aURL, aFile: string): Boolean;
     function GetURLFileName(aURL: string): string;
     function GET_CODE(V_s: TstringS; V_CODE: string): string;
     function GET_SubStr(V_s: string; V_CODE1, V_CODE2: string): string;
     procedure DelFile(V_Name: string);
     function GET_Ora_Home(): string;
   private
         { Private declarations }

   public
         { Public declarations }
   end;

 var
   Frm_FTP: TFrm_FTP;
   ss: Tstrings;
   V_Err: Boolean;
   BytesToTransfer: LongWord;

 implementation

 {$R *.dfm}

 function TFrm_FTP.GET_Ora_Home(): string;
 var
   v_Result: string;
 begin
   v_Result := '';
   with TRegistry.Create do
   try
     RootKey := HKEY_LOCAL_MACHINE;
     if OpenKey('\Software\ORACLE', false) then
     begin
       v_Result := ReadString('ORACLE_HOME');
       if v_Result <> '' then
         v_Result := v_Result + '\network\admin\tnsnames.ora';
       CloseKey;
     end;
   finally
     Free;
   end;
   Result := v_Result;
 end;

 procedure TFrm_FTP.RUN_start;
 var
   V_LiveUpdate, V_version, C_ServerIP, C_ServerVer, C_ExeVer, c_ExeName, C_ExePath: string;
   i: Integer;
 begin
   V_Err := False;
   C_ExePath := ExtractFilePath(Application.ExeName); //可执行程序的路径[D:\CDERP\长电包装生产管理系统\]
   //获取本地的版本信息等数据
   ss := Tstringlist.create;
   ss.loadfromfile(C_ExePath + 'LiveUpdate.ini');
   V_version := GET_SubStr(ss.Strings[], 'url=', ''); //服务器地址
   V_LiveUpdate := stringreplace(UpperCase(V_version), 'VERSION.INF', 'LIVEUPDATE.INI', [rfReplaceAll]); //服务器地址
   C_ExeVer := GET_SubStr(ss.Strings[], 'version=', ''); //本地程序的版本
   C_ExeName := GET_SubStr(ss.Strings[], 'exe=', ''); //本地程序的名称
   //获取服务器的版本
   if HttpDownLoad(V_version, C_ExePath + GetURLFileName(V_version)) then
   begin
     ss.loadfromfile(C_ExePath + 'version.inf');
     C_ServerVer := get_code(ss, '#version=');
   end
   else
     C_ServerVer := C_ExeVer; //如果升级服务器异常就不升级
   if (trim(ParamStr()) = '') or (trim(ParamStr()) = '/afterupgrade0') then
   begin
     //程序在本地第一次执行，如果需要升级将下载cderp.exe到本地update.exe并执行
     //比较版本信息
     if C_ServerVer > C_ExeVer then
     begin
       C_ExeVer := C_ServerVer;
       DelFile(C_ExePath + 'update.exe');
       HttpDownLoad(GET_SubStr(V_version, '', '/exe/') + '/exe/ERP_Update.exe', C_ExePath + 'update.exe');
       ShellExecute(handle, 'open', pchar(C_ExePath + 'ERP_Update.exe'), pchar('"' + C_ExePath + '" "' + C_ExeVer + '"'), nil, SW_ShowNormal);
     end
     else
       ShellExecute(handle, 'open', pchar(C_ExePath + C_ExeName), nil, nil, SW_ShowNormal);
     application.Terminate;
   end
   else
   begin
     Frm_FTP.WindowState := wsNormal;
     Frm_FTP.Visible := true;
     Frm_FTP.Refresh;
     V_Err := False;
     //防止可执行程序没有完全关闭， 等待一会
     ProgressBar1.max := ;
     for i :=  to  do
     begin
       Label4.Caption := '升级准备...';
       ProgressBar1.Position := i;
       Application.ProcessMessages;
       Sleep();
     end;
     for i :=  to  do
     begin
       C_ServerIP := get_code(ss, '#url' + trim(IntToStr(i)) + '=');
       if C_ServerIP = '' then
       begin
         Break;
       end;
       HttpDownLoad(C_ServerIP, C_ExePath + GetURLFileName(C_ServerIP));
     end;
     HttpDownLoad(V_LiveUpdate, C_ExePath + GetURLFileName(V_LiveUpdate));
     if not V_Err then
     begin
       ss.loadfromfile(C_ExePath + GetURLFileName(V_LiveUpdate));
       ss.delete();
       ss.delete();
       ss.Add('version=' + C_ServerVer);
       ss.Add('exe=' + C_ExeName);
       ss.savetofile(C_ExePath + GetURLFileName(V_LiveUpdate));
       ss.free;
       Application.MessageBox('程序已经升级完成！', '升级完成', MB_ICONINFORMATION + MB_OK);
       ShellExecute(handle, 'open', pchar(C_ExePath + C_ExeName), nil, nil, SW_ShowNormal);
     end;
     application.Terminate;
   end;
 end;

 procedure TFrm_FTP.FormCreate(Sender: TObject);
 begin
   RUN_start;
 end;

 function TFrm_FTP.GET_CODE(V_s: TstringS; V_CODE: string): string;
 var
   i, j, l: integer;
   v_Result: string;
 begin
   j := V_s.Count - ;
   l := length(v_code);
   i := ;
   while i <= j do
   begin
     if copy(trim(UpperCase(V_s.Strings[i])), , l) = UpperCase(V_CODE) then
     begin
       v_Result := copy(trim(V_s.Strings[i]), l + , );
       j := ;
     end;
     i := i + ;
   end;
   Result := v_Result;
 end;

 function TFrm_FTP.GET_SubStr(V_s: string; V_CODE1, V_CODE2: string): string;
 var
   j, k: integer;
   v_str: string;
 begin
   //Label4.Caption := GET_SubStr('url=http://192.1.1.0/exe/ERP_Update/version.inf', '://', '/exe');
   //数据解析，找到字符串中的子串
   v_str := UpperCase(V_s);
   k := pos(UpperCase(v_code1), v_str);
   if v_code1 = '' then
   begin
     k := ;
   end;
   if k >  then
   begin
     v_str := copy(v_str, k + length(v_code1), );
     if v_code2 = '' then
       k :=
     else
       k := pos(UpperCase(v_code2), v_str);
     if k >  then
     begin
       v_str := copy(v_str, , k - );
     end
     else
     begin
       v_str := '';
     end;
   end
   else
   begin
     v_str := '';
   end;
   Result := v_str;
 end;

 procedure TFrm_FTP.DelFile(V_Name: string);
 var
   i: integer;
 begin
   i := ;
   while FileExists(V_Name) do
   begin
     DeleteFile(V_Name);
     Application.ProcessMessages;
     i := i + ;
     if i >  then
     begin
       if MessageDlg('系统不能执行删除操作[' + V_Name + ']，是否重试?', mtConfirmation, [mbYes, mbNo], ) = mrNO then
       begin
         i := ;
         Abort;
       end;
     end;
   end;
 end;

 procedure TFrm_FTP.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
   const AWorkCount: Integer);
 begin
   ProgressBar1.Position := AWorkCount;
 end;

 procedure TFrm_FTP.IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
   const AWorkCountMax: Integer);
 begin
   if AWorkCountMax >  then
     ProgressBar1.max := AWorkCountMax
   else
     ProgressBar1.Max := BytesToTransfer;

 end;

 procedure TFrm_FTP.IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
 begin
   BytesToTransfer := ;

 end;
 //http方式下载

 function TFrm_FTP.HttpDownLoad(aURL, aFile: string): Boolean;
 var
   MyStream: TMemoryStream; //如果文件不存在
   F_Str: string;
 begin
   if V_Err then exit;
   try
     label4.Caption := '正在升级...' + GetURLFileName(aURL);
     label4.Refresh;
     MyStream := TMemoryStream.Create;
     IdHTTP1.Request.ContentRangeStart := ;
     try
       IdHTTP1.Get(stringreplace(UpperCase(aURL), '192.1.1.0/EXE/', '192.1.1.0/EXE/', [rfReplaceAll]), MyStream); //开始下载
       MyStream.SaveToFile(aFile);
       if pos('.REG', UpperCase(aFile)) >  then
         WinExec(pchar('regedit.exe /s "' + aFile + '"'), SW_HIDE);

       if pos('TNSNAMES.ORA', UpperCase(aFile)) >  then
       begin
         F_Str := GET_Ora_Home;
         if F_Str <> '' then MyStream.SaveToFile(F_Str);
       end;

       label4.Caption := '升级完成';
     finally
       MyStream.Free;
     end;
     Result := True;
   except
     on E: Exception do
     begin
       Application.MessageBox(PChar('升级[' + GetURLFileName(aURL) + ']过程中出现错误了,错误信息如下：' + # + # + E.Message), PChar('系统提示'), Mb_OK + MB_ICONERROR);
       V_Err := True;
       Result := False;
     end;
   end;
 end;

 function TFrm_FTP.GetURLFileName(aURL: string): string;
 var
   i: integer;
   s: string;
 begin
   s := aURL;
   i := Pos('/', s);
   while i <>  do //去掉"/"前面的内容剩下的就是文件名了
   begin
     Delete(s, , i);
     i := Pos('/', s);
   end;
   Result := s;
 end;

 end.

2：FTP服务器搭建，FTP用户创建

举例说明如下：

在192.1.1.0上创建FTP账户Test 密码Test，路径 \exe\;

案例：将Test.exe系统做出一个可以自动升级的系统

文件准备：

1：Test.exe （目标系统）；

2：ERP_Update.exe （自动升级外壳程序）；

3：创建配置文件 （LiveUpdate.ini、Version.inf）；

建立一个记事本文件，命名为LiveUpdate.ini，内容输入

[LiveUpdate]
url=http://192.1.1.0/exe/Test/version.inf
version=0
exe=Test.EXE

建立一个记事本文件，命名为version.inf，内容输入

#############################################################
#   Generated by AutoUpgrader Pro at: 2019-8-29 20:50:39    #
#############################################################

#message={}

#url1=http://192.1.1.0/exe/ERP_Update.exe
#url2=http://192.1.1.0/exe/Test/Test.exe
#url3=http://192.19.1.0/exe/Test/version.inf

#method=0 (self-upgrade)

#version=0

4：FTP操作（文件替换、配置文件更新）；

将Test.exe （目标系统）、ERP_Update.exe （自动升级外壳程序）、创建配置文件 （LiveUpdate.ini、Version.inf）文件同时放到192.1.1.0FTP服务器\exe\Test\文件夹下。

并手工修改LiveUpdate中的Version，同理Version中也需要这么改。

至此在本地打开ERP_Udapate即可实现自动升级。

作者：Jeremy.Wu
  出处：https://www.cnblogs.com/jeremywucnblog/

  本文版权归作者和博客园共有，欢迎转载，但未经作者同意必须保留此段声明，且在文章页面明显位置给出原文连接，否则保留追究法律责任的权利。