TKGM Parsel Sorgu Dosyasının Koordinatlarının İndirilmesi ve Netcad ile Açılması (Netcad Makro)

Makro Hakkında:

Bu makronun 2023 yılında hazırlanan güncel sürümü ile toplu sorgu dosyası yükleme işleminide yapabilirsiniz. Yeni sürüme gitmek için tıklayınız.

Tapu ve Kadastro Müdürlüğünün sunduğu Parsel sorgulama hizmeti ile size sunulan sorgulama sonucunu netcad projesine atabilirsiniz. Bunun için parsel sorgulama sayfasında sorgulama yaptıktan sonra parselin üzerini tıkladığınızda karşınıza gelen ekrandan dosya indirme seçeneğini tıklayınız. Buradan parsel sorgulama yaptığınız parsele ait koordinat ve bilgilerinin bulunduğu .json dosyasını indiriniz. İndirdiğiniz dosyayı Netcad üzerinden parsel sorgulama dosyasının Netcad ile Açılması makrosunu kullanarak parsel sorgulama sonucunu netcad üzerinden görebilirsiniz.

DİKKAT:

TKGM Tarafından yapılan değişiklikler ile 2019 yılından sonra yapılan sorgulamalar artık açılmıyor. Bu değişikliğe karşı Parsel Sorgulama Dosyası Açılmasının 2019 ( 3. sürüm ) sürümünü yaptık ve yayımladık.

Parsel Sorgulama Dosyası Koordinatlandırma 2019

Program Güncellemesi (2):

Parsel Sorgulama Yazılımımız 01.10.2017 tarihi itibari ile güncellenmiştir. Güncelleme ile bazı hatalar giderilmiş, makronun daha hızlı çalışması sağlanmıştır. Yapılan Değişiklikler Aşağıdaki gibidir.

• 67.Satır Hatası Çözüldü.
• Makroda hata çıkması halinde kendi kendine çözümlüyor
• Ekran Arayüzü yeniden tasarlandı.
• Tabaka seçim ekranı kaldırıldı.
• Alan Adı Gözükmüyor Hatası Alınıyordu. Bu hata çözümlendi.
• Projenin Alan Adları ve Nokta Adları Otomatik Açılacak, Alan Taraması Kapatılacaktır.

Dosyanın İndirilmesi

• Tapu ve Kadastro Genel Müdürlüğü Parsel Sorgulama İnternet Sayfasını Ziyaret Ediniz.   https://parselsorgu.tkgm.gov.tr/ web sitesine giriniz.

• Kaydetme seçeneklerinden GeoJson seçiniz.
• İndirdiğiniz dosyayı bilgisayarınıza depolayınız. ( kaydediniz )
• Netcad\’den aşağıda verilen makroyu kullanarak  sırayla şu işlemleri yapınız.
• Öncelikle dosya seçiniz.  Daha sonra dönüşüm yapmak istiyorsanız Datum, Dilim numarasını seçip proje dönüşümüne evet diyiniz. Burada dikkat etmeniz gereken tüm projenizde dönüşüm yapılacağından bu işlemi yeni proje açarak yapınız.
• Ardından dosyanın aktarılacağı tabakaları seçerek tamam\’a basınız
•   bu form yeni sürümde kaldırıldı
•  Sonuç:

• Makroda Üzerinde Çalıştığımız Gelişmeler:
  • Birden fazla dosya yüklemesi özelliği eklenecek
• Etiketler: Basit düzey makro, Netcad, Makro, Pratik Netcad, Netcad Araçları, Netcad tabaka, netcad seçim, Pratik Netcad, Netcadde nasıl yapılır,netcad menü, netcad araç, nvb, ücretsiz makro, harita makro,

Uyarılar:

(Eski Sürüm İçin )DİKKAT:

67.Satır hatası alanlar için:

Hata alanlar için: bilgisayarınızda
C:SagulNetcadMakroTanimlar klasöründeki jsonoku.sagul dosyasını not defteri ile açıp içini silin ve 2,2,1 yazın. Sorun çözülüyor

• Dosyayı indirerek veya yükleyerek tüm sorumluluğu kabul etmiş sayılırsınız.
• Dosyayı netcadde açarken yeni proje oluşturup açınız. Aksi halde önceki projeniz bozulur ve bu işlemi geri alamayabilirsiniz.
• İndirilen dosyadaki koordinatlar kesinlikle kesinlik arz etmez, resmi işlemlerde kullanılmaz. Sadece bilgilendirme amaçlıdır.
• Netcad makrolarında hiçbir metni veya karakteri değiştirmeyiniz. Aksi halde makro işlevsiz hale gelebilir veya hatalı işlev ile karşılaşabilirsiniz.
• Bu Makronun Çalışması için bilgisayarınızın C Sürücüsünün içerisine klasör ve dosyalar oluşturulur.  Makronun çalışması için bu klasörlere de ihtiyaç duyulmaktadır.
  • C Sürücüsü içerisine Sagul isimli klasör oluşturulur.
  • C:Sagul klasörünün içerisine Netcad isimli klasör oluşturulur.
  • C:SagulNetcad klasörünün içerisine Makro isimli klasör oluşturulur.
  • C:SagulNetcadMakro klasörünün içerisine Tanimlar isimli klasör oluşturulur.
  • C:SagulNetcadMakroTanimlar klasörü içerisine jsonoku.sagul isimli dosya oluşturulur.
  • .sagul dosya türünü not defteri ile açabilir ve görüntüleyebilirsiniz.
  • Bu makroyu çalıştırarak bu klasörleri ve dosyaları oluşturmaya izin vermiş ve sorumluluğu kendiniz almış olacaksınız.

İndirme Linkleri:

İndirme Linki-1: Google Drive ( Harita Akademi )

Makro Açık Kaynak Kodu:

\'\' www.sabangul.com.tr Web Sayfasından İndirilmiştir
\' Şaban GÜL , Harita Mühendisi
\' Her Türlü Hata, İstek ve Öneriler İçin 
\' haritaakademi@gmail.com veya sagulnet@gmail.com
\' adresine durumu anlatan bir e-posta gönderiniz.
Sub Main
 Dim sagultabaka
 with NCLayerManager
.Add \"@SAGUL\",3
 .Add \"SAGUL_NOKTA\", 32
 .Add \"SAGUL_ALAN\", 3
 .Add \"SAGUL_TABLO\", 64
 end with
with netcad
Const ForReading = 1, ForWriting = 2, ForAppending = 8
 Dim fso, objFolder,f
Set fso = CreateObject(\"Scripting.FileSystemObject\")
 Set objFolder = FSO.GetFolder(\"C:\")
 If Not FSO.FolderExists(\"C:Sagul\") Then
 objFolder.SubFolders.Add \"Sagul\"
 End If
Set fso = CreateObject(\"Scripting.FileSystemObject\")
 Set objFolder = FSO.GetFolder(\"C:Sagul\")
 If Not FSO.FolderExists(\"C:SagulNetcad\") Then
 objFolder.SubFolders.Add \"Netcad\"
 End If
Set fso = CreateObject(\"Scripting.FileSystemObject\")
 Set objFolder = FSO.GetFolder(\"C:SagulNetcad\")
 If Not FSO.FolderExists(\"C:SagulNetcadMakro\") Then
 objFolder.SubFolders.Add \"Makro\"
 End If
Set fso = CreateObject(\"Scripting.FileSystemObject\")
 Set objFolder = FSO.GetFolder(\"C:SagulNetcadMakro\")
 If Not FSO.FolderExists(\"C:SagulNetcadMakroTanimlar\") Then
 objFolder.SubFolders.Add \"Tanimlar\"
 End If
dim dosyaoku,frs
 Set fso = CreateObject(\"Scripting.FileSystemObject\")
 Set frs = fso.OpenTextFile(\"C:SagulNetcadMakroTanimlarjsonoku.sagul\", ForReading, True)
Do While Not frs.AtEndOfStream
 dosyaoku= Split(frs.ReadLine,\",\")
 Loop
frs.Close
dim sgul1,sgul2,sgul3,sgul4,sgul5
 sgul1= dosyaoku(0)
 sgul2= dosyaoku(1)
 sgul3= dosyaoku(2)
dim BD,XLSpath,BD_SAGUL,tabaka,hakademi1,hakademi2,hakademi3,hakademi4 ,ha1,ha2,ha3,ha4
hakademi1= \"SAGUL_ALAN\"
 hakademi2= \"SAGUL_TABLO\"
 hakademi3= \"SAGUL_NOKTA\"
 hakademi4= \"\"
for tabaka = 0 to .numlayers - 1
 if .LayerNameOf(tabaka)=hakademi1 then ha1=tabaka
 next
for tabaka = 0 to .numlayers - 1
 if .LayerNameOf(tabaka)=hakademi2 then ha2=tabaka
 next
for tabaka = 0 to .numlayers - 1
 if .LayerNameOf(tabaka)=hakademi3 then ha3=tabaka
 next
for tabaka = 0 to .numlayers - 1
 if .LayerNameOf(tabaka)=hakademi4 then ha4=tabaka
 next
set BD = Netcad.NewBDialog(\"PARSEL SORGU DOSYASI AKTARMA ,[Harita Akademi, Şaban GÜL]\")
 set BD_SAGUL = Netcad.NewBDialog(\"PARSEL SORGU DOSYASI AKTARMA , [Harita Akademi, Şaban GÜL]\")
 BD.PutPrompt \"DİKKAT: İndirdiğiniz Dosyanın Koordinatları Coğrafi Koordinat Sistemindedir\"
 BD.PutPrompt \" Söz konusu koordinatlar aşağıdan seçilecek koordinat sistemine dönüştürülecektir.\"
 BD.PutPrompt \" Dönüşüm yaparken tüm proje etkilenecektir. Bu nedenden dolayı bu aktarım işlemini\"
 BD.PutPrompt \" lütfen yeni proje üzerinde yapınız. \"
 BD.PutPrompt \" \"
 BD.GetFileName \"sabangul\",\"TKGM Parsel Sorgu Json Dosyasını Seçiniz...\",\"C:UsersUSERDownloadsKarabedran-1 Parsel (1).json\",\"Json Dosyası|*.json|Tum Dosyalar|*.*\",\"xls\"
BD.Getradio \"item1\",\"Dönüştürülecek Koordinat Sistemi (UTM3)\",\"Dönüşüm Yapma|ED50|ITRF\" ,sgul1
 BD.Getradio \"item2\",\"Dönüştürülecek Dilim Numarası\",\"27|30|33|36|39|42|45\" ,sgul2
 BD.Getradio \"item3\",\"Koordinat Dönüşümünde Projede Dönüşsün mü ? \",\"Hayır|Evet\" ,sgul3
 if BD.showmodal then
 xlspath = BD.ValueByName(\"sabangul\")
Dim fsot, ft
 Set fsot = CreateObject(\"Scripting.FileSystemObject\")
 Set ft = fsot.OpenTextFile(\"C:SagulNetcadMakroTanimlarjsonoku.sagul\", ForWriting, True)
dim gul1,gul2,gul3,gul4
 gul1= BD.ValueByName(\"item1\")
 gul2= BD.ValueByName(\"item2\")
 gul3= BD.ValueByName(\"item3\")
ft.WriteLine ( gul1 & \",\" & gul2 & \",\" & gul3 )
ft.close
BD_SAGUL.GetCombo \"TABAKA\", \"Alanların Aktarılacağı Tabakayı Seçiniz\", \"\", ha1
 for tabaka = 0 to .numlayers - 1
 BD_SAGUL.AddCombo .LayerNameOf(tabaka)
 next
BD_SAGUL.GetCombo \"TABAKA1\", \"Tapu Bilgilerin Aktarılacağı Tabakayı Seçiniz\", \"\", ha2
 for tabaka = 0 to .numlayers - 1
 BD_SAGUL.AddCombo .LayerNameOf(tabaka)
 next
BD_SAGUL.GetCombo \"TABAKA2\", \"Alanların Aktarılacağı Tabakayı Seçiniz\", \"\", ha3
 for tabaka = 0 to .numlayers - 1
 BD_SAGUL.AddCombo .LayerNameOf(tabaka)
 next
if BD_SAGUL.showmodal then
 hakademi1= BD_SAGUL.ValueByName(\"TABAKA\")
 hakademi2= BD_SAGUL.ValueByName(\"TABAKA1\")
 hakademi3= BD_SAGUL.ValueByName(\"TABAKA2\")
 hakademi4= \"\"
else
 exit sub
 end if
dim ahmet,furkan,uncu
 ahmet= 0
 furkan= 33
 uncu=0
 if BD.ValueByName(\"item1\")=0 then ahmet=0
 if BD.ValueByName(\"item1\")=1 then ahmet=4
 if BD.ValueByName(\"item1\")=2 then ahmet=1
 if BD.ValueByName(\"item2\")=0 then furkan=27
 if BD.ValueByName(\"item2\")=1 then furkan=30
 if BD.ValueByName(\"item2\")=2 then furkan=33
 if BD.ValueByName(\"item2\")=3 then furkan=36
 if BD.ValueByName(\"item2\")=4 then furkan=39
 if BD.ValueByName(\"item2\")=5 then furkan=42
 if BD.ValueByName(\"item2\")=6 then furkan=45
 if BD.ValueByName(\"item3\")=1 then uncu=1
 else
 exit sub
 end if
if XLSpath=-1 or XLSpath=\"\" then
 msgbox \"Dosya Seçilmedi\"
 exit sub
 end if
Dim Satir ,o ,a ,c1,c2,c3,c4,c5,c6
Set fso = CreateObject(\"Scripting.FileSystemObject\")
 Set f = fso.OpenTextFile(BD.ValueByName(\"sabangul\"), ForReading, True)
set BD = Nothing
a= F.ReadLine
 a= replace(a,\"[[[\",\"$\")
 a= replace(a,\"]]]\",\"$\")
if ahmet<>0 then
 dim pc
 set pc = Netcad.NewProjection
 pc.ProjectionType =1
 pc.Zone = 36
 pc.Datum = 0
 pc.SetToCurrentProject FALSE
end if
dim elif,yaren,gul,ruhan
 satir=Split(a,\"$\")
 elif = satir(0)
 yaren= satir(1)
 gul= satir(2)
 ruhan=\"\"
dim saban,soner,olcayto,sagul1,sagul2
 saban=\"\"\"\"
 soner=\"},properties:{\"
 olcayto=\"}}],type:FeatureCollection,crs:{type:name,properties:{name:EPSG:4326}}}\"
 sagul1=replace(yaren,\"],[\",\"$\")
sagul2 =Replace(gul,saban,\"\")
 sagul2 =Replace(sagul2,soner,\"\")
 sagul2 =Replace(sagul2,olcayto,\"\")
 sagul2 =Replace(sagul2,\",\",\" \")
dim sagulnet,sagulnet1,sagulnet2,sagul_1,sagul_2,sagul_3,sagul_4,sagul_5,nitelik
 sagulnet1=Split(sagul2,\"Alan\")
 sagulnet2=Split(sagul2,\"m2\")
 sagul_1=replace(sagulnet2(0),sagulnet1(0),\"\")
 sagul_2=replace(sagul_1,\"Alan:\",\"\")
 sagul_3=replace(sagul_2,\" \",\"\")
sagul_4 = replace(sagul2,sagul_2,sagul_3)
 sagul_5 = replace(sagul_4,\"m2\",\"\")
sagulnet=replace(sagul_5,\"ParselNo\",\"\")
 sagulnet=replace(sagulnet,\"Alan\",\"\")
 sagulnet=replace(sagulnet,\"Mevkii\",\"\")
 sagulnet=replace(sagulnet,\"Nitelik\",\"\")
 sagulnet=replace(sagulnet,\"Ada\",\"\")
 sagulnet=replace(sagulnet,\"Ilce\",\"\")
 sagulnet=replace(sagulnet,\"Il\",\"\")
 sagulnet=replace(sagulnet,\"Pafta\",\"\")
 sagulnet=replace(sagulnet,\"Mahalle\",\"\")
nitelik=Split(sagulnet,\" :\")
dim n1,n2,n3,n4,n5,n6,n7,n8,n9
 n1= replace(nitelik(0),\":\",\"\") \' parsel no
 n2= nitelik(1) \' Alan
 n3= nitelik(2) \' Mevkii
 n4= nitelik(3) \' Nitelik
 n5= replace(nitelik(4),\" \",\"\") \' Ada
 n6= nitelik(5) \' Il
 n7= nitelik(6) \' Ilce
 n8= nitelik(7) \' Pafta
 n9= nitelik(8) \' Mahalle
dim ili,ilcesi,mahallesi,adaparseli,alani,mevkiisi,paftasi,cinsi
ili= n6
 ilcesi= n7
 mahallesi= n9
 adaparseli= n5 & \"_\" & n1
 alani= n2
 mevkiisi= n3
 paftasi= n8
 cinsi= n4
 paftasi= n8
dim x,kubilay ,satir2
 dim i,j,p
 dim yasin
 dim soner1,soner2
 Satir=Split(sagul1,\"$\")
 kubilay=0
set p = nothing
 set p = .NewPoly
 for each x in satir
 kubilay=kubilay+1
 Satir2=Split(x,\",\")
 soner1= satir2(0)
 soner2= satir2(1)
 p.AddCoor(.NewC(soner1,soner2,0))
.AddObject .MakePoint(.newc(soner1,soner2,0), kubilay,\"SAGULNET\" ,hakademi3)
 next
 set o = .MakePline(adaparseli,POLYCLOSED+POLYFILLED,alani,hakademi1,0,0,p)
 .AddObject o
set o = nothing
 set p = nothing
f.Close
if ahmet<>0 then
set pc = Netcad.NewProjection
 pc.ProjectionType =3
 pc.Zone = furkan
 pc.Datum = ahmet
 if uncu=1 then
 pc.SetToCurrentProject true
 else
 pc.SetToCurrentProject false
 end if
 end if
.findworld
dim secim,c,obj,yazi,layerno ,yaz1,yaz2,yaz3,yaz4,yaz5,yaz6,yaz7,yaz8,yaz9,yaz10,asilyazi,yaziboy,koorx
 set secim = .NewSelectStatus()
 set c = .newc(0,0,0)
asilyazi=2
 yaziboy=3
 layerno=.foundlayer(\"TXT_KOORDINAT\")
if .SelectPoint(\"Tablonun Yerleştirileceği Yeri Seçiniz\", c, 2) then
koorx=c.x
 koorx=koorx+2
c.x=koorx-(yaziboy)
 set yaz1=.maketext(c, adaparseli & \" No\'lu Parsel Bilgileri\",0,0,asilyazi,0,\"1\",hakademi2)
 c.x=koorx-(yaziboy*2)
 set yaz2=.maketext(c, \"İli: \" & ili,0,0,asilyazi,0,\"1\",hakademi2)
 c.x=koorx-(yaziboy*3)
 set yaz3=.maketext(c, \"İlçesi: \" & ilcesi,0,0,asilyazi,0,\"1\",hakademi2)
 c.x=koorx-(yaziboy*4)
 set yaz4=.maketext(c, \"Mahallesi: \" & mahallesi,0,0,asilyazi,0,\"1\",hakademi2)
 c.x=koorx-(yaziboy*5)
 set yaz5=.maketext(c, \"Alanı: \" & alani,0,0,asilyazi,0,\"1\",hakademi2)
 c.x=koorx-(yaziboy*6)
 set yaz6=.maketext(c, \"Cinsi: \" & cinsi,0,0,asilyazi,0,\"1\",hakademi2)
 c.x=koorx-(yaziboy*7)
 set yaz7=.maketext(c, \"Paftası: \" & paftasi,0,0,asilyazi,0,\"1\",hakademi2)
 c.x=koorx-(yaziboy*8)
 set yaz8=.maketext(c, \"Mevkiisi: \" & mevkiisi,0,0,asilyazi,0,\"1\",hakademi2)
.addobject(yaz1)
 .addobject(yaz2)
 .addobject(yaz3)
 .addobject(yaz4)
 .addobject(yaz5)
 .addobject(yaz6)
 .addobject(yaz7)
 .addobject(yaz8)
\'.AddObject .MakeLine(.newc(c.y,c.x+(asilyazi*3),0), .newc(c.y+asilyazi*25,c.x+(asilyazi*3),0), .CreateLayer(\"TABAKA1\",yellow), 0, 0)
end if
End With
End Sub