没试过，网上流传的代码。估计是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中的字符串数

阅读全文