Annotation of mozptch/shell_func.pas, revision 1.3

1.1       oertel      1: (* Copyright (c) uib umwelt informatik buero gmbh (www.uib.de)
                      2:  This sourcecode is owned by uib
                      3:  and published under the Terms of the General Public License.
                      4: #*###CVS_HEAD_START###******************************************************
1.2       oertel      5: # $Id: shell_func.pas,v 1.1 2004/03/14 12:49:07 oertel Exp $
1.1       oertel      6: #
                      7: #*###EXCLUDE_CVS_LOG###*****************************************************
                      8: # History:
                      9: # ========
                     10: #
1.2       oertel     11: # $Log: shell_func.pas,v $
                     12: # Revision 1.1  2004/03/14 12:49:07  oertel
                     13: # Initial commit version 9.29
                     14: #
1.1       oertel     15: *)
                     16: unit shell_func;
                     17: 
                     18: 
                     19: interface
1.2       oertel     20: {$IFDEF MSWINDOWS}
                     21: uses
1.1       oertel     22: 
                     23:   sysutils, WinTypes, Winprocs, Messages, Forms, Dialogs, ShellApi;
                     24: 
                     25: 
1.2       oertel     26: 
1.1       oertel     27: function StartProcess (CmdLinePasStr : String; ShowWindowFlag : Integer;
                     28:                        WaitForReturn : Boolean;
                     29:                        Var Report : String): Boolean;
                     30: 
                     31: 
                     32: function start(commandline : string) : boolean;
                     33: function startfile(commandline : string) : boolean;
                     34: function startprogram(commandline : string; parameters : string) : boolean;
1.2       oertel     35: {$ENDIF}
1.1       oertel     36: 
                     37: implementation
                     38: 
1.2       oertel     39: {$IFDEF MSWINDOWS}
1.1       oertel     40: procedure processmess;
                     41: begin
                     42:  Application.processmessages;
                     43: end;
                     44: 
                     45: function StartProcess (CmdLinePasStr : String; ShowWindowFlag : Integer;
                     46:                        WaitForReturn : Boolean;
                     47:                        Var Report : String): Boolean;
                     48: 
                     49: 
                     50:   var
                     51:   // StartupInfo : TStartupInfo;
                     52:   // ProcessInformation : TProcessInformation;
                     53:   // tokenhandle: thandle;
                     54: 
                     55:    executeInfo : TShellExecuteInfo;
                     56:    pExecuteInfo : PShellExecuteInfo;
                     57: 
                     58:    running : Boolean;
                     59:    lpExitCode : DWORD;
                     60: 
                     61:    WaitWindowStarted : Boolean;
                     62:    starttime, nowtime : TDateTime;
                     63: 
                     64:    line : String;
                     65:    filename : String;
                     66:    params : String;
                     67:    dir: String;
                     68:    firstsplit: Integer;
                     69:    len : DWord;
                     70:    functionresult : hinst;
                     71: 
                     72:    const secsPerDay = 86400;
                     73: 
                     74:  Begin
                     75:    {
                     76:     with StartupInfo do
                     77:      Begin
                     78:        cb := SizeOf (TStartupInfo);
                     79:        lpReserved  := nil;
                     80:        lpDesktop   := nil;
                     81:        lpTitle     := nil;
                     82:        dwFlags     := STARTF_USESHOWWINDOW;
                     83:        wShowWindow := ShowWindowFlag;
                     84:        lpReserved2 := nil;
                     85:      end;
                     86: 
                     87:     }
                     88: 
                     89:     if length(CmdLinePasStr) = 0
                     90:     then
                     91:     Begin
                     92:       result := false;
                     93:       Report := 'No file to execute';
                     94:       exit;
                     95:     end;
                     96: 
                     97:     params := '';
                     98: 
                     99:     if CmdLinePasStr[1] = '"'
                    100:     then
                    101:     Begin
