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;
}



'模块名: 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



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



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




支持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中的字符串数



复制如下代码,保存至 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)

'本示例演示把指定名称的任意窗体包容进来.
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()



下面这条正则表达式牛啊,判断YYYY-MM-DD这种格式的,基本上把闰年和2月等的情况都考虑进去了:

^((((1[6-9]|[2-9]\d)\d{2})-(0?[13578]|1[02])-(0?[1-9]|[12]\d|3[01]))|(((1[6-9]|[2-9]\d)\d{2})-(0?[13456789]|1[012])-(0?[1-9]|[12]\d|30))|(((1[6-9]|[2-9]\d)\d{2})-0?2-(0?[1-9]|1\d|2[0-8]))|(((1[6-9]|[2-9]\d)(0[48]|[2468][048]|[13579][26])|((16|[2468][048]|[3579][26])00))-0?2-29-))$


JiaJia: 我看到这一串东西,彻底无语...暴强~乱得我都看不下去了...