Makro Hakkında:
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.
-
( Eski Sürüme Ait Fotoğraf )
- Ö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ızbu 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:\Sagul\Netcad\Makro\Tanimlar 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:\Sagul\Netcad klasörünün içerisine Makro isimli klasör oluşturulur.
- C:\Sagul\Netcad\Makro klasörünün içerisine Tanimlar isimli klasör oluşturulur.
- C:\Sagul\Netcad\Makro\Tanimlar 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:\Sagul\Netcad") Then
objFolder.SubFolders.Add "Netcad"
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder("C:\Sagul\Netcad")
If Not FSO.FolderExists("C:\Sagul\Netcad\Makro") Then
objFolder.SubFolders.Add "Makro"
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder("C:\Sagul\Netcad\Makro")
If Not FSO.FolderExists("C:\Sagul\Netcad\Makro\Tanimlar") Then
objFolder.SubFolders.Add "Tanimlar"
End If
dim dosyaoku,frs
Set fso = CreateObject("Scripting.FileSystemObject")
Set frs = fso.OpenTextFile("C:\Sagul\Netcad\Makro\Tanimlar\jsonoku.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:\Users\USER\Downloads\Karabedran-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:\Sagul\Netcad\Makro\Tanimlar\jsonoku.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
7 thoughts on “TKGM Parsel Sorgu Dosyasının Koordinatlarının İndirilmesi ve Netcad ile Açılması (Netcad Makro)”
Serkan Şentürk
(19 Eylül 2017 - 12:12)Çalışmanız için çok teşekkür ederim. Çoklu dosya ekleme özelliği daha çok işimize yarayacak
Aykut Allahverdi
(23 Eylül 2017 - 10:51)Merhabalar, yıllardır yapılmasını beklediğimiz bu güzel makronun yapımını da sizden başkasının el atması da düşünülemezdi Şaban abi elinize sağlık çok teşekkür ederiz işimizi gerçekten çok kolaylaştıracak bu makro. Ancak ben 58. Satır 1.Kolon hatası ile karşılaştım çözüm yolu nedir ?
Galip YOĞURT
(2 Ekim 2017 - 20:01)Sevgili Meslektaşım Bu Macro Netcad 7.6 da Koordinat dönüşümünü yapmıyor. Cografi sistemde açıyor parseli. Güzel Çalışmanız ve paylaşımınız için teşekkürler.
Yasin
(19 Ekim 2017 - 13:15)Aynen Şaban bey bu konuda yardımınızı bekliyoruz lütfen.
Şaban GÜL
(20 Ekim 2017 - 14:39)Sayın Galip Yoğurt ve Sn Yasin .. malesef bu durum Netcad 7.6 ile ilgili olup yapabileceğimiz hiçbir şey yok. Durum için üzgünüz.
cihan üner
(11 Kasım 2017 - 09:01)TÜR UYUMSUZ DOSYAOKU 67. SATIR1. KOLON DİYE BİR HATA ALIYORUM BUNUN ÇÖZÜMÜ İÇİN YARDIMCI OLURSANIZ SEVİNİRİM
murat şahin
(24 Mart 2018 - 14:04)merhaba şaban bey macroyu çaliştır dediğim zaman 58. satır 1, kolon diye hata alıyorum yardımcı olursanız sevinirim iyi çalişmalar.