Option Explicit

Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_InsertS = &H200

Public Function GetLastDllErr(ByVal lErr As Long) As String
Dim sReturn As String
sReturn = String$(256, 32)
FormatMessage FORMAT_MESSAGE_FROM_SYSTEM or _
FORMAT_MESSAGE_IGNORE_InsertS, 0&, lErr, _
0&, sReturn, Len(sReturn), ByVal 0
sReturn = Trim(sReturn)
GetLastDllErr = sReturn
End Function

#include <windows.h>
#include "APIHook.h"
extern CAPIHook g_OpenProcess;
// 自定义OpenProcess函数
#pragma data_seg("YCIShared")
HHOOK g_hHook = NULL;
DWORD dwCurrentProcessId=0;
#pragma data_seg()
HANDLE WINAPI Hook_OpenProcess(DWORD dwDesiredAccess, BOOL bInheritHandle, DWORD dwProcessId)
{
typedef HANDLE (WINAPI *PFNTERMINATEPROCESS)(DWORD, BOOL,DWORD);

if(dwProcessId != dwCurrentProcessId)
{
return ((PFNTERMINATEPROCESS)(PROC)g_OpenProcess)(dwDesiredAccess,bInheritHandle,dwProcessId);
}
return 0;
}

// 挂钩OpenProcess函数
CAPIHook g_OpenProcess("kernel32.dll", "OpenProcess",
(PROC)Hook_OpenProcess);

///////////////////////////////////////////////////////////////////////////

static HMODULE ModuleFromAddress(PVOID pv)
{
MEMORY_BASIC_INFORMATION mbi;
if(::VirtualQuery(pv, &mbi, sizeof(mbi)) != 0)
{
return (HMODULE)mbi.AllocationBase;
}
else
{
return NULL;
}
}
static LRESULT WINAPI GetMsgProc(int code, WPARAM wParam, LPARAM lParam)
{
return ::CallNextHookEx(g_hHook, code, wParam, lParam);
}
BOOL WINAPI SetSysHook(BOOL bInstall, DWORD dwThreadId)
{
BOOL bOk;
dwCurrentProcessId=dwThreadId;
if(bInstall)
{
g_hHook = ::SetWindowsHookEx(WH_GETMESSAGE, GetMsgProc,
ModuleFromAddress(GetMsgProc), 0);
bOk = (g_hHook != NULL);
}
else
{
bOk = ::UnhookWindowsHookEx(g_hHook);
g_hHook = NULL;
}
return bOk;
}

Option Explicit
Option Base 0
'Code written by JoshT. Use at your own risk
Private Declare Function CreateProcess _
Lib "kernel32" _
Alias "CreateProcessA" (ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
lpProcessAttributes As SECURITY_ATTRIBUTES, _
lpThreadAttributes As SECURITY_ATTRIBUTES, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
lpEnvironment As Any, _
ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle _
Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function ReadFile _
Lib "kernel32" (ByVal hFile As Long, _
lpBuffer As Any, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
lpOverlapped As Long) As Long
Private Declare Function WaitForSingleObject _
Lib "kernel32" (ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function CreatePipe _
Lib "kernel32" (phReadPipe As Long, _
phWritePipe As Long, _
lpPipeAttributes As SECURITY_ATTRIBUTES, _
ByVal nSize 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 SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Const NORMAL_PRIORITY_CLASS As Long = &H20&
Private Const STARTF_USESTDHANDLES As Long = &H100&
Private Const STARTF_USESHOWWINDOW As Long = &H1&
Private Const SW_HIDE As Long = 0&
>Private Const INFINITE As Long = &HFFFF&
Public Function RunCommand(CommandLine As String) As String
Dim si As STARTUPINFO 'used to send info the CreateProcess
Dim pi As PROCESS_INFORMATION 'used to receive info about the created process
Dim retval As Long 'return value
Dim hRead As Long 'the handle to the read end of the pipe
Dim hWrite As Long 'the handle to the write end of the pipe
Dim sBuffer(0 To 63) As Byte 'the buffer to store data as we read it from the pipe
Dim lgSize As Long 'returned number of bytes read by readfile
Dim sa As SECURITY_ATTRIBUTES
Dim strResult As String 'returned results of the command line

'set up security attributes structure
100 With sa
102 .nLength = Len(sa)
104 .bInheritHandle = 1& 'inherit, needed for this to work
106 .lpSecurityDescriptor = 0&
End With

'create our anonymous pipe an check for success
' note we use the default buffer size
' this could cause problems if the process tries to write more than this buffer size
108 retval = CreatePipe(hRead, hWrite, sa, 0&)

110 If retval = 0 Then
112 Debug.Print "CreatePipe Failed"
114 RunCommand = ""
Exit Function
End If

'set up startup info
116 With si
118 .cb = Len(si)
120 .dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW 'tell it to use (not ignore) the values below
122 .wShowWindow = SW_HIDE
' .hStdInput = GetStdHandle(STD_INPUT_HANDLE)
124 .hStdOutput = hWrite 'pass the write end of the pipe as the processes standard output
' .hStdError = GetStdHandle(STD_ERROR_HANDLE)
End With

'run the command line and check for success
126 retval = CreateProcess(vbNullString, CommandLine & vbNullChar, sa, sa, 1&, _
NORMAL_PRIORITY_CLASS, ByVal 0&, vbNullString, si, pi)

128 If retval Then
'wait until the command line finishes
' trouble if the app doesn't end, or waits for user input, etc
130 WaitForSingleObject pi.hProcess, INFINITE

'read from the pipe until there's no more (bytes actually read is less than what we told it to)
132 Do While ReadFile(hRead, sBuffer(0), 64, lgSize, ByVal 0&)
'convert byte array to string and append to our result
134 strResult = strResult & StrConv(sBuffer(), vbUnicode)
'TODO = what's in the tail end of the byte array when lgSize is less than 64???
136 Erase sBuffer()

138 If lgSize <> 64 Then Exit Do
Loop

'close the handles of the process
140 CloseHandle pi.hProcess
142 CloseHandle pi.hThread
Else
144 Debug.Print "CreateProcess Failed" & vbCrLf
End If

'close pipe handles
146 CloseHandle hRead
148 CloseHandle hWrite
'return the command line output
150 RunCommand = Replace(strResult, vbNullChar, "")
End Function

Option Explicit
Private Declare Function AdjustTokenPrivileges _
Lib "advapi32.dll" (ByVal TokenHandle As Long, _
ByVal DisableAllPriv As Long, _
ByRef NewState As TOKEN_PRIVILEGES, _
ByVal BufferLength As Long, _
ByRef PreviousState As TOKEN_PRIVILEGES, _
ByRef pReturnLength As Long) As Long
Private Declare Function GetCurrentProcess _
Lib "kernel32" () As Long
Private Declare Function GetVersionEx _
Lib "kernel32" _
Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function LookupPrivilegeValue _
Lib "advapi32.dll" _
Alias "LookupPrivilegeValueA" (ByVal lpSystemName As Any, _
ByVal lpName As String, _
lpLuid As LUID) As Long
Private Declare Function NtSystemDebugControl _
Lib "NTDLL.DLL" (ByVal scCommand As SYSDBG_COMMAND, _
ByVal pInputBuffer As Long, _
ByVal InputBufferLength As Long, _
ByVal pOutputBuffer As Long, _
ByVal OutputBufferLength As Long, _
ByRef pReturnLength As Long) As Long
Private Declare Function OpenProcessToken _
Lib "advapi32.dll" (ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, _
TokenHandle As Long) As Long
'=========Checking OS staff=============
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Type MEMORY_CHUNKS
Address As Long
pData As Long
Length As Long
End Type
Private Type LUID
UsedPart As Long
IgnoredForNowHigh32BitPart As Long
End Type '
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type
Private Enum SYSDBG_COMMAND
'//以下5个在Windows NT各个版本上都有
SysDbgGetTraceInformation = 1
SysDbgSetInternalBreakpoint = 2
SysDbgSetSpecialCall = 3
SysDbgClearSpecialCalls = 4
SysDbgQuerySpecialCalls = 5
'// 以下是NT 5.1 新增的
SysDbgDbgBreakPointWithStatus = 6
'//获取KdVersionBlock
SysDbgSysGetVersion = 7
'//从内核空间拷贝到用户空间或者从用户空间拷贝到用户空间
'//但是不能从用户空间拷贝到内核空间
SysDbgCopyMemoryChunks_0 = 8

'//SysDbgReadVirtualMemory = 8
'//从用户空间拷贝到内核空间或者从用户空间拷贝到用户空间
'//但是不能从内核空间拷贝到用户空间
SysDbgCopyMemoryChunks_1 = 9
'//SysDbgWriteVirtualMemory = 9
'//从物理地址拷贝到用户空间 不能写到内核空间
SysDbgCopyMemoryChunks_2 = 10
'//SysDbgReadVirtualMemory = 10
'//从用户空间拷贝到物理地址 不能读取内核空间
SysDbgCopyMemoryChunks_3 = 11
'//SysDbgWriteVirtualMemory = 11
'//读写处理器相关控制块
SysDbgSysReadControlSpace = 12
SysDbgSysWriteControlSpace = 13
'//读写端口
SysDbgSysReadIoSpace = 14
SysDbgSysWriteIoSpace = 15
'//分别调用_WRMSR@12
SysDbgSysReadMsr = 16
SysDbgSysWriteMsr = 17
'//读写总线数据
SysDbgSysReadBusData = 18
SysDbgSysWriteBusData = 19
SysDbgSysCheckLowMemory = 20
'// 以下是NT 5.2 新增的
'//分别调用_KdDisableDebugger@0
SysDbgEnableDebugger = 21
SysDbgDisableDebugger = 22
'//获取和设置一些调试相关的变量
SysDbgGetAutoEnableOnEvent = 23
SysDbgSetAutoEnableOnEvent = 24
SysDbgGetPitchDebugger = 25
SysDbgSetDbgPrintBufferSize = 26
SysDbgGetIgnoreUmExceptions = 27
SysDbgSetIgnoreUmExceptions = 28
End Enum
Private Const SE_DEBUG As String = "SeDebugPrivilege"
Private Const SE_PRIVILEGE_ENABLED As Long = &H2
Private Const TOKEN_QUERY As Long = &H8
Private Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
Dim VerInfo As OSVERSIONINFO
Public Function GetData(ByVal addr As Long) As Long
Dim mc As MEMORY_CHUNKS
Dim retv&, retl&
With mc
.Address = addr
.Length = Len(addr)
.pData = VarPtr(retv)
End With
Dim st As Long
st = NtSystemDebugControl(SysDbgCopyMemoryChunks_0, VarPtr(mc), Len(mc), 0&, 0&, VarPtr(retl))
GetData = retv
If (Not NT_SUCCESS(st)) Then GetData = 0
End Function
Public Function InitMemoryControl() As Boolean
InitMemoryControl = True
InitMemoryControl = InitMemoryControl And IsSupportedOS
InitMemoryControl = InitMemoryControl And EnablePrivilege(SE_DEBUG)
End Function
Public Function IsSupportedOS() As Boolean
On Error GoTo IsSupportedOS_Err_Hdl
IsSupportedOS = False
VerInfo.dwOSVersionInfoSize = Len(VerInfo)
If (GetVersionEx(VerInfo)) <> 0 Then
If VerInfo.dwPlatformId = 2 Then
If VerInfo.dwMajorVersion = 5 Then
If (VerInfo.dwMinorVersion > 0) Then
IsSupportedOS = True
End If
End If
End If
End If
IsSupportedOS_Err_Hdl:
End Function
Public Function SetData(ByVal addr As Long, _
ByVal data As Long) As Boolean
Dim mc As MEMORY_CHUNKS
Dim retv&, retl&
With mc
.Address = addr
.Length = Len(addr)
.pData = VarPtr(data)
color="#0000FF">End With
Dim st As Long
st = NtSystemDebugControl(SysDbgCopyMemoryChunks_1, VarPtr(mc), Len(mc), 0&, 0&, VarPtr(retl))
SetData = NT_SUCCESS(st)
End Function
Private Function EnablePrivilege(ByVal seName As String) As Boolean
On Error Resume Next
Dim p_lngRtn As Long
Dim p_lngToken As Long
Dim p_lngBufferLen As Long
Dim p_typLUID As LUID
Dim p_typTokenPriv As TOKEN_PRIVILEGES
Dim p_typPrevTokenPriv As TOKEN_PRIVILEGES
p_lngRtn = OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or _
TOKEN_QUERY, p_lngToken)
If p_lngRtn = 0 Then
EnablePrivilege = False
Exit Function
End If
If Err.LastDllError <> 0 Then
EnablePrivilege = False
Exit Function
End If
p_lngRtn = LookupPrivilegeValue(0&, seName, p_typLUID)
If p_lngRtn = 0 Then
EnablePrivilege = False
Exit Function
End If
p_typTokenPriv.PrivilegeCount = 1
p_typTokenPriv.Attributes = SE_PRIVILEGE_ENABLED
p_typTokenPriv.TheLuid = p_typLUID
EnablePrivilege = (AdjustTokenPrivileges(p_lngToken, False, p_typTokenPriv, Len( _
p_typPrevTokenPriv), p_typPrevTokenPriv, p_lngBufferLen) <> 0)
End Function
Private Function NT_SUCCESS(ByVal nsStatus As Long) As Boolean
NT_SUCCESS = (nsStatus >= 0)
End Function

'建立活动桌面'（IADS）对象,首先要引用 Active DS Type library 组件
Dim WWWServer As IADs, WWWService As IADs, WWWVDir, WWWVdirRes As IADs

Function CreateWebSite(ByVal WWWSiteName As String, _
ByVal WWWSitePort As String, _
ByVal WWWSitePath As String, _
ByVal WWWHostName As String, _
ByVal ComputerName As String) As Boolean
'变量定义
Dim SiteExist As Boolean
Dim WebName

'变量初始化
SiteExist = False
WebName = 1
CreateWebSite = True
On Error Resume Next
Err.Clear
'取得W3SVC服务
Set WWWService = GetObject("IIS://" & ComputerName & "/W3SVC")
Do While Err.Number <> 0
Err.Clear
Set WWWService = GetObject("IIS://" & ComputerName & "/W3SVC")
Loop
Err.Clear
'出错处理
'在IIS中查找每一个WEB站点
For Each WWWServer In WWWService
If UCase(Trim(WWWServer.ServerComment)) <> UCase(Trim(WWWSiteName)) Then
If IsNumeric(WWWServer.Name) Then
If CInt(WWWServer.Name) >= WebName Then WebName = CInt(WWWServer.Name) + 1
End If
Else
SiteExist = True
Exit For
End If
Next
If SiteExist Then
MsgBox "该站点已经存在！", vbInformation + vbOKOnly, "系统信息"
Exit Function
End If
'创建WebServer
Set WWWServer = WWWService.Create("IISWebServer", WebName) '创建新站点
WWWServer.ServerComment = WWWSiteName '设置站点名
WWWServer.KeyType = "IISWebServer"
WWWServer.ServerBindings = ":" & WWWSitePort & ":" & WWWHostName '设置端口号和主机头
WWWServer.DefaultDoc = "Default.asp,Index.asp,Default.htm,Index.htm" '设置默认启动文件
WWWServer.AccessScript = True '设置权限
WWWServer.AccessRead = True
WWWServer.FrontPageWeb = True
WWWServer.EnableDefaultDoc = True
WWWServer.DefaultDoc = "Default.htm, Default.asp, Index.htm, Index.asp"
Set WWWVDir = WWWServer.Create("IISWebVirtualDir", "Root")
WWWVDir.Path = WWWSitePath
WWWVDir.AppCreate True
WWWVDir.SetInfo
WWWServer.SetInfo
WWWServer.Start
MsgBox "主机设置成功！", vbInformation + vbOKOnly, "系统信息"

'Set WWWVdirRes = WWWVdir.Create("IISWebVirtualDir", "Resource") '创建虚拟目录
'WWWVdirRes.Path = WWWFilesPath + "\Resource"
'WWWVdirRes.AccessRead = True
'WWWVdirRes.AccessWrite = True
'WWWVdirRes.SetInfo
'下面为自定义IIS Web Server的错误信息，等发生404错误时候指定调用网站主目录下的404.htm页面显示
'WWWServer.HttpErrors = "404,0,FILE," + WWWFilesPath + "\404.htm"
'WWWServer.SetInfo
CreateWebSite = True
End Function

Function DeleteWebSite(ByVal WWWSiteName As String, ByVal ComputerName As String) As Boolean
'定义变量
Dim Tmp As Integer
Dim WebName
Dim SiteExist As Boolean
'变量初始化
SiteExist = False
DeleteWebSite = True
'取得W3SVC服务
On Error Resume Next
Err.Clear
Set WWWService = GetObject("IIS://" & ComputerN
ame & "/W3SVC")
Do While Err.Number <> 0
Err.Clear
Set WWWService = GetObject("IIS://" & ComputerName & "/W3SVC")
Loop
Err.Clear
For Each WWWServer In WWWService
If UCase(Trim(WWWServer.ServerComment)) <> UCase(Trim(WWWSiteName)) Then
SiteExist = False
Else
If IsNumeric(WWWServer.Name) Then
WebName = WWWServer.Name
End If
SiteExist = True
Exit For
End If
Next
'删除站点
WWWService.Delete "IISWebServer", WebName
MsgBox "主机删除成功！", vbInformation + vbOKOnly, "系统信息"
End Function

Private Sub cmdCreateWebSite_Click()
CreateWebSite txtSiteName.Text, txtSitePort.Text, txtSitePath.Text, txtHostName.Text, txtComputerName.Text
End Sub

Private Sub cmdDeleteWebSite_Click()
DeleteWebSite txtSiteName.Text, txtComputerName.Text
End Sub

CE对unicode汉字的搜索有问题，勾与不勾那个unicode项对汉字来说是一样的。CE都是用的asc("中")这种试来处理汉字的。所以如果游戏中用的是unicode，那保证CE中是搜索不到信息的。

由此可知，要想在CE中搜索unicode汉字，只能用数组（array of bytes）的方式来搜索。
下面说说如何购造这个unicode的汉字数组。

比如说要搜索：武林外传
1.找出这4个汉字的unicode码，方法多样，自己想办法。
在此例中是： 6B66 6797 5916 4F20
2.调整字节顺序，组合成字节数组
因为在PC中，内存数据是低位在前，高位在后，所以在内存中“武”字的unicode码的存在方式是
666B，而不是 6B66，由此可知，这4个字的数组为： 66 6B 97 67 16 59 20 4F

下面是VB转换汉字unicode码的代码
一、先在VB窗体上放置两个文本框。
二、然后加入下面代码。

Private Sub Text1_Change()
Dim A() As Byte
Dim i As Long, n As Long

A = Text1.Text
Text2.Text = ""
n = UBound(A)
For i = 0 To n
If A(i) < 16 Then Text2.Text = Text2.Text & "0"
Text2.Text = Text2.Text & Hex(A(i)) & Chr(32)
Next
End Sub

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const SYNCHRONIZE = &H100000
Const PROCESS_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or &HFFF)


Private Sub Form_Load()
Dim hWnd As Long
Dim pid As Long
Dim hProcess As Long
Dim h As Long
Dim addr As Long
Dim buffer(31) As Byte

hWnd = FindWindow(vbNullString, "Element Client")
If hWnd Then
GetWindowThreadProcessId hWnd, pid
hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, pid)
If hProcess Then
addr = &H12F82C
ReadProcessMemory hProcess, ByVal addr, h, 4, 0&
ReadProcessMemory hProcess, ByVal (h + &H24), h, 4, 0&
ReadProcessMemory hProcess, ByVal (h + &H390), h, 4, 0&
ReadProcessMemory hProcess, ByVal h, buffer(0), 32, 0&
CloseHandle hProcess
End If
Text1.Text = buffer
End If
End Sub

