Vba windows 1251 to utf 8

Смена кодировки строки с UTF-8 на ANSI (Windows-1251) и преобразование кодировки текста ANSI (Windows-1251) в UTF-8.

Перекодировка строки с UTF-8 в ANSI (Windows-1251) может понадобиться в VBA, например, при загрузке данных из CSV-файла с кодировкой UTF-8 на рабочий лист книги Excel.

Изменение кодировки текста UTF-8 на ANSI (Windows-1251) для 32-разрядных платформ:

Private Declare Function MultiByteToWideChar Lib «kernel32.dll» (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long Function FromUTF8(ByVal sText As String) As String Dim nRet As Long, strRet As String     strRet = String(Len(sText), vbNullChar)     nRet = MultiByteToWideChar(65001, &H0, sText, Len(sText), StrPtr(strRet), Len(strRet)) FromUTF8 = Left(strRet, nRet) End Function

Пример перекодировки строки с UTF-8 в ANSI (Windows-1251):

Sub Primer() Dim num1 As Integer, a1 As String, str1 As String     ‘Выбираем файл CSV с кодировкой UTF-8     a1 = Application.GetOpenFilename(«Текст с разделителями,*.csv», , «Выбор файла»)         If Right(a1, 4) <> «.csv» Then Exit Sub     ‘Открываем файл и считываем текст в переменную     num1 = FreeFile         Open a1 For Input As num1             str1 = Input(LOF(num1), num1)         Close num1     ‘Меняем кодировку с UTF-8 на Windows-1251     str1 = FromUTF8(str1)     ‘Работаем с текстом и вставляем нужные значения на рабочий лист End Sub

Преобразование кодировки ANSI в UTF-8

Изменение кодировки текста ANSI (Windows-1251) на UTF-8 для 32-разрядных платформ:

Private Declare Function WideCharToMultiByte Lib «kernel32.dll» (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long Function ToUTF8(ByVal sText As String) As String Dim nRet As Long, strRet As String     strRet = String(Len(sText) * 2, vbNullChar)     nRet = WideCharToMultiByte(65001, &H0, StrPtr(sText), Len(sText), StrPtr(strRet), Len(sText) * 2, 0&, 0&)     ToUTF8 = Left(StrConv(strRet, vbUnicode), nRet) End Function

Пример перекодировки строки с ANSI (Windows-1251) в UTF-8:

Изменение кодировки в 64-разрядных системах

Если у вас 64-разрядная версия VBA Excel, добавьте ключевое слово PtrSafe после оператора Declare и замените тип данных Long на LongPtr:

Private Declare PtrSafe Function MultiByteToWideChar Lib «kernel32.dll» (ByVal CodePage As LongPtr, ByVal dwFlags As LongPtr, ByVal lpMultiByteStr As String, ByVal cchMultiByte As LongPtr, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As LongPtr) As LongPtr Private Declare PtrSafe Function WideCharToMultiByte Lib «kernel32.dll» (ByVal CodePage As LongPtr, ByVal dwFlags As LongPtr, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As LongPtr, ByVal lpMultiByteStr As LongPtr, ByVal cchMultiByte As LongPtr, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As LongPtr

В среде разработки VBA 7 тип данных LongPtr на 32-разрядных платформах интерпретируется как Long, а в 64-разрядных — как LongLong.

---

Функции ChangeFileCharset и ChangeTextCharset предназначены для изменения кодировки символов в текстовых файлах и строках.

Исходную и конечную (желаемую) кодировку можно задать в параметрах вызова функций.

ВНИМАНИЕ: Новая (универсальная) версия функции сохранения текста в файл в заданной кодировке:
http://excelvba.ru/code/SaveTextToFile

Список доступных на вашем компьютере кодировок можно найти в реестре Windows в ветке
HKEY_CLASSES_ROOTMIMEDatabaseCharset

Среди доступных кодировок есть koi8-r, ascii, utf-7, utf-8, Windows-1250, Windows-1251, Windows-1252, и т.д. и т.п.

Определить исходную и конечную кодировку можно, воспользовавшись онлайн-декодером:
http://www.artlebedev.ru/tools/decoder/advanced/
(после преобразования снизу будет написано, из какой кодировки в какую переведён текст)

Sub ПримерИспользования_ChangeTextCharset()

    ИсходнаяСтрока = "бНОПНЯ"

    ' вызываем функцию ChangeTextCharset с указанием кодировок

    ' (меняем кодировку с KOI8-R на Windows-1251)

    ПерекодированнаяСтрока = ChangeTextCharset(ИсходнаяСтрока, "Windows-1251", "KOI8-R")

    MsgBox "Результат перекодировки: """ & ПерекодированнаяСтрока & """", _

           vbInformation, "Исходная строка: """ & ИсходнаяСтрока & """"

End Sub

Function ChangeFileCharset(ByVal filename$, ByVal DestCharset$, _

                           Optional ByVal SourceCharset$) As Boolean

    ' функция перекодировки (смены кодировки) текстового файла

    ' В качестве параметров функция получает путь filename$ к текстовому файлу,

    ' и название кодировки DestCharset$ (в которую будет переведён файл)

    ' Функция возвращает TRUE, если перекодировка прошла успешно

    On Error Resume Next: Err.Clear

    With CreateObject("ADODB.Stream")

        .Type = 2

        If Len(SourceCharset$) Then .Charset = SourceCharset$    ' указываем исходную кодировку

        .Open

        .LoadFromFile filename$    ' загружаем данные из файла

        FileContent$ = .ReadText   ' считываем текст файла в переменную FileContent$

        .Close

        .Charset = DestCharset$    ' назначаем новую кодировку

        .Open

        .WriteText FileContent$

        .SaveToFile filename$, 2   ' сохраняем файл уже в новой кодировке

        .Close

    End With

    ChangeFileCharset = Err = 0

End Function

Function ChangeTextCharset(ByVal txt$, ByVal DestCharset$, _

                           Optional ByVal SourceCharset$) As String

    ' функция перекодировки (смены кодировки) текстовоq строки

    ' В качестве параметров функция получает текстовую строку txt$,

    ' и название кодировки DestCharset$ (в которую будет переведён текст)

    ' Функция возвращает текст в новой кодировке

    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 Function

‘ Функция для перекодировки файла в UTF-8 без BOM (то же самое, что и UTF-8, только без первых 3 байтов)

Function ChangeFileCharset_UTF8noBOM(ByVal filename$, Optional ByVal SourceCharset$) As Boolean

    ' функция перекодировки (смены кодировки) текстового файла

    ' В качестве параметров функция получает путь filename$ к текстовому файлу,

    ' Функция возвращает TRUE, если перекодировка прошла успешно

    On Error Resume Next: Err.Clear

    DestCharset$ = "utf-8"

    With CreateObject("ADODB.Stream")

        .Type = 2

        If Len(SourceCharset$) Then .Charset = SourceCharset$        ' указываем исходную кодировку

        .Open

        .LoadFromFile filename$        ' загружаем данные из файла

        FileContent$ = .ReadText        ' считываем текст файла в переменную FileContent$

        .Close

        .Charset = DestCharset$        ' назначаем новую кодировку "utf-8"

        .Open

        .WriteText FileContent$

        'Write your data into the stream.

        Dim binaryStream As Object

        Set binaryStream = CreateObject("ADODB.Stream")

        binaryStream.Type = 1

        binaryStream.Mode = 3

        binaryStream.Open

        'Skip BOM bytes

        .Position = 3

        .CopyTo binaryStream

        .Flush

        .Close

        binaryStream.SaveToFile filename$, 2

        binaryStream.Close

    End With

    ChangeFileCharset_UTF8noBOM = Err = 0

End Function

Функция перекодировки текста в UTF-8 без BOM

Function EncodeUTF8noBOM(ByVal txt As String) As String

    For i = 1 To Len(txt)

        l = Mid(txt, i, 1)

        Select Case AscW(l)

            Case Is > 4095: t = Chr(AscW(l)  64  64 + 224) & Chr(AscW(l)  64) & Chr(8 * 16 + AscW(l) Mod 64)

            Case Is > 127: t = Chr(AscW(l)  64 + 192) & Chr(8 * 16 + AscW(l) Mod 64)

            Case Else: t = l

        End Select

        EncodeUTF8noBOM = EncodeUTF8noBOM & t

    Next

End Function

• 87909 просмотров

Sub CallKML(control As IRibbonControl)
Dim i As Integer
Dim fn As Long
Dim npg As Integer
If ActiveSheet.Name = "Вуличні ПГ" Then wnet = "Вуличні ПГ"
If ActiveSheet.Name = "Об'єктові ПГ" Then wnet = "Об'єктові ПГ"
fn = FreeFile
Open ThisWorkbook.Path & "ResultExcel.kml" For Output As fn
Print #fn, "<?xml version='1.0' encoding='UTF-8'?>"
Print #fn, "<kml xmlns='http://www.opengis.net/kml/2.2'>"
Print #fn, "<Document>"
Print #fn, "<Style id=""placemark-blue"">"
Print #fn, "<IconStyle>"
Print #fn, "<Icon>"
Print #fn, "<href>images/1.png</href>"
Print #fn, "</Icon>"
Print #fn, "<hotSpot x='0.5' y='0.5' xunits='fraction' yunits='fraction'/>"
Print #fn, "</IconStyle>"
Print #fn, "<LabelStyle><color>ff000000</color><scale>0.5</scale><face>Arial</face><visible>1</visible><style>00000000</style></LabelStyle>"
Print #fn, "</Style>"
Print #fn, "<Style id=""placemark-red"">"
Print #fn, "<IconStyle>"
Print #fn, "<Icon>"
Print #fn, "<href>images/2.png</href>"
Print #fn, "</Icon>"
Print #fn, "<hotSpot x='0.5' y='0.5' xunits='fraction' yunits='fraction'/>"
Print #fn, "</IconStyle>"
Print #fn, "<LabelStyle><color>ff000000</color><scale>0.5</scale><face>Arial</face><visible>1</visible><style>00000000</style></LabelStyle>"
Print #fn, "</Style>"
Print #fn, "<Style id=""placemark-orange"">"
Print #fn, "<IconStyle>"
Print #fn, "<Icon>"
Print #fn, "<href>images/3.png</href>"
Print #fn, "</Icon>"
Print #fn, "<hotSpot x='0.5' y='0.5' xunits='fraction' yunits='fraction'/>"
Print #fn, "</IconStyle>"
Print #fn, "<LabelStyle><color>ff000000</color><scale>0.5</scale><face>Arial</face><visible>1</visible><style>00000000</style></LabelStyle>"
Print #fn, "</Style>"
        
npg = 0
For i = 2 To 1001
If ActiveSheet.Cells(i, 2) <> "" Then
npg = npg + 1

Print #fn, "<Placemark>"
If wnet = "Вуличні ПГ" Then Print #fn, "<description>" & "Вуличні ПГ" & "</description>"
If wnet = "Об'єктові ПГ" Then Print #fn, "<description>" & "Об'єктові ПГ" & "</description>"
Print #fn, "<name>" & ActiveSheet.Cells(i, 2) & "</name>"

      If ActiveSheet.Cells(i, 3) = "Справний" Then Print #fn, "<styleUrl>#placemark-blue</styleUrl>"
      If ActiveSheet.Cells(i, 3) = "Несправний" Then Print #fn, "<styleUrl>#placemark-red</styleUrl>"
           
Print #fn, "<ExtendedData> "
Print #fn, "<Data name='Вулиця'> <value>" & ActiveSheet.Cells(i, 1) & "</value> </Data>"
Print #fn, "<Data name='Технічний стан'> <value>" & ActiveSheet.Cells(i, 3) & "</value> </Data>"
Print #fn, "<Data name='Характер несправності'> <value>" & ActiveSheet.Cells(i, 4) & "</value> </Data>"
Print #fn, "<Data name='Належність'> <value>" & ActiveSheet.Cells(i, 5) & "</value> </Data>"
Print #fn, "<Data name='Примітка'> <value>" & ActiveSheet.Cells(i, 8) & "</value> </Data>"

If ActiveSheet.Cells(i, 9) <> "" Then Print #fn, "<Data name='gx_media_links'> <value>" & ActiveSheet.Cells(i, 9) & "</value> </Data>"
Print #fn, "</ExtendedData> "
Print #fn, "<Point> <coordinates>" & ActiveSheet.Cells(i, 7); "," & ActiveSheet.Cells(i, 6) & ",0.0</coordinates> </Point>"
Print #fn, "</Placemark>"
   End If
Next i
 
Print #fn, "</Document>"
Print #fn, "</kml>"

Close fn

ChangeFileCharset Filename$, "utf-8"

    MsgBox "Експорт таблиці в kml завершено"
End Sub
Function ChangeFileCharset(ByVal Filename$, ByVal DestCharset$, _
                           Optional ByVal SourceCharset$) As Boolean
      On Error Resume Next: Err.Clear
    With CreateObject("ADODB.Stream")
        .Type = 2
        If Len(SourceCharset$) Then .Charset = "Windows-1251"
        .Open
        .LoadFromFile "ResultExcel.kml"
        FileContent$ = .ReadText
        .Close
        .Charset = "utf-8"
        .Open
        .WriteText FileContent$
        .SaveToFile "ResultExcel.kml", 2
        .Close
    End With
    ChangeFileCharset = Err = 0
End Function

Получил файл в формате MXL — выгрузка из 1С, с абракадаброй внутри. Попробовал два решения: на VBA и на Python. Сравните и убедитесь.

Для начала на Python:

>>> print 'Чековая лента SMS'.decode('utf-8')
Чековая лента SMS

Теперь на VBA. Нашел такое решение (см. первоисточник):

Sub ПримерИспользования_ChangeTextCharset()

    ИсходнаяСтрока = «Р§РµРєРѕРІР°СЏ лента SMS«

‘ вызываем функцию ChangeTextCharset с указанием кодировок
  ‘ (меняем кодировку с Windows-1251 на UTF-8)
   ПерекодированнаяСтрока = ChangeTextCharset(ИсходнаяСтрока, «UTF-8», «Windows-1251«)

    MsgBox «Результат перекодировки: ««» & ПерекодированнаяСтрока & «»«», _
           vbInformation, «Исходная строка: ««» & ИсходнаяСтрока & «»«»

End Sub

Function ChangeFileCharset(ByVal filename$, ByVal DestCharset$, _
                          Optional ByVal SourceCharset$) As Boolean
    ‘ функция перекодировки (смены кодировки) текстового файла
  ‘ В качестве параметров функция получает путь filename$ к текстовому файлу,
  ‘ и название кодировки DestCharset$ (в которую будет переведён файл)
  ‘ Функция возвращает TRUE, если перекодировка прошла успешно
  On Error Resume Next: Err.Clear
    With CreateObject(«ADODB.Stream»)
        .Type = 2
        If Len(SourceCharset$) Then .Charset = SourceCharset$   ‘ указываем исходную кодировку
       .Open
        .LoadFromFile filename$   ‘ загружаем данные из файла
       FileContent$ = .ReadText   ‘ считываем текст файла в переменную FileContent$
       .Close
        .Charset = DestCharset$   ‘ назначаем новую кодировку
       .Open
        .WriteText FileContent$
        .SaveToFile filename$, 2   ‘ сохраняем файл уже в новой кодировке
       .Close
    End With
    ChangeFileCharset = Err = 0
End Function

Function ChangeTextCharset(ByVal txt$, ByVal DestCharset$, _
                          Optional ByVal SourceCharset$) As String
    ‘ функция перекодировки (смены кодировки) текстовоq строки
  ‘ В качестве параметров функция получает текстовую строку txt$,
  ‘ и название кодировки DestCharset$ (в которую будет переведён текст)
  ‘ Функция возвращает текст в новой кодировке
  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 Function

Получился такой результат:

Выводы? )))

Макросы в 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