- Option Explicit
-
- 'Flags ShellExecuteEx
- Private Const SEE_MASK_NOCLOSEPROCESS = &H40
- Private Const SEE_MASK_FLAG_NO_UI = &H400
-
- 'Constantes ERREUR ShellExecuteEx
- Private Const SE_ERR_FNF As Byte = 2
- Private Const SE_ERR_PNF As Byte = 3
- Private Const SE_ERR_ACCESSDENIED As Byte = 5
- Private Const SE_ERR_OOM As Byte = 8
- Private Const SE_ERR_SHARE As Byte = 26
- Private Const SE_ERR_ASSOCINCOMPLETE As Byte = 27
- Private Const SE_ERR_DDETIMEOUT As Byte = 28
- Private Const SE_ERR_DDEFAIL As Byte = 29
- Private Const SE_ERR_DDEBUSY As Byte = 30
- Private Const SE_ERR_NOASSOC As Byte = 31
- Private Const SE_ERR_DLLNOTFOUND As Byte = 32
-
- 'Constantes AFFICHAGE ShellExecuteEx
- Private Const SW_SHOWNORMAL = 1
- Private Const SW_SHOW = 5
- Private Const SW_SHOWDEFAULT = 10
-
- Private Type SHELLEXECUTEINFO
- 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
-
- 'OpenProgram
- Private Declare Function ShellExecuteEx Lib "shell32.dll" _
- (SEI As SHELLEXECUTEINFO) As Long
-
-
- 'CloseProgram
- Private Declare Function CloseHandle Lib "kernel32" _
- (ByVal hObject As Long) As Long
-
- Private Declare Function TerminateProcess Lib "kernel32" _
- (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
-
- Private Declare Sub Sleep Lib "kernel32" _
- (ByVal dwMilliseconds As Long)
-
-
-
- ' ***********************************************************
- ' *
- ' * Lance le programme par défaut associé à un fichier (en fonction de son
- ' * extension ) et retourne le hWnd de la fênetre du programme lançé.
- ' *
- ' ***********************************************************
-
- Public Function OpenProgram(ByRef FileName As String, ByRef OwnerhWnd As Long) As Long
- Dim SEI As SHELLEXECUTEINFO
-
- On Error GoTo ErrorHandler
-
- 'Vérifie si le fichier à lancer est un exécutable (.exe)
- If GetExtension(FileName) = "exe" Then
- If vbNo = MsgBox("ATTENTION, êtes-vous sûr de vouloir lancer ce programme exécutable ?", vbExclamation + vbYesNo) _
- Then
- OpenProgram = 0
- Exit Function
- End If
- End If
-
- With SEI
- .cbSize = Len(SEI)
- .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_FLAG_NO_UI
- .hWnd = OwnerhWnd
- .lpVerb = "open"
- .lpFile = FileName
- .lpParameters = vbNullChar
- .lpDirectory = vbNullChar
- .nShow = SW_SHOW
- .hInstApp = OwnerhWnd
- End With
-
- OpenProgram = ShellExecuteEx(SEI)
-
- If SEI.hInstApp <= 32 Then
- 'Erreurs
- OpenProgram = 0
-
- Select Case SEI.hInstApp
- Case SE_ERR_FNF
- OpenProgram = SEI.hProcess
- Case SE_ERR_PNF
- MsgBox "Le chemin du fichier à ouvrir est incorrect.", vbExclamation
- Case SE_ERR_ACCESSDENIED
- MsgBox "Accès au fichier refusé.", vbExclamation
- Case SE_ERR_OOM
- MsgBox "Mémoire insuffisante.", vbExclamation
- Case SE_ERR_DLLNOTFOUND
- MsgBox "Dynamic-link library non trouvé.", vbExclamation
- Case SE_ERR_SHARE
- MsgBox "Le fichier est déjà ouvert.", vbExclamation
- Case SE_ERR_ASSOCINCOMPLETE
- MsgBox "Information d'association du fichier incomplète.", vbExclamation
- Case SE_ERR_DDETIMEOUT
- MsgBox "Opération DDE dépassée.", vbExclamation
- Case SE_ERR_DDEFAIL
- MsgBox "Opération DDE echouée.", vbExclamation
- Case SE_ERR_DDEBUSY
- MsgBox "Opération DDE occupée.", vbExclamation
- Case SE_ERR_NOASSOC
- 'Ouvrir avec...
- Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " + FileName, vbNormalFocus)
- End Select
- Else
- 'Retourne le hWnd du programme lançé par ShellExecuteEx
- OpenProgram = SEI.hProcess
- End If
-
- Exit Function
- ErrorHandler:
- OpenProgram = 0
- End Function
-
- ' ***********************************************************
- ' *
- ' * Ferme un programme à partir du hWnd de sa fenêtre.
- ' *
- ' ***********************************************************
-
- Public Function CloseProgram(hWnd As Long) As Boolean
- Dim lExitCode As Long
-
- If hWnd = 0 Then
- Exit Function
- End If
-
- CloseProgram = CBool(TerminateProcess(hWnd, lExitCode))
- CloseHandle hWnd
- DoEvents
- Sleep (100)
-
- End Function
Option Explicit
'Flags ShellExecuteEx
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SEE_MASK_FLAG_NO_UI = &H400
'Constantes ERREUR ShellExecuteEx
Private Const SE_ERR_FNF As Byte = 2
Private Const SE_ERR_PNF As Byte = 3
Private Const SE_ERR_ACCESSDENIED As Byte = 5
Private Const SE_ERR_OOM As Byte = 8
Private Const SE_ERR_SHARE As Byte = 26
Private Const SE_ERR_ASSOCINCOMPLETE As Byte = 27
Private Const SE_ERR_DDETIMEOUT As Byte = 28
Private Const SE_ERR_DDEFAIL As Byte = 29
Private Const SE_ERR_DDEBUSY As Byte = 30
Private Const SE_ERR_NOASSOC As Byte = 31
Private Const SE_ERR_DLLNOTFOUND As Byte = 32
'Constantes AFFICHAGE ShellExecuteEx
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOW = 5
Private Const SW_SHOWDEFAULT = 10
Private Type SHELLEXECUTEINFO
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
'OpenProgram
Private Declare Function ShellExecuteEx Lib "shell32.dll" _
(SEI As SHELLEXECUTEINFO) As Long
'CloseProgram
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
' ***********************************************************
' *
' * Lance le programme par défaut associé à un fichier (en fonction de son
' * extension ) et retourne le hWnd de la fênetre du programme lançé.
' *
' ***********************************************************
Public Function OpenProgram(ByRef FileName As String, ByRef OwnerhWnd As Long) As Long
Dim SEI As SHELLEXECUTEINFO
On Error GoTo ErrorHandler
'Vérifie si le fichier à lancer est un exécutable (.exe)
If GetExtension(FileName) = "exe" Then
If vbNo = MsgBox("ATTENTION, êtes-vous sûr de vouloir lancer ce programme exécutable ?", vbExclamation + vbYesNo) _
Then
OpenProgram = 0
Exit Function
End If
End If
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_FLAG_NO_UI
.hWnd = OwnerhWnd
.lpVerb = "open"
.lpFile = FileName
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = SW_SHOW
.hInstApp = OwnerhWnd
End With
OpenProgram = ShellExecuteEx(SEI)
If SEI.hInstApp <= 32 Then
'Erreurs
OpenProgram = 0
Select Case SEI.hInstApp
Case SE_ERR_FNF
OpenProgram = SEI.hProcess
Case SE_ERR_PNF
MsgBox "Le chemin du fichier à ouvrir est incorrect.", vbExclamation
Case SE_ERR_ACCESSDENIED
MsgBox "Accès au fichier refusé.", vbExclamation
Case SE_ERR_OOM
MsgBox "Mémoire insuffisante.", vbExclamation
Case SE_ERR_DLLNOTFOUND
MsgBox "Dynamic-link library non trouvé.", vbExclamation
Case SE_ERR_SHARE
MsgBox "Le fichier est déjà ouvert.", vbExclamation
Case SE_ERR_ASSOCINCOMPLETE
MsgBox "Information d'association du fichier incomplète.", vbExclamation
Case SE_ERR_DDETIMEOUT
MsgBox "Opération DDE dépassée.", vbExclamation
Case SE_ERR_DDEFAIL
MsgBox "Opération DDE echouée.", vbExclamation
Case SE_ERR_DDEBUSY
MsgBox "Opération DDE occupée.", vbExclamation
Case SE_ERR_NOASSOC
'Ouvrir avec...
Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " + FileName, vbNormalFocus)
End Select
Else
'Retourne le hWnd du programme lançé par ShellExecuteEx
OpenProgram = SEI.hProcess
End If
Exit Function
ErrorHandler:
OpenProgram = 0
End Function
' ***********************************************************
' *
' * Ferme un programme à partir du hWnd de sa fenêtre.
' *
' ***********************************************************
Public Function CloseProgram(hWnd As Long) As Boolean
Dim lExitCode As Long
If hWnd = 0 Then
Exit Function
End If
CloseProgram = CBool(TerminateProcess(hWnd, lExitCode))
CloseHandle hWnd
DoEvents
Sleep (100)
End Function