Private Declare Function SetWindowPos Lib "user32" (ByVal HWND As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function ShowWindow Lib "user32" ( _ ByVal HWND As Long, _ ByVal param As Long) As Long Private Declare Function SetForegroundWindow Lib "user32" (ByVal HWND As Long) As Long Dim hInst As Long Dim HFentre As Long Dim hWndApp As Long Dim lRet As Long Dim lgRetVal As Long Dim R As RECT Private Sub Command1_Click() lRet = MyShell(App.Path & "\CouleurVB.exe", vbNormalFocus) If lRet <> 0 Then SetForegroundWindow (lRet) DoEvents SendKeys lRet, True Else End If SetParent lRet, Picture1.HWND DoEvents hWndApp = lRet hInst = lRet HFentre = lRet TextHandle = lRet lgRetVal = GetWindowRect(lRet, R) toto = R.Right toto1 = R.Bottom HWNDTOP = 0 swpnozorder = 4 cx = 100 cy = 200 cWidth = Wzone cHeight = H SetWindowPos lRet, HWNDTOP, cx, cy, toto, toto1, swpnozorder Handle = lRet PP = ShowWindow(Handle, 3) NewNomNB = NewNomNB + 1 NewNom = SetText(lRet, "mon soft - (N° " & NewNomNB & ")") End Sub Private Sub Form_Load() NewNomNB = 0 End Sub
Const SEE_MASK_DOENVSUBST = &H200 ' Expand any environment variables specified in the string given by the lpDirectory or lpFile member. Const SEE_MASK_FLAG_NO_UI = &H400 ' Do not display an error message box if an error occurs. Const SEE_MASK_IDLIST = &H4 ' Use the item identifier list given by the lpIDList member. The lpIDList member must point Const SEE_MASK_NOCLOSEPROCESS = &H40 ' Use to indicate that the hProcess member receives the process handle. This handle is typically Private Type SHELLEXECUTEINFO cbSize As Long fMask As Long ' Voir liste des constantes SEE_ ci-dessus HWND As Long lpVerb As String ' Action à mener : edit, explore, find, open, print, properties lpFile As String lpParameters As String lpDirectory As String nShow As Long ' Voir liste des constantes de VbAppWinStyle hInstApp As Long ' Voir liste des constantes SE_ ci-dessus lpIDList As Long lpClass As String hkeyClass As Long dwHotKey As Long hIcon As Long hProcess As Long ' Si <> 0, ProcessId de l'instance créée (avec GetProcessId) End Type Public Declare Function GetWindowRect Lib "user32" (ByVal HWND As Long, lpRect As RECT) As Long Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type GUITHREADINFO cbSize As Long flags As Long hwndActive As Long hwndFocus As Long hwndCapture As Long hwndMenuOwner As Long hwndMoveSize As Long hwndCaret As Long rcCaret As RECT End Type Private Declare Function ShellExecuteEx Lib "shell32.dll" (SEI As SHELLEXECUTEINFO) As Long Private Declare Function GetProcessId Lib "kernel32" (ByVal hProcessId As Long) As Long Private Declare Function GetGUIThreadInfo Lib "user32" (ByVal dwthreadid As Long, lpguithreadinfo As GUITHREADINFO) As Long Private Const GW_HWNDNEXT As Long = 2 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindow Lib "user32" (ByVal HWND As Long, ByVal wCmd As Long) As Long Private Declare Function GetParent Lib "user32" (ByVal HWND As Long) As Long Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal HWND As Long, lpdwProcessId As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Const WAIT_TIMEOUT As Long = 258& Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long ' Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, _ ByVal hWndNewParent As Long) As Long 'internet Private Declare Function InternetGetConnectedState Lib "Wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Public Declare Function GetWindowLong Lib "user32" Alias _ "GetWindowLongA" (ByVal HWND As Long, ByVal nIndex _ As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias _ "SetWindowLongA" (ByVal HWND As Long, ByVal nIndex _ As Long, ByVal dwNewLong As Long) As Long Public Declare Function GetSystemMenu Lib "user32" (ByVal _ HWND As Long, ByVal bRevert As Long) As Long Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu _ As Long, ByVal nPosition As Long, ByVal wFlags As Long) _ As Long Public Declare Function GetMenuItemCount Lib "user32" (ByVal _ hMenu As Long) As Long Public Declare Function DrawMenuBar Lib "user32" (ByVal HWND _ As Long) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Const WM_GETTEXT = &HD Private Const WM_SETTEXT = &HC Public Const GWL_STYLE = (-16) Public Const WS_MAXIMIZEBOX = &H10000 Public Const WS_MINIMIZEBOX = &H20000 Public Const WS_THICKFRAME = &H40000 Public Const SC_CLOSE = &HF060 Public Const SC_MAXIMIZE = &HF030 Public Const SC_MINIMIZE = &HF020 Public Const SC_MOVE = &HF010 Public Const SC_RESTORE = &HF120 Public Const MF_BYCOMMAND = &H0 Public Const MF_BYPOSITION = &H400 Public Const MF_REMOVE = &H1000& Public Function IsNetConnectOnline() As Boolean IsNetConnectOnline = InternetGetConnectedState(0&, 0&) End Function Public Function active() Dim activation activation = "Code d'activation correct." End Function Public Function MyShell(ByRef sFichier As String, _ ByVal xStyle As VbAppWinStyle) As Long Dim SEI As SHELLEXECUTEINFO Dim lRet As Long Dim lProcID As Long Dim lAppHwnd As Long With SEI .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_FLAG_NO_UI Or SEE_MASK_DOENVSUBST Or SEE_MASK_IDLIST .HWND = 0 .lpVerb = "open" .lpFile = sFichier .lpParameters = vbNullChar .lpDirectory = vbNullChar .nShow = xStyle .hInstApp = 0 .lpIDList = 0 .cbSize = LenB(SEI) End With lRet = ShellExecuteEx(SEI) If lRet = 0 Then GoTo Sortie lProcID = GetProcessId(SEI.hProcess) If lProcID = 0 Then GoTo Sortie Do While lAppHwnd 0 And (WaitForSingleObject(SEI.hProcess, 200) WAIT_TIMEOUT) lAppHwnd = InstanceToWnd(lProcID) DoEvents Loop If lAppHwnd = 0 Then GoTo Sortie MyShell = lAppHwnd Sortie: If SEI.hProcess > 0 Then CloseHandle SEI.hProcess End Function Private Function InstanceToWnd(ByVal lTarget_pid As Long) As Long Dim lTest_hwnd As Long, lTest_pid As Long, lTest_thread_id As Long lTest_hwnd = FindWindow(vbNullString, vbNullString) Do While lTest_hwnd <> 0 If GetParent(lTest_hwnd) = 0 Then lTest_thread_id = GetWindowThreadProcessId(lTest_hwnd, lTest_pid) If lTest_pid = lTarget_pid Then If IsActiveWindowInThread(lTest_thread_id, lTest_hwnd) Then InstanceToWnd = lTest_hwnd Exit Do End If End If End If DoEvents lTest_hwnd = GetWindow(lTest_hwnd, GW_HWNDNEXT) Loop End Function Private Function IsActiveWindowInThread(lThreadId As Long, lHandleToCompare) As Boolean Dim lThrdInfo As GUITHREADINFO lThrdInfo.cbSize = LenB(lThrdInfo) If GetGUIThreadInfo(lThreadId, lThrdInfo) Then If lThrdInfo.hwndActive lHandleToCompare Then IsActiveWindowInThread True End If End Function Public Function GetText(HWND As Long) As String Dim Txt As String Txt = Space$(255) SendMessage HWND, WM_GETTEXT, 255&, ByVal Txt GetText = Txt End Function Public Function SetText(HWND As Long, Text As String) As Long SetText = SendMessage(HWND, WM_SETTEXT, 0&, ByVal Text) End Function
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function Putfocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long Const GW_HWNDNEXT = 2 Dim mWnd As Long Private Sub Form_Activate() Dim Pid As Long LockWindowUpdate GetDesktopWindow 'ici son exécutable ou assimilé Pid = Shell("C:\Program Files\Internet Explorer\iexplore.exe", vbNormalFocus) If Pid = 0 Then MsgBox "Erreur / démarrage de l'application" mWnd = InstanceToWnd(Pid) SetParent mWnd, Picture1.hwnd Putfocus mWnd LockWindowUpdate False End Sub Function InstanceToWnd(ByVal target_pid As Long) As Long Dim test_hwnd As Long, test_pid As Long, test_thread_id As Long test_hwnd = FindWindow(ByVal 0&, ByVal 0&) Do While test_hwnd <> 0 If GetParent(test_hwnd) = 0 Then test_thread_id = GetWindowThreadProcessId(test_hwnd, test_pid) If test_pid = target_pid Then InstanceToWnd = test_hwnd Exit Do End If End If test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT) Loop End Function Private Sub Form_Unload(Cancel As Integer) DestroyWindow mWnd End Sub