Public Const WM_CLOSE = &H10
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Dim hWndProcess As Long
Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Boolean
Dim pID As Long
GetWindowThreadProcessId hWnd, pID
If pID = lParam Then
If GetParent(hWnd) = 0 Then
hWndProcess = hWnd
EnumWindowsProc = False
End If
End If
EnumWindowsProc = True
End Function
Function FindProcessWindow(ByVal pID As Long) As Long
hWndProcess = 0
EnumWindows AddressOf EnumWindowsProc, pID
FindProcessWindow = hWndProcess
End Function
'程序中
Option Explicit
Dim pID As Long
Private Sub Command1_Click()
pID = Shell("notepad", vbHide)
End Sub
Private Sub Command2_Click()
Dim hWnd As Long
hWnd = FindProcessWindow(pID)
SetForegroundWindow hWnd
PostMessage hWnd, WM_CLOSE, 0, 0&
End Sub
Private Sub Form_Load()
Command1.Caption = "启动 NotePad"
Command2.Caption = "关闭 NotePad"
End Sub
'\\ Global memory management functions
private Declare Function GlobalLock Lib "kernel32" (byval hMem as Long) as Long
private Declare Function GlobalSize Lib "kernel32" (byval hMem as Long) as Long
private Declare Function GlobalUnlock Lib "kernel32" (byval hMem as Long) as Long
private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest as Any, lpvSource as Any, byval cbCopy as Long)
private Declare Function GlobalAlloc Lib "kernel32" (byval wFlags as Long, byval dwBytes as Long) as Long
private Declare Function GlobalFree Lib "kernel32" (byval hMem as Long) as Long
private mMyData() as Byte
private mMyDataSize as Long
private mHmem as Long
public Enum enGlobalmemoryAllocationConstants
GMEM_FIXED = &H0
GMEM_DISCARDABLE = &H100
GMEM_MOVEABLE = &H2
GMEM_NOCOMPACT = &H10
GMEM_NODISCARD = &H20
GMEM_ZEROINIT = &H40
End Enum
'**************************************
' Name: Global memory
' Description:Allows you to read and wri
' te global memory blocks, which in turn a
' llows you to pass big chunks of data bet
' ween applications easily.
' By: Duncan Jones
'
'
' Inputs:None
'
'\\ --[CopyFromHandle]---------------------------
'\\ Copies the data from a global memory handle
'\\ to a private byte array copy
'\\ ---------------------------------------------
public Sub CopyFromHandle(byval hMemHandle as Long)
Dim lRet as Long
Dim lPtr as Long
lRet = GlobalSize(hMemHandle)
If lRet > 0 then
mMyDataSize = lRet
lPtr = GlobalLock(hMemHandle)
If lPtr > 0 then
ReDim mMyData(0 to mMyDataSize - 1) as Byte
CopyMemory mMyData(0), byval lPtr, mMyDataSize
Call GlobalUnlock(hMemHandle)
End If
End If
End Sub
'\\ --[CopyToHandle]-----------------------------
'\\ Copies the private data to a memory handle
'\\ passed in
'\\ ---------------------------------------------
public Sub CopyToHandle(byval hMemHandle as Long)
Dim lSize as Long
Dim lPtr as Long
'\\ Don't copy if its empty
If Not (mMyDataSize = 0) then
lSize = GlobalSize(hMemHandle)
'\\ Don't attempt to copy if zero size..
If lSize > 0 then
lPtr = GlobalLock(hMemHandle)
If lPtr > 0 then
CopyMemory byval lPtr, mMyData(0), lSize
Call GlobalUnlock(hMemHandle)
End If
End If
End If
End Sub
程序A的代码:
'作为测试,程序A中没有form,只有很简单的一个过程:
Sub Main()
Do Until i = 100
DoEvents
i = i + 1
DoEvents
i = i - 1
DoEvents
Loop
End Sub
生成一个test.exe
程序B的代码:
'模块中
Option Explicit
Public Const TOKEN_ADJUST_PRIVILEGES = &H20
Public Const TOKEN_QUERY = &H8
Public Const ANYSIZE_ARRAY = 1
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
Public Const SE_DEBUG_NAME = "SeDebugPrivilege"
Public Const SE_PRIVILEGE_ENABLED = &H2
Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Type Luid
lowpart As Long
highpart As Long
End Type
Type LUID_AND_ATTRIBUTES
pLuid As Luid
Attributes As Long
End Type
Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function GetCurrentProcess Lib "kernel32" () As Long
Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As Luid) As Long
Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Sub SeDebugSample(ApplicationPID As Long)
Dim hProcessID As Long
Dim hProcess As Long
Dim hToken As Long
Dim lPrivilege As Long
Dim iPrivilegeflag As Boolean
Dim lResult As Long
hProcessID = ApplicationPID
hProcess = GetCurrentProcess
lResult = OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hToken)
lResult = SetPrivilege(hToken, SE_DEBUG_NAME, True)
hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0, hProcessID)
lResult = SetPrivilege(hToken, SE_DEBUG_NAME, False)
lResult = TerminateProcess(hProcess, 0)
CloseHandle (hProcess)
CloseHandle (hToken)
End Sub
Private Function SetPrivilege(hToken As Long, Privilege As String, bSetFlag As Boolean) As Boolean
Dim TP As TOKEN_PRIVILEGES
Dim TPPrevious As TOKEN_PRIVILEGES
Dim Luid As Luid
Dim cbPrevious As Long
Dim lResult As Long
cbPrevious = Len(TP)
lResult = LookupPrivilegeValue("", Privilege, Luid)
If (lResult = 0) Then
SetPrivilege = False
End If
TP.PrivilegeCount = 1
TP.Privileges(0).pLuid = Luid
TP.Privileges(0).Attributes = 0
SetPrivilege = lResult
lResult = AdjustTokenPrivileges(hToken, -1, TP, Len(TP), TPPrevious, cbPrevious)
If (lResult = 0) Then
SetPrivilege = False
End If
TPPrevious.PrivilegeCount = 1
TPPrevious.Privileges(0).pLuid = Luid
Select Case bSetFlag
Case True: TPPrevious.Privileges(0).Attributes = TPPrevious.Privileges(0).Attributes Or (SE_PRIVILEGE_ENABLED)
Case False: TPPrevious.Privileges(0).Attributes = TPPrevious.Privileges(0).Attributes Xor (SE_PRIVILEGE_ENABLED And TPPrevious.Privileges(0).Attributes)
End Select
lResult = AdjustTokenPrivileges(hToken, -1, TPPrevious, cbPrevious, TP, cbPrevious)
If (lResult = 0) Then
SetPrivilege = False
Else
SetPrivilege = True
End If
End Function
'程序中:
Private iAppPID As Long
Private Sub Command1_Click()
iAppPID = Shell("test.exe", vbNormalFocus)
End Sub
Private Sub Command2_Click()
SeDebugSample CLng(iAppPID)
End Sub
Public Function WindowProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If lMsgID = Msg Then
'结束进程
'当然在这里你可以不结束进程,A运行到这里说明已经接收到的关闭的消息,接
'下来要做些什么工作,你完全可以自己控制,甚至杀死B,呵呵
Call TerminateProcess(GetCurrentProcess, ByVal 0&)
Exit Function
Else
WindowProc = CallWindowProc(lpreProc, hWnd, Msg, wParam, lParam)
End If
End Function
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 Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_CLOSE = &H10
Private Sub Command1_Click()
Dim ShellX As String
Dim lPid As Long
Dim lHnd As Long
Dim lRet As Long
Dim VarX As String
ShellX = Shell(App.Path & "\工程2.exe", vbNormalFocus)
lPid = ShellX
If lPid <> 0 Then
lHnd = OpenProcess(SYNCHRONIZE, 0, lPid)
If lHnd <> 0 Then
SendMessage lHnd, WM_CLOSE, 0&, 0&
CloseHandle (lHnd)
End If
End If
End Sub
模块:
Public Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function BroadcastSystemMessage Lib "user32" (ByVal dw As Long, pdw As Long, ByVal un As Long, ByVal wParam As Long, ByVal lParam 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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Const MYMESS As String = "This is my message"
Public Const BSF_POSTMESSAGE = &H10
Public Const BSF_IGNORECURRENTTASK = &H2
Public Const BSF_NOHANG = &H8
Public Const BSM_APPLICATIONS = &H8
Public Const GWL_WNDPROC = (-4)
Public lMsgID As Long
Public lpreProc As Long
Public Function WindowProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If lMsgID = Msg Then
'结束进程
Call TerminateProcess(GetCurrentProcess, ByVal 0&)
Exit Function
Else
WindowProc = CallWindowProc(lpreProc, hWnd, Msg, wParam, lParam)
End If
End Function