'保存文本文件
'返回值:是否成功
'FileName:[in]文件名
'sText:[in]欲输出的文本
'IsAppend:[in]是否是添加方式
'fmt:[in,out]使用何种文本编码格式来存储文本。当IsAppend=True时允许UEF_Auto自动判断,且在fmt参数返回文本所用编码格式
'DefFmt:[in]当使用添加模式时,若文件不存在且fmt = UEF_Auto时应使用的编码格式
Public Function UEFSaveTextFile(ByVal FileName As String, _
ByRef sText As String, Optional ByVal IsAppend As Boolean = False, _
Optional ByRef fmt As UnicodeEncodeFormat = UEF_Auto, Optional ByVal DefFmt As UnicodeEncodeFormat = UEF_ANSI) As Boolean
Dim hFile As Long
Dim nFileSize As Long
Dim nNumRead As Long
Dim dwFirst As Long
Dim cbBOM As Long
Dim CurCP As Long
Dim byBuf() As Byte
Dim cbBuf As Long
Dim I As Long
Dim byTemp As Byte
'判断fmt范围
If IsAppend And (fmt = UEF_Auto) Then
Else
If fmt < [_UEF_Min] Or fmt > [_UEF_Max] Then
GoTo FunEnd
End If
End If
'打开文件
hFile = CreateFile(FileName, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, IIf(IsAppend, OPEN_ALWAYS, CREATE_ALWAYS), FILE_ATTRIBUTE_NORMAL, ByVal 0&)
If INVALID_HANDLE_VALUE = hFile Then '文件无法打开
GoTo FunEnd
End If
'判断文件大小
nFileSize = GetFileSize(hFile, nNumRead)
If nFileSize = 0 And nNumRead = 0 Then '文件大小为0字节
IsAppend = False '此时需要写BOM标志
If fmt = UEF_Auto Then fmt = DefFmt
End If
'判断BOM
If IsAppend And (fmt = UEF_Auto) Then
dwFirst = 0
Call ReadFile(hFile, dwFirst, 4, nNumRead, ByVal 0&)
cbBOM = UEFCheckBOM(dwFirst, fmt)
ElseIf IsAppend = False Then
cbBOM = UEFMakeBOM(fmt, dwFirst)
End If
Case UEF_UTF32LE
UEFSaveTextFile = False '暂时不支持
Case UEF_UTF32BE
UEFSaveTextFile = False '暂时不支持
Case Else
Debug.Assert False
End Select
Else
UEFSaveTextFile = True
End If
'读取文本文件
'返回值:读取的文本。返回vbNullString表示文件无法打开
'FileName:[in]文件名
'fmt:[in,out]使用何种文本编码格式来读取文本。为UEF_Auto时表示自动判断,且在fmt参数返回文本所用编码格式
Public 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
'修正文本长度
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
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
'## API ####################################################
#If IncludeAPILib = 0 Then
'== File ===================================================
Private Declare 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 Lib "kernel32" (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, ByVal lpOverlapped As Long) As Long
Private Declare 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 Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare 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 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
'ANSI+DBCS方式的文本所使用的代码页。默认为0,表示使用系统当前代码页。可以利用该参数实现读取其他代码编码的文本,比如想在 简体中文平台下 读取 繁体中文平台生成的txt,就将它设为950
Public UEFCodePage As Long
'判断BOM
'返回值:BOM所占字节
'dwFirst:[in]文件最开始的4个字节
'fmt:[out]返回编码类型
Public 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(ByVal fmt As UnicodeEncodeFormat, ByRef dwFirst As Long) As Long
Select 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(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
注册表的:
'This program needs 3 buttons
Const REG_SZ = 1 ' Unicode nul terminated string
Const REG_BINARY = 3 ' Free form binary
Const HKEY_CURRENT_USER = &H80000001
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private 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
Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long
'retrieve nformation about the key
lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize)
If lResult = 0 Then
If lValueType = REG_SZ Then
'Create a buffer
strBuf = String(lDataBufSize, Chr$(0))
'retrieve the key's content
lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize)
If lResult = 0 Then
'Remove the unnecessary chr$(0)'s
RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
End If
ElseIf lValueType = REG_BINARY Then
Dim strData As Integer
'retrieve the key's value
lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize)
If lResult = 0 Then
RegQueryStringValue = strData
End If
End If
End If
End Function
Function GetString(hKey As Long, strPath As String, strValue As String)
Dim Ret
'Open the key
RegOpenKey hKey, strPath, Ret
'Get the key's content
GetString = RegQueryStringValue(Ret, strValue)
'Close the key
RegCloseKey Ret
End Function