В этой статье представлены 3 функции для работы с текстовыми файлами:
- Text_LoadFromFile - загружает текст из заданного файла
- Text_SaveToFile - сохраняет текст в файл в нужной кодировке
- ReturnCharset - получает кодировку заданного текстового файла
Среди доступных кодировок есть koi8-r, ascii, utf-7, utf-8, utf-8noBOM, utf-16, Windows-1251, unicode, и т.д.
Под кодировкой utf-8noBOM подразумевается utf-8 без BOM (без трёх стартовых байтов 0xEF, 0xBB, 0xBF)
Список доступных кодировок можно найти в реестре Windows, в ветке HKEY_LOCAL_MACHINE\SOFTWARE\Classes\MIME\Database\Charset
Для начала — пример использования функций:
Sub Example_ReadAndWriteTextFile() Dim file$, txt$, enc$ ' полный путь к текстовому файлу file$ = "C:\Windows\win.ini" ' получаем кодировку файла (необязательно) enc$ = ReturnCharset(file$) ' считываем текст из файла txt$ = Text_LoadFromFile(file$) ' добавляем строку в начало текста txt$ = "; это добавленная строка" & vbNewLine & txt ' записываем обратно в файл (кодировка файла не изменится) Text_SaveToFile txt$, file$, enc$ ' проверяем, был ли добавлен текст txt$ = Text_LoadFromFile(file$) MsgBox Left(txt, 200), , "Кодировка: " & enc End Sub
Sub Example_ReadTextFilesOnDesktop() Dim folder$, sFiles, txt$, enc$, item ' путь к папке РАБОЧИЙ СТОЛ folder$ = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" sFiles = Dir(folder$ & "*.txt*") Do While sFiles <> "" ' перебираем файлы в папке item = folder$ & sFiles ' полный путь к файлу enc$ = ReturnCharset(item) ' получаем кодировку файла txt$ = Text_LoadFromFile(item) ' считываем текст из файла ' выводим данные о файле (размер в байтах, кодировка, имя файла) Debug.Print "Размер: " & FileLen(item), "Кодировка: " & enc$, sFiles Debug.Print " Текст: " & Replace(Replace(Left(txt$, 50), vbCr, " "), vbLf, " ") sFiles = Dir Loop End Sub
Код функций для работы с текстовыми файлами:
Function Text_LoadFromFile(ByVal Filename$, Optional ByVal Encoding$) As String ' функция загружает текст в кодировке Encoding$ из файла filename$ ' © 2022 ExcelVBA.ru On Error Resume Next: Dim FSO, ts If Encoding$ = "" Then Encoding$ = ReturnCharset(Filename$) If Encoding$ = "ANSI" Then Encoding$ = "windows-1251" If Encoding$ = "UTF-8noBOM" Then Encoding$ = "UTF-8" If Encoding$ = "windows-1251" Then ' так НАМНОГО быстрее считываются большие файлы Set FSO = CreateObject("scripting.filesystemobject") Set ts = FSO.OpenTextFile(Filename$, 1, True): Text_LoadFromFile = ts.ReadAll: ts.Close Set ts = Nothing: Set FSO = Nothing: Exit Function End If With CreateObject("ADODB.Stream") .Type = 2: If Len(Encoding$) Then .charset = Encoding$ .Open: .LoadFromFile Filename$ Text_LoadFromFile = .ReadText: .Close End With End Function Function Text_SaveToFile(ByVal txt$, ByVal Filename$, Optional ByVal Encoding$) As Boolean ' функция сохраняет текст txt в кодировке Encoding$ в файл filename$ ' возвращает TRUE, если сохранение прошло успешно ' © 2022 ExcelVBA.ru On Error Resume Next: Err.Clear If Encoding$ = "ANSI" Then Encoding$ = "windows-1251" If Encoding$ = "" Then Encoding$ = "UTF-8" ' кодировка по умолчанию: UTF-8 Select Case Encoding$ Case "utf-8noBOM" With CreateObject("ADODB.Stream") .Type = 2: .charset = "utf-8": .Open: .WriteText txt$ Dim binaryStream As Object: 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 Text_SaveToFile = Err = 0: DoEvents End Function Function ReturnCharset(ByVal filePath As String) As String On Error Resume Next ' © 2022 ExcelVBA.ru Dim bytHeader(2) As Byte, txt$, lngFileNum As Long, fLen& lngFileNum = FreeFile If CreateObject("Scripting.FileSystemObject").FileExists(filePath) Then Open filePath For Binary Access Read As lngFileNum Get lngFileNum, , bytHeader ' first 3 bytes Close lngFileNum End If Select Case bytHeader(0) Case 255: 'UTF-16 (LE) FF FE 255 254 If bytHeader(1) = 254 Then ReturnCharset = "UTF-16LE" ' Unicode Case 254: 'UTF-16 (BE) FE FF 254 255 If bytHeader(1) = 255 Then ReturnCharset = "UTF-16BE" ' UnicodeBigEndian Case 239: 'UTF-8 EF BB BF 239 187 191 If bytHeader(1) = 187 Then If bytHeader(2) = 191 Then ReturnCharset = "UTF-8" Case 43: 'UTF-7 2b 2f 76 43 47 118 If bytHeader(1) = 47 Then If bytHeader(2) = 118 Then ReturnCharset = "UTF-7" End Select If ReturnCharset = "" Then fLen& = FileLen(filePath) ' для файлов более 2 МБ не уточняем тип файла, ибо это занимает много времени If fLen& > 2048000 Then ReturnCharset = "ANSI": Exit Function With CreateObject("ADODB.Stream") .Type = 2: .charset = "UTF-8": .Open .LoadFromFile filePath ' загружаем данные из файла txt$ = .ReadText ReturnCharset = IIf(Len(txt) < .Size - 3, "UTF-8noBOM", "ANSI") .Close End With End If End Function
Комментарии
Добрый день, если в рамках пути к файлу передать ссылку на облако OneDrive (типа "https://d.docs.live.net/a5eca55df8f971a0d/Рабочий стол/1C_SteelWay.txt"), то получим ошибку 3004 "Не удается записать файл.".
А ведь именно облачный путь передаст любой диалог сохранения..
Как можно победить? или как заставить excel вместо облачного пути получить локальный?
Очень помогли. Спасибо за выложенные примеры кода.
у меня файлы Excel сохраняются с "?" знаками вместо умлаутов.
Пожалуйста объясните подробно(пошагово)как это изменить.
Заранее благодарен.
P.S. WIN 10 установлен рускоязычный, затем язык системы заменён на немецкий.
Куда этот код в exel вписывать?
Отличные примеры, очень помогли, спасибо
Спасибо автору! В который раз уже выручает.
Функция вызывается не так
а так
Не эксперт в VBA. Есть вопрос - каким образом правильно вызвать функции?
Если вот так
Sub sss ()
With ActiveWorkbook.WebOptions
.RelyOnCSS = True
.OrganizeInFolder = True
.UseLongFileNames = True
.DownloadComponents = False
.RelyOnVML = False
.encoding = msoEncodingUTF8
End With
AD = ActiveWorkbook.Path & "\" & "led001.csv"
ActiveWorkbook.SaveAs filename:= _
AD, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
encoding$ = "windows-1251"
filename$ = AD
LoadTextFromTextFile(ByVal filename$, Optional ByVal encoding$)
End Sub
выдает ошибку.
https://s.mail.ru/HHBf/GrzfCKfRR
Если надо делать поиск в файле, то результат LoadTextFromTextFile передавать в переменную типа String или выводить на лист и там уже искать? Спасибо
Просто, как все гениальное. Спасибо автору
Отправить комментарий