Vba excel изменить кодировку - Word и Excel - помощь в работе с программами

Смена кодировки строки с 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 предназначены для изменения кодировки символов в текстовых файлах и строках.

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

ВНИМАНИЕ: Функции чтения и сохранения текста в файл в заданной кодировке

Список доступных на вашем компьютере кодировок можно найти в реестре 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

144363 просмотра

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.

Источник

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

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

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

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

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

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 просмотров

Источник

I have a VBA Excel code which takes Japanese data from excel sheet compares it with Japanese data in text file and replaces Japanese words with English words. But I am supposed to be able to do this on UTF-8 text file. This code replaces all the Japanese words with weird characters. How do I save without any issue ?

Open sFileName For Input As iFileNum

For n = 1 To lngLastCell
Label5.Caption = n & "/" & lngLastCell
searchtext = MySearch(n)
valuetext = MyText(n)

eplcCount = 0
spltCount = 0

searchpart = Array(searchtext)
valuepart = Array(valuetext)

Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & sBuf & vbCrLf

Loop


Close iFileNum

sTemp = Replace(sTemp, searchtext, valuetext)

'iFileNum = FreeFile
Open sFileName For Output As iFileNum
Print #iFileNum, sTemp

Next n

Code works well with ANSI characters.

asked Jul 25, 2017 at 11:27

The Open function from VBA works on ANSI encoded files only and binary. If you wish to read/write an utf-8 file, you’ll have to find another way.

The utf-8 encoding has a larger set of characters than ANSI, thus it’s not possible to convert from ANSI to utf-8 without loss. That said, a String in Excel and VBA is stored as utf-16 (VBA editor still use ANSI), so you only need to convert from utf-8 to utf-16.

With ADODB.Stream :

Public Function ReadFile(path As String, Optional CharSet As String = "utf-8")
  Static obj As Object
  If obj Is Nothing Then Set obj = VBA.CreateObject("ADODB.Stream")
  obj.CharSet = CharSet
  obj.Open
  obj.LoadFromFile path
  ReadFile = obj.ReadText()
  obj.Close
End Function

Public Sub WriteFile(path As String, text As String, Optional CharSet As String = "utf-8")
  Static obj As Object
  If obj Is Nothing Then Set obj = VBA.CreateObject("ADODB.Stream")
  obj.CharSet = CharSet
  obj.Open
  obj.WriteText text
  obj.SaveToFile path
  obj.Close
End Sub

Shafeek

1351 silver badge7 bronze badges

answered Jul 25, 2017 at 13:46

Florent B.Florent B.

41.2k7 gold badges85 silver badges101 bronze badges

Источник

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

Источник