Option Explicit

Public Declare Function ZwQueryInformationProcess _
Lib "NTDLL.DLL" (ByVal ProcessHandle As Long, _
ByVal ProcessInformationClass As PROCESSINFOCLASS, _
ByVal ProcessInformation As Long, _
ByVal ProcessInformationLength As Long, _
ByRef ReturnLength As Long) As Long

Public Enum
PROCESSINFOCLASS
ProcessBasicInformation
ProcessQuotaLimits
ProcessIoCounters
ProcessVmCounters
ProcessTimes
ProcessBasePriority
ProcessRaisePriority
ProcessDebugPort
ProcessExceptionPort
ProcessAccessToken
ProcessLdtInformation
ProcessLdtSize
ProcessDefaultHardErrorMode
ProcessIoPortHandlers
'// Note: this is kernel mode only
ProcessPooledUsageAndLimits
ProcessWorkingSetWatch
ProcessUserModeIOPL
ProcessEnableAlignmentFaultFixup
ProcessPriorityClass
ProcessWx86Information
ProcessHandleCount
ProcessAffinityMask
ProcessPriorityBoost
ProcessDeviceMap
ProcessSessionInformation
ProcessForegroundInformation
ProcessWow64Information
ProcessImageFileName
ProcessLUIDDeviceMapsEnabled
ProcessBreakOnTermination
ProcessDebugObjectHandle
ProcessDebugFlags
ProcessHandleTracing
ProcessIoPriority
ProcessExecuteFlags
ProcessResourceManagement
ProcessCookie
ProcessImageInformation
MaxProcessInfoClass
'// MaxProcessInfoClass should always be the last enum
End Enum

Public
Type PROCESS_BASIC_INFORMATION
ExitStatus
As Long 'NTSTATUS
PebBaseAddress As Long 'PPEB
AffinityMask As Long 'ULONG_PTR
BasePriority As Long 'KPRIORITY
UniqueProcessId As Long 'ULONG_PTR
InheritedFromUniqueProcessId As Long 'ULONG_PTR
End Type

Private Function GetProcessId(ByVal hProcess As Long) As Long
Dim
st As Long
Dim
pbi As PROCESS_BASIC_INFORMATION: pbi = GetProcessBasicInfo(hProcess)
GetProcessId = pbi.UniqueProcessId
End Function

Private Function
GetProcessBasicInfo(ByVal hProcess As Long) As PROCESS_BASIC_INFORMATION
Dim st As Long
Dim
pbi As PROCESS_BASIC_INFORMATION
st = ZwQueryInformationProcess(hProcess, ProcessBasicInformation, VarPtr(pbi), LenB(pbi),
0)

If (Not NT_SUCCESS(st)) Then Exit Function
GetProcessBasicInfo = pbi
End Function

Public Function
NT_SUCCESS(ByVal Status As Long) As Boolean
NT_SUCCESS = (Status >= 0)
End Function




以下列出三种不同方法的代码供大家参考

1、注册表方式

模块代码

Option Explicit

Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Public Declare Function
RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Public Declare Function
RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Public Declare Function
RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

Public Const
REG_SZ = 1

Public Const HKEY_LOCAL_MACHINE = &H80000002

'*************************************************************************
'**函 数 名: SetAutoRun
'**输 入: ByVal Autorun(Boolean)
'**功能描述: 随WINDOWS自动启动/取消启动模块
'**调用方法: Call SetAutoRun(True/False)
'**作 者: Mr.David
'**日 期: 2006-09-05 09:07:25
'*************************************************************************

Public Sub SetAutoRun(ByVal Autorun As Boolean)

Dim KeyId As Long
Dim
MyexePath As String
Dim
regkey As String

MyexePath = App.Path & "\" & App.EXEName & ".exe" '获取程序位置

regkey = "Software\Microsoft\Windows\CurrentVersion\Run" '键值位置变量

Call RegCreateKey(HKEY_LOCAL_MACHINE, regkey, KeyId) '建立

If Autorun Then

RegSetValueEx KeyId, "MySoftware", 0&, REG_SZ, ByVal MyexePath, LenB(MyexePath)

Else

RegDeleteValue KeyId, "MySoftware"

End If

RegCloseKey KeyId

End Sub



调用方法

SetAutoRun(ByVal Autorun As Boolean)



-----------------------------------------------------------------------------------------------

2、利用Vb5stkit.dll里的函数

窗体部分代码,加入6个按钮。

Option Explicit

Private Sub CmdAddStartup_Click() '在开始菜单的启动程序组下创建记事本的快捷方式
Call OSfCreateShellLink("\启动", "记事本", GetWindowsPath & "\Notepad.exe", "")
End Sub

