Смена кодировки
Excel всё норовит сохранять текстовые файлы в Winodws-1251. Очень актуален вопрос преобразования текста в другие кодировки, в первую очередь в UTF-8.
Вот несколько полезных функций для решения подобных вопросов:
Перекодировка файла из кодировки SourceCharset$ в UTF-8
'filename - путь к файлу
'SourceCharset - исходная кодировка (необязательный параметр)
'BomDelete - удалять ли BOM?
Function ChangeFileCharset_UTF8noBOM(ByVal filename$, _
Optional ByVal SourceCharset$, _
Optional BomDelete As Boolean = True) As Boolean
On Error Resume Next: Err.Clear
Dim DestCharset As String 'Кодировка
DestCharset = "utf-8"
Dim FileContent As Variant
With CreateObject("ADODB.Stream")
.Type = 2
'Исходная кодировка, если указана
If Len(SourceCharset$) Then .Charset = SourceCharset$
.Open
.LoadFromFile filename$ 'Загружаем данные из файла
'Считываем текст в переменную FileContent
FileContent = .ReadText
.Close 'Закрываепм файл
'Назначаем файлу новую кодировку "utf-8"
.Charset = DestCharset
.Open 'Снова открываепм файл
'Записываем текст в файл в новой кодировке
.WriteText FileContent
'Удалить BOM?
If BomDelete Then
Dim binaryStream As Object
Set binaryStream = CreateObject("ADODB.Stream")
binaryStream.Type = 1
binaryStream.Mode = 3
binaryStream.Open
'Удаляем BOM байты
.Position = 3
.CopyTo binaryStream
.Flush
.Close
binaryStream.SaveToFile filename$, 2
binaryStream.Close
End If
End With
ChangeFileCharset_UTF8noBOM = Err = 0
End Function
Сохраняет текст в указанной кодировке в файл
'Функция сохраняет текст txt
'в кодировке Charset$ в файл filename$
'koi8-r, ascii, utf-7, utf-8, utf-8noBOM,
'utf-16, windows-1251, unicode и другие
Function SaveTextToFile(ByVal txt$, ByVal filename$, _
Optional ByVal encoding$ = "utf-8noBOM") As Boolean
Dim FSO As Object
Dim ts As Object
Dim binaryStream As Object
On Error Resume Next: Err.Clear
Select Case encoding$
Case "windows-1251", "", "ansi"
Set FSO = CreateObject("scripting.filesystemobject")
Set ts = FSO.CreateTextFile(filename, True)
ts.Write txt: ts.Close
Set ts = Nothing: Set FSO = Nothing
Case "utf-16", "utf-16LE"
Set FSO = CreateObject("scripting.filesystemobject")
Set ts = FSO.CreateTextFile(filename, True, True)
ts.Write txt: ts.Close
Set ts = Nothing: Set FSO = Nothing
Case "utf-8noBOM"
With CreateObject("ADODB.Stream")
.Type = 2: .Charset = "utf-8": .Open
.WriteText txt$
Set binaryStream = CreateObject("ADODB.Stream")
binaryStream.Type = 1: binaryStream.Mode = 3
binaryStream.Open:
.Position = 3: .CopyTo binaryStream 'Skip BOM bytes
.Flush: .Close
binaryStream.SaveToFile filename$, 2
binaryStream.Close
End With
Case Else
With CreateObject("ADODB.Stream")
.Type = 2: .Charset = encoding$: .Open
.WriteText txt$
'Сохраняем файл в заданной кодировке
.SaveToFile filename$, 2
.Close
End With
End Select
SaveTextToFile = Err = 0: DoEvents
End Function
Перекодировка строки
Function ChangeTextCharset(ByVal txt$, ByVal DestCharset$, _
Optional ByVal SourceCharset$) As String
If Trim(txt$) = "" Then
ChangeTextCharset = ""
Else
On Error Resume Next: Err.Clear
With CreateObject("ADODB.Stream")
.Type = 2
.Mode = 3
'Исходная кодировка
If Len(SourceCharset$) Then .Charset = SourceCharset$
.Open
.WriteText txt$
.Position = 0
.Charset = DestCharset$ 'Назначаем новую кодировку
ChangeTextCharset = .ReadText
.Close
End With
End If
End Function
Перекодировка файла
'False если не получилось
Function ChangeFileCharset(filename As String, _
DestCharset As String, _
Optional SourceCharset As String) As Boolean
Dim FileContent As String 'Содержимое файла
On Error Resume Next: Err.Clear
With CreateObject("ADODB.Stream")
.Type = 2
'Если начальная кодировка задана явно то отмечаем её
If Len(SourceCharset) Then .Charset = SourceCharset
.Open 'Открываем объект ADO
.LoadFromFile filename 'Загружаем в объект файл
FileContent = .ReadText 'Извлекаем контент
.Close 'Закрываем объект
.Charset = DestCharset 'Переустанавливаем кодировку
.Open 'Снова открываем
.WriteText FileContent 'Записываем в него контент
.SaveToFile filename 'Сохраняем по тому же путив файл
.Close 'Окончательно закрываем
End With
ChangeFileCharset = Err = 0 'Успешно?
End Function