Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA проблемы с кодировкой, создать текстовый файл в кодировке UTF-8
 
#1
08.04.2013 16:39:46
Добрый день!
Есть таблица из нее собирается kml файл. Все работает. Но сохранить или пересохранить созданный файл в кодировке UTF-8 не получается. Пробовал по всякому. Не получилось. Нужны мысли как это можно сделать.
На всякий случай приведу пример кода, возможно можно отказаться от метода Print, в пользу аналогичного который можно использовать с ADODB.Stream
Заранее благодарен.
Код
Sub KML()
Dim fn, kontr, adr, marsh, coord, fnName, cel

fn = ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Styles").Cells(1, 2) & ".kml"
fnName = ThisWorkbook.Sheets("Styles").Cells(1, 2)

Open fn For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "UTF-8" & Chr(34) & "?>"
Print #1, "<kml xmlns=""http://earth.google.com/kml/2.2"">"
Print #1, "<Document>"
Print #1, "<name>" & fnName & "</name>"
Print #1, "<description><![CDATA[]]></description>"
        For Each cel In ThisWorkbook.Sheets("Styles").Range("A1:A50")  '(ThisWorkbook.Sheets("Styles")  a:a)
            If cel.Value <> Empty Then
            stl = cel
            href = cel.Offset(0, 1)
            Print #1, "<Style id=" & Chr(34) & stl & Chr(34) & ">"
            Print #1, "  <IconStyle>"
            Print #1, "    <Icon>"
            Print #1, "       <href>" & href & "</href>"
            Print #1, "    </Icon>"
            Print #1, "  </IconStyle>"
            End If
        Next
        
        For Each ro In ThisWorkbook.Sheets("Route").Range(Cells(2, 2), Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 2))
       
            If ro.Value <> Empty Then
                kontr = ro
                adr = ro.Offset(0, 1)
                marsh = ro.Offset(0, 2)
                coord = ro.Offset(0, 3)
                Print #1, "<Placemark>"
                Print #1, " <name>" & kontr & "</name>"
                Print #1, "    <description><![CDATA[<div dir="; ltr; ">" & adr & "<br><br>" & marsh & "</div>]]></description>"
                Print #1, "     <styleUrl>#style" & marh & "</styleUrl>"
                Print #1, "     <Point>"
                Print #1, "         <coordinates>" & coord & "</coordinates>"
                Print #1, "     </Point>"
                Print #1, "</Placemark>"
              End If
        Next
Close #1

End Sub
 
 
 
#2
08.04.2013 16:55:16
Недавно было: http://planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=47039
 
 
 
#3
08.04.2013 17:00:28
Казанский, видел. не получилось совместить ADODB.Stream и Print #1
 
 
 
#4
08.04.2013 17:10:48
http://stackoverflow.com/questions/2524703/save-text-file-utf-8-encoded-with-vba
не то?
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#5
08.04.2013 17:19:22
ikki, тоже видел. вроде какбы и оно, но .WriteText лепит все в 1 строку.
 
 
 
#6
08.04.2013 17:21:30
а понавставлять в нужные места символ новой строки (перед тем, как вызывать WriteText) не получается?
Изменено: ikki - 08.04.2013 17:22:28
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#7
08.04.2013 17:39:20
ikki, да, сработало  - .WriteText vbCrLf
попробую так. Спасибо
 
 
 
#8
10.03.2018 18:34:06
Доброго времени суток. Недавно пришлось столкнуться с VBA для решения вопросов по работе. Если брать шкалу знаний по VBA до 100 то мои равны 1... Спасибо вашему форуму, многим помог, почти все что я хотел реализовать получилось, но столкнулся с проблемой кодировки. Готовый файл постоянно в кодировке windows-1251 и перевести его в UTF-8 никак не могу.. Прошу помощи в этом не легком для меня деле. Какие варианты я не пробовал либо вылазило много не понятных ошибок либо никакой реакции (как в этом примере).  Ниже код и файл моего "творения". Благодарен всем кто поможет хоть чем то ...
Код
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
 
 
 
#9
10.03.2018 19:06:11
War2Darius,  как вариант - использовать оригинальный вариант функции
Код
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

а вызывать её так:
Код
ChangeFileCharset ThisWorkbook.Path & "\ResultExcel.kml", "utf-8"

годится ли результат - решать Вам.
 
 
 
#10
10.03.2018 19:40:16
Основная задача макроса создавать из таблицы файл который далее загружается на карту гугла (точки координат). Вопрос только по кодировке текста. Сделал все как Вы написали получил кучу иероглифов
Код
ChangeFileCharset ThisWorkbook.Path & "\ResultExcel.kml", "utf-8"


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 = SourceCharset$
        .Open
        .LoadFromFile Filename$
        FileContent$ = .ReadText
        .Close
        .Charset = DestCharset$
        .Open
        .WriteText FileContent$
        .SaveToFile Filename$, 2
        .Close
    End With
    ChangeFileCharset = Err = 0
End Function
Изменено: War2Darius - 10.03.2018 19:47:14
 
 
 
#11
10.03.2018 19:57:36
Но ведь в UTF :)
 
 
 
#12
10.03.2018 20:01:48
Это точно! :) но хотелось бы еще иметь возможность это все прочитать. Очень желательно )
Нашел решение!!!
использовал функцию с перекодировкой в UTF-8 без BOM и вписал начальную и конечную кодировку. Большое спасибо за помощь :)
Код
Function ChangeFileCharset(ByVal filename$, Optional ByVal SourceCharset$) As Boolean
    On Error Resume Next: Err.Clear
    DestCharset$ = "utf-8"
    With CreateObject("ADODB.Stream")
        .Type = 2
        If Len(SourceCharset$) Then .Charset = "windows-1251"
        .Open
        .LoadFromFile filename$
        FileContent$ = .ReadText
        .Close
        .Charset = "utf-8"
        .Open
        .WriteText FileContent$

        Dim binaryStream As Object
        Set binaryStream = CreateObject("ADODB.Stream")
        binaryStream.Type = 1
        binaryStream.Mode = 3
        binaryStream.Open
        
        .Position = 3
        .CopyTo binaryStream
        .Flush
        .Close
        binaryStream.SaveToFile filename$, 2
        binaryStream.Close
    End With
    ChangeFileCharset_UTF8noBOM = Err = 0
End Function
Изменено: War2Darius - 10.03.2018 22:05:08
 
 
 
#13
10.03.2018 20:36:27
Я тоже решил чуть другим способом - перекодировал через CreateObject("OlePrn.OleCvt.1"), а вот записать через FSO никак не получалось (не пишет и всё!), записал тоже через CreateObject("ADODB.Stream") - вроде и то, но с каракулями местами...
Затем ещё сделал версию только на CreateObject("ADODB.Stream") - получил в итоге такой же файл как и у Вас, но на 3 байта больше и  с пометкой UTF-8-BOM :)
 
 
 
#14
10.03.2018 20:45:08
В любом случае огромное Вам спасибо за подсказу с кодом вызова функции и за общие старания :)
 
 
 
 
Страницы: 1
Читают тему
Наверх