1.2       oertel    102:       line := copy (CmdLinePasStr, 2, length (CmdLinePasStr));
1.1       oertel    103:       firstsplit := pos ('"', line);
                    104:       if firstsplit <= 0
                    105:       then
                    106:       Begin
                    107:         result := false;
                    108:         Report := 'No valid filename';
                    109:         exit;
                    110:       End;
                    111:       filename := copy (line, 1, firstsplit-1);
                    112:       params := copy (line, firstsplit + 1, length (line));
                    113:     end
                    114:     else
                    115:     Begin
                    116:       firstsplit := pos(' ', CmdLinePasStr);
                    117:       if firstsplit > 0
                    118:       then
                    119:       Begin
                    120:         filename := copy (CmdLinePasStr, 1, firstsplit - 1);
                    121:         params := copy (CmdLinePasStr, firstsplit + 1, length (CmdLinePasStr));
                    122:       End
                    123:       else
                    124:       Begin
                    125:         filename := CmdLinePasStr;
                    126:       End;
                    127:     End;
                    128: 
                    129:     with executeInfo do
                    130:     Begin
                    131:       cbSize := sizeOf (TShellExecuteInfo);
                    132: 
                    133:       fMask := SEE_MASK_NOCLOSEPROCESS; //leave the process running
                    134: 
                    135:       Wnd := 0;
                    136:       lpVerb := 'Open';
                    137:       lpFile := PChar (filename);
                    138:       lpParameters := PChar (params);
                    139:       lpDirectory := nil;
                    140:       nShow := ShowWindowFlag;
                    141:     {  hInstApp: HINST; }
                    142:     { Optional fields
                    143:        lpIDList: Pointer;
                    144:        lpClass: PWideChar;
                    145:        hkeyClass: HKEY;
                    146:        dwHotKey: DWORD;
                    147:        hIcon: THandle;
                    148:        hProcess: THandle;
                    149:        }
                    150: 
                    151:     End;
                    152: 
                    153:     pExecuteInfo := addr(executeInfo);
                    154: 
                    155: 
                    156:     //functionresult := ShellExecute (0, 'open', PChar (Filename), PChar(params), nil, showWindowFlag);
                    157:     //if functionresult <= 32
                    158: 
                    159:     if not ShellExecuteEx (pExecuteInfo)
                    160:     {
                    161:     if not CreateProcess (nil, PChar (CmdLinePasStr),
                    162:                      nil, nil, true, 0 (* CREATE_SEPARATE_WOW_VDM*), nil, nil,
                    163:                      StartupInfo, ProcessInformation)
                    164:     }
                    165:     then
                    166:     Begin
                    167:       result := false;
                    168:       Report :=  CmdLinePasStr + ' .... ShellExecute Error ' + IntToStr (functionResult)
                    169:                  + ' (' + SysErrorMessage (functionResult) + ')'
                    170:     End
                    171:     else
                    172: 
                    173:         Begin
                    174:       result := true;
                    175: 
                    176:       Report := 'Process started:    ' + CmdLinePasStr;
                    177: 
                    178:       if WaitForReturn
                    179:       then
                    180:       Begin
                    181:        running := true;
                    182:        while running do
                    183:        begin
                    184:          GetExitCodeProcess (ExecuteInfo.hProcess, lpExitCode);
                    185:          if lpExitCode <> still_active
                    186:          then running := false
                    187:          else Application.ProcessMessages
                    188:        End;
                    189: 
                    190:        Application.ProcessMessages;
                    191:       End;
                    192:     End;
                    193: 
                    194:  End;
                    195: 
                    196: 
                    197: function startShellExecute (CmdLinePasStr : String;
                    198:                        parameterPasStr : String;
                    199:                        ShowWindowFlag : Integer;
                    200:                        WaitForReturn : Boolean;
                    201:                        WaitForWindowVanished : Boolean; WindowToVanish : String;
                    202:                        Var Report : String): Boolean;
                    203:   var
                    204:    StartupInfo : TStartupInfo;
                    205:    ProcessInformation : TProcessInformation;
                    206: 
                    207: 
                    208:    running : Boolean;
                    209:    lpExitCode : DWORD;
                    210: 
                    211:    WaitWindowStarted : Boolean;
                    212: 
                    213:  Begin
                    214: 
                    215:     with StartupInfo do
                    216:      Begin
                    217:        cb := SizeOf (TStartupInfo);
                    218:        lpReserved  := nil;
                    219:        lpDesktop   := nil;
                    220:        lpTitle     := nil;
                    221:        dwFlags     := STARTF_USESHOWWINDOW;
                    222:        wShowWindow := ShowWindowFlag;
                    223:        lpReserved2 := nil;
                    224:      end;
                    225: 
                    226:     if 32 >= ShellExecute(Application.MainForm.Handle,NIL,PChar(CmdLinePasStr)
                    227:                        ,PChar(parameterPasStr),'',ShowWindowFlag)
                    228:     //if not CreateProcess (nil, PChar (CmdLinePasStr),
                    229:     //                 nil, nil, true, 0 (* CREATE_SEPARATE_WOW_VDM*), nil, nil,
                    230:     //                 StartupInfo, ProcessInformation)
                    231:     then
                    232:     Begin
                    233:       result := false;
                    234:       Report :=  CmdLinePasStr + ' .... CreateProcess Error ' + IntToStr (GetLastError)
                    235:                  + ' (' + SysErrorMessage (GetLastError) + ')';
                    236:     End
                    237:     else
                    238:     Begin
                    239:       result := true;
                    240: 
                    241:       if not WaitForReturn
                    242:       then
                    243:          Report := 'Process started:    ' + CmdLinePasStr
                    244:       else
                    245:       Begin
                    246:         running := true;
                    247:         WaitWindowStarted := false;
                    248:         while running do
                    249:         begin
                    250:           if WaitForWindowVanished and not WaitWindowStarted
                    251:           then
                    252:           Begin
                    253:             if FindWindowEx (0, 0, nil, PChar (WindowToVanish) ) <> 0
                    254:             then
                    255:               WaitWindowStarted := true
                    256:             else
                    257:               ProcessMess
                    258:           End
                    259:           else
                    260:           Begin
                    261:             if GetExitCodeProcess (ProcessInformation.hProcess, lpExitCode)
                    262:                and (lpExitCode <> still_active)
                    263:             then
                    264:             Begin
                    265:               if WaitForWindowVanished then
                    266:               Begin
                    267:                 if FindWindowEx (0, 0, nil, PChar (WindowToVanish) ) = 0
                    268:                 then running := false
                    269:                 else ProcessMess;
                    270:               End
                    271:               else
                    272:               Begin
                    273:                 (* ProcessMess;
                    274:                 if MyMessageDlg.WiMessage ('Exit Process  Code ' + IntToStr (lpExitCode)
                    275:                                            + '   ' + CmdLinePasStr, [mrYes, mrNo])
                    276:                   = mrYes
                    277:                 then *)
                    278:                 running := false
                    279:               End
                    280:             End
                    281:             else ProcessMess
                    282:           End
                    283:         End;
                    284: 
                    285:         ProcessMess;
                    286:         Report := 'Process executed    ' + CmdLinePasStr
                    287:       End;
                    288:     End;
                    289: 
                    290:  End;
                    291: 
                    292: 
                    293: function start(commandline : string) : boolean;
                    294:  var
                    295:   option, report : String;
                    296:  begin
                    297:   if not StartProcess (commandline, sw_shownormal, true,Report)
                    298:   then
                    299:   Begin
                    300:    messageDlg('Error: ' + Report,mtError,[mbOK],0);
                    301:    result := false;
                    302:   End
                    303:   else
                    304:   begin
                    305:     result := true;
                    306:     //messageDlg('Success: ' + Report,mtInformation,[mbOK],0);
                    307:   end;
                    308:  end;
                    309: 
                    310:  function startfile(commandline : string) : boolean;
                    311:  var
                    312:   option, report : String;
                    313:  begin
                    314:   if not startShellExecute(commandline, '', sw_shownormal, false, false, '', Report)
                    315:   then
                    316:   Begin
                    317:    messageDlg('Error: ' + Report,mtError,[mbOK],0);
                    318:    result := false;
                    319:   End
                    320:   else
                    321:   begin
                    322:     result := true;
                    323:     //messageDlg('Success: ' + Report,mtInformation,[mbOK],0);
                    324:   end;
                    325:  end;
                    326: 
                    327:  function startprogram(commandline : string; parameters : string) : boolean;
                    328:  var
                    329:   option, report : String;
                    330:  begin
                    331:   if not startShellExecute(commandline, parameters, sw_shownormal, false, false, '', Report)
                    332:   then
                    333:   Begin
                    334:    messageDlg('Error: ' + Report,mtError,[mbOK],0);
                    335:    result := false;
                    336:   End
                    337:   else
                    338:   begin
                    339:     result := true;
                    340:     //messageDlg('Success: ' + Report,mtInformation,[mbOK],0);
                    341:   end;
                    342:  end;
1.2       oertel    343: {$ENDIF}
1.1       oertel    344: 
                    345: end.

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>