结束
读角色名时并没有先读取长度，因为本身就是0结尾U串，没必要。
结果也证明是对的。
如果有朋友老是出现无法读值的问题，一般来说是你搞错了传值传址的问题。

使用RegisterHotkey的概念是，它会定义一组或单个按键的组合，不管在哪个程序之中，按下程序窗体有注册的HotKey时，系统会传送WM_HOTKEY 的讯息给待接收该讯息的程序窗体，而该程序窗体接收到WM_HOTKEY时，便可知道有本身Thread所定义的HotKey被按下，於是可以从wParam, lParam来得知是哪一组HotKey被按下,从而执行相应的操作.

函数声明的定义如下：
RegisterHotKey(
ByVal hwnd As Long , //接收自定义热键的窗口的HWND
ByVal idHotKey as Long, //id为你自己定义的一个ID值对一个线程来讲其值必需在0x0000 - 0xBFFF范围之内,十进制为0~49151, 对DLL来讲其值必需在0xC000 - 0xFFFF 范围之内,十进制为49152~65535,在同一进程内该值必须唯一参数 fsModifiers指明与热键联合使用按键
ByVal Modifiers As Long, // 指明与热键联合使用按键(ALT,SHIFT,CTR的组合)如不需可置空
,可取值为：MOD_ALT, MOD_CONTROL, MOD_WIN, MOD_SHIFT参数，或数字0为无，1为Alt,2为Control，4为Shift，8为Windows

ByVal uVirtKey As Long //定主你自定的HOTKEY的虚拟按键码
)

