[RESOLU] Attendre la fin du shellexecute

Max88400

XLDnaute Nouveau
Bonsoir à tous,
je travaille sur un projet permettant de fusionner via PDFCREATOR des feuilles EXCEL alternées avec un document PDF.
Voici le code permettant d'imprimer les PDF.

Code:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Private Sub PrintFichier(sNomFichier As String)
Dim Rep As Integer
Dim hwnd As Long
    Rep = ShellExecute(hwnd, "Print", sNomFichier, 0&, 0&, 1)
  DoEvents
End Sub
 
Sub Tst()
Dim sDossier As String
Dim sFichier As String
Dim Nomfichier As Variant
   
   Nomfichier = ActiveCell.Hyperlinks(1).Address
   If Left(Nomfichier, 2) = "FM" Then
   Nomfichier = ActiveWorkbook.Path & "\" & Nomfichier
   End If
    PrintFichier (Nomfichier)
End Sub

Le soucis, l'impression de mes PDF prend beaucoup plus de temps que mes feuilles EXCEL, du coup le code continue et je me retrouve avec toutes mes feuilles EXCEL au début de ma liste de fusion et mes PDF à la fin.
La solution serait donc d'attendre que la commande shellexecute soit "fini" avant de continuer mon code.

Je ne peux pas utiliser la fonction wait ou autre car la durée d'impression du PDF est extrêmement variable.
J'ai essayé la fonction DoEvents sans sucés.

Ce sujet à déjà été traité mais jamais résolu sur différentes forums, alors je remercie tous ceux qui pourrait m'aider à trouver la solution.

Bonne soirée, Merci.
 
Dernière édition:

Max88400

XLDnaute Nouveau
Re : Attendre la fin du shellexecute

Bonjour tototiti,
merci de t'être penché sur mon soucis, j'ai essayer de mettre ce code dans un module, mais rien ne se passe....
Je ne sais pas quoi modifier pour que ça corresponde à mon projet, peux tu m'aider?

Merci
 

tototiti2008

XLDnaute Barbatruc
Re : Attendre la fin du shellexecute

Bonsoir Max,

Essaye de coller ça dans un module

Code:
   'les déclarations :
    Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
    Public Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long
    Public Declare Function ShellExecuteEx Lib "shell32.dll" (ByRef lpExecInfo As SHELLEXECUTEINFOA) As Long
    Public Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    
    Public Const SEE_MASK_DOENVSUBST As Long = &H200
    Public Const SEE_MASK_IDLIST As Long = &H4
    Public Const SEE_MASK_NOCLOSEPROCESS As Long = &H40
    Public Const SW_HIDE As Long = 0
    Public Const SW_SHOW As Long = 5
    Public Const WAIT_TIMEOUT As Long = 258&
    
    Public Type SHELLEXECUTEINFOA
    cbSize As Long
    fMask As Long
    hwnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
    End Type



    Public Function ExecCmd(ByRef vsCmdLine As String, Optional ByRef vsParameters As String, Optional ByRef vsCurrentDirectory As String = vbNullString, Optional ByVal vnShowCmd As Long = SW_SHOW, Optional ByVal vnTimeOut As Long = 200) As Long
    Dim lpShellExInfo As SHELLEXECUTEINFOA
    With lpShellExInfo
    .cbSize = Len(lpShellExInfo)
    .lpDirectory = vsCurrentDirectory
    .lpVerb = "open"
    .lpFile = vsCmdLine
    .lpParameters = vsParameters
    .nShow = vnShowCmd
    .fMask = SEE_MASK_DOENVSUBST Or SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_IDLIST
    End With
    If ShellExecuteEx(lpShellExInfo) Then
    Do While WaitForSingleObject(lpShellExInfo.hProcess, vnTimeOut) = WAIT_TIMEOUT
    DoEvents
    Loop
    GetExitCodeProcess lpShellExInfo.hProcess, ExecCmd
    CloseHandle lpShellExInfo.hProcess
    Else
    ExecCmd = vbError
    End If
    End Function

    Sub test()
        ExecCmd "calc.exe"
        MsgBox "fini"
    End Sub
 

Max88400

XLDnaute Nouveau
Re : Attendre la fin du shellexecute

