Макросы в Excel VBA Макросы Смена кодировки

Смена кодировки

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