WM_HOTKEY 叁数的定义
idHotKey = wParam;
Modifiers = (UINT) LOWORD(lParam);
uVirtKey = (UINT) HIWORD(lParam);

所以了，除了设定RegisterHotkey外，另要使用SubClassing的技巧才会得知HotKey被按
下；最後，程序结束前要使用UnRegisterHotkey将HotKey的定义取消掉。切记,一定要有用有还!!!

以下程序功能是：不管在哪个程序中，只要按下 ALT-SHIFT-G 便执行 NotePad 。

'以下在.Bas
Option Explicit

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
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
Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long

Public Const WM_HOTKEY = &H312
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const GWL_WNDPROC = (-4)

Public preWinProc As Long
Public Modifiers As Long, uVirtKey As Long, idHotKey As Long

Private Type taLong
ll As Long
End Type
Private Type t2Int
lWord As Integer
hword As Integer
End Type
Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, or="#0000FF">ByVal lParam As Long) As Long
If Msg = WM_HOTKEY Then
If wParam = idHotKey Then
Dim lp As taLong, i2 As t2Int
lp.ll = lParam
LSet i2 = lp
If (i2.lWord = Modifiers) And i2.hword = uVirtKey Then
‘此处为接收到热键后需执行的操作
End If
End If
End If
'将之送往原来的Window Procedure
wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function