Private Sub
CmdAddDeskTop_Click() '在桌面创建记事本的快捷方式
Call OSfCreateShellLink("..\..\桌面", "记事本", GetWindowsPath & "\Notepad.exe", "")
End Sub

Private Sub
CmdAddProgram_Click() '在程序菜单的Notepad程序组下创建记事本的快捷方式
Call OSfCreateShellGroup("Notepad") '先建立程序组
Call OSfCreateShellLink("Notepad", "记事本", GetWindowsPath & "\Notepad.exe", "")
End Sub

Private Sub
CmdAddStartMenu_Click()
Dim i lor="#0000FF">As Long
For
i = 1 To 5 '在开始菜单创建记事本的快捷方式,必须用循环才能创建?
Call OSfCreateShellLink("..\..\「开始」菜单", "记事本", GetWindowsPath & "\Notepad.exe", "")
Next
End Sub

Private Sub
CmdQuickLaunch_Click() '在快捷工具栏下创建记事本的快捷方式
Call OSfCreateShellLink("..\..\Application Data\Microsoft\Internet Explorer\Quick Launch", "记事本", GetWindowsPath & "\Notepad.exe", "")
End Sub

Private Sub
CmdDelAllLink_Click()
Call OSfRemoveShellLink("..\..\「开始」菜单", "记事本") '删除开始菜单上的快捷方式
Call OSfRemoveShellLink("..\..\桌面", "记事本") '删除桌面上的快捷方式
'Call OSfRemoveShellLink("Notepad", "记事本") '删除Notepad程序组下的快捷方式,这样不能删除程序组
Call RemoveShellGroup '删除Notepad程序组下的快捷方式
Call OSfRemoveShellLink("\启动", "记事本") '删除启动菜单下的快捷方式
Call OSfRemoveShellLink("..\..\Application Data\Microsoft\Internet Explorer\Quick Launch", "记事本") '删除快捷工具栏下的快捷方式
End Sub

Private Sub
RemoveShellGroup()
On Error GoTo ToExit '打开错误陷阱
'------------------------------------------------
'RmDir删除一个存在的目录或文件夹。语法RmDir Path
'必要的 path 参数是一个字符串表达式,用来指定要删除的目录或文件夹。path 可以包含驱动器。如果没有指定驱动器,则 RmDir 会在当前驱动器上删除目录或文件夹。
'说明如果想要使用 RmDir 来删除一个含有文件的目录或文件夹,则会发生错误。在试图删除目录或文件夹之前,先使用 Kill 语句来删除所有文件。
Kill (GetProgarmPath(Me.hWnd) & "\Notepad\记事本.lnk")
RmDir (GetProgarmPath(Me.hWnd) &
"\Notepad")
'------------------------------------------------
Exit Sub

ToExit:
Resume Next
End Sub



模块代码

Option Explicit

'-----------------------------------------------------
' 创建和删除快捷方式
'-----------------------------------------------------
' CmdAddStartup "创建启动程序组快捷方式"
' CmdAddDeskTop "创建桌面快捷方式"
' CmdAddStartMenu "创建开始菜单快捷方式"
' CmdAddProgram "创建程序组下的快捷方式"
' CmdQuickLaunch "创建快捷工具栏的快捷方式"
' CmdDelAllLink "删除所有快捷方式"
'-----------------------------------------------------
'要在VB中创建Windows的快捷方式,需要用到VB的一个动态链接库
'Vb5stkit.dll。在该动态链接库中提供了三个函数
'OSfCreateShellGroup、OSfCreateShellLink、OSfRemoveShellLink
'分别用于创建快捷方式程序组、创建快捷方式和删除快捷方式。
'-----------------------------------------------------

Declare Function OSfCreateShellGroup Lib "Vb5stkit.dll" _
Alias "fCreateShellFolder" (ByVal lpstrDirName As String) As Long

'lpstrDirName指定了程序组的名称
'-----------------------------------------------------

