Sujet Précédent Sujet Suivant

Comment fermer UN FICHIER ouvert avec ShellExecute ?.

Résolu
Excalibur_56 Messages postés 44 Date d'inscription jeudi 14 février 2019 Statut Membre Dernière intervention 22 août 2023 - Modifié le 6 mars 2019 à 10:34
Excalibur_56 Messages postés 44 Date d'inscription jeudi 14 février 2019 Statut Membre Dernière intervention 22 août 2023 - 16 avril 2019 à 12:39
Bonjour à tous;
Voilà, j'ouvre un fichier avec ShellExecute
ShellExecute(0, open, "MonFichier" .exe, ou .txt, ou .doc ..., sw_show)
J' ouvre mon fichier correctement;
mais, comment le refermer ?? , pas l'application !!! .
je ne veux pas fermer Notepad.exe, ou Word.exe ou tout autre application,
Mais juste "MonFichier" qui est ouvert.

je n'ai rien trouvé sur ShellExit

En vous remercient de votre aide ;
sincères salutations

3 réponses

Réponse 1 / 3
papyvore Messages postés 223 Date d'inscription samedi 15 novembre 2003 Statut Membre Dernière intervention 16 décembre 2021 15
19 mars 2019 à 09:41
salut
vas lire https://stackoverflow.com/questions/43774320/how-to-kill-a-process-by-name
ça marche mais il y a d'autres possibilités
0
Réponse 2 / 3
papyvore Messages postés 223 Date d'inscription samedi 15 novembre 2003 Statut Membre Dernière intervention 16 décembre 2021 15
16 avril 2019 à 11:16
Salut
je sais pas si t'as résolu ton problème ,mais j'ai retrouvé un prog que j'avais fait largement inspiré d'autres sources qui sont citées dans le fichier.
je joins les fichiers .pas et .dfm (il y a encore des questions à résoudre)
le.pas 

unit uLance;

interface

uses
  Winapi.Windows, System.SysUtils, System.Classes, Graphics, Controls, Forms,
  Dialogs, System.UITypes ,
  StdCtrls, System.Types, ShellApi, Vcl.Grids;
  // Uses nécessaires pr les fichiers .LNK :
 //  ShlObj, ActiveX;

type
  TForm1 = class(TForm)
    ButtonClose: TButton;
    ButtonOpen: TButton;
    OpenDialog1: TOpenDialog;
    StringGrid1: TStringGrid;
    ButtonCloseAll: TButton;
    procedure ButtonCloseClick(Sender: TObject);
    procedure ButtonOpenClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ButtonCloseAllClick(Sender: TObject);
  private
    { Private declarations }

  public
    { Public declarations }
    function StartAssociatedExe(FileName: String;
      var ErrorCode: Cardinal): Boolean;

  end;

type
  TCustomGridHelper = class helper for TCustomGrid
  public
    procedure DelRow(ARow: Integer);
  end;

var
  Form1: TForm1;
  Nom: string;
  ProcessInfo: TProcessInformation;
  StartupInfo: TStartupInfo;
  ErrorCode: Cardinal;
  Redir : string;
implementation

