K

- Base de connaissances

Accueil > Langages de programmation > VB6 - VBA > Exécution d’application avec VB6

Exécution d’application avec VB6

mercredi 5 décembre 2012, par webmestre

Lire aussi :

Depuis la version Windows 7 du système d’exploitation de Microsoft, l’instruction Shell de VB6 n’est plus fonctionnelle, celle-ci génèrera une erreur d’exécution dans votre programme à son appel.

Pour palier à ce problème, les APIs, et avec le code suivant mettant en oeuvre la gestion des processus, vous pourrez exécuter d’autres applications via votre application. Et, dans le cas de Windows 7 vous aurez le fameux message de sécurité demandant à l’utilisateur de valider l’exécution de l’application.

'--- for CreateProcess
Private Const NORMAL_PRIORITY_CLASS         As Long = &H20&
Private Const STARTF_USESHOWWINDOW          As Long = 1
Private Const SW_HIDE                       As Long = 0
Private Const SW_SHOWDEFAULT                As Long = 10
Private Const ERROR_ELEVATION_REQUIRED      As Long = 740
'--- for WaitForXxx
Private Const INFINITE                      As Long = &HFFFFFFFF
'--- for ShellExecuteEx
Private Const SEE_MASK_NOCLOSEPROCESS       As Long = &H40
'--- Msg
Private Const MSG_ELEVATION_REQUIRED        As String = "To run %1 as administrator please confirm next elevation of rights"
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (lpExecInfo As SHELLEXECUTEINFO) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Type STARTUPINFO
    cb                  As Long
    lpReserved          As String
    lpDesktop           As String
    lpTitle             As String
    dwX                 As Long
    dwY                 As Long
    dwXSize             As Long
    dwYSize             As Long
    dwXCountChars       As Long
    dwYCountChars       As Long
    dwFillAttribute     As Long
    dwFlags             As Long
    wShowWindow         As Integer
    cbReserved2         As Integer
    lpReserved2         As Long
    hStdInput           As Long
    hStdOutput          As Long
    hStdError           As Long
End Type
Private Type PROCESS_INFORMATION
    hProcess            As Long
    hThread             As Long
    dwProcessID         As Long
    dwThreadID          As Long
End Type
Private Type SHELLEXECUTEINFO
    cbSize              As Long
    fMask               As Long
    hWnd                As Long
    lpVerb              As String
    lpFile              As String
    lpParameters        As String
    lpDirectory         As Long
    nShow               As Long
    hInstApp            As Long
    '  Optional fields
    lpIDList            As Long
    lpClass             As Long
    hkeyClass           As Long
    dwHotKey            As Long
    hIcon               As Long
    hProcess            As Long
End Type
Public Function ShellWait(ByVal sFile As String, Optional sParams As String, Optional ByVal bStartHidden As Boolean, Optional oOwnerForm As VB.Form) As Long
    '--- Declaration
    Const FUNC_NAME     As String = "ShellWait"
    Dim sCommandLine    As String
    Dim uInfo           As PROCESS_INFORMATION
    Dim uStart          As STARTUPINFO
    Dim lExitCode       As Long
    Dim uShell          As SHELLEXECUTEINFO
    Dim sFilename       As String
   
    '--- Initialization
    On Error GoTo EH
    ShellWait = 0 ' By default : the return is succed
   
    '--- win9x: fix spaces or not working on 9x
    If InStr(sFile, " ") > 0 Then
        sCommandLine = """" & sFile & """" & " " & sParams
    Else
        sCommandLine = sFile & " " & sParams
    End If
    uStart.cb = Len(uStart)
    If bStartHidden Then
        uStart.dwFlags = STARTF_USESHOWWINDOW
        uStart.wShowWindow = SW_HIDE
    End If
    If CreateProcess(vbNullString, sCommandLine, 0, 0, 1, NORMAL_PRIORITY_CLASS, 0, vbNullString, uStart, uInfo) <> 0 Then
        Call WaitForSingleObject(uInfo.hProcess, INFINITE)
        If GetExitCodeProcess(uInfo.hProcess, lExitCode) <> 0 Then
            ShellWait = lExitCode
        End If
        Call CloseHandle(uInfo.hThread)
        Call CloseHandle(uInfo.hProcess)
    Else
        If Err.LastDllError = ERROR_ELEVATION_REQUIRED Then
            If Not oOwnerForm Is Nothing Then
                If InStrRev(sFile, "\") > 0 Then
                    sFilename = Mid(sFile, InStrRev(sFile, "\") + 1)
                Else
                    sFilename = sFile
                End If
                MsgBox Replace(MSG_ELEVATION_REQUIRED, "%1", sFilename), vbExclamation
                uShell.hwnd = oOwnerForm.hwnd
            End If
            With uShell
                .cbSize = Len(uShell)
                .fMask = SEE_MASK_NOCLOSEPROCESS
                .lpVerb = "runas"
                .lpFile = sFile
                .lpParameters = sParams
                .nShow = IIf(bStartHidden, SW_HIDE, SW_SHOWDEFAULT)
            End With
            If ShellExecuteEx(uShell) Then
                Call WaitForSingleObject(uShell.hProcess, INFINITE)
                If GetExitCodeProcess(uShell.hProcess, lExitCode) <> 0 Then
                    ShellWait = lExitCode
                End If
                Call CloseHandle(uShell.hProcess)
            End If
        End If
    End If
    Exit Function
EH:
    Debug.Print FUNC_NAME; ": "; Error
    Resume Next
End Function
Private Sub Command1_Click()
    MsgBox "Exit code = " & ShellWait("cmd"), vbExclamation
End Sub

Référence :
http://stackoverflow.com/questions/2228410/vb6-how-to-run-a-program-from-vb6-and-close-it-once-it-finishes

Répondre à cet article

Plan du site | Suivre la vie du site RSS 2.0 | powered by NYSTEK-EDITIONS and NYSTEK-CONSULTING