UNKNOWN '************************************** ' Name: Load/Save VB/Unicode strings to ' file ' Description:VB (and Windows) use UTF16 ' Little Endien strings. This will load/sa ' ve those to file with the correct BOM (B ' yte Order Mark) to indicate the type of ' file. Or convert to Big Endien. UTF-8, o ' r Ansi instead. These are the 4 formats ' Notepad supports - so you can use Notepa ' d to test/examine the results. ' By: Je. ' ' ' Inputs:None ' ' Returns:None ' 'Assumes:None ' 'Side Effects:None 'This code is copyrighted and has limite ' d warranties. 'Please see http://www.Planet-Source-Cod ' e.com/xq/ASP/txtCodeId.74535/lngWId.1/qx ' /vb/scripts/ShowCode.htm '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 - ge ' t length required 'note MultiByteToWideChar may not handle ' d 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 t ' o that 'in the call or change the default to UT ' F16LEnoBOM 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 in ' volved method than here would run throug ' h 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 handle ' d 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, TextE ' ncodings.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