{$R *.DFM}
{$REGION 'FindExecutable'}
{
  function FindExecutable (NomFichier, Répertoire: PChar; Résultat: PChar): HINST;

  La fonction FindExecutable renvoie le nom et le descripteur de l'application (.EXE) associée
  à un nom de fichier spécifique (type de fichier).

  Paramètres:
  NomFichier : Chaîne spécifiant le nom du fichier. Cela peut être un document ou un fichier exécutable.

  Répertoire : chaîne définissant le dossier par défaut.

  Résultat : une chaîne (tableau de caractères) qui prend un nom de fichier lorsque la fonction renvoie
  un nom de fichier.
  Le nom de fichier est une chaîne contenant le chemin d'accès à l'application exécutable lorsque
  la commande "open" est déclenchée pour associer le type de fichier.

  Si la fonction réussit, la valeur renvoyée est supérieure à 32.
  Si la fonction échoue, la valeur renvoyée est inférieure ou égale à 32.
  Le tableau ci-dessous contient les erreurs possibles:
  0 - Le système ne dispose ni de suffisamment de mémoire ni de ressources.
  31 - Aucune association pour un type de fichier spécifique.
  ERROR_FILE_NOT_FOUND - Fichier non trouvé.
  ERROR_PATH_NOT_FOUND - Chemin introuvable.
  ERROR_BAD_FORMAT - Le format .EXE est incorrect (non-Win32 .EXE ou une erreur dans le fichier .EXE).

  Remarques
  Lorsque FindExecutable est renvoyé, le paramètre Result peut contenir le chemin du serveur DDE en cours
  d'exécution. Si le serveur ne répond pas à la demande, initialisez-la. }
{$ENDREGION}

procedure TCustomGridHelper.DelRow(ARow: Integer);
begin
  Self.DeleteRow(ARow);
end;

function TForm1.StartAssociatedExe(FileName: String;
  var ErrorCode: Cardinal): Boolean;
// sources
// http://www.fobec.com/CMS/delphi/trucsetastuces/lancer-fichier-attendre-fermeture_140.html
// https://www.swissdelphicenter.ch/en/showcode.php?id=103
var
  Prg: string;
  Nom: string;
begin
  Result := False;
  if FileName = '' then
    exit;

  SetLength(Prg, MAX_PATH);
  ErrorCode := FindExecutable(PWideChar(FileName), nil, PWideChar(Prg));

  if ErrorCode >= 32 then
  begin
    SetLength(Prg, StrLen(PWideChar(Prg)));
    FillChar(StartupInfo, Sizeof(TStartupInfo), 0);
    with StartupInfo do
    begin
      cb          := Sizeof(TStartupInfo);
      wShowWindow := SW_SHOW;
    end;
    // "FileName" *******************************************************************************
    // if ExtractFileExt(UpperCase( FileName)) ='.JPG' then  FileName := '"'+FileName+'"';
    FileName := '"' + FileName + '"';
    Prg      := '"' + Prg + '"';
    Nom      := Prg + ' ' + FileName;

    // ne marche pas   Nom      := '"' + Prg + ' ' + FileName + '"';
    // *********************************************************************************************

   {  if CreateProcess(PChar(Prg), PChar(Format('%s %s', [(Prg), (FileName)])), nil,
     nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo)  then
    ne marche pas pour les fichiers JPG . pas trouvé pourquoi!!
     if CreateProcess( nil , PChar(Format('%s %s', [Prg, FileName])), nil , nil , false,
     CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil , nil ,StartupInfo,ProcessInfo) then }

//pour fichier lnk  ???
    if CreateProcess(nil, PChar(FileName), nil, nil, False, CREATE_NEW_CONSOLE or
      NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
    else
//pour les autres fichiers ou programmes pourquoi pas lnk ???
    if CreateProcess(nil, PChar(Nom), nil, nil, False, CREATE_NEW_CONSOLE or
      NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
    begin
      //
    end;

      StringGrid1.RowCount := StringGrid1.RowCount + 1;
      StringGrid1.Cells[1, StringGrid1.RowCount - 1] := OpenDialog1.FileName;
      StringGrid1.Cells[2, StringGrid1.RowCount - 1] :=
        IntToStr(ProcessInfo.dwProcessId);
      Result := True;
  end
  else
    ErrorCode := GetLastError;
end;


procedure TForm1.ButtonCloseAllClick(Sender: TObject);
var
  i: Integer;
  HandleProcess: THandle;
begin
  i := StringGrid1.RowCount - 1;
  while i <> 0 do
  begin
    HandleProcess := OpenProcess(PROCESS_TERMINATE, False,
      StrToInt(StringGrid1.Cells[2, i]));
    if i <> 0 then
      StringGrid1.DelRow(i + 1);
    TerminateProcess(HandleProcess, i);
    Dec(i);
  end;
end;

procedure TForm1.ButtonCloseClick(Sender: TObject);
var
  HandleProcess: THandle;
begin
  if StringGrid1.Row = 0 then
  begin
    MessageDlg('Vous devez selectionner une ligne', mtWarning, [mbOK], 0);
    exit;
  end;
  // Obtention du Handle du process à partir de l'identifiant du thread (dwProcessId)
  HandleProcess := OpenProcess(PROCESS_TERMINATE, False,
    StrToInt(StringGrid1.Cells[2, StringGrid1.Row]));
  if StringGrid1.Row <> 0 then
    StringGrid1.DelRow(StringGrid1.Row);
  TerminateProcess(HandleProcess, 0);
end;

procedure TForm1.ButtonOpenClick(Sender: TObject);
begin
 if OpenDialog1.Execute then
    Nom := OpenDialog1.FileName;
  begin
    if StartAssociatedExe(Nom, ErrorCode) then
    begin
    // Showmessage('l''application est lancée')
    end
    else
     Showmessage(SysErrorMessage(ErrorCode));
  end
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  StringGrid1.Cells[1, 0]  := 'FileName';
  StringGrid1.ColWidths[1] := 250;
  StringGrid1.Cells[2, 0]  := 'dwProcessId';
  StringGrid1.ColWidths[2] := 100;
  StringGrid1.ColCount     := 3;
  StringGrid1.FixedRows    := 0;
  StringGrid1.RowCount     := 1;
end;

initialization
//  CoInitialize(nil);

finalization
 // CoUninitialize;
end.

le dfm 

object Form1: TForm1
  Left = 629
  Top = 129
  Caption = 'Form1'
  ClientHeight = 343
  ClientWidth = 441
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = [fsBold]
  OldCreateOrder = True
  Position = poDesigned
  OnCreate = FormCreate
  DesignSize = (
    441
    343)
  PixelsPerInch = 96
  TextHeight = 13
  object ButtonClose: TButton
    Left = 120
    Top = 312
    Width = 75
    Height = 25
    Hint = 'kjhgkjhgkg'
    BiDiMode = bdLeftToRight
    Caption = 'Close '
    ParentBiDiMode = False
    ParentShowHint = False
    ShowHint = True
    TabOrder = 0
    OnClick = ButtonCloseClick
  end
  object ButtonOpen: TButton
    Left = 24
    Top = 312
    Width = 75
    Height = 25
    Caption = 'Open'
    ParentShowHint = False
    ShowHint = True
    TabOrder = 1
    OnClick = ButtonOpenClick
  end
  object StringGrid1: TStringGrid
    Left = 0
    Top = 16
    Width = 441
    Height = 281
    Anchors = [akLeft, akTop, akRight]
    ColCount = 3
    RowCount = 1
    FixedRows = 0
    Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goColSizing, goRowSelect]
    TabOrder = 2
  end
  object ButtonCloseAll: TButton
    Left = 216
    Top = 312
    Width = 75
    Height = 25
    Hint = 'kjhgkjhgkg'
    BiDiMode = bdLeftToRight
    Caption = 'Close All'
    ParentBiDiMode = False
    ParentShowHint = False
    ShowHint = True
    TabOrder = 3
    OnClick = ButtonCloseAllClick
  end
  object OpenDialog1: TOpenDialog
    Left = 344
    Top = 216
  end
end
0
Réponse 3 / 3
Excalibur_56 Messages postés 44 Date d'inscription jeudi 14 février 2019 Statut Membre Dernière intervention 22 août 2023
16 avril 2019 à 12:39
Bonjour Papyvore;
Un grand merci pour ton aide;
Effectivement, je n'avais pas mis "problème résolu", milles excuses
Je vais réessayer ton code, car je l'avais trouvé, mais , je ne sais plus pourquoi, il ne m'avais pas répondu à mes attentes, je crois.
autrement, j'avais trouvé ceci:

function UpString(Str: string): string;
var i: integer;
begin
result:='';
for i:=1 to length(str) do
result:=result+UpCase(str[i]);
end;

function ProgEnCours(NomProg:string):boolean;
var
LPPE : TProcessEntry32;
H : Thandle;
begin
result := false;
h:=CreateToolhelp32Snapshot(TH32CS_SNAPALL ,0);
Lppe.DwSize:=Sizeof(TProcessEntry32);
if Process32First(h,lppe)
then
Begin;
if UpString(ExtractFileName(LPPE.szexefile))=UpString(NomProg) then result:=true;
while Process32next(h,lppe) do
begin
if UpString(ExtractFileName(LPPE.szexefile))=Upstring(NomProg) then result:=true;
end;
End;
Closehandle(h);
end;

procedure TForm1.Timer1Timer(Sender: TObject); // Timer à 1000 (par defaut)
begin
if ProgEnCours(Edit1.Text) then
Label1.Caption:= 'présent'
else
Label1.Caption:= 'non présent';
end;

Voilà ce que j'ai trouvé; il fonctionne bien,
Mille merci à toi
Cordialement
0

Discussions similaires

Parametre de ShellExecute
armetiz -
armetiz -

28 réponses
ShellExecute
Also know as -
Also know as -

1 réponse
ShellExecute probleme
g0belin -
hardghost -

5 réponses
ShellExecute
eric_delphi_man -
Hnimsgern -

1 réponse
Lancer deux shellexecute
cs_jmonnier -
L_art_ment -

7 réponses
Rejoignez-nous