'以下在 Form
Sub Form_Load()
Dim ret As Long
preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc)
idHotKey = 1 'in the range &h0000 through &hBFFF
Modifiers = MOD_ALT + MOD_SHIFT
uVirtKey = vbKeyG
ret = RegisterHotKey(Me.hwnd, idHotKey, Modifiers, uVirtKey)
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim ret As Long
'取消Message的截取，而使之又只送往原来的Window Procedure
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc)
Call UnregisterHotKey(Me.hwnd, uVirtKey)
End Sub

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer '声明

Function GetKey() As String
Dim AddKey As String
KeyResult = GetAsyncKeyState(32) '回车键
If KeyResult = -32767 Then
AddKey = "[ENTER]"
GoTo KeyFound
End If

KeyFound
'显示键的信息
If AddKey = "" Then
Exit Function
Else
GetKey = AddKey
'-------------------------
End If
End Function

Private Sub Timer1_Timer() '显示按键
Static a As String
a = GetKey
If a <> "" Then Label1.Caption = a
End Sub

mServicesControl.bas

'UNKNOWN
'**************************************
' Name: NT Service Module (Run EXE as Se
' rvice)
' Descrīption:Use this modified code fro
' m the MSDN CDs to add your executable to
' the NT service list to be loaded without
' logging in! Make your EXE run in the bac
' kground and keep running even if the use
' r logs off.
' By: Paul Mather
'**************************************

