Poné esto en un módulo:
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Const SYNCHRONIZE = &H100000
Private Const WAIT_FAILED = -1&
Private Const WAIT_OBJECT_0 = 0
Private Const WAIT_ABANDONED = &H80&
Private Const WAIT_ABANDONED_0 = &H80&
Private Const WAIT_TIMEOUT = &H102&
Public Function ShellSincronico(Comando As String, Optional TimeOut As Integer = 60, Optional Foco As VbAppWinStyle = vbMinimizedNoFocus) As Boolean
'---------------------------------------------------------------------------------------
' Fecha Hora: 24/02/2003 15:03
' Autor : Fabio Marredo
' Propósito : Ejecuta un proceso externo (DOS) en forma sincronica
'---------------------------------------------------------------------------------------
Dim ret As Long
On Error GoTo Errores
ret = Shell(Comando, Foco)
Select Case EsperarFinProceso(ret, TimeOut)
Case WAIT_FAILED
Err.Raise vbObjectError + 110, , "Proceso fallido"
Case WAIT_TIMEOUT
Err.Raise vbObjectError + 120, , "Terminó el tiempo de espera: " & TimeOut & " segs."
Case WAIT_OBJECT_0
ShellSincronico = True
End Select
On Error GoTo 0
Exit Function
Errores:
MsgBox "ShellSincronico::Error " & Err.Number & ": " & Err.Description
End Function
Public Function EsperarFinProceso(ByVal lngIDProceso As Long, Optional ByVal lngTimeOut As Long = -1) As Long
Dim phnd As Long
Dim Resu As Long
On Error GoTo Errores
phnd = OpenProcess(SYNCHRONIZE, 0, lngIDProceso)
If phnd <> 0 Then
Resu = WaitForSingleObject(phnd, lngTimeOut * 1000)
CloseHandle phnd
End If
EsperarFinProceso = Resu
Errores:
If Err Then MsgBox "EsperarFinProceso::" & Err.Description
End Function
MODO DE USO:
ShellSincronico rutacmd, 30, vbNormalFocus
|
