Alan Degerini Ada Ve Merkeze Yaz (WriteAreaToNameAndCenter)

' www.sabangul.com Web Sayfasından İndirilmiştir
' Şaban GÜL, Harita Mühendisi
' Her Türlü Hata, İstek ve Öneriler İçin
' sabangul67@gmail.com adresine durumu anlatan bir e-posta gönderiniz.
'
' Amaç: Ekrandan seçilen alan (opline) objelerinin alan değerlerini hesaplar,
' kullanıcı tarafından belirtilen birime (m², dönüm, hektar) çevirir, belirtilen
' ondalık basamak sayısına yuvarlar ve bu değerleri isteğe bağlı bir önek ile
' objelerin adlarına (pname) atar. Ayrıca, bu değerleri alanların ağırlık merkezine
' yazı objesi olarak ekler. Yazı objeleri, kullanıcı tarafından belirtilen tabakaya
' yazılır (yeni veya mevcut tabaka).

Sub Main
Dim sabangul1, sabangul2, sabangul3, sabangul4, sabangul5, sabangul6
Dim i, j, tabakaNo
Dim secimkumesi, obje, yaziObje, alanDegeri, merkez
Dim tabakaAdi, birim, donusumKatsayisi, birimEtiketi

With Netcad
    ' Dialog penceresi oluştur
    Set sabangul1 = .NewBDialog("Alan Değerlerini Adlara ve Merkeze Yazma [Şaban GÜL, sabangul.com]")
    sabangul1.PutPrompt "Seçilen alanların alan değerleri adlara ve merkeze yazı olarak yazılacaktır."
    sabangul1.GetString "onek", "Önek Giriniz (örn: ALAN_, isteğe bağlı):", "", 20
    sabangul1.GetInteger "basamak", "Ondalık Basamak Sayısı (0-4):", 2
    sabangul1.GetString "tabaka", "Yazıların Yazılacağı Tabaka Adı:", "ALAN_YAZILARI", 20
    sabangul1.GetRadio "birim", "Alan Birimi Seçiniz:", "Metrekare (m²)", 0
    sabangul1.AddRadio "Metrekare (m²)"
    sabangul1.AddRadio "Dönüm"
    sabangul1.AddRadio "Hektar"
    sabangul1.PutPrompt "Önek boş bırakılırsa sadece alan değeri kullanılır."

    ' Dialog penceresini göster
    If sabangul1.ShowModal Then
        sabangul2 = sabangul1.ValueByName("onek") ' Önek
        sabangul3 = sabangul1.ValueByName("basamak") ' Ondalık basamak
        sabangul4 = sabangul1.ValueByName("tabaka") ' Tabaka adı
        sabangul5 = sabangul1.ValueByName("birim") ' Birim
        ' Basamak sayısını 0-4 aralığında sınırla
        If sabangul3 < 0 Then sabangul3 = 0
        If sabangul3 > 4 Then sabangul3 = 4
    Else
        Exit Sub
    End If

    ' Tabaka adı boşsa varsayılan değer
    If sabangul4 = "" Then sabangul4 = "ALAN_YAZILARI"
    tabakaAdi = sabangul4

    ' Tabakayı bul veya oluştur
    tabakaNo = .FoundLayer(tabakaAdi)
    If tabakaNo = -1 Then
        tabakaNo = .AddLayer(tabakaAdi) ' Yeni tabaka oluştur
        If tabakaNo = -1 Then
            MsgBox "Tabaka oluşturulamadı! İşlem iptal edildi.", 48, "Şaban GÜL, sabangul.com"
            Exit Sub
        End If
    End If

    ' Birim dönüşüm katsayısını ve etiketi belirle
    Select Case sabangul5
        Case "Metrekare (m²)"
            donusumKatsayisi = 1
            birimEtiketi = "m²"
        Case "Dönüm"
            donusumKatsayisi = 0.001 ' 1 m² = 0.001 dönüm
            birimEtiketi = "dönüm"
        Case "Hektar"
            donusumKatsayisi = 0.0001 ' 1 m² = 0.0001 hektar
            birimEtiketi = "hektar"
    End Select

    ' Seçim kümesi ve objeler oluştur
    Set secimkumesi = .NewSelectionSet
    Set obje = .NewObject
    Set yaziObje = .NewObject

    ' Kullanıcıdan alan objelerini seçmesini iste
    If secimkumesi.Select("Alan Değerleri Yazılacak Objeleri Seçiniz...", Array(opline)) Then
        sabangul6 = 0 ' İşlenen obje sayacı
        For i = 0 To secimkumesi.NE - 1
            j = secimkumesi.GetSelectedObject(i, obje)
            alanDegeri = obje.area * donusumKatsayisi ' Alanı birime çevir
            ' Alanı belirtilen basamağa yuvarla
            alanDegeri = Round(alanDegeri, sabangul3)
            ' Önek + yuvarlanmış alan değerini ad olarak ata
            obje.pname = sabangul2 & CStr(alanDegeri)
            .PutObject j, obje ' Objeyi güncelle

            ' Ağırlık merkezini al
            Set merkez = obje.Centroid
            ' Yazı objesi oluştur
            yaziObje.type = otext ' Yazı objesi tipi
            yaziObje.tabaka = tabakaNo ' Belirtilen tabaka
            yaziObje.text = sabangul2 & CStr(alanDegeri) ' Yazı içeriği
            yaziObje.x = merkez.x ' Merkez X koordinatı
            yaziObje.y = merkez.y ' Merkez Y koordinatı
            yaziObje.height = 1 ' Yazı yüksekliği (varsayılan)
            yaziObje.angle = 0 ' Yazı açısı
            .AddObject yaziObje ' Yazıyı ekle
            sabangul6 = sabangul6 + 1
        Next
        secimkumesi.RedrawAndRewind ' Ekranı yenile
        MsgBox "Seçilen " & sabangul6 & " adet alanın adı ve merkezi yazı objeleri başarıyla güncellendi." & vbCrLf & _
               "Önek: " & sabangul2 & vbCrLf & _
               "Ondalık Basamak: " & sabangul3 & vbCrLf & _
               "Birim: " & sabangul5 & vbCrLf & _
               "Yazılar Tabakası: " & tabakaAdi, 64, "Şaban GÜL, sabangul.com"
    Else
        MsgBox "Hiçbir alan objesi seçilmedi!", 48, "Şaban GÜL, sabangul.com"
    End If

    ' Belleği temizle
    Set secimkumesi = Nothing
    Set obje = Nothing
    Set yaziObje = Nothing
    Set sabangul1 = Nothing
    Set merkez = Nothing
End With
End Sub