В экселе формирую код для 3D модели, которая, должна быть сохранена в дальнейшем в Unicod. Но открывая сохраненный файл, обнаруживаю, что первых ~60 символов просто нет. Причем, судя по экспериментам, именно эта длина пропадает. Почему так происходит и что с этим можно сделать?
П.С. при запуске макроса, формируются файлы на каждую пару километров.
В экселе формирую код для 3D модели, которая, должна быть сохранена в дальнейшем в Unicod. Но открывая сохраненный файл, обнаруживаю, что первых ~60 символов просто нет. Причем, судя по экспериментам, именно эта длина пропадает. Почему так происходит и что с этим можно сделать?
П.С. при запуске макроса, формируются файлы на каждую пару километров.Паштет
Дополнительно поясню: в 14 строке в вариантного столбца в ячейке собираю текст кода модели с помощью СЦЕПИТЬ. В ячейке текст отображается правильно. Далее с помощью нижеуказанного макроса сохраняю его в виде текстового файла с раcширением *.s в Unicode, но при открытии полученного файла блокнотом, нет первых ~60 символов. Я сейчас ради эксперимента добавил их в ячейку повтором и итоговый файл стал верным, но интересно почему так происходит. [vba]
Код
Private Sub Start_Click() Dim razmin, razmax, v As Byte, a, b As Long Dim FileTxt, FullFileName As String, F As Integer
a = minkm.Value b = maxkm.Value
razmin = Len(a) razmax = Len(b)
For i = a To b - 1
'... пропущен кусок кода обработки вводных данных
100: ''' Формирование наименования файла и Запись данных в текстовый файл FileTxt = i & "-" & i + 1 & "km" & ".s" FullFileName = ThisWorkbook.Path & Application.PathSeparator & FileTxt ''' Стандартный способ записи текстового файла в VBA. F = FreeFile Open FullFileName For Output As #F: Print #1, Replace$(Cells(14, v).Value, vbLf, vbCrLf, vbUnicode): Close #F Next i Unload Me End Sub
[/vba] В итоговом файле не хватает следующего куска:
Код
SIMISA@@@@@@@@@@JINX0s1t______
shape ( shape_header ( 0000000
Дополнительно поясню: в 14 строке в вариантного столбца в ячейке собираю текст кода модели с помощью СЦЕПИТЬ. В ячейке текст отображается правильно. Далее с помощью нижеуказанного макроса сохраняю его в виде текстового файла с раcширением *.s в Unicode, но при открытии полученного файла блокнотом, нет первых ~60 символов. Я сейчас ради эксперимента добавил их в ячейку повтором и итоговый файл стал верным, но интересно почему так происходит. [vba]
Код
Private Sub Start_Click() Dim razmin, razmax, v As Byte, a, b As Long Dim FileTxt, FullFileName As String, F As Integer
a = minkm.Value b = maxkm.Value
razmin = Len(a) razmax = Len(b)
For i = a To b - 1
'... пропущен кусок кода обработки вводных данных
100: ''' Формирование наименования файла и Запись данных в текстовый файл FileTxt = i & "-" & i + 1 & "km" & ".s" FullFileName = ThisWorkbook.Path & Application.PathSeparator & FileTxt ''' Стандартный способ записи текстового файла в VBA. F = FreeFile Open FullFileName For Output As #F: Print #1, Replace$(Cells(14, v).Value, vbLf, vbCrLf, vbUnicode): Close #F Next i Unload Me End Sub
[/vba] В итоговом файле не хватает следующего куска:
Насколько я помню в функции Replace четвертый аргумент - это начальная позиция для поиска. У вас это константа vbUnicode = 64. Вот эти 64 символа и отсекаются Может, этот аргумент не нужен? [vba]
Код
Replace(Cells(14, v).Value, vbLf, vbCrLf)
[/vba]
Насколько я помню в функции Replace четвертый аргумент - это начальная позиция для поиска. У вас это константа vbUnicode = 64. Вот эти 64 символа и отсекаются Может, этот аргумент не нужен? [vba]
Pelena, да, вы правы. Теперь надо подумать, чем заменить Replace. Брал этот кусок как готовое решение для сохранение текстового файла, но vbUnicod сам уже подставил, где-то подсмотрев. С данным аргументом сохранение верное в Unicode, а без него формируется ANSI.
Pelena, да, вы правы. Теперь надо подумать, чем заменить Replace. Брал этот кусок как готовое решение для сохранение текстового файла, но vbUnicod сам уже подставил, где-то подсмотрев. С данным аргументом сохранение верное в Unicode, а без него формируется ANSI.Паштет
Sub Writer_To(strUnicode As String, FileName As String)
Const adTypeBinary = 1 Const adTypeText = 2 Dim oFS: Set oFS = CreateObject("Scripting.FileSystemObject") Dim oTo: Set oTo = CreateObject("ADODB.Stream") Dim sTFSpec: sTFSpec = oFS.GetAbsolutePathName(FileName) If oFS.FileExists(sTFSpec) Then oFS.DeleteFile sTFSpec oTo.Type = adTypeText oTo.Charset = "utf-16" oTo.Open oTo.WriteText strUnicode oTo.SaveToFile sTFSpec oTo.Close Set oFS = Nothing Set oTo = Nothing End Sub
[/vba]
Вот так.[vba]
Код
Sub Writer_To(strUnicode As String, FileName As String)
Const adTypeBinary = 1 Const adTypeText = 2 Dim oFS: Set oFS = CreateObject("Scripting.FileSystemObject") Dim oTo: Set oTo = CreateObject("ADODB.Stream") Dim sTFSpec: sTFSpec = oFS.GetAbsolutePathName(FileName) If oFS.FileExists(sTFSpec) Then oFS.DeleteFile sTFSpec oTo.Type = adTypeText oTo.Charset = "utf-16" oTo.Open oTo.WriteText strUnicode oTo.SaveToFile sTFSpec oTo.Close Set oFS = Nothing Set oTo = Nothing End Sub
Спасибо большое. Работает. cmivadwot, очень творчески подошли к проблеме ))) Некоторые предложенные вещи обязательно использую в своем проекте, и работает вроде шустрее, чем у меня.
Спасибо большое. Работает. cmivadwot, очень творчески подошли к проблеме ))) Некоторые предложенные вещи обязательно использую в своем проекте, и работает вроде шустрее, чем у меня.Паштет
Сообщение отредактировал Паштет - Понедельник, 24.03.2025, 20:54
Const adTypeBinary = 1 Const adTypeText = 2 Dim oFS: Set oFS = CreateObject("Scripting.FileSystemObject") Dim oTo: Set oTo = CreateObject("ADODB.Stream") Dim sTFSpec: sTFSpec = oFS.GetAbsolutePathName(FullFileName) If oFS.FileExists(sTFSpec) Then oFS.DeleteFile sTFSpec oTo.Type = adTypeText oTo.Charset = "utf-16" oTo.Open oTo.WriteText strUnicode oTo.SaveToFile sTFSpec oTo.Close Set oFS = Nothing Set oTo = Nothing
fileNo = FreeFile Open FullFileName For Binary Lock Read Write As #fileNo Close #fileNo
End Function
[/vba]
Для уменьшения объема файла требуется теперь перевести его в двоичный код. Дописал последние три строчки, но что-то эффекта я не увидел: [vba]
Код
Function savebin() Dim strUnicode, fileName, FullFileName, content As String, fileNo As Integer, testVar As Integer
Const adTypeBinary = 1 Const adTypeText = 2 Dim oFS: Set oFS = CreateObject("Scripting.FileSystemObject") Dim oTo: Set oTo = CreateObject("ADODB.Stream") Dim sTFSpec: sTFSpec = oFS.GetAbsolutePathName(FullFileName) If oFS.FileExists(sTFSpec) Then oFS.DeleteFile sTFSpec oTo.Type = adTypeText oTo.Charset = "utf-16" oTo.Open oTo.WriteText strUnicode oTo.SaveToFile sTFSpec oTo.Close Set oFS = Nothing Set oTo = Nothing
fileNo = FreeFile Open FullFileName For Binary Lock Read Write As #fileNo Close #fileNo
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