Encore Merci tototiti,
mais cette commende m'ouvre bien la calculette Windows, et s’arrête lorsque je la ferme manuellement.
J'arrive à "calc.exe" remplacer par "AcroRd32.exe" mais ça m'ouvre juste acrobat et le code me dit fini quand je le ferme manuellement.
Moi je veux ouvrir un PDF et l'imprimer fermer acrobat automatiquement et continuer, je pense qu'il faut bidouiller dans les paramètres SHELLEXECUTEINFOA mais je suis un peu dépassé par ces paramètre.
Bonne journée
 

MJ13

XLDnaute Barbatruc
Re : Attendre la fin du shellexecute

Bonjour Max, Tototiti

Je fais ce test pour voir si un processus est encore en cours (ici cmd.exe).

Code:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Test_Processus()
Sleep 200
Dim objProcess As Object, colProcessList As Object, objWMIService As Object
Dim strComputer As String
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.execQuery _
("Select * from Win32_Process Where Name = 'cmd.exe'")
For Each objProcess In colProcessList
If (objProcess.Name) = "cmd.exe" Then Test_Processus
Next
Exit Sub
End Sub

Sinon, on peut tester dans le code précédent pour fermer:

Code:
If (objProcess.Name) = "AcroRd32.exe" Then objProcess.Terminate
 
Dernière édition:

Max88400

XLDnaute Nouveau
Re : Attendre la fin du shellexecute

Merci à vous deux,
la compilation des deux à l'air de fonctionner.
Tototiti, les 2 modifs ont fonctionnées le print et le mon fichier

MJ13 j'ai du ajouter un "on error resume next" car il bouclait et voulait me le fermer 2 fois (je sais pas pourquoi) mais ça fonctionne quand j'ignore l'erreur.

Voici le code de totti dans un premier module

Code:
Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
    Public Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long
    Public Declare Function ShellExecuteEx Lib "shell32.dll" (ByRef lpExecInfo As SHELLEXECUTEINFOA) As Long
    Public Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
   
    Public Const SEE_MASK_DOENVSUBST As Long = &H200
    Public Const SEE_MASK_IDLIST As Long = &H4
    Public Const SEE_MASK_NOCLOSEPROCESS As Long = &H40
    Public Const SW_HIDE As Long = 0
    Public Const SW_SHOW As Long = 5
    Public Const WAIT_TIMEOUT As Long = 258&
   
    Public Type SHELLEXECUTEINFOA
    cbSize As Long
    fMask As Long
    hwnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
    End Type



    Public Function ExecCmd(ByRef vsCmdLine As String, Optional ByRef vsParameters As String, Optional ByRef vsCurrentDirectory As String = vbNullString, Optional ByVal vnShowCmd As Long = SW_SHOW, Optional ByVal vnTimeOut As Long = 200) As Long
    Dim lpShellExInfo As SHELLEXECUTEINFOA
    With lpShellExInfo
    .cbSize = Len(lpShellExInfo)
    .lpDirectory = vsCurrentDirectory
    .lpVerb = "Print"
    .lpFile = vsCmdLine
    .lpParameters = vsParameters
    .nShow = vnShowCmd
    .fMask = SEE_MASK_DOENVSUBST Or SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_IDLIST
    End With
    If ShellExecuteEx(lpShellExInfo) Then
    Do While WaitForSingleObject(lpShellExInfo.hProcess, vnTimeOut) = WAIT_TIMEOUT
    DoEvents
    Call Test_Processus
    Loop
    GetExitCodeProcess lpShellExInfo.hProcess, ExecCmd
    CloseHandle lpShellExInfo.hProcess
    Else
    ExecCmd = vbError
    End If
    End Function

    Sub test()
    NomFichier = ActiveCell.Hyperlinks(1).Address
        If Left(NomFichier, 2) = "FM" Then
            NomFichier = ActiveWorkbook.Path & "\" & NomFichier
        End If
    ExecCmd (NomFichier)
    
    End Sub

et le code de MJ13 dans un second module

Code:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Test_Processus()
Sleep 1000
Dim objProcess As Object, colProcessList As Object, objWMIService As Object
Dim strComputer As String
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.execQuery _
("Select * from Win32_Process Where Name = 'AcroRd32.exe'")
For Each objProcess In colProcessList
On Error Resume Next
If (objProcess.Name) = "AcroRd32.exe" Then objProcess.Terminate
Next

Exit Sub
End Sub

Il me reste juste à essayer avec un gros PDF au boulot pour être sure que ca ne ferme pas acrobat afin qu'il n'ai fini d'imprimer mais je le sent bien.

Merci et bravo à vous deux
 

Discussions similaires

Réponses
4
Affichages
402