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
|
вопрос еще актуален 