Declare Function OSfCreateShellLink Lib "Vb5stkit.dll" _
Alias "fCreateShellLink" (ByVal lpstrFolderName As String, _
ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long

'lpstrfoldername指定保存快捷方式的文件夹
'lpstrlinkname指定快捷方式的文件名
'lpstrLinkpathe指定快捷方式所指向的应用程序或文件
'lpstrLinkArguments是程序运行所需的参数
'-----------------------------------------------------

Declare Function OSfRemoveShellLink Lib "Vb5stkit.dll" Alias _
"fRemoveShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName olor="#0000FF">As String) As Long

'获取Windows目录
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias _
"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'获得文件夹路径
Private Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" (ByVal hwndOwner As Long, ByVal lpszPath As String, ByVal nFolder As Long, ByVal fCreate As Long) As Long

Private Const
Max_Path = 260 '缓冲区大小
Private Const CSIDL_PROGRAMS = &H2 '程序组常量

'*************************************************************************
'**函 数 名: GetWindowsPath
'**输 入: 无
'**输 出: (String) -
'**功能描述: 得到Windows路径
'**全局变量:
'**调用模块:
'**作 者: Mr.David
'**日 期: 2006-09-19 19:49:17
'**修 改 人:
'**日 期:
'**版 本: V1.0.0
'*************************************************************************

Public Function GetWindowsPath() As String
Dim
ChrLen As Long, WinDir As String

WinDir = Space$(Max_Path)
ChrLen = GetWindowsDirectory(WinDir, Max_Path)

WinDir = Left$(WinDir, ChrLen)
GetWindowsPath = WinDir
End Function

'*************************************************************************
'**函 数 名: GetProgarmPath
'**输 入: frmHwnd(Long) -
'**输 出: (String) -
'**功能描述: 获取开始菜单程序组的路径
'**作 者: Mr.David
'**日 期: 2006-09-19 19:48:16
'*************************************************************************

Public Function GetProgarmPath(frmHwnd As Long) As String
Dim
CSILD_NUM As Long, strBouff As String

strBouff = String$(Max_Path, 0)

SHGetSpecialFolderPath frmHwnd, strBouff, CSIDL_PROGRAMS,
0
GetProgarmPath = Left$(strBouff, InStr(1, strBouff, Chr$(0)) - 1)
End Function



-----------------------------------------------------------------------------------------------

3、引用系统里面都有的WSHom.Ocx


Option Explicit

'*************************************************************************
'**函 数 名: SetAutoRun
'**输 入: ByVal Autorun(Boolean)
'**功能描述: 随WINDOWS自动启动/取消启动模块
'**调用方法: Call SetAutoRun(True/False)
'**作 者: Mr.David
'**日 期: 2006-09-05 09:07:25
'*************************************************************************

Public Sub SetAutoRun(ByVal Autorun As Boolean)
'WshShell 对象
'ProgId Wscript.Shell
'文件名 WSHom.Ocx

Dim WshShell As WshShell
Set WshShell = CreateObject("Wscript.Shell")

If Autorun Then
WshShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
Else
WshShell.RegDelete "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName
End If

Set
WshShell = Nothing
End Sub




查找方法:按ctrl+f,输入要查找的问题关键字即可
每个问题中间用///分隔,这只是一部分最常见到的问题,以后会逐渐更新。

////////////////////////////////////////////////////////////////////////////////////
如何用VB建立快捷方式

Private Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
Sub
Command1_Click()
Dim lReturn As Long
'添加到桌面
lReturn = fCreateShellLink("..\..\Desktop", "Shortcut to Calculator", "c:\windows\calc.exe", "")
'添加到程序组
lReturn = fCreateShellLink("", "Shortcut to Calculator", "c:\windows\calc.exe", "")
'添加到启动组
lReturn = fCreateShellLink("\Startup", "Shortcut to Calculator", "c:\windows\calc.exe", "")
End Sub

////////////////////////////////////////////////////////////////////////////////////
如何让程序在 Windows 启动时自动执行?

有以下二个方法:

方法1: 直接将快捷方式放到启动群组中。

方法2:
在注册档 HKEY_LOCAL_MACHINE 中找到以下机码
\Software\Microsoft\Windows\CurrentVersion\Run
新增一个字串值,包括二个部份
1. 名称部份:自己取名,可设定为 AP 名称。
2. 资料部份:则是包含 '全路径档案名称' 及 '执行参数'

例如:
Value Name = Notepad
Value Data = c:\windows\notepad.exe


////////////////////////////////////////////////////////////////////////////////////
在 TextBox 中如何限制只能输入数字?

参考下列程序:
Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii < 48 or KeyAscii > 57 Then
KeyAscii = 0
End If
End Sub

////////////////////////////////////////////////////////////////////////////////////
我希望 TextBox 中能不接受某些特定字符,例如
'@#$%",有没有简单一点的写法?

方法有好几种, 以下列举二种:

方法1: 可以使用
IF Select Case 一个个判断, 但如果不接受的字符多时, 较麻烦!
方法2: 将要剔除的字符统统放在一个字串中,只要一个
IF 判断即可 !! 如下:
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim sTemplate As String
sTemplate = "!@#$%^&*()_+-=" '用来存放不接受的字符
If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then
KeyAscii = 0
End If
End Sub


////////////////////////////////////////////////////////////////////////////////////
如何让鼠标进入 TextBox 时自动选定 TextBox 中之整串文字?

这个自动选定反白整串文字的动作,会使得输入的资料完全取代之前在 TextBox 中的所有字符。

Private Sub Text1_GotFocus()
Text1.SelStart =
0
Text1.SelLength = Len(Text1)
End Sub


////////////////////////////////////////////////////////////////////////////////////
如何检查软盘驱动器里是否有软盘?

使用:
Dim Flag As Boolean
Flag = Fun_FloppyDrive("A:")
If Flag = False Then MsgBox "A:驱没有准备好,请将磁盘插入驱动器!", vbCritical

'-------------------------------
'函数:检查软驱中是否有盘的存在
'-------------------------------
Private Function Fun_FloppyDrive(sDrive As String) As Boolean
On Error Resume Next
Fun_FloppyDrive = Dir(sDrive) <> ""
End Function


////////////////////////////////////////////////////////////////////////////////////
如何弹出和关闭光驱托盘?

Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Sub
Command1_Click()
mciExecute
"set cdaudio door open" '弹出光驱
Label2.Caption = "弹 出"
End Sub

Private Sub
Command2_Click()
Label2.Caption =
"关 闭"
mciExecute "set cdaudio door closed" '合上光驱
Unload Me
End
End Sub


////////////////////////////////////////////////////////////////////////////////////
如何让你的程序在任务列表隐藏

Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private Declare Function
GetCurrentProcessId Lib "kernel32" () As Long

'请你试试 Ctrl+Alt+Del 是不是你的程序隐藏了
Private Sub Command1_Click()
i = RegisterServiceProcess(GetCurrentProcessId,
1)
End Sub


////////////////////////////////////////////////////////////////////////////////////
如何用程序控制滑鼠游标 (Mouse Cursor) 到指定位置?

以下这个例子,当 User 在 Text1 中按下
'Enter' 键后,滑鼠游标会自动移到 Command2 按钮上方

请在声明区中加入以下声明:

'16 位版本: ( Sub 无传回值 )
Declare Sub SetCursorPos Lib "User" (ByVal X As Integer, ByVal Y As Integer)

'32 位版本: ( Function 有传回值,Integer 改成 Long )
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long

'在 Form1 中加入以下程序码:
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
x% = (Form1.Left + Command2.Left + Command2.Width / 2 + 60) / Screen.TwipsPerPixelX
y% = (Form1.Top + Command2.Top + Command2.Height /
2 + 360) / Screen.TwipsPerPixelY
SetCursorPos x%, y%
End If
End Sub
////////////////////////////////////////////////////////////////////////////////////
如何用鼠标移动没有标题的 Form,或移动 Form 中的控制项?

在声明区中放入以下声明:

'16 位版本: ( Sub 无返回值 )
Private Declare Sub ReleaseCapture Lib "User" ()
Private Declare Sub SendMessage Lib "User" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Long)

