'**************************************
' Name: Load/Save VB/Unicode strings to file
' Description:VB (and Windows) use UTF16 Little Endien strings. This will load/save those to file with the correct BOM (Byte Order Mark) to indicate the type of file. Or convert to Big Endien. UTF-8, or Ansi instead. These are the 4 formats Notepad supports - so you can use Notepad to test/examine the results.
' By: Je.
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=74535&lngWId=1'for details.'**************************************
Option Explicit
Public Enum TextEncodings 'custom enum
UnknownF
ansiF
UTF8F
UTF16LE
UTF16BigE
UTF16LEnoBOM
End Enum
Private Const CP_ACP = 0, CP_UTF7 = 65000, CP_UTF8 = 65001 'CodePage
Private Const FILE_BEGIN = 0, FILE_SHARE_READ = &H1, FILE_SHARE_WRITE = &H2
Private Const CREATE_NEW = 1, CREATE_ALWAYS = 2, OPEN_EXISTING = 3
Private Const GENERIC_READ = &H80000000, GENERIC_WRITE = &H40000000
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar 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 Any) 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 Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, 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 SetFilePointer Lib "kernel32" (ByVal HFILE As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal HFILE As Long, lpFileSizeHigh As Long) As Long
Function SaveText(pth As String, st As String, TextEncoding As TextEncodings) As Boolean
Dim HFILE As Long, nob As Long, b() As Byte, bb() As Byte, lenbb As Long, lenst As String, res As Long
lenst = Len(st)
HFILE = CreateFile(pth, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, CREATE_ALWAYS, 0, 0)
Select Case TextEncoding
Case TextEncodings.UTF16LE
ReDim b(1): b(0) = &HFF: b(1) = &HFE
WriteFile HFILE, b(0), 2, nob, ByVal 0& 'write BOM
lenst = lenst * 2
Case TextEncodings.UTF16BigE
swapendiens st
ReDim b(1): b(0) = &HFE: b(1) = &HFF 'write BOM
WriteFile HFILE, b(0), 2, nob, ByVal 0&
lenst = lenst * 2
Case TextEncodings.UTF16LEnoBOM: lenst = lenst * 2
Case TextEncodings.ansiF: st = StrConv(st, vbFromUnicode)
Case TextEncodings.UTF8F
'use WideCharToMultiByte to convert - get length required
'note MultiByteToWideChar may not handled malformed UTF-8 very well
res = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(st), lenst, 0, lenbb, ByVal 0&, ByVal 0&) 'get required buffer size
If res = 0 Then GoTo FINISH
lenbb = res: ReDim bb(lenbb - 1) 'redim for length and process string
res = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(st), lenst, ByVal VarPtr(bb(0)), lenbb, ByVal 0&, ByVal 0&)
ReDim b(2): b(0) = &HEF: b(1) = &HBB: b(2) = &HBF 'prepare and write BOM for utf8
WriteFile HFILE, b(0), 3, nob, ByVal 0&
WriteFile HFILE, ByVal VarPtr(bb(0)), lenbb, nob, ByVal 0& 'write converted string
SaveText = True
GoTo FINISH
End Select
WriteFile HFILE, ByVal StrPtr(st), lenst, nob, ByVal 0& 'write string
SaveText = True 'I haven't handled every possible bad api return and error but hopefully...
FINISH:
CloseHandle HFILE
End Function
Function openText(pth As String, st As String, Optional TextEncoding As TextEncodings = UnknownF) As Boolean
'assumes ANSI if nothing else. If using UTF16LEnoBOM you must set textencoding to that
'in the call or change the default to UTF16LEnoBOM
Dim HFILE As Long, nob As Long, b(1) As Byte, b2 As Byte, res As Long
Dim bb() As Byte, slen As Long, lenbb As Long, fsize As Long, pointerpos As Variant
If Dir(pth, vbNormal) = "" Then Exit Function
HFILE = CreateFile(pth, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
fsize = GetFileSize(HFILE, ByVal 0&)
If TextEncoding = TextEncodings.UnknownF Then
'try and work out file format (a more involved method than here would run through the file)
If fsize >= 2 Then
ReadFile HFILE, b(0), 2, nob, ByVal 0& 'get and check for BOM
If b(0) = &HFF And b(1) = &HFE Then
TextEncoding = TextEncodings.UTF16LE
ElseIf b(0) = &HFE And b(1) = &HFF Then
TextEncoding = TextEncodings.UTF16BigE
Else
TextEncoding = TextEncodings.ansiF
If fsize >= 3 Then
ReadFile HFILE, b2, 1, nob, ByVal 0& 'check for longer BOM
If b(0) = &HEF And b(1) = &HBB And b2 = &HBF Then TextEncoding = TextEncodings.UTF16BigE
End If
End If
Else
TextEncoding = TextEncodings.ansiF 'assume ANSI if nothing else.
End If
End If
pointerpos = Array(0, 0, 3, 2, 2, 0) 'byte to move to depending on length of BOM
fsize = fsize - pointerpos(TextEncoding)
If fsize <= 0 Then Exit Function
st = String((fsize \ 2) + (1 * (fsize And 1)), Chr(0)) 'prepare buffer
SetFilePointer HFILE, pointerpos(TextEncoding), 0, FILE_BEGIN 'set pointer to past BOM
ReadFile HFILE, ByVal StrPtr(st), fsize, nob, ByVal 0& 'read file
CloseHandle HFILE
Select Case TextEncoding
Case TextEncodings.ansiF: st = StrConv(st, vbUnicode)
Case TextEncodings.UTF16BigE: swapendiens st
Case TextEncodings.UTF8F
'use MultiByteToWideChar to convert
'note MultiByteToWideChar may not handled malformed UTF-8 very well
res = MultiByteToWideChar(CP_UTF8, 0&, ByVal StrPtr(st), fsize, ByVal 0&, lenbb) 'get required buffer size
If res = 0 Then Exit Function 'bad return
lenbb = (res * 2) - 1: ReDim bb(lenbb)
res = MultiByteToWideChar(CP_UTF8, 0&, ByVal StrPtr(st), fsize, ByVal VarPtr(bb(0)), lenbb)
st = bb
'bCase TextEncodings.UTF16LEnoBOM, TextEncodings.UTF16LE nothing to do
End Select
openText = True 'I haven't handled every possible bad api return and error but hopefully...
End Function
Sub swapendiens(st As String) 'swap every pair of bytes.
Dim b1() As Byte, b2() As Byte, c As Long, i As Long
c = 1: b1 = st: ReDim b2(UBound(b1))
For i = 0 To UBound(b1) - 1 Step 2
b2(i) = b1(c): b2(c) = b1(i): c = c + 2
Next
st = b2
End Sub
|
