Komsu Alanlari Tespit Et (Detect Neighbor Areas)

' 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 komşu alanlarını otomatik tespit eder,
' komşuları belirtilen tabakaya taşır ve seçilen renkle boyar. Kullanıcı, komşuluk
' tolerans mesafesini, tabaka adını, rengi ve komşu adlarına önek ekleme seçeneğini
' dialog penceresinden belirler. Kadastro, imar veya komşuluk analizi projelerinde
' sınır kontrolü ve görselleştirme için kullanılır.

Sub Main
Dim sabangul1, sabangul2, sabangul3, sabangul4, sabangul5
Dim i, j, k, tabakaNo
Dim secimkumesi, obje, komsuObje, komsuKumesi
Dim tabakaAdi, tolerans, renk, adOnek, komsuSayisi

With Netcad
    ' Dialog penceresi oluştur
    Set sabangul1 = .NewBDialog("Komşu Alanları Tespit Etme [Şaban GÜL, sabangul.com]")
    sabangul1.PutPrompt "Seçilen alanların komşuları tespit edilip renklendirilecektir."
    sabangul1.GetFloat "tolerans", "Komşuluk Toleransı (metre):", 0.01
    sabangul1.GetString "tabaka", "Komşuların Taşınacağı Tabaka Adı:", "KOMSU_ALANLARI", 20
    sabangul1.GetRadio "renk", "Komşular için Renk Seçiniz:", "Kırmızı", 0
    sabangul1.AddRadio "Kırmızı"
    sabangul1.AddRadio "Mavi"
    sabangul1.AddRadio "Yeşil"
    sabangul1.GetString "onek", "Komşu Adlarına Önek (isteğe bağlı):", "KOMSU_", 20
    sabangul1.PutPrompt "Tolerans pozitif olmalıdır. Tabaka yoksa oluşturulur."

    ' Dialog penceresini göster
    If sabangul1.ShowModal Then
        sabangul2 = sabangul1.ValueByName("tolerans") ' Tolerans mesafesi
        sabangul3 = sabangul1.ValueByName("tabaka") ' Tabaka adı
        sabangul4 = sabangul1.ValueByName("renk") ' Renk
        sabangul5 = sabangul1.ValueByName("onek") ' Önek
        ' Tolerans kontrolü
        If sabangul2 <= 0 Then
            MsgBox "Tolerans pozitif bir değer olmalıdır!", 48, "Şaban GÜL, sabangul.com"
            Exit Sub
        End If
    Else
        Exit Sub
    End If

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

    ' 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

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

    ' Kullanıcıdan alan objelerini seçmesini iste
    If secimkumesi.Select("Komşuları Tespit Edilecek Alan Objelerini Seçiniz...", Array(opline)) Then
        komsuSayisi = 0 ' Komşu alan sayacı
        For i = 0 To secimkumesi.NE - 1
            j = secimkumesi.GetSelectedObject(i, obje)
            ' Komşuları tespit et
            komsuKumesi.Clear
            komsuKumesi.SelectByDistance(obje, sabangul2, Array(opline)) ' Tolerans mesafesinde komşular
            For k = 0 To komsuKumesi.NE - 1
                If komsuKumesi.GetSelectedObject(k, komsuObje) <> j Then ' Seçilen objeyi hariç tut
                    komsuObje.tabaka = tabakaNo ' Tabakayı değiştir
                    ' Rengi ayarla
                    Select Case sabangul4
                        Case "Kırmızı"
                            komsuObje.color = 1 ' Kırmızı
                        Case "Mavi"
                            komsuObje.color = 2 ' Mavi
                        Case "Yeşil"
                            komsuObje.color = 3 ' Yeşil
                    End Select
                    ' Önek ekle (boş değilse)
                    If sabangul5 <> "" Then
                        komsuObje.pname = sabangul5 & komsuObje.pname
                    End If
                    .PutObject komsuKumesi.GetSelectedObjectHandle(k), komsuObje ' Objeyi güncelle
                    komsuSayisi = komsuSayisi + 1
                End If
            Next
        Next
        secimkumesi.RedrawAndRewind ' Ekranı yenile
        If komsuSayisi > 0 Then
            MsgBox komsuSayisi & " adet komşu alan tespit edilip güncellendi." & vbCrLf & _
                   "Tolerans: " & sabangul2 & " m" & vbCrLf & _
                   "Tabaka: " & tabakaAdi & vbCrLf & _
                   "Renk: " & sabangul4 & vbCrLf & _
                   "Önek: " & IIf(sabangul5 = "", "Yok", sabangul5), 64, "Şaban GÜL, sabangul.com"
        Else
            MsgBox "Hiçbir komşu alan tespit edilemedi!", 48, "Şaban GÜL, sabangul.com"
        End If
    Else
        MsgBox "Hiçbir alan objesi seçilmedi!", 48, "Şaban GÜL, sabangul.com"
    End If

    ' Belleği temizle
    Set secimkumesi = Nothing
    Set komsuKumesi = Nothing
    Set obje = Nothing
    Set komsuObje = Nothing
    Set sabangul1 = Nothing
End With
End Sub