Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Public Const INFINITE = &HFFFFFFFF ' Infinite timeout
Public Const SYNCHRONIZE = &H100000
'---------------------------------------------------------------------------------------
' Procedure : OuvrirFichier
' DateTime : 27/09/2006 18:20
' Author : Casy
' Purpose : Permet d'ouvrir un document avec l'applicatif (.exe) par défaut.
' Vérifie d'abord si le fichier existe, si un applicatif est installé
' Possibilité de bloquer le process tant que l'applicatif n'est pas fermé
' Retourne TRUE si l'ouverture s'est bien passée, FALSE sinon.
'---------------------------------------------------------------------------------------
Public Function OuvrirFichier(fichier As String, Optional attenteFermeture As Boolean = False) As Boolean
Dim fileappli As String * 250
Dim result As Integer
Dim temp As String
Dim fichAOuvrir As String
Dim i As Integer
Dim pid As Double
Dim phnd As Long
On Error GoTo OuvrirFichier_Error
temp = Dir$(fichier) 'recherche si le fichier existe
If temp <> "" Then
' Le fichier existe
' Recherche l'exécutable associé
result = FindExecutable(fichier, vbNullString, fileappli)
If result > 32 Then
' Association trouvée
i = InStr(1, fileappli, Chr(0), vbBinaryCompare) - 1
fichAOuvrir = """" & Left$(fileappli, i) & """ " & fichier
Else
' Aucune association de trouvée
OuvrirFichier = False
Exit Function
End If
Else
' Le fichier n'existe pas
OuvrirFichier = False
Exit Function
End If
' Ouverture du fichier
pid = Shell(fichAOuvrir, vbMaximizedFocus)
If pid <> 0 Then
' Si attente fermeture demandé, on suspend le process jusqu'à que le logiciel soit fermé.
If attenteFermeture = True Then
phnd = OpenProcess(SYNCHRONIZE, 0, pid)
If phnd <> 0 Then
Call WaitForSingleObject(phnd, INFINITE)
Call CloseHandle(phnd)
End If
End If
OuvrirFichier = True
Else
OuvrirFichier = False
End If
On Error GoTo 0
Exit Function
OuvrirFichier_Error:
OuvrirFichier = False
'---- Code à personaliser en cas d'erreur -------------------------------------------------
Dim message As String
message = "Erreur " & Err.Number & " (" & Err.Description & ") dans la procedure OuvrirFichier" & vbCrLf & vbCrLf
message = message & "Vérifier que le fichier est accessible !" & vbCrLf
message = message & "Vérifier que le logiciel associé est un exécutable !"
MsgBox message, vbCritical & vbOKOnly, "ERREUR - OuvrirFichier"
'------------------------------------------------------------------------------------------
End Function