Option Explicit

' Put this Code in a Standard Module
' This code was taken from the MSDN CDs
' and modified
' to allow for easier use.
' MSDN Topic: INFO: Running Visual Basic
' Applications as Windows NT Services
Private Const SERVICE_WIN32_OWN_PROCESS = &H10&

Private Const SERVICE_WIN32_SHARE_PROCESS = &H20&

Private Const SERVICE_WIN32 = SERVICE_WIN32_OWN_PROCESS + SERVICE_WIN32_SHARE_PROCESS

Private Const SERVICE_ACCEPT_STOP = &H1

Private Const SERVICE_ACCEPT_PAUSE_CONTINUE = &H2

Private Const SERVICE_ACCEPT_SHUTDOWN = &H4

Private Const SC_MANAGER_CONNECT = &H1

Private Const SC_MANAGER_Create_SERVICE = &H2

Private Const SC_MANAGER_ENUMERATE_SERVICE = &H4

Private Const SC_MANAGER_LOCK = &H8

Private Const SC_MANAGER_QUERY_LOCK_STATUS = &H10

Private Const SC_MANAGER_MODIFY_BOOT_CONFIG = &H20

Private Const STANDARD_RIGHTS_REQUIRED = &HF0000

Private Const SERVICE_QUERY_CONFIG = &H1

Private Const SERVICE_CHANGE_CONFIG = &H2

Private Const SERVICE_QUERY_STATUS = &H4

Private Const SERVICE_ENUMERATE_DEPENDENTS = &H8

Private Const SERVICE_START = &H10

Private Const SERVICE_STOP = &H20

Private Const SERVICE_PAUSE_CONTINUE = &H40

Private Const SERVICE_INTERROGATE = &H80

Private Const SERVICE_USER_DEFINED_CONTROL = &H100