'32 位版本: ( Function 有返回值,Integer 改成 Long )
Private Declare Function ReleaseCapture Lib "user32" () 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

'共用常数:
Const WM_SYSCOMMAND = &H112
Const SC_MOVE = &HF012

'若要移动 Form,程序码如下:
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
i = ReleaseCapture
i = SendMessage(Form1.hwnd, WM_SYSCOMMAND, SC_MOVE, t>0)
End Sub

'以上功能也适用于用鼠标在 Form 中移动控制项,程序码如下:
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
i = ReleaseCapture
i = SendMessage(Command1.hwnd, WM_SYSCOMMAND, SC_MOVE,
0)
End Sub

////////////////////////////////////////////////////////////////////////////////////
检查文件是否存在?

Function FileExists(filename As String) As Integer
Dim
i As Integer
On Error Resume Next
i = Len(Dir$(filename))
If Err or i = 0 Then FileExists = False Else FileExists = True
End Function

////////////////////////////////////////////////////////////////////////////////////
如何设置对VB数据库连接的动态路径

我个人因为经常作一些数据库方面的程序,对于程序间如何与数据库进行接口的问题之烦是深有体会,因为VB在数据库链接的时候,一般是静态,即数据库存放的路径是固定的,如用VB的DATA,adodc,DataEnvironment 等到作数据库链接时,如果存放数据库的路径被改变的话,就会找不到路经,真是一个特别烦的事。
笔者的解决方法是利用app.path 来解决这个问题。
一、用data控件进行数据库链接,可以这样:
在form_load()过程中放入:
private form_load()
Dim str As String '定义
str = App.Path
If Right(str, 1) <> "\" Then
str = str + "\"
End If
data1.databasename=str & "\数据库名"
data1.recordsource="数据表名"
data1.refresh
sub end
这几句话的意为,打开当前程序运行的目录下的数据库。
你只要保证你的数据库在你程序所在的目录之下就行了。

