Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA проблемы с кодировкой, создать текстовый файл в кодировке UTF-8
 
#1
08.04.2013 16:39:46
Добрый день!
Есть таблица из нее собирается kml файл. Все работает. Но сохранить или пересохранить созданный файл в кодировке UTF-8 не получается. Пробовал по всякому. Не получилось. Нужны мысли как это можно сделать.
На всякий случай приведу пример кода, возможно можно отказаться от метода Print, в пользу аналогичного который можно использовать с ADODB.Stream
Заранее благодарен.
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
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 никак не могу.. Прошу помощи в этом не легком для меня деле. Какие варианты я не пробовал либо вылазило много не понятных ошибок либо никакой реакции (как в этом примере).  Ниже код и файл моего "творения". Благодарен всем кто поможет хоть чем то ...
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
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,  как вариант - использовать оригинальный вариант функции
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
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

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

годится ли результат - решать Вам.
 
 
 
#10
10.03.2018 19:40:16
Основная задача макроса создавать из таблицы файл который далее загружается на карту гугла (точки координат). Вопрос только по кодировке текста. Сделал все как Вы написали получил кучу иероглифов
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
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 и вписал начальную и конечную кодировку. Большое спасибо за помощь :)
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
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
Читают тему
Loading...