Перекодировка текстового файла - VBA

Sub KML_XLS_Shablon()
Dim i As Integer
Dim fn As Integer
fn = FreeFile
Dim strFileName As String
Dim strMessage As String
 
ChangeFileCharset filename, "UTF-8", "Windows-1251"  'вызов процедуры
 
' Это все код самого макраса преобразования в kml
strFileName = Application.GetSaveAsFilename _
         ("", "ALL files (*.*), *.*)")
 
If InStr(strFileName, "False") = 0 Then
Open strFileName For Output As fn
 
Print #fn, "<kml xmlns=""http://earth.google.com/kml/2.0"">"
Print #fn, "<Document>"
Print #fn, "<name>KML - Google Maps</name>"
'  добавить свое название карты в теге name
 
Print #fn, "<description><![CDATA[KML 4 Google Maps]]></description>"
'  добавить свое краткое описание карты
 
Print #fn, "<Style id=""style1"">"
Print #fn, "<IconStyle>"
Print #fn, "<Icon>"
Print #fn, "<href>http://www.urg.ru/temp/iconRental.png</href>"
Print #fn, "</Icon>"
Print #fn, "</IconStyle>"
Print #fn, "</Style>"
 
'  создать свои и прописать ссылку на них в Style
 
Print #fn, "<Style id=""style2"">"
Print #fn, "<IconStyle>"
Print #fn, "<Icon>"
Print #fn, "<href>http://www.urg.ru/temp/iconSale.png</href>"
Print #fn, "</Icon>"
Print #fn, "</IconStyle>"
Print #fn, "</Style>"
 
Print #fn, "<Style id=""style3"">"
Print #fn, "<IconStyle>"
Print #fn, "<Icon>"
Print #fn, "<href>http://www.urg.ru/temp/off-iconRental.png</href>"
Print #fn, "</Icon>"
Print #fn, "</IconStyle>"
Print #fn, "</Style>"
 
Print #fn, "<Style id=""style4"">"
Print #fn, "<IconStyle>"
Print #fn, "<Icon>"
Print #fn, "<href>http://www.urg.ru/temp/off-iconSale.png</href>"
Print #fn, "</Icon>"
Print #fn, "</IconStyle>"
Print #fn, "</Style>"
 
For i = 3 To 200
  If Sheets(1).Cells(i, 1) > "" Then
 
Print #fn, "<Placemark>"
Print #fn, "<name> " & Sheets(1).Cells(i, 2) & "</name>"
Print #fn, "<description><![CDATA[<IMG WIDTH=""150"" src=""" & Sheets(1).Cells(i, 5) & """>"
Print #fn, "<P>" & Sheets(1).Cells(i, 3)
Print #fn, "<P>" & Sheets(1).Cells(i, 4)
Print #fn, "<P> Дата:" & Sheets(1).Cells(i, 1)
Print #fn, "<BR><br><A href=" & Sheets(1).Cells(i, 8) & ">Подробное описание>>></A>]]>"
Print #fn, "</description>"
 
If Sheets(1).Cells(i, 2) = "1" Then
Print #fn, "<styleUrl>#style1</styleUrl>"
End If
 
If Sheets(1).Cells(i, 2) = "2" Then
Print #fn, "<styleUrl>#style2</styleUrl>"
End If
 
If Sheets(1).Cells(i, 2) = "3" Then
Print #fn, "<styleUrl>#style3</styleUrl>"
End If
 
If Sheets(1).Cells(i, 2) = "4" Then
Print #fn, "<styleUrl>#style4</styleUrl>"
End If
 
Print #fn, "<Point>"
Print #fn, "<coordinates>" & Sheets(1).Cells(i, 5) & "," & Sheets(1).Cells(i, 6) & "</coordinates>"
Print #fn, "</Point>"
Print #fn, "</Placemark>"
 
   End If
 Next i
 
Print #fn, "</Document>"
Print #fn, "</kml>"
 
Close fn
         strMessage = "File saved" & strFileName & "'."
 
       Else
         strMessage = "Ошибка!"
     End If
   MsgBox strMessage
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