MyTetra Share
Делитесь знаниями!
Макрос перекодировки (изменения кодировки) текста и файлов
16.03.2019
23:43
Текстовые метки: vba,Encode,Текстовые файлы,кодировка
Раздел: !Закладки - VBA - Кодировки

Макрос перекодировки (изменения кодировки) текста и файлов

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

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

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

Список доступных на вашем компьютере кодировок можно найти в реестре Windows в ветке
HKEY_CLASSES_ROOT\MIME\Database\Charset

Среди доступных кодировок есть 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 просмотров
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования