Alan İçindeki Küçük Alanları Otomatik Adlandırma Makrosu (Automatic Naming Macro for Small Areas Within a Larger Area)

Sub Main()
Dim i,BD,alanOBJ,alanPOLY,DISTBK,sec,DISALAN
with Netcad
set BD = .NewBDialog("Parsel İçindeki Yapıların İsmini Parselden Alma , Şaban GÜL, SAGUL.NET ")
    BD.GetCombo "DPALAN","Dış Alan Hangi Tabakada: ","LÜTFEN TABAKA SEÇİNİZ",0
    for i = 0 to .numlayers-1
        BD.AddCombo .LayerNameOf(i)
    next
  BD.PutPrompt " [+] Yukarıdan Küçük Alanların içinde Bulunduğu Dış Alan Tabakasını Seçiniz "
  BD.GetRadio "YPI", "Adlandırılacak Küçük Alan Tipini Seçiniz", "Tecilsiz Alanlar |Tecilli Alanlar | Yıkık Alanlar ",0
  BD.PutPrompt " [+] Ardından Karşınıza Çıkan Ekrandan, Sadece Adlandırılacak KÜÇÜK ALANLARI seçiniz"
  BD.PutPrompt " [+] Alanlar 101/1/A.. adlandırılır. "
  BD.PutPrompt "___________________________________________________________________"
  BD.PutPrompt "Şaban GÜL, Harita Mühendisi    www.sagul.net"

    if BD.ShowModal then
   sec= BD.ValueByName("YPI")
   DISALAN=BD.ValueByName("DPALAN")-1
    ELSE
    Exit sub
    end if
     
DISTBK = .LayerNameOf(DISALAN)
IF DISALAN<1 THEN EXIT SUB
NCLayerManager.add "SGL_SIL_67",5
 dim o,p
 dim SEL
 set SEL = .NewSelectionSet ' Yeni kume yarat
 set o = .NewObject
 set p=.Newpoly
 'TabNo = 3
 dim elif,fy
 dim j
 elif=0
if SEL.SELECT("İsmi Değiştirilecek Küçük Alanları Seçiniz , Şaban GÜL - Harita Mühendisi - www.sagul.net",array(opline)) then ' istenen turleri kumeye ekle
 for i = 0 to SEL.NE-1 ' kumenin her bir elemani icin
  elif=elif+1
 j = SEL.GetSelectedObject(i, o) ' objeyi ve gercek indeksini al
 set p=.getplineExt(o)
 o.renk = red ' rengini sari yap

dim ruhan
 ruhan=""
 ruhan = o.pname
 dim tx
 set tx=.MakePoint(p.CenterOfMass,ruhan,0, .foundlayer("SGL_SIL_67"))
 .addobject(tx)
next
 SEL.RedrawAndRewind ' secim kumesini toplu kendi renginde
 end if ' cizdir ve kumeyi basa sardir.

elif=0
        set alanOBJ = .newobject()
        .setFilter nothing,array(DISALAN),array(opline)
        while .GetNextObject2(alanOBJ)
            .DrawObject alanOBJ, blue
            if sec=0 then  TESCILSIZ alanOBJ,.foundlayer("SGL_SIL_67"),.CurObjPos,DISALAN
           if sec=1 then  TESCILLI alanOBJ,.foundlayer("SGL_SIL_67"),.CurObjPos,DISALAN
         if sec=2 then  YIKIK alanOBJ,.foundlayer("SGL_SIL_67"),.CurObjPos,DISALAN
        wend
        .Resetfilter
        set alanOBJ = nothing
  
    .BackMessage

dim alanOBJ2
   set alanOBJ2 = .newobject()
        .setFilter nothing,array(),array(opline)
        while .GetNextObject2(alanOBJ2)
            .DrawObject alanOBJ2, blue
     if DISALAN <> alanOBJ2.Tabaka then
     icalanno alanOBJ2,.foundlayer("SGL_SIL_67"),.CurObjPos,DISALAN
     end if 

wend
        .Resetfilter
        set alanOBJ2 = nothing

 '****************
dim toptbk ,tbksay
toptbk = .numlayers - 1
With nclayermanager
For tbksay = 0 To toptbk
if  .layer(tbksay).name = "SGL_SIL_67" then
.Delete tbksay, true
end if
next
End With
  '****************
end with
MSGBOX "BİTTİ"
End Sub

function  TESCILSIZ(refOBJ,LayerIndex,refOBJIndex,DISALAN)
dim i,yaziOBJ,refPOLY,HARF,HRF,ZF
dim elif
HARF="ABCDEFGHIJKLMNOPRSUVZXWQÇİÖŞÜĞ"
with netcad
    set yaziOBJ = .newobject()
    .setFilter refOBJ.Limits,array(LayerIndex),array(opoint)
    elif=0
    while .GetNextObject2(yaziOBJ)
        set refPOLY = .newobject()
        set refPOLY = refOBJ.GetObjectAsPline
        if refPOLY.InPoly(yaziOBJ.p1) then
        elif=elif+1
            .DrawObject yaziOBJ, red
               if yaziOBJ.tabaka <> DISALAN  then
                 HRF=mid(harf,elif,1)
            yaziOBJ.pname = refOBJ.pname & "/" & HRF
            .PutObject .CurObjPos, yaziOBJ
              END iF
        end if
        set refPOLY = nothing
    wend
    .Resetfilter
    set yaziOBJ = nothing
end with
end function

function  icalanno(refOBJ,LayerIndex,refOBJIndex,DISALAN)
dim i,yaziOBJ,refPOLY
with netcad
    set yaziOBJ = .newobject()
    .setFilter refOBJ.Limits,array(LayerIndex),array(opoint)
    while .GetNextObject2(yaziOBJ)
        set refPOLY = .newobject()
        set refPOLY = refOBJ.GetObjectAsPline
        if refPOLY.InPoly(yaziOBJ.p1) AND DISALAN<>refOBJ.TABAKA then
            .DrawObject yaziOBJ, red
          refOBJ.pname = yaziOBJ.pname
            .PutObject refOBJIndex, refOBJ
            end if
        set refPOLY = nothing
    wend
    .Resetfilter
    set yaziOBJ = nothing
end with
end function

function  TESCILLI(refOBJ,LayerIndex,refOBJIndex,DISALAN)
dim i,yaziOBJ,refPOLY,harf,hrf,zf
dim elif 
with netcad
    set yaziOBJ = .newobject()
    .setFilter refOBJ.Limits,array(LayerIndex),array(opoint)
    elif=0
    while .GetNextObject2(yaziOBJ)
        set refPOLY = .newobject()
        set refPOLY = refOBJ.GetObjectAsPline
        if refPOLY.InPoly(yaziOBJ.p1) then
        elif=elif+1
        zf=elif-1:IF zf<1 THEN HRF="T" ELSE  HRF="T" & zf
            .DrawObject yaziOBJ, red
               if yaziOBJ.tabaka <> DISALAN  then
                '  yaziOBJ.pname = refOBJ.pname & "/" & elif
          yaziOBJ.pname = refOBJ.pname & "/" & hrf
            .PutObject .CurObjPos, yaziOBJ
              END iF
        end if
        set refPOLY = nothing
    wend
    .Resetfilter
    set yaziOBJ = nothing
end with
end function

function  YIKIK(refOBJ,LayerIndex,refOBJIndex,DISALAN)
dim i,yaziOBJ,refPOLY,harf,hrf,zf
dim elif 
with netcad
    set yaziOBJ = .newobject()
    .setFilter refOBJ.Limits,array(LayerIndex),array(opointAlpha
    elif=0
    while .GetNextObject2(yaziOBJ)
        set refPOLY = .newobject()
        set refPOLY = refOBJ.GetObjectAsPline
        if refPOLY.InPoly(yaziOBJ.p1) then
        elif=elif+1
        zf=elif-1:IF zf<1 THEN HRF="Y" ELSE  HRF="Y" & zf
            .DrawObject yaziOBJ, red
               if yaziOBJ.tabaka <> DISALAN  then
                '  yaziOBJ.pname = refOBJ.pname & "/" & elif
          yaziOBJ.pname = refOBJ.pname & "/" & hrf
            .PutObject .CurObjPos, yaziOBJ
              END iF
        end if
        set refPOLY = nothing
    wend
    .Resetfilter
    set yaziOBJ = nothing
end with
end function