二、利用adodc(ADO Data Control)进行数据库链接:
private form_load ()
Dim str As String '定义
str = App.Path
If Right(str, 1) <> "\" Then
str = str + "\"
End If
str = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & str & "\tsl.mdb"
Adodc1.ConnectionString = str
Adodc1.CommandType = adCmdText
Adodc1.RecordSource =
"select * from table3"
Adodc1.Refresh
end sub

三、利用DataEnvironment进行数据库链接
可在过程中放入:
On Error Resume Next
If
DataEnvironment1.rsCommand1.State <> adStateClosed Then
DataEnvironment1.rsCommand1.Close '如果打开,则关闭
End If
'i = InputBox("请输入友人编号:", "输入")
'If i = "" Then Exit Sub
DataEnvironment1.Connection1.Open App.Path & "\userdatabase\tsl.mdb"
DataEnvironment1.rsCommand1.Open "select * from table3 where 编号='" & i & "'"
'Set DataReport2.DataSource = DataEnvironment1
'DataReport2.DataMember = "command1"
'DataReport2.show
end sub

四、利用ADO(ActiveX Data Objects)进行编程:
建立连接:
dim conn as new adodb.connection
dim rs as new adodb.recordset
dim str
str = App.Path
If Right(str, 1) <> "\" Then
str = str + "\"
End If
str = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & str & "\tsl.mdb"
conn.open str
rs.cursorlocation=aduseclient
rs.open
"数据表名",conn,adopenkeyset.adlockpessimistic
用完之后关闭数据库:
conn.close
set conn=nothing

////////////////////////////////////////////////////////////////////////////////////
如何让用户自行输入方程式,并计算其结果?

假设我们要让使用者在“方程式”栏位中自由输入方程式,然后利用方程式进行计算,则引用ScriptControl控件可以很方便地做到。
( ScriptControl 控件附属于VB
6.0,如果安装后没有看到此一控件,可在光盘的 \Common\Tools\VB\Script 目录底下找此一控件, 其.文件名为Msscript.ocx。) 假设放在窗体上的ScriptControl控件名称为ScriptControl1,则在“计算”按钮的Click事件中编写如下代码: Dim Statement As String Statement = "X=" + Text1.Text + vbCrLf + _ "Y=" + Text2.Text + vbCrLf + _ "MsgBox ""计算结果="" & Y " ScriptControl1.ExecuteStatement( Statement

////////////////////////////////////////////////////////////////////////////////////
如何让一个 App 永远保持在最上层 ( Always
on Top )

请在声明区中加入以下声明

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

Const
SWP_NOMOVE = &H2 '不更动目前视窗位置
Const SWP_NOSIZE = &H1 '不更动目前视窗大小
Const HWND_TOPMOST = -1 '设定为最上层
Const HWND_NOTOPMOST = -2 '取消最上层设定
Const FLAGS = SWP_NOMOVE or SWP_NOSIZE

'将 APP 视窗设定成永远保持在最上层
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS

'取消最上层设定
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS

////////////////////////////////////////////////////////////////////////////////////
我要如何在程序中开启网页?

在声明区中声明如下 (在 .bas 档中用
Public, 在 Form 中用 Private)

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

在程序中

Intranet:
ShellExecute Me.hWnd,
"open", "http://Intranet主机/目录", "", "", 5
Internet:
ShellExecute Me.hWnd,
"open", "http://www.ruentex.com.tw", "", "", 5


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


VB可以产生四角形以外其他形状的 Form 吗?

这个问题,您一定无法想像有多容易,您可以产生任何形状的 Form,但必须借助 CreateEllipticRgn 及 SetWindowRgn 二个 API ,例如:

Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function
SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Private Sub
Form_Load()
Dim lReturn As Long
Me.Show
lReturn = SetWindowRgn(hWnd, CreateEllipticRgn(
10, 10, 340, 150), True)
End Sub

执行结果图片

CreateEllipticRgn
之四个参数说明如下:
X1:椭圆中心点之X轴位置,但以 Form 的实№边界为限。
Y1:椭圆中心点之Y轴位置,但以 Form 的实№边界为限。
X2:椭圆长边的长度
Y2:椭圆短边的长度的

////////////////////////////////////////////////////////////////////////////////////
如何移除 Form 右上方之『X』按钮?

其实 Form 右上方之三个按钮分别对应到 Form 左上方控制盒 (ControlBox) 中的几个选项 (缩到最小 / 放到最大 / 关闭),而其中的最大化 (MaxButton) 及最小化 (Minbutton) 都可以直接在 Form 的属性中设定,但是 VB 并没有提供设定『X』按钮的功能!要达到这个功能,必须借助 API:

由于『X』按钮对应到 ControlBox 的关闭选项,所以我们只要移除系统 Menu (就是ControlBox) 的关闭选项即可!您自己可以先看看您现在使用的 Browser 左上方的系统 Menu,【关闭】选项是在第几个,不是第
6 个!是第 7 个,分隔线也算一个!分隔线才是第 6 个!

当我们移除了关闭选项之後,会留下一条很奇怪的分隔线,所以最好连分隔线也一并移除。而 Menu 的 Index 是从
0 开始,分隔线是第 6 个,所以 Index = 5

修正:为了让程序码在 Windows NT 也能运作正常,将各
Integer 型态改成 Long。 89.05.04

'抓取系统 Menu 的 hwnd
Private Declare Function GetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

'移除系统 Menu 的 API
Private Declare Function RemoveMenu Lib "user32" Alias "RemoveMenu" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
'第一个参数是系统 Menu 的 hwnd
'第二个参数是要移除选项的 Index

////////////////////////////////////////////////////////////////////////////////////
如何制作透明的表单 (Form)?

请在声明区中放入以下声明

Const GWL_EXSTYLE = (-20)
Const WS_EX_TRANSPARENT = &H20&
Const SWP_FRAMECHANGED = &H20
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const SWP_SHOWME = SWP_FRAMECHANGED or SWP_NOMOVE or SWP_NOSIZE
Const HWND_NOTOPMOST = -2

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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

在 Form_Load 使用的范例如下:

Private Sub Form_Load()
SetWindowLong Me.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT
SetWindowPos Me.hwnd, HWND_NOTOPMOST,
0&, 0&, 0&, 0&, SWP_SHOWME
Me.Refresh
End Sub

////////////////////////////////////////////////////////////////////////////////////
如何在 Menu 中加入MM的图案?

在模组中加入以下程序码:

Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long

Declare Function
GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Declare Function
GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Declare Function
SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

Public Const
MF_BITMAP = &H4&

Type MENUITEMINFO
cbSize
As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End
Type

Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long

Declare Function
GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, _
ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO) As Boolean