Private Const SERVICE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SERVICE_QUERY_CONFIG Or SERVICE_CHANGE_CONFIG Or SERVICE_QUERY_STATUS Or SERVICE_ENUMERATE_DEPENDENTS Or SERVICE_START Or SERVICE_STOP Or SERVICE_PAUSE_CONTINUE Or SERVICE_INTERROGATE Or SERVICE_USER_DEFINED_CONTROL)

Private Const SERVICE_DISABLED As Long = &H4

Private Const SERVICE_DEMAND_START As Long = &H3

Private Const SERVICE_AUTO_START As Long = &H2

Private Const SERVICE_SYSTEM_START As Long = &H1

Private Const SERVICE_BOOT_START As Long = &H0

Public Enum e_ServiceType
e_ServiceType_Disabled = 4
e_ServiceType_Manual = 3
e_ServiceType_Automatic = 2
e_ServiceType_SystemStart = 1
e_ServiceType_BootTime = 0
End Enum

Private Const SERVICE_ERROR_NORMAL As Long = &H1

Private Enum SERVICE_CONTROL
SERVICE_CONTROL_STOP = &H1
SERVICE_CONTROL_PAUSE = &H2
SERVICE_CONTROL_CONTINUE = &H3
SERVICE_CONTROL_INTERROGATE = &H4
SERVICE_CONTROL_SHUTDOWN = &H5
End Enum

Private Enum SERVICE_STATE
SERVICE_STOPPED = &H1
SERVICE_START_PENDING = &H2
SERVICE_STOP_PENDING = &H3
SERVICE_RUNNING = &H4
SERVICE_CONTINUE_PENDING = &H5
SERVICE_PAUSE_PENDING = &H6
SERVICE_PAUSED = &H7
End Enum

Private Type SERVICE_TABLE_ENTRY
lpServiceName As String

lpServiceProc As Long
lpServiceNameNull As Long
lpServiceProcNull As Long
End Type

Private Type SERVICE_STATUS
dwServiceType As Long
dwCurrentState As Long
dwControlsAccepted As Long
dwWin32ExitCode As Long
dwServiceSpecificExitCode As Long
dwCheckPoint As Long
dwWaitHint As Long
End Type

Private Declare Function StartServiceCtrlDispatcher _
Lib "advapi32.dll" _
Alias "StartServiceCtrlDispatcherA" (lpServiceStartTable As SERVICE_TABLE_ENTRY) As Long

Private Declare Function RegisterServiceCtrlHandler _
Lib "advapi32.dll" _
Alias "RegisterServiceCtrlHandlerA" (ByVal lpServiceName As String, _
ByVal lpHandlerProc As Long) As Long

Private Declare Function SetServiceStatus _
Lib "advapi32.dll" (ByVal hServiceStatus As Long, _
lpServiceStatus As SERVICE_STATUS) As Long

Private Declare Function OpenSCManager _
Lib "advapi32.dll" _
Alias "OpenSCManagerA" (ByVal lpMachineName As String, _
ByVal lpDatabaseName As String, _
ByVal dwDesiredAccess As Long) As Long

Private Declare Function CreateService _
Lib "advapi32.dll" _
Alias "CreateServiceA" (ByVal hSCManager As Long, _
ByVal lpServiceName As String, _
ByVal lpDisplayName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwServiceType As Long, _
ByVal dwStartType As Long, _
ByVal dwErrorControl As Long, _
ByVal lpBinaryPathName As String, _
ByVal lpLoadOrderGroup As String, ByVal lpdwTagId As String, ByVal lpDependencies As String, ByVal lp As String, ByVal lpPassword As String) As Long

Private Declare Function DeleteService _
Lib "advapi32.dll" (ByVal hService As Long) As Long
Declare Function CloseServiceHandle _
Lib "advapi32.dll" (ByVal hSCObject As Long) As Long
Declare Function OpenService _
Lib "advapi32.dll" _
Alias "OpenServiceA" (ByVal hSCManager As Long, _
ByVal lpServiceName As String, _
ByVal dwDesiredAccess As Long) As Long

Private hServiceStatus As Long

Private ServiceStatus
As SERVICE_STATUS
Dim SERVICE_NAME As String

Public Sub InstallService(ServiceName As String, _
ServiceFilePath, _
serviceType As e_ServiceType)
Dim hSCManager As Long
Dim hService As Long
Dim cmd As String
Dim lServiceType As Long
Dim iph As Long

Select Case serviceType

