VB 调用资源文件例子(文件打包与释放) 2/14
Option Explicit
Dim AppEXE() As Byte
Dim FileNum As Long
Private Sub Test()
'将自定义资源中101号资源读入数组
AppEXE = LoadResData(101, "CUSTOM")
FileNum = FreeFile
'以二进制方式写（生成）temp1.exe到当前目录
Open "C:\Test.exe" For Binary As #FileNum
Put #1, , AppEXE
Close #FileNum
'运行Test.exe
Shell "C:\Test.exe"
End Sub
Option Explicit
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 EM_SETPASSWORDCHAR = &HCC
'hwnd 标识与定时器相关的窗口
'nIDEvent 指定一个非零定时器事件标识符
'uElapse 指定定时器事件之间的时间间隔
'lpTimerFunc 表示定时器事件发生后接收详细的函数的过程实例地址
Public Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) _
As Long
Private Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent 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 FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) _
As Long
Dim m_lngTimerId As Long
Private Sub Main()
'建立API时间,句柄参数这里没有窗体赋值为0，但需要保存计时器标识符供KillTimer使用
m_lngTimerId = SetTimer(0, 0, 1, AddressOf TimerProc)
'Prompt作为对话框消息出现的字符串表达式。
'Title显示对话框标题栏中的字符串表达式。如果省略 title，则把应用程序名放入标题栏中。
'Default显示文本框中的字符串表达式，在没有其它输入时作为缺省值。如果省略 default，则文本框为空。
Call InputBox("请输入姓名", "输入框")
End Sub
Public Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
Dim lngHwnd As Long
lngHwnd = FindWindow(vbNullString, "输入框") '参数复制是Input的Title参数
lngHwnd = FindWindowEx(lngHwnd, 0, "Edit", vbNullString) '继续查找子窗口，使用TextBox类名"Edit"
If lngHwnd Then
Call PostMessage(lngHwnd, EM_SETPASSWORDCHAR, &H2A, 0) '&H2A是什么？就是*的AscII码42，这个参数为""就是不显示密码了。
Call KillTimer(0, m_lngTimerId) '关闭计时器
End If
End Sub
没试过，网上流传的代码。估计是1.20e版本用的。
#include <windows.h>
#include <winbase.h>
int main()
{
//Find wc3 windows
HWND hwar3=::FindWindow(NULL,"Warcraft III");
HANDLE hcurrent=GetCurrentProcess();
HANDLE hToken;
BOOL bret=OpenProcessToken(hcurrent,40,&hToken);
LUID luid;
bret=LookupPrivilegeValue(NULL,"SeDebugPrivilege",&luid);
TOKEN_PRIVILEGES NewState,PreviousState;
DWORD ReturnLength;
NewState.PrivilegeCount =1;
NewState.Privileges[0].Luid =luid;
NewState.Privileges[0].Attributes=2;
bret=AdjustTokenPrivileges(hToken,FALSE,&NewState,28,&PreviousState,&ReturnLength);
DWORD PID, TID;
TID = ::GetWindowThreadProcessId (hwar3, &PID);
//Open wc3 process
HANDLE hopen=OpenProcess( PROCESS_ALL_ACCESS|PROCESS_TERMINATE|PROCESS_VM_OPERATION|PROCESS_VM_READ|PROCESS_VM_WRITE,FALSE,PID);
//Write memory
DWORD data=0x74;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F4069F0,&data,1,0);
data=0x8B;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F406A0E,&data,1,0);
data=0x09;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F406A0F,&data,1,0);
data=0x90;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F406A10,&data,1,0);
data=0x8B;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F406A13,&data,1, or="#800080">0);
data=0x09;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F406A14,&data,1,0);
data=0x90;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F406A15,&data,1,0);
data=0x90;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F29FE20,&data,1,0);
data=0x90;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F29FE21,&data,1,0);
data=0x00;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F149198,&data,1,0);
data=0x40;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F2A0803,&data,1,0);
data=0x33;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F2A0804,&data,1,0);
data=0xC0;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F2A0805,&data,1,0);
data=0x42;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F2A0806,&data,1,0);
data=0x33;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F2A0807,&data,1,0);
data=0xD2;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F2A0808,&data,1,0);
data=0xEB;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F14A0B4,&data,1,0);
data=0xEB;
bret=WriteProcessMemory(hopen,(LPVOID)0x6F2A0703,&data,1,0);
//Close handle
bret=CloseHandle(hopen);
return 0;
}
VB 中注册/反注册ActiveX部件 2/14
'模块名: ActiveX 部件(OCX DLL)注册/反注册
'描 述: 该代码演示怎样在程序中注册和反注册,在regsvr32上自己进行.
Option Explicit
Private Declare Function LoadLibraryRegister _
Lib "KERNEL32" _
Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibraryRegister _
Lib "KERNEL32" _
Alias "FreeLibrary" (ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Function GetProcAddressRegister _
Lib "KERNEL32" _
Alias "GetProcAddress" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function CreateThreadForRegister _
Lib "KERNEL32" _
Alias "CreateThread" (lpThreadAttributes As Long, _
ByVal dwStackSize As Long, _
ByVal lpStartAddress As Long, _
ByVal lpparameter As Long, _
ByVal dwCreationFlags As Long, _
lpThreadID As Long) As Long
Private Declare Function WaitForSingleObject _
Lib "KERNEL32" (ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeThread _
Lib "KERNEL32" (ByVal hThread As Long, _
lpExitCode As Long) As Long
Private Declare Sub ExitThread Lib "KERNEL32" (ByVal dwExitCode As Long)
Private Const STATUS_WAIT_0 = &H0
Private Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)
Private Const NOERRORS As Long = 0
Private Enum stRegisterStatus
stFileCouldNotBeLoadedIntoMemorySpace = 1
stNotAValidActiveXComponent = 2
stActiveXComponentRegistrationFailed = 3
stActiveXComponentRegistrationSuccessful = 4
stActiveXComponentUnRegisterSuccessful = 5
stActiveXComponentUnRegistrationFailed = 6
stNoFileProvided = 7
End Enum
Public Function Register(ByVal p_sFileName As String) As Variant
Dim lLib As Long
Dim lProcAddress As Long
Dim lThreadID As Long
Dim lSuccess As Long
Dim lExitCode As Long
Dim lThreadHandle As Long
Dim lRet As Long
On Error GoTo ErrorHandler
If lRet = NOERRORS Then
If p_sFileName = "" Then
lRet = stNoFileProvided
End If
End If
If lRet = NOERRORS Then
lLib = LoadLibraryRegister(p_sFileName)
If lLib = 0 Then
lRet = stFileCouldNo
tBeLoadedIntoMemorySpace
End If
End If
If lRet = NOERRORS Then
lProcAddress = GetProcAddressRegister(lLib, "DllRegisterServer")
If lProcAddress = 0 Then
lRet = stNotAValidActiveXComponent
Else
lThreadHandle = CreateThreadForRegister(0, 0, lProcAddress, 0, 0, lThreadID)
If lThreadHandle <> 0 Then
lSuccess = (WaitForSingleObject(lThreadHandle, 10000) = WAIT_OBJECT_0)
If lSuccess = 0 Then
Call GetExitCodeThread(lThreadHandle, lExitCode)
Call ExitThread(lExitCode)
lRet = stActiveXComponentRegistrationFailed
Else
lRet = stActiveXComponentRegistrationSuccessful
End If
End If
End If
End If
ExitRoutine:
Register = lRet
If lThreadHandle <> 0 Then
Call CloseHandle(lThreadHandle)
End If
If lLib <> 0 Then
Call FreeLibraryRegister(lLib)
End If
Exit Function
ErrorHandler:
lRet = Err.Number
Resume ExitRoutine
End Function
Public Function UnRegister(ByVal p_sFileName As String) As Variant
Dim lLib As Long
Dim lProcAddress As Long
Dim lThreadID As Long
Dim lSuccess As Long
Dim lExitCode As Long
Dim lThreadHandle As Long
Dim lRet As Long
On Error GoTo ErrorHandler
If lRet = NOERRORS Then
If p_sFileName = "" Then
lRet = stNoFileProvided
End If
End If
If lRet = NOERRORS Then
lLib = LoadLibraryRegister(p_sFileName)
If lLib = 0 Then
lRet = stFileCouldNotBeLoadedIntoMemorySpace
End If
End If
If lRet = NOERRORS Then
lProcAddress = GetProcAddressRegister(lLib, "DllUnregisterServer")
If lProcAddress = 0 Then
lRet = stNotAValidActiveXComponent
Else
lThreadHandle = CreateThreadForRegister(0, 0, lProcAddress, 0, 0, lThreadID)
If lThreadHandle <> 0 Then
lSuccess = (WaitForSingleObject(lThreadHandle, 10000) = WAIT_OBJECT_0)
If lSuccess = 0 Then
Call GetExitCodeThread(lThreadHandle, lExitCode)
Call ExitThread(lExitCode)
lRet = stActiveXComponentUnRegistrationFailed
Else
lRet = stActiveXComponentUnRegisterSuccessful
End If
End If
End If
End If
ExitRoutine:
UnRegister = lRet
If lThreadHandle <> 0 Then
Call CloseHandle(lThreadHandle)
End If
If lLib <> 0 Then
Call FreeLibraryRegister(lLib)
End If
Exit Function
ErrorHandler:
lRet = Err.Number
Resume ExitRoutine
End Function
VB 调用NT系统“选择用户组”对话框 2/14
Option Explicit
Private Const NERR_SUCCESS As Long = 0&
Private Const OPENUSERBROWSER_INCLUDE_SYSTEM As Long = &H10000
Private Const OPENUSERBROWSER_SINGLE_SelectION As Long = &H1000&
Private Const OPENUSERBROWSER_NO_LOCAL_DOMAIN As Long = &H100&
Private Const OPENUSERBROWSER_INCLUDE_CREATOR_OWNER As Long = &H80&
Private Const OPENUSERBROWSER_INCLUDE_EVERYONE As Long = &H40&
Private Const OPENUSERBROWSER_INCLUDE_INTERACTIVE As Long = &H20&
Private Const OPENUSERBROWSER_INCLUDE_NETWORK As Long = &H10&
Private Const OPENUSERBROWSER_INCLUDE_USERS As Long = &H8&
Private Const OPENUSERBROWSER_INCLUDE_USER_BUTTONS As Long = &H4&
Private Const OPENUSERBROWSER_INCLUDE_GROUPS As Long = &H2&
Private Const OPENUSERBROWSER_INCLUDE_ALIASES As Long = &H1&
Private Const OPENUSERBROWSER_FLAGS As Long = OPENUSERBROWSER_INCLUDE_USERS Or OPENUSERBROWSER_INCLUDE_USER_BUTTONS Or OPENUSERBROWSER_INCLUDE_EVERYONE Or OPENUSERBROWSER_INCLUDE_INTERACTIVE Or OPENUSERBROWSER_INCLUDE_NETWORK Or OPENUSERBROWSER_INCLUDE_ALIASES
Private Declare Function OpenUserBrowser _
Lib "netui2.dll" (lpOpenUserBrowser As Any) As Long
Private Declare Function EnumUserBrowserSelection _
Lib "netui2.dll" (ByVal hBrowser As Long, _
ByRef lpEnumUserBrowser As Any, _
ByRef cbSize As Long) As Long
Private Declare Function CloseUserBrowser _
Lib "netui2.dll" (ByVal hBrowser As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Type OPENUSERBROWSER_STRUCT
cbSize As Long
fCancelled As Long
Unknown As Long
hWndParent As Long
szTitle As Long
szDomainName As Long
dwFlags As Long
dwHelpID As Long
szHelpFile As Long
End Type
Private Type ENUMUSERBROWSER_STRUCT
SidType As Long
Sid1 As Long
Sid2 As Long
szFullName As Long
szUserName As Long
szDisplayName As Long
szDomainName As Long
szDescription As Long
sBuffer As String * 1000
End Type
Pri
vate Sub Command1_Click()
Dim sUsers As String
If GetBrowserNames(Me.hWnd, "\\shang", "Select Users & Groups Demo", sUsers) Then
Text1.Text = sUsers
End If
End Sub
Private Function GetBrowserNames(ByVal hParent As Long, _
ByVal sDomain As String, _
ByVal sTitle As String, _
sBuff As String) As Boolean
Dim hBrowser As Long
Dim browser As OPENUSERBROWSER_STRUCT
Dim enumb As ENUMUSERBROWSER_STRUCT
'initialize the OPENUSERBROWSER structure
With browser
.cbSize = Len(browser)
.fCancelled = 0
.Unknown = 0
.hWndParent = hParent
.szTitle = StrPtr(sTitle)
.szDomainName = StrPtr(sDomain)
.dwFlags = OPENUSERBROWSER_FLAGS
End With
'show the dialog function
hBrowser = OpenUserBrowser(browser)
'if not cancelled...
If browser.fCancelled = NERR_SUCCESS Then
'...retrieve any selections and populate
'the sBuff string passed to this function,
'returning True if successful.
Do While EnumUserBrowserSelection(hBrowser, enumb, Len(enumb) + 1) <> 0
'return selection as \\DOMAIN\NAME
'can be adjusted at will
sBuff = sBuff & GetPointerToByteStringW(enumb.szDomainName) & "\" & GetPointerToByteStringW(enumb.szUserName) & vbCrLf
GetBrowserNames = True
Loop
Call CloseUserBrowser(hBrowser)
'if desired, strip the last crlf from the string
If GetBrowserNames = True Then
sBuff = Left(sBuff, Len(sBuff) - 2)
End If
End If
End Function
Private Function GetPointerToByteStringW(ByVal dwData As Long) As String
Dim tmp() As Byte
Dim tmplen As Long
If dwData <> 0 Then
tmplen = lstrlenW(dwData) * 2
If tmplen <> 0 Then
ReDim tmp(0 To (tmplen - 1)) As Byte
CopyMemory tmp(0), ByVal dwData, tmplen
GetPointerToByteStringW = tmp
End If
End If
End Function
VB 根据TTF文件取得字体名称的模块 2/14
Option Explicit
'******************************************************************
'根据.ttf字体文件，取得字体名称。
'转载注明来源 Http://Www.YuLv.Net/
'******************************************************************
'Api 声明
Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal Length As Long)
Private Declare Function ntohl Lib "ws2_32.dll" (ByVal netlong As Long) As Long
Private Declare Function ntohs Lib "ws2_32.dll" (ByVal netshort As Integer) As Integer
'常量声明
Public Type OFFSET_TABLE
uMajorVersion As Integer
uMinorVersion As Integer
uNumOfTables As Integer
uSearchRange As Integer
uEntrySelector As Integer
uRangeShift As Integer
End Type
Public Type TABLE_DIRECTORY
szTag As String * 4
uCheckSum As Long
uOffset As Long
uLength As Long
End Type
Public Type NAME_TABLE_HEADER
uFSelector As Integer
uNRCount As Integer
uStorageOffset As Integer
End Type
Public Type NAME_RECORD
uPlatformID As Integer
uEncodingID As Integer
uLanguageID As Integer
uNameID As Integer
uStringLength As Integer
uStringOffset As Integer
End Type
'************************************************************
'转换字节顺序相关
'***********************************************************
Sub SwapLong(LongVal As Long)
LongVal = ntohl(LongVal)
End Sub
Sub SwapInt(IntVal As Integer)
IntVal = ntohs(IntVal)
End Sub
'************************************************************
'主要过程如下：
'***********************************************************
Function GetFontName(ByVal FontPath As String) As String
Dim TblDir As TABLE_DIRECTORY
Dim OffSetTbl As OFFSET_TABLE
Dim NameTblHdr As NAME_TABLE_HEADER
Dim NameRecord As NAME_RECORD
Dim FileNum As Integer
Dim lPosition As Long
Dim sFontTest As String
Dim X As Long
Dim I As Long
'以二进制的方式打开TTF文件
On Error GoTo Finished
FileNum = FreeFile
Open FontPath For Binary As FileNum
'读取第一个表头
Get #FileNum, , OffSetTbl
'检查版本是否为1.0
With OffSetTbl
SwapInt .uMajorVersion
SwapInt .uMinorVersion
SwapInt .uNumOfTables
If .uMajorVersion <> 1 Or .uMinorVersion <> 0 Then
Debug.Print FontPath & " -> 字体版本不正确, 无法取得字体名称!"
GoTo Finished
End If
End With
If OffSetTbl.uNumOfTables > 0 Then
For X = 0 To OffSetTbl.uNumOfTables - 1
Get #FileNum, , TblDir
If StrComp(TblDir.szTag, "name", vbTextCompare) = 0 Then
'如果找到了字体的名称偏移量则继续：
With TblDir
SwapLong .uLength
SwapLong .uOffset
If .uOffset Then
Get #FileNum, .uOffset + 1, NameTblHdr
SwapInt NameTblHdr.uNRCount
SwapInt NameTblHdr.uStorageOffset
For I = 0 To NameTblHdr.uNRCount - 1
Get #FileNum, , NameRecord
SwapInt NameRecord.uNameID
If NameRecord.uNameID = 1 Then
SwapInt NameRecord.uStringLength
SwapInt NameRecord.uStringOffset
lPosition = Loc(FileNum)
If NameRecord.uStringLength Then
sFontTest = Space$(NameRecord.uStringLength)
Get #FileNum, TblDir.uOffset + NameRecord.uStringOffset + NameTblHdr.uStorageOffset + 1, sFontTest
If Len(sFontTest) Then
GoTo Finished
End If
End If
'字符串为空，继续搜索。
Seek #FileNum, lPosition
End If
Next I
End If
End With
End If
Next X
End If
Finished:
Close #FileNum
GetFontName = sFontTest
End Function
VB 访问UTF文本文件的模块 2/14
支持UTF文本文件访问的模块
支持常见的ANSI、UTF-8、UTF-16LE、UTF-16BE这几种编码文本
【原理】
以二进制方式打开，判断BOM标记，自己写格式转换程序
对于UTF-8
可以以用MultiByteToWideChar将其转为Unicode格式，使用Windows2000新增代码页65001
对于UTF-16LE
VB的String用的就是UTF-16LE格式，先用字节数组读取文件内容，再直接给字符串变量赋值（sText = byBuf）
对于UTF-16BE
这是大端方式的UTF-16，先还是用字节数组读取文件内容，然后在字节数组中两个两个地交换相邻字节，再直接给字符串变量赋值
对于UTF-32
UTF-32采用的是4字节编码，只能手动转换，幸亏其不多见。
【代码】
Option Explicit
'mTextUTF.bas
'模块：UTF文本文件访问
'作者：zyl910
'版本：1.0
'日期：2006-1-23
'== 说明 ===================================================
'支持Unicode编码的文本文件读写。暂时支持ANSI、UTF-8、UTF-16LE、UTF-16BE这几种编码文本
'== 更新记录 ===============================================
'[V1.0] 2006-1-23
'1.支持最常见的ANSI、UTF-8、UTF-16LE、UTF-16BE这几种编码文本
'## 编译预处理常数 #########################################
'== 全局常数 ===============================================
'IncludeAPILib：引用了API库，此时不需要手动写API声明
'## API ####################################################
#If IncludeAPILib = 0 Then
'== File ===================================================
Private Declare Function CreateFile()Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle()Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReadFile()Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function WriteFile()Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function GetFileSize()Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function SetFilePointer()Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const Create_NEW = 1
Private Const Create_ALWAYS = 2
Private Const OPEN_EXISTING = 3
Private Const OPEN_ALWAYS = 4
Private Const TRUNCATE_EXISTING = 5
Priv
ate Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_BEGIN = 0
Private Const FILE_CURRENT = 1
Private Const FILE_END = 2
'== Unicode ================================================
Private Declare Function MultiByteToWideChar()Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByRef lpWideCharStr As Any, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte()Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpWideCharStr As Any, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByRef lpDefaultChar As Any, ByVal lpUsedDefaultChar As Long) As Long
Private Const CP_UTF8 As Long = 65001
#End If
'###########################################################
'Unicode编码格式
Public Enum UnicodeEncodeFormatEnum UnicodeEncodeFormat
UEF_ANSI = 0 'ANSI+DBCS
UEF_UTF8 'UTF-8
UEF_UTF16LE 'UTF-16LE
UEF_UTF16BE 'UTF-16BE
UEF_UTF32LE 'UTF-32LE
UEF_UTF32BE 'UTF-32BE
UEF_Auto = -1 '自动识别编码
'隐藏项目
[_UEF_Min] = UEF_ANSI
[_UEF_Max] = UEF_UTF32BE
End Enum
'ANSI+DBCS方式的文本所使用的代码页。默认为0，表示使用系统当前代码页。可以利用该参数实现读取其他代码编码的文本，比如想在 简体中文平台下 读取 繁体中文平台生成的txt，就将它设为950
Public UEFCodePage As Long
'判断BOM
'返回值：BOM所占字节
'dwFirst：[in]文件最开始的4个字节
'fmt：[out]返回编码类型
Public Function UEFCheckBOM()Function UEFCheckBOM(ByVal dwFirst As Long, ByRef fmt As UnicodeEncodeFormat) As Long
If dwFirst = &HFEFF& Then
fmt = UEF_UTF32LE
UEFCheckBOM = 4
ElseIf dwFirst = &HFFFE0000 Then
fmt = UEF_UTF32BE
UEFCheckBOM = 4
ElseIf (dwFirst And &HFFFF&) = &HFEFF& Then
fmt = UEF_UTF16LE
UEFCheckBOM = 2
ElseIf (dwFirst And &HFFFF&) = &HFFFE& Then
fmt = UEF_UTF16BE
UEFCheckBOM = 2
ElseIf (dwFirst And &HFFFFFF) = &HBFBBEF Then
fmt = UEF_UTF8
UEFCheckBOM = 3
Else
fmt = UEF_ANSI
UEFCheckBOM = 0
End If
End Function
'生成BOM
'返回值：BOM所占字节
'fmt：[in]编码类型
'dwFirst：[out]文件最开始的4个字节
Public Function UEFMakeBOM()Function UEFMakeBOM(ByVal fmt As UnicodeEncodeFormat, ByRef dwFirst As Long) As Long
Selec
t Case fmt
Case UEF_UTF8
dwFirst = &HBFBBEF
UEFMakeBOM = 3
Case UEF_UTF16LE
dwFirst = &HFEFF&
UEFMakeBOM = 2
Case UEF_UTF16BE
dwFirst = &HFFFE&
UEFMakeBOM = 2
Case UEF_UTF32LE
dwFirst = &HFEFF&
UEFMakeBOM = 4
Case UEF_UTF32BE
dwFirst = &HFFFE0000
UEFMakeBOM = 4
Case Else
dwFirst = 0
UEFMakeBOM = 0
End Select
End Function
'判断文本文件的编码类型
'返回值：编码类型。文件无法打开时，返回UEF_Auto
'FileName：文件名
Public Function UEFCheckTextFileFormat()Function UEFCheckTextFileFormat(ByVal FileName As String) As UnicodeEncodeFormat
Dim hFile As Long
Dim dwFirst As Long
Dim nNumRead As Long
'打开文件
hFile = CreateFile(FileName, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, ByVal 0&)
If INVALID_HANDLE_VALUE = hFile Then '文件无法打开
UEFCheckTextFileFormat = UEF_Auto
Exit Function
End If
'判断BOM
dwFirst = 0
Call ReadFile(hFile, dwFirst, 4, nNumRead, ByVal 0&)
nNumRead = UEFCheckBOM(dwFirst, UEFCheckTextFileFormat)
'Debug.Print nNumRead
'关闭文件
Call CloseHandle(hFile)
End Function
'读取文本文件
'返回值：读取的文本。返回vbNullString表示文件无法打开
'FileName：[in]文件名
'fmt：[in,out]使用何种文本编码格式来读取文本。为UEF_Auto时表示自动判断，且在fmt参数返回文本所用编码格式
Public Function UEFLoadTextFile()Function UEFLoadTextFile(ByVal FileName As String, Optional ByRef fmt As UnicodeEncodeFormat = UEF_Auto) As String
Dim hFile As Long
Dim nFileSize As Long
Dim nNumRead As Long
Dim dwFirst As Long
Dim CurFmt As UnicodeEncodeFormat
Dim cbBOM As Long
Dim cbTextData As Long
Dim CurCP As Long
Dim byBuf() As Byte
Dim cchStr As Long
Dim I As Long
Dim byTemp As Byte
'判断fmt范围
If fmt <> UEF_Auto Then
If fmt < [_UEF_Min] Or fmt > [_UEF_Max] Then
GoTo FunEnd
End If
End If
'打开文件
hFile = CreateFile(FileName, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, ByVal 0&)
If INVALID_HANDLE_VALUE = hFile Then '文件无法打开
GoTo FunEnd
End If
'判断文件大小
nFileSize = GetFileSize(hFile, nNumRead)
If nNumRead <> 0 Then '超过4GB
GoTo FreeHandle
End If
If nFileSize < 0 Then '超过2GB
GoTo FreeHandle
End If
'判断BOM
dwFirst = 0
Call ReadFile(hFile, dwFirst, 4, nNumRead, ByVal 0&)
cbBOM = UEFCheckBOM(dwFirst, Cur
Fmt)
'恢复文件指针
If fmt = UEF_Auto Then '自动判断
fmt = CurFmt
'cbBOM = cbBOM
Else '手动设置编码
If fmt = CurFmt Then '若编码相同，则忽略BOM标记
'cbBOM = cbBOM
Else '编码不同，那么都是数据
cbBOM = 0
End If
End If
Call SetFilePointer(hFile, cbBOM, ByVal 0&, FILE_BEGIN)
cbTextData = nFileSize - cbBOM
'读取数据
UEFLoadTextFile = ""
Select Case fmt
Case UEF_ANSI, UEF_UTF8
'判断应使用的CodePage
CurCP = IIf(fmt = UEF_UTF8, CP_UTF8, UEFCodePage)
'分配缓冲区
On Error GoTo FreeHandle
ReDim byBuf(0 To cbTextData - 1)
On Error GoTo 0
'读取数据
nNumRead = 0
Call ReadFile(hFile, byBuf(0), cbTextData, nNumRead, ByVal 0&)
'取得Unicode文本长度
cchStr = MultiByteToWideChar(CurCP, 0, byBuf(0), nNumRead, ByVal 0&, ByVal 0&)
If cchStr > 0 Then
'分配字符串空间
On Error GoTo FreeHandle
UEFLoadTextFile = String$(cchStr, 0)
On Error GoTo 0
'取得文本
cchStr = MultiByteToWideChar(CurCP, 0, byBuf(0), nNumRead, ByVal StrPtr(UEFLoadTextFile), cchStr + 1)
End If
Case UEF_UTF16LE
cchStr = (cbTextData + 1) 2
'分配字符串空间
On Error GoTo FreeHandle
UEFLoadTextFile = String$(cchStr, 0)
On Error GoTo 0
'取得文本
nNumRead = 0
Call ReadFile(hFile, ByVal StrPtr(UEFLoadTextFile), cbTextData, nNumRead, ByVal 0&)
'修正文本长度
cchStr = (nNumRead + 1) 2
If cchStr > 0 Then
If Len(UEFLoadTextFile) > cchStr Then
UEFLoadTextFile = Left$(UEFLoadTextFile, cchStr)
End If
Else
UEFLoadTextFile = ""
End If
Case UEF_UTF16BE
'分配缓冲区
On Error GoTo FreeHandle
ReDim byBuf(0 To cbTextData - 1)
On Error GoTo 0
'读取数据
nNumRead = 0
Call ReadFile(hFile, byBuf(0), cbTextData, nNumRead, ByVal 0&)
If nNumRead > 0 Then
'隔两字节翻转相邻字节
For I = 0 To nNumRead - 1 - 1 Step 2 '再-1是为了避免最后多出的那个字节
byTemp = byBuf(I)
byBuf(I) = byBuf(I + 1)
byBuf(I + 1) = byTemp
Next I
'取得文本
UEFLoadTextFile = byBuf 'VB允许String中的字符串数
VB 通用枚举进程模块 2/14
复制如下代码，保存至 mProcess.bas 中。
Option Explicit
'************************************* 用于枚举进程*********************************
'CreateToolhelpSnapshot为指定的进程、进程使用的堆[HEAP]、模块[MODULE]、线程[THREAD]）建立一个快照[snapshot]。
'参数：
'dwFlags
'TH32CS_INHERIT -声明快照句柄是可继承的
'TH32CS_SNAPall -在快照中包含系统中所有的进程和线程
'TH32CS_SNAPheaplist -在快照中包含在th32ProcessID中指定的进程的所有的堆
'TH32CS_SNAPmodule -在快照中包含在th32ProcessID中指定的进程的所有的模块
'TH32CS_SNAPPROCESS -在快照中包含系统中所有的进程
'TH32CS_SNAPthread -在快照中包含系统中所有的线程
'th32ProcessID
'[输入]指定将要快照的进程ID。如果该参数为0表示快照当前进程。
'该参数只有在设置了TH32CS_SNAPHEAPLIST或TH32CS_SNAPMOUDLE后才有效，在其他情况下该参数被忽略，所有的进程都会被快照。
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
'获得系统快照中的第一个进程的信息
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
'获得系统快照中的下一个进程的信息
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
'参数: Handle hSnapshot传入的Snapshot句柄
'参数：LPMODULEENTRY3 lpme 指向一个 MODULEENTRY32结构的指针
'作用：从Snapshot得到第一个进程记录信息
Private Declare Function Module32First Lib "kernel32" (ByVal hSnapShot As Long, lppe As MODULEENTRY32) As Long
'参数: Handle hSnapshot传入的Snapshot句柄
'参数：LPMODULEENTRY3 lpme 指向一个 MODULEENTRY32结构的指针
'作用: 从Snapshot得到下一个Module记录信息
Private Declare Function Module32Next Lib "kernel32" (ByVal hSnapShot As Long, lppe As MODULEENTRY32) As Long
'关闭句柄
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Type PROCESSENTRY32
dwSize As Long '结构大小
cntUsage As Long '此进程的引用计数
th32ProcessID As Long '进程ID
th32DefaultHeapID As Long '进程默认堆ID
th32ModuleID As Long '进程模块ID
cntThreads As Long '此进程开启的线程计数
th32ParentProcessID As Long '父进程ID
pcPriClassBase As Long '线程优先权
dwFlags As Long '保留
szExeFile As String * 260 '进程全名
End Type
Private Const TH32CS_SNAPPROCESS = &H2 'TH32CS_SNAPPROCESS -在快照中包含系统中所有的进程?
Private Const TH32CS_SNAPmodule = &H8 '表示对象为由th32ProcessID参数指定的进程调用的所有模块
Private Type MODULEENTRY32
dwSize As Long '指定结构的大小，在调用Module32First前需要设置，否则将会失败
th32ModuleID As Long '模块号
th32ProcessID As Long '包含本模块的进程号
GlblcntUsage As Long '本模块的全局引用计数
ProccntUsage As Long '包含模块的进程上下文中的模块引用计数
modBaseAddr As Byte '模块基地址
modBaseSize As Long '模块大小（字节数）
hModule olor="#0000FF">As Long '包含模块的进程上下文中的hModule句柄
szModule As String * 256 '模块名
szExePath As String * 1024 '模块对应的文件名和路径
End Type
'*************************************************************************
'**函 数 名： GetProcess
'**输 入： ByVal frmRuningProcess(Form) - 直接传入各对象名
'** ： ByVal treProcess(TreeView) -
'** ： ByVal lblProcessNumber(Label) -
'**输 出： 无
'**功能描述：建立进程树结构
'**全局变量：
'**调用模块：
'**作 者： Mr.David
'**日 期： 2007-11-27 14:09:37
'**修 改 人：
'**日 期：
'**版 本： V1.0.0
'*************************************************************************
Public Sub GetProcess(ByVal frmRuningProcess As Form, ByVal treProcess As TreeView, ByVal lblProcessNumber As Label)
Dim lngResult As Long
Dim hSnapShot As Long '这些定义和VB定义有点不同，由于是Api使用，那就保留其所有权了。
Dim hMSnapshot As Long
Dim strTreTxt As String
Dim lngRet As Long
Dim treNode As Node
Dim lngProcCount As Long
Dim strTreKey As String
Dim MEY As MODULEENTRY32
Dim PEE As PROCESSENTRY32
On Error GoTo PROC_ERR
hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0) '快照所有进程
PEE.dwSize = Len(PEE)
MEY.dwSize = Len(MEY)
lngResult = ProcessFirst(hSnapShot, PEE) '获取第一进程
'外循环读取进程名
Do While lngResult <> 0
lngProcCount = lngProcCount + 1 '累计进程数
hMSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPmodule, PEE.th32ProcessID) '快照当前进程模块
MEY.szExePath = Space$(256)
strTreKey = PEE.szExeFile '对树根关键字采用的PEE.szExeFile，注意运行同一程序多个实例会转入PROC_ERR处理
strTreTxt = PEE.szExeFile
Set treNode = treProcess.Nodes.Add(, , strTreKey, strTreTxt) '进程树根是进程名
lngRet = Module32First(hMSnapshot, MEY)
'内循环读取模块名
Do While lngRet > 0
'注意一个进程的最后一个模块列出后继续列出下一个会出现类似 ??1??鏴? 的名称，这显然不是我们需要的，排除了。
'另外TreeView控件会自己处理文件名的Chr(0)字符，我们就由它处理了。
If InStr(1, MEY.szExePath, "?") = 0 Then
Set treNode = treProcess.Nodes.Add(strTreKey, tvwChild, , MEY.szExePath) '列出模块
End If
lngRet = Module32Next(hMSnapshot, MEY) '获取下一模块
Loop
'treNode.EnsureVisible '展开分支,可以选用这句
Call CloseHandle(hMSnapshot) '关闭模块快照句柄
lngResult = ProcessNext(hSnapShot, PEE) '获取下一进程
Loop
Call CloseHandle(hSnapShot) '关闭进程快照句柄
lblProcessNumber.Caption = "当前进程数：" & lngProcCount
lblProcessNumber.Visible = True
Exit Sub
PROC_ERR:
'如果发生集合中的关键字不唯一，则关键字重命名，比如Nt系统会存在多个Svchost进程，此关键字这里不重要，随便处理一下
If Err.Number = 35602 Then strTreKey = strTreKey & "1"
Resume
End Sub
调用例子：
'先分别添加一个TreeView命名为treProcess，和Label命名为lblProcessNumber。
treProcess.Nodes.Clear
Call GetProcess(frmRuningProcess, treProcess, lblProcessNumber)
让别的程序在你的窗口里运行，设置父窗口。 2/13
'本示例演示把指定名称的任意窗体包容进来.
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Const GWL_STYLE = (-16)
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_VISIBLE = &H10000000
Private Sub Form_Load()
Dim Handle As Long, Ret As Long
'根据窗口标题获取窗体句柄
Handle = FindWindow(vbNullString, "好无聊哇！")
If Handle = 0 Then Exit Sub
Ret = SetWindowLong(Handle, GWL_STYLE, WS_VISIBLE Or WS_CLIPSIBLINGS)
'插入指定的窗体
SetParent Me.hWnd, Handle
Form1.Move 4000, 5000, 320, 320
End Sub
'WMI检查本机是否安装了.NET Framework
Public Function IsMSFrameworkInstalled() As Boolean
On Error Resume Next
Dim objWMIService
Dim colItems
Dim objItem
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_Product")
For Each objItem In colItems
If InStr(objItem.Name, "Microsoft .NET Framework") > 0 Then
IsMSFrameworkInstalled = True
End If
Next
End Function
调用：
MsgBox IsMSFrameworkInstalled()
