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

Posted jeremywucnblog

tags:

篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了Delphi - Indy TIdHTTP方式创建程序外壳 - 实现可执行程序的自动升级相关的知识,希望对你有一定的参考价值。

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

 

准备工作:

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

说明:程序工程命名为ERP_Update

界面布局如下:

技术图片

代码实现如下:

  1 unit Unit1;
  2 
  3 interface
  4 
  5 uses
  6   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7   Dialogs, StdCtrls, ExtCtrls,
  8   IdTCPConnection, SHELLAPI, ComCtrls, jpeg, IdHTTP,
  9   IdTCPClient, IdBaseComponent, IdComponent, Registry;
 10 
 11 type
 12   TFrm_FTP = class(TForm)
 13     Label4: TLabel;
 14     IdHTTP1: TIdHTTP;
 15     Image1: TImage;
 16     ProgressBar1: TProgressBar;
 17     Label1: TLabel;
 18     procedure RUN_START;
 19     procedure FormCreate(Sender: TObject);
 20     procedure IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
 21       const AWorkCount: Integer);
 22     procedure IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
 23       const AWorkCountMax: Integer);
 24     procedure IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
 25     function HttpDownLoad(aURL, aFile: string): Boolean;
 26     function GetURLFileName(aURL: string): string;
 27     function GET_CODE(V_s: TstringS; V_CODE: string): string;
 28     function GET_SubStr(V_s: string; V_CODE1, V_CODE2: string): string;
 29     procedure DelFile(V_Name: string);
 30     function GET_Ora_Home(): string;
 31   private
 32          Private declarations 
 33 
 34   public
 35          Public declarations 
 36   end;
 37 
 38 var
 39   Frm_FTP: TFrm_FTP;
 40   ss: Tstrings;
 41   V_Err: Boolean;
 42   BytesToTransfer: LongWord;
 43 
 44 implementation
 45 
 46 $R *.dfm
 47 
 48 function TFrm_FTP.GET_Ora_Home(): string;
 49 var
 50   v_Result: string;
 51 begin
 52   v_Result := ‘‘;
 53   with TRegistry.Create do
 54   try
 55     RootKey := HKEY_LOCAL_MACHINE;
 56     if OpenKey(\\Software\\ORACLE, false) then
 57     begin
 58       v_Result := ReadString(ORACLE_HOME);
 59       if v_Result <> ‘‘ then
 60         v_Result := v_Result + \\network\\admin\\tnsnames.ora;
 61       CloseKey;
 62     end;
 63   finally
 64     Free;
 65   end;
 66   Result := v_Result;
 67 end;
 68 
 69 procedure TFrm_FTP.RUN_start;
 70 var
 71   V_LiveUpdate, V_version, C_ServerIP, C_ServerVer, C_ExeVer, c_ExeName, C_ExePath: string;
 72   i: Integer;
 73 begin
 74   V_Err := False;
 75   C_ExePath := ExtractFilePath(Application.ExeName); //可执行程序的路径[D:\\CDERP\\长电包装生产管理系统\\]
 76   //获取本地的版本信息等数据
 77   ss := Tstringlist.create;
 78   ss.loadfromfile(C_ExePath + LiveUpdate.ini);
 79   V_version := GET_SubStr(ss.Strings[1], url=, ‘‘); //服务器地址
 80   V_LiveUpdate := stringreplace(UpperCase(V_version), VERSION.INF, LIVEUPDATE.INI, [rfReplaceAll]); //服务器地址
 81   C_ExeVer := GET_SubStr(ss.Strings[2], version=, ‘‘); //本地程序的版本
 82   C_ExeName := GET_SubStr(ss.Strings[3], exe=, ‘‘); //本地程序的名称
 83   //获取服务器的版本
 84   if HttpDownLoad(V_version, C_ExePath + GetURLFileName(V_version)) then
 85   begin
 86     ss.loadfromfile(C_ExePath + version.inf);
 87     C_ServerVer := get_code(ss, #version=);
 88   end
 89   else
 90     C_ServerVer := C_ExeVer; //如果升级服务器异常就不升级
 91   if (trim(ParamStr(1)) = ‘‘) or (trim(ParamStr(1)) = /afterupgrade0) then
 92   begin
 93     //程序在本地第一次执行,如果需要升级将下载cderp.exe到本地update.exe并执行
 94     //比较版本信息
 95     if C_ServerVer > C_ExeVer then
 96     begin
 97       C_ExeVer := C_ServerVer;
 98       DelFile(C_ExePath + update.exe);
 99       HttpDownLoad(GET_SubStr(V_version, ‘‘, /exe/) + /exe/ERP_Update.exe, C_ExePath + update.exe);
100       ShellExecute(handle, open, pchar(C_ExePath + ‘ERP_Update.exe), pchar(" + C_ExePath + " " + C_ExeVer + "), nil, SW_ShowNormal);
101     end
102     else
103       ShellExecute(handle, open, pchar(C_ExePath + C_ExeName), nil, nil, SW_ShowNormal);
104     application.Terminate;
105   end
106   else
107   begin
108     Frm_FTP.WindowState := wsNormal;
109     Frm_FTP.Visible := true;
110     Frm_FTP.Refresh;
111     V_Err := False;
112     //防止可执行程序没有完全关闭, 等待一会
113     ProgressBar1.max := 100;
114     for i := 1 to 100 do
115     begin
116       Label4.Caption := 升级准备...;
117       ProgressBar1.Position := i;
118       Application.ProcessMessages;
119       Sleep(50);
120     end;
121     for i := 1 to 100 do
122     begin
123       C_ServerIP := get_code(ss, #url + trim(IntToStr(i)) + =);
124       if C_ServerIP = ‘‘ then
125       begin
126         Break;
127       end;
128       HttpDownLoad(C_ServerIP, C_ExePath + GetURLFileName(C_ServerIP));
129     end;
130     HttpDownLoad(V_LiveUpdate, C_ExePath + GetURLFileName(V_LiveUpdate));
131     if not V_Err then
132     begin
133       ss.loadfromfile(C_ExePath + GetURLFileName(V_LiveUpdate));
134       ss.delete(3);
135       ss.delete(2);
136       ss.Add(version= + C_ServerVer);
137       ss.Add(exe= + C_ExeName);
138       ss.savetofile(C_ExePath + GetURLFileName(V_LiveUpdate));
139       ss.free;
140       Application.MessageBox(程序已经升级完成!, 升级完成, MB_ICONINFORMATION + MB_OK);
141       ShellExecute(handle, open, pchar(C_ExePath + C_ExeName), nil, nil, SW_ShowNormal);
142     end;
143     application.Terminate;
144   end;
145 end;
146 
147 procedure TFrm_FTP.FormCreate(Sender: TObject);
148 begin
149   RUN_start;
150 end;
151 
152 function TFrm_FTP.GET_CODE(V_s: TstringS; V_CODE: string): string;
153 var
154   i, j, l: integer;
155   v_Result: string;
156 begin
157   j := V_s.Count - 1;
158   l := length(v_code);
159   i := 0;
160   while i <= j do
161   begin
162     if copy(trim(UpperCase(V_s.Strings[i])), 1, l) = UpperCase(V_CODE) then
163     begin
164       v_Result := copy(trim(V_s.Strings[i]), l + 1, 500);
165       j := 0;
166     end;
167     i := i + 1;
168   end;
169   Result := v_Result;
170 end;
171 
172 function TFrm_FTP.GET_SubStr(V_s: string; V_CODE1, V_CODE2: string): string;
173 var
174   j, k: integer;
175   v_str: string;
176 begin
177   //Label4.Caption := GET_SubStr(‘url=http://192.1.1.0/exe/ERP_Update/version.inf‘, ‘://‘, ‘/exe‘);
178   //数据解析,找到字符串中的子串
179   v_str := UpperCase(V_s);
180   k := pos(UpperCase(v_code1), v_str);
181   if v_code1 = ‘‘ then
182   begin
183     k := 1;
184   end;
185   if k > 0 then
186   begin
187     v_str := copy(v_str, k + length(v_code1), 500);
188     if v_code2 = ‘‘ then
189       k := 500
190     else
191       k := pos(UpperCase(v_code2), v_str);
192     if k > 0 then
193     begin
194       v_str := copy(v_str, 1, k - 1);
195     end
196     else
197     begin
198       v_str := ‘‘;
199     end;
200   end
201   else
202   begin
203     v_str := ‘‘;
204   end;
205   Result := v_str;
206 end;
207 
208 procedure TFrm_FTP.DelFile(V_Name: string);
209 var
210   i: integer;
211 begin
212   i := 0;
213   while FileExists(V_Name) do
214   begin
215     DeleteFile(V_Name);
216     Application.ProcessMessages;
217     i := i + 1;
218     if i > 10 then
219     begin
220       if MessageDlg(系统不能执行删除操作[ + V_Name + ],是否重试?, mtConfirmation, [mbYes, mbNo], 0) = mrNO then
221       begin
222         i := 0;
223         Abort;
224       end;
225     end;
226   end;
227 end;
228 
229 procedure TFrm_FTP.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
230   const AWorkCount: Integer);
231 begin
232   ProgressBar1.Position := AWorkCount;
233 end;
234 
235 procedure TFrm_FTP.IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
236   const AWorkCountMax: Integer);
237 begin
238   if AWorkCountMax > 0 then
239     ProgressBar1.max := AWorkCountMax
240   else
241     ProgressBar1.Max := BytesToTransfer;
242 
243 end;
244 
245 procedure TFrm_FTP.IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
246 begin
247   BytesToTransfer := 0;
248 
249 end;
250 //http方式下载
251 
252 function TFrm_FTP.HttpDownLoad(aURL, aFile: string): Boolean;
253 var
254   MyStream: TMemoryStream; //如果文件不存在
255   F_Str: string;
256 begin
257   if V_Err then exit;
258   try
259     label4.Caption := 正在升级... + GetURLFileName(aURL);
260     label4.Refresh;
261     MyStream := TMemoryStream.Create;
262     IdHTTP1.Request.ContentRangeStart := 0;
263     try
264       IdHTTP1.Get(stringreplace(UpperCase(aURL), 192.1.1.0/EXE/, 192.1.1.0/EXE/, [rfReplaceAll]), MyStream); //开始下载
265       MyStream.SaveToFile(aFile);
266       if pos(.REG, UpperCase(aFile)) > 0 then
267         WinExec(pchar(regedit.exe /s " + aFile + "), SW_HIDE);
268 
269       if pos(TNSNAMES.ORA, UpperCase(aFile)) > 0 then
270       begin
271         F_Str := GET_Ora_Home;
272         if F_Str <> ‘‘ then MyStream.SaveToFile(F_Str);
273       end;
274 
275       label4.Caption := 升级完成;
276     finally
277       MyStream.Free;
278     end;
279     Result := True;
280   except
281     on E: Exception do
282     begin
283       Application.MessageBox(PChar(升级[ + GetURLFileName(aURL) + ]过程中出现错误了,错误信息如下: + #13 + #10 + E.Message), PChar(系统提示), Mb_OK + MB_ICONERROR);
284       V_Err := True;
285       Result := False;
286     end;
287   end;
288 end;
289 
290 function TFrm_FTP.GetURLFileName(aURL: string): string;
291 var
292   i: integer;
293   s: string;
294 begin
295   s := aURL;
296   i := Pos(/, s);
297   while i <> 0 do //去掉"/"前面的内容剩下的就是文件名了
298   begin
299     Delete(s, 1, i);
300     i := Pos(/, s);
301   end;
302   Result := s;
303 end;
304 
305 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即可实现自动升级。

 

以上是关于Delphi - Indy TIdHTTP方式创建程序外壳 - 实现可执行程序的自动升级的主要内容,如果未能解决你的问题,请参考以下文章

冻结 Indy HTTP。进入 Android Delphi 11 内部线程

THttpCli发送和接受数据,代替indy10 TidHttp解决超时时间无效的问题

使用 Delphi 在 TIdHttp 中的文件下载问题

使用 Delphi 和 Indy 以编程方式通过 Progress 事件从 Internet 下载文件

delphi中使用HTTP控件,怎么使用POST的异步方式

无法使用Delphi通过Post打开Microsoft语音识别API