Girilen Alan koordinatlarını KML'ye çevirme

[neonkratos]

A ve B sütununa girdiğim WGS84 formatındaki alan koordinatlarını makro ile KML'ye çevirmek istiyorum. Yardımcı olabilir misiniz

* Forumda göz gezdirdim ama alan olarak herhangi bir şey göremedim. Aynı konudan var ise ve bulamadıysam şimdiden kusura bakmayın.

 

[Korhan Ayhan]

Merhaba,

Linkteki konular faydalı olabilir...

Google Search

 

[netzone]

Merhaba,
Korhan Bey'in vermiş olduğu bağlantıda bulunan konuları inceleyin, farklı dosyalar farklı çözümler mutlaka bulacaksınız.

Vermiş olduğunuz koordinatlar ile bir alan çizdiğimde Altınova yakınlarından baston gibi bir alan çizdi, söz konusu koordinatlar doğrumu bilemedim.



Aşağıdaki kodların alanı doğru çizip çizmediğinden emin olmak için verdiğiniz konuma yakın bir arazi üzerinden çokgen kullanarak edindiğim koordinatları denedim, sonuç olumlu gibi deneyiniz.

Örnek koordinatlar

36,80616	37,48388
36,80653	37,48307
36,80711	37,48337
36,8067	37,48427
36,80641	37,48404
36,80642	37,48402
36,8064	37,48405
36,80639	37,48407
36,80639	37,48411
36,80638	37,48414
36,80636	37,48415
36,80635	37,48414
36,80633	37,48413
36,80616	37,48388

*Kodlar yapay zeka ile üretilmiştir.

Sub KoordinatlarıAlanKMLYap()
    Dim LastRow As Long
    Dim i As Long
    Dim FilePath As String
    Dim FileNumber As Integer
    Dim Y_Coord As String, X_Coord As String
    Dim First_Y As String, First_X As String

    ' 1. Son dolu satırı bul (B sütununa göre)
    LastRow = Cells(Rows.Count, "B").End(xlUp).Row
  
    If LastRow < 3 Then
        MsgBox "A3 hücresinden başlayan yeterli veri bulunamadı!", vbExclamation
        Exit Sub
    End If

    ' 2. Kayıt yolu (Masaüstü)
    FilePath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Kapali_Alan.kml"
    FileNumber = FreeFile

    ' 3. Dosyayı oluştur ve KML Alan (Polygon) etiketlerini yaz
    Open FilePath For Output As #FileNumber

    Print #FileNumber, "<?xml version=""1.0"" encoding=""UTF-8""?>"
    Print #FileNumber, "<kml xmlns=""http://www.opengis.net/kml/2.2"">"
    Print #FileNumber, "<Document>"
    Print #FileNumber, "  <Style id=""alanStili"">"
    Print #FileNumber, "    <LineStyle><color>ff0000ff</color><width>2</width></LineStyle>" ' Kırmızı kenarlık
    Print #FileNumber, "    <PolyStyle><color>7f00ff00</color></PolyStyle>" ' Yarı saydam yeşil dolgu
    Print #FileNumber, "  </Style>"
    Print #FileNumber, "  <Placemark>"
    Print #FileNumber, "    <name>Excelden Gelen Alan</name>"
    Print #FileNumber, "    <styleUrl>#alanStili</styleUrl>"
    Print #FileNumber, "    <Polygon>"
    Print #FileNumber, "      <tessellate>1</tessellate>"
    Print #FileNumber, "      <outerBoundaryIs>"
    Print #FileNumber, "        <LinearRing>"
    Print #FileNumber, "          <coordinates>"

    ' 4. Koordinatları Döngüyle Yazdır
    For i = 3 To LastRow
        Y_Coord = Replace(Trim(Cells(i, 1).Value), ",", ".") ' A Sütunu (Boylam)
        X_Coord = Replace(Trim(Cells(i, 2).Value), ",", ".") ' B Sütunu (Enlem)
      
        ' İlk koordinatı hafızada tut (Kapatma işlemi için)
        If i = 3 Then
            First_Y = Y_Coord
            First_X = X_Coord
        End If
      
        Print #FileNumber, "            " & Y_Coord & "," & X_Coord & ",0"
    Next i

    ' 5. ALANI KAPAT: İlk koordinatı sona tekrar yazdır
    Print #FileNumber, "            " & First_Y & "," & First_X & ",0"

    ' KML Kapatma Etiketleri
    Print #FileNumber, "          </coordinates>"
    Print #FileNumber, "        </LinearRing>"
    Print #FileNumber, "      </outerBoundaryIs>"
    Print #FileNumber, "    </Polygon>"
    Print #FileNumber, "  </Placemark>"
    Print #FileNumber, "</Document>"
    Print #FileNumber, "</kml>"

    Close #FileNumber

    MsgBox "Alan (Polygon) KML dosyası masaüstüne kaydedildi!", vbInformation
End Sub

İyi çalışmalar.