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

  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.