Case e_ServiceType_Automatic
lServiceType = SERVICE_AUTO_START

Case e_ServiceType_BootTime
lServiceType = SERVICE_BOOT_START

Case e_ServiceType_Disabled
lServiceType = SERVICE_DISABLED

Case e_ServiceType_Manual
lServiceType = SERVICE_DEMAND_START

Case e_ServiceType_SystemStart
lServiceType = SERVICE_SYSTEM_START
End Select

hSCManager = OpenSCManager(vbNullString, vbNullString, SC_MANAGER_Create_SERVICE)
' CreateService (ByVal hSCManager As Long, ByVal lpServiceName As String, ByVal lpDisplayName As String, ByVal dwDesiredAccess As Long, ByVal dwServiceType As Long, ByVal dwStartType As Long, ByVal dwErrorControl As Long, ByVal lpBinaryPathName As String, ByVal lpLoadOrderGroup As String, ByVal lpdwTagId As String, ByVal lpDependencies As String, ByVal lp As String, ByVal lpPassword As String) As Long
hService = CreateService(hSCManager, ServiceName, ServiceName, SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS, lServiceType, SERVICE_ERROR_NORMAL, ServiceFilePath, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString)
'iph = RegisterServiceCtrlHandler(serviceName, hService)
CloseServiceHandle hService
CloseServiceHandle hSCManager
End Sub

Public Sub RemoveService(ServiceName As String)
Dim hSCManager As Long
Dim hService As Long
Dim cmd As String
hSCManager = OpenSCManager(vbNullString, vbNullString, SC_MANAGER_Create_SERVICE)
hService = OpenService(hSCManager, ServiceName, SERVICE_ALL_ACCESS)
DeleteService hService
CloseServiceHandle hService
CloseServiceHandle hSCManager
End Sub

Public Function RunService(ServiceName As String) As Boolean
Dim ServiceTableEntry As SERVICE_TABLE_ENTRY
Dim b As Boolean
ServiceTableEntry.lpServiceName = ServiceName
SERVICE_NAME = ServiceName
ServiceTableEntry.lpServiceProc = FncPtr(AddressOf ServiceMain)
b = StartServiceCtrlDispatcher(ServiceTableEntry)
RunService = b
Debug.Print b
End Function

Private Sub Handler(ByVal fdwControl As Long)
Dim b As Boolean

Select Case fdwControl

Case SERVICE_CONTROL_PAUSE
ServiceStatus.dwCurrentState = SERVICE_PAUSED

Case SERVICE_CONTROL_CONTINUE
ServiceStatus.dwCurrentState = SERVICE_RUNNING

Case SERVICE_CONTROL_STOP
ServiceStatus.dwWin32ExitCode = 0
ServiceStatus.dwCurrentState = SERVICE_STOP_PENDING
ServiceStatus.dwCheckPoint = 0
ServiceStatus.dwWaitHint = 0
b = SetServiceStatus(hServiceStatus, ServiceStatus)
ServiceStatus.dwCurrentState = SERVICE_STOPPED

Case SERVICE_CONTROL_INTERROGATE

Case Else
End Select

b = SetServiceStatus(hServiceStatus, ServiceStatus)
End Sub

Private Function FncPtr(ByVal fnp As Long) As Long
FncPtr = fnp
End Function

Private Sub ServiceMain(ByVal dwArgc As Long, _
ByVal lpszArgv As Long)
Dim b As Boolean
'Set initial state
ServiceStatus.dwServiceType = SERVICE_WIN32_OWN_PROCESS
ServiceStatus.dwCurrentState = SERVICE_START_PENDING
ServiceStatus.dwControlsAccepted = SERVICE_ACCEPT_STOP Or SERVICE_ACCEPT_PAUSE_CONTINUE Or SERVICE_ACCEPT_SHUTDOWN
ServiceStatus.dwWin32ExitCode = 0
ServiceStatus.dwServiceSpecificExitCode = 0
ServiceStatus.dwCheckPoint = 0
ServiceStatus.dwWaitHi
nt = 0
hServiceStatus = RegisterServiceCtrlHandler(SERVICE_NAME, AddressOf Handler)
ServiceStatus.dwCurrentState = SERVICE_START_PENDING
b = SetServiceStatus(hServiceStatus, ServiceStatus)
ServiceStatus.dwCurrentState = SERVICE_RUNNING
b = SetServiceStatus(hServiceStatus, ServiceStatus)
End Sub