Public Const
MIIM_ID = &H2
Public Const MIIM_TYPE = &H10
Public Const MFT_STRING = &H0&

在 Form 中加入一个 PictureBox,属性设定为:
AutoSize =
True
Picture = .bmp (尺寸大小为 13x13,不可设定为 .ico)

在 Form_Load 中的程序码如下:

Private Sub Form_Load()
'取得程序中 Mennu 的 handle
hMenu& = GetMenu(Form1.hWnd)
'取得第一个 submenu 的 handle
hSubMenu& = GetSubMenu(hMenu&, 0)
'取得 Submenu 第一个选项的 menuId
hID& = GetMenuItemID(hSubMenu&, 0)
'加入图片
SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, Picture1.Picture, Picture1.Picture
'在一个 Menu 选项中您一共可以加入二张图片
'一张是 checked 状态用,一张是 unchecked 状态用
End Sub

89、如何把小图片填满 Form 成为背景图?

对于这个问题,我看过很多方法,有的方法很麻烦,要声明一大堆 Type,用一大堆的 API,但是有一个最笨但我认为最好的方法如下: (就好像拼磁砖一样,不用任何 API, 不必声明任何 Type)

在 Form 中放一个 PictureBox,Picture 属性设定为某一张小图,AutoSize 属性性设定 True,完成的模组如下:

Sub PictureTile(Frm As Form, Pic As PictureBox)
Dim i As Integer
Dim
t As Integer
Frm.AutoRedraw = True
Pic.BorderStyle = 0
For t = 0 To Frm.Height Step Pic.ScaleHeight
For i = 0 To Frm.Width Step Pic.ScaleWidth
Frm.PaintPicture Pic.Picture, i, t
Next i
Next t
End Sub

PictureTile 这个模组共有二个参数,第一个是表单名称,第二个则是 PictureBox 的名称。以下为一应用实例:

Private Sub Form_Load()
PictureTile
Me, Picture1
End Sub

90、如何把小图片填满 MDIForm 成为背景图?

以下这个范例, 要:
1、一个 MDIForm:不必设定任何属性。
2、一个 Form1:不一定是 MDIChild,最好 MDIChild 为 False,但是 AutoRedraw 设成 True。
3、Form1 上面放一个隐藏的 PictureBox:名称为 Picture1,不必设定 Picture 属性。
4、一张图片的完整路径。 />
'将以下模组放入 MDIForm 的声明区中:

