Delphi - 调用外部程序并阻塞到外部程序中

delphi 调用外部程序并阻塞到外部程序中

背景说明：

前段时间开发一个数据转换的系统，业务逻辑中说明数据需要压缩成.tar.gz格式。

我在windows系统下采用，先生成批处理文件，然后调用winexec执行批处理文件，休眠等待一段时间，完成数据的自动压缩。

后来发现，待压缩文件的大小不确定，单纯的执行winexec时sleep固定时间，可能导致压缩失败、文件不全或损坏。

优化方案：

取代winexe用createprocess用来启动进程, 执行批处理文件, 同时系统会自动填写tprocessinformation这个结构。

此时程序会自动阻塞到该批处理中，等待批处理句柄的进程结束或超时。这样就能解决压缩损坏问题。

 

给个实例demo:

d7代码如下：

 1 unit umain;
 2 
 3 interface
 4 
 5 uses
 6   windows, messages, sysutils, variants, classes, graphics, controls, forms,
 7   dialogs, rzbutton, stdctrls;
 8 
 9 type
10   tfrmmain = class(tform)
11     mmmsg: tmemo;
12     btnexecute: trzbitbtn;
13     btnclear: trzbitbtn;
14     procedure msgdsp(v_str: string);
15     procedure btnexecuteclick(sender: tobject);
16     procedure btnclearclick(sender: tobject);
17   private
18     { private declarations }
19   public
20     { public declarations }
21   end;
22 
23 var
24   frmmain: tfrmmain;
25 
26 implementation
27 
28 {$r *.dfm}
29 
30 procedure tfrmmain.msgdsp(v_str: string);
31 begin
32   mmmsg.lines.add('[ admin ] - [' + v_str + '] - [' + formatdatetime('yyyy-mm-dd hh:mm:ss zzz', now()) + ']');
33 end;
34 
35 procedure tfrmmain.btnexecuteclick(sender: tobject);
36 var
37   sinfo: tstartupinfo;
38   pinfo: tprocessinformation;
39   cmdline: string;
40   exitcode: cardinal;
41 begin
42   msgdsp('初始化参数');
43   cmdline := 'c:\program files\7-zip\7zfm.exe';
44   fillchar(sinfo, sizeof(sinfo), #0);
45   sinfo.cb := sizeof(sinfo);
46   sinfo.dwflags := startf_useshowwindow;
47   sinfo.wshowwindow := sw_normal;
48   msgdsp('参数初始化完成，启动winexec调试');
49   //createprocess用来启动进程, 进程启动后, 会填写tprocessinformation这个结构，
50   //此时程序阻塞到该句柄中，等待句柄的进程结束或超时
51   if not createprocess(nil, pchar(cmdline), nil, nil, false, create_new_console or normal_priority_class, nil, nil, sinfo, pinfo) then
52   begin
53     msgdsp('winexec调试失败！');
54     messagebox(application.handle, '指定程序启动失败!', '错误', mb_ok or mb_iconstop);
55   end
56   else
57   begin
58     //等待指定句柄的进程结束或超时
59     waitforsingleobject(pinfo.hprocess, infinite);
60     getexitcodeprocess(pinfo.hprocess, exitcode);
61     msgdsp('winexec调试成功！');
62   end;
63 end;
64 
65 procedure tfrmmain.btnclearclick(sender: tobject);
66 begin
67    mmmsg.clear;
68 end;
69 
70 end.

运行效果如下：

 

封装成函数如下：

 1 //jeremy.wu
 2 //2019.09.19
 3 //https://www.cnblogs.com/jeremywucnblog/
 4 function tfrmmain.getcreateprocess(vcmdline: string): boolean;
 5 var
 6   sinfo: tstartupinfo;
 7   pinfo: tprocessinformation;
 8   exitcode: cardinal;
 9 begin
10   result := false;
11   fillchar(sinfo, sizeof(sinfo), #0);
12   sinfo.cb := sizeof(sinfo);
13   sinfo.dwflags := startf_useshowwindow;
14   sinfo.wshowwindow := sw_normal;
15   //createprocess用来启动进程, 进程启动后, 会填写tprocessinformation这个结构，
16   //此时程序阻塞到该句柄中，等待句柄的进程结束或超时
17   if not createprocess(nil, pchar(vcmdline), nil, nil, false, create_new_console or normal_priority_class, nil, nil, sinfo, pinfo) then
18   begin
19     result := false;
20   end
21   else
22   begin
23     //等待指定句柄的进程结束或超时
24     waitforsingleobject(pinfo.hprocess, infinite);
25     getexitcodeprocess(pinfo.hprocess, exitcode);
26     result := true;
27   end;
28 end;