Sub TileMDIBkgd(MDIForm As Form, bkgdtiler As Form, bkgdfile As String)
If bkgdfile = "" Then Exit Sub
Dim
ScWidth%, ScHeight%
ScWidth% = Screen.Width / Screen.TwipsPerPixelX
ScHeight% = Screen.Height / Screen.TwipsPerPixelY
Load bkgdtiler
bkgdtiler.Height = Screen.Height
bkgdtiler.Width = Screen.Width
bkgdtiler.ScaleMode =
3
bkgdtiler!Picture1.Top = 0
bkgdtiler!Picture1.Left = 0
bkgdtiler!Picture1.Picture = LoadPicture(bkgdfile)
bkgdtiler!Picture1.ScaleMode =
3

For n% = 0 To ScHeight% Step bkgdtiler!Picture1.ScaleHeight
For o% = 0 To ScWidth% Step bkgdtiler!Picture1.ScaleWidth
bkgdtiler.PaintPicture bkgdtiler!Picture1.Picture, o%, n%
Next o%
Next n%

MDIForm.Picture = bkgdtiler.Image
Unload bkgdtiler
End Sub

以下为一应用实例:

Private Sub MDIForm_Load()
TileMDIBkgd
Me, Form1, "c:\windows\Tiles.bmp"
End Sub

////////////////////////////////////////////////////////////////////////////////////
关闭指定的程序

要做到像 Task Manager 一样,可以关闭指定的程序,方法如下:

在声明区中放入以下声明:(
16位 改成 win31 API)

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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

Public Const
WM_CLOSE = &H10

以下之范例示范如何关闭一个视窗标题 (Caption) 为 【小算盘】的程序:

Dim winHwnd As Long
Dim
RetVal As Long
winHwnd = FindWindow(vbNullString, "小算盘")
Debug.Print winHwnd
If winHwnd <> 0 Then
RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
If RetVal = 0 Then
MsgBox "Error posting message."
End If
Else
MsgBox "并未开启小算盘程序."
End If

////////////////////////////////////////////////////////////////////////////////////
如何隐藏及再显示鼠标

很简单,只用到了一个 ShowCursor API,参数也很简单,只有一个 bShow,设定值如下:

True:显示鼠标 / False:隐藏鼠标

Declare Function ShowCursor Lib "user32" Alias "ShowCursor" (ByVal bShow As Long) As Long

////////////////////////////////////////////////////////////////////////////////////
如何从您的应程序中结束 Windows 重开机?

很多软件在 Setup 完之后都会自动关机重开机,以便让某些设定值可以生效,其实这个功能很简单,只要几行指令就可以做到了!

关键就是要使用 ExitWindowsEx 这个 API,这个 API 只有二个参数,第一个参数是一个 Flag,目的是要告诉 Windows 要以什么方式关机,在下面的声明中会列出可用的 Flag 常数值,至于第二个参数则是一个保留值,只要设定成
0 就可以了。

很重要的一点是:如果您想要让关机动作更顺利,记得要 Unload 您的程序!

'在声明区中 (Bas Module / Form Module) 加入以下声明:

Public Const EWX_LOGOFF = 0 '这四个常数值可以并用
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4

Declare Function ExitWindowsEx Lib "user32" Alias "ExitWindowsEx" (ByVal uFlags As Long, ByVal ="#000000">dwReserved As Long) As Long

'实例:如果您想强迫关机重开机,程序码如下:

ret = ExitWindowsEx(EWX_FORCE or EWX_REBOOT, 0)

////////////////////////////////////////////////////////////////////////////////////
如何用 VB 启动其他程序或开启各类文件?

要在 VB 中启动其他程序或开启各类文件,最简单的方法就是使用 Shell 函数,例如:要开启 C:\Test.txt 这个文字文件,则要启动记事本来开启这个文件案,程序如下:

Dim RetVal As Long
RetVal = Shell("C:\Windows\Notepad.exe C:\Test.txt", 3) '3代表视窗会最大化,并具有驻点,细节请查 Help

以上的语法虽然很简单,但有一个风险,若是我们不知道开启文件的执行文件位置,则程序便会有错误产生,尤其一般软件在安装的时候都可以让使用者自行选择安装目录,所以执行文件的路径不能写死在程序中,要解决这个问题,就是在注册文件中找到该副文件名之启动程序位置,再放入 Shell 中。

但是以上的作法必须熟悉注册文件,而且必须使用 Windows API 来
Call (注册文件的存取以后会有专文来说明),如果您对注册文件的存取及 API 的使用都很纯熟的话,当然没问题,但是有些人对于注册文件会有畏惧,这时候,您可以使用下面的方法:

Shell(
"Start C:\Test.txt")

您完全不用知道这份文件的启动程序是什么?它放在什么地方?参数 Start 便会自动依照附文件名到注册文件中找到启动程序来开启该份文件案! 不赖吧!

注一:在 Windows
95/98/NT 平台中, 什么副文件名之文件案, 该由什么执行文件来启动, 都设在关联中,

代码为 HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Extensions

例如: 名称为
".DOC" 之资料为 "C:\Progra~1\Micros~2\Office\WINWORD.EXE ^.DOC"

名称为 ".TXT" 之资料为 "notepad.exe ^.txt"

注二:使用 Start 之唯一缺点为 "会比直接指定执行文件稍为慢 0.5-1 秒钟."


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


如何找出 Windows 目录的正确路径?

有时候我们在程序中必须用到 Windows 的目录,以存取 Windows 目录下的文件,照理说,这应该是最简单的功能,前提是每个人在 Setup Windows 必须采用 Windows 的预设目录名称,也就是 C:\Windows,但是常常不是这样,有时候由於要使新旧版本共存,或者其他原因,有人会将 Windows 目录改成 c:\win95、c:\win98、Windows95 或 Windows98......

若是程序中必须用到 Windows 目录,要找到正确的路径,做法如下:

'在声明区中加入以下声明:

Const MAX_PATH = 260

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Function
GetWinPath()
Dim strFolder As String
Dim
lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetWindowsDirectory(strFolder, MAX_PATH)
If lngResult <> 0 Then
GetWinPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetWinPath = ""
End If
End Function

'在程序中使用方法如下:

Private Sub Command1_Click()
Call MsgBox("您电脑中 Windows 目录的正确路径是: " & GetWinPath, vbInformation)
End Sub

////////////////////////////////////////////////////////////////////////////////////
让您的文字框有 Undo / Redo 的功能

很多软件都有提供 Undo / Redo 的功能,Microsoft 的产品都可以提供多次 Undo 反悔,功能更强大!

在 VB 的程序中,我们也可以提供这样的功能!不过只能 Undo / Redo 一次

'在声明区中加入以下声明:

'32位元
'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
'Const EM_UNDO = &HC7

'16位元
Private Declare Function SendMessage Lib "User" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Const
WM_USER = &H400
Const EM_UNDO = WM_USER + 23

'在程序中使用的方式如下: ( Undo Text1 中的输入 )

Private Sub Command1_Click()
Dim UndoResult As Long
>UndoResult = SendMessage(Text1.hwnd, EM_UNDO, 0, 0)
'传回值 UndoResult = -1 表示 Undo 不成功
End Sub

'使用以上的方法,第一次是 Undo ,第二次就等于是 Redo

////////////////////////////////////////////////////////////////////////////////////
如何得到某年每个月的第一天是星期几

Private Sub Command1_Click()
Dim i As Integer, A As Integer, B As Integer, C As String
A = InputBox("请输入年份", "某年每个月的第一天是星期几")
Form1.Cls
For i = 1 To 12
C = A & "-" & i & "-1"
B = Weekday(C)
Select Case B
Case vbSunday
Print A &
"年" & i & "月1日是 星期日"
Case vbMonday
Print A &
"年" & i & "月1日是 星期一"
Case vbTuesday
Print A &
"年" & i & "月1日是 星期二"
Case vbWednesday
Print A &
"年" & i & "月1日是 星期三"
Case vbThursday
Print A &
"年" & i & "月1日是 星期四"
Case vbFriday
Print A &
"年" & i & "月1日是 星期五"
Case vbSaturday
Print A &
"年" & i & "月1日是 星期六"
End Select
Next
i

End Sub

////////////////////////////////////////////////////////////////////////////////////
如何隐藏及显示任务栏?

有时候,我们希望在我们的程序执行中,将任务栏隐藏,让桌面变得比较清爽,等到我们的程序执行完毕之后,再将任务栏显示出来,这时就要用到 SetWindowPos 这个 API 了!

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
FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Const
SWP_HIDEWINDOW = &H80 '隐藏视窗
Const SWP_SHOWWINDOW = &H40 '显示视窗

'在程序中若要隐藏任务栏

Private Sub Command1_Click()
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub

'在程序中若要再显示任务栏

Private Sub Command2_Click()
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub

////////////////////////////////////////////////////////////////////////////////////
模拟 Windows 的资源回收站!

您现在将屏幕上所有的视窗全部缩小,找到资源回收站,按鼠标右键,选择【属性】,便会出现【资源回收站】的属性问话框。

其中有几个选项如下:

1、不要将文件移到资源回收站,删除时立即移除文件。
2、显示删除确认对话


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串,没必要。
结果也证明是对的。
如果有朋友老是出现无法读值的问题,一般来说是你搞错了传值传址的问题。