Netcad Makro : Seçilen noktayı parsel sorgulama da açma




Netcad çizim ekranı üzerinden tıklanan noktayı bilgisayarınızda varsayılan olarak tanımlı tarayıcıyı kullanarak Parsel Sorgulama sayfasını açar ve ilgili koordinatlarda bir geometri bilgisi varsa gösteren makro.

Yazının tarihi itibariyle 3 / 36 / ITRF96 için gayet yeterli doğru sonuçlar vermektedir. Diğer dom'lar için test edilmediği ve Parsel Sorgulama sisteminin altyapısı değişirse makronun çalışmama ihtimali olduğu göz önünde bulundurularak kullanılmadır.


Sub Main

Dim cr
dim dom6,x6,y6,dom3,x3,y3
dim a,b,k0,f,f1,e,eisq,ei,kc1,kc2,kc3,kc4,sin1
dim yayuzunlugu,mu,phi,c1,t1,n1,r1,d
dim fact1,fact2,fact3,fact4,lofact1,lofact2,lofact3,deltalong,zoneDOM,rawEnlem
dim enlem,boylam,enlemderece,enlemdakika,enlemsaniye,boylamderece,boylamdakika,boylamsaniye
dim pi
dim objShell,url
dim x,y
dim secim

with Netcad

'Kullanıcıdan koordinat sistemi ve DOM bilgisini alır
'DOM 27 - 30 - 33 - 36 - 39 - 42 - 45
'Koordinat ITRF96 - ED50
'Dilim 3 Derece - 6 Derece
set secim = Netcad.NewBDialog("Parsel Sorgulama Sayfasında Ara")
secim.Getcombo "dilim","Dilim : ","3",0
secim.Getcombo "koordinat","Koordinat Sistemi : ","ITRF96",0
secim.Getcombo "dilimorta","Dilim Orta Meridyeni : ","27|30|33|36|39|42|45",3
if secim.showmodal then

set cr = .newc(0,0,0)
while .SelectPoint("Herhangi Bir Nokta Seç",cr,-1)
'Değişmeyen Sabit
pi=3.141592654 'Yaklaşık en doğru sonuca bu şekilde ulaştım

'dom ayarlaması
if secim.ValueByName("dilimorta")=0 then
dom3=27
ElseIf secim.ValueByName("dilimorta")=1 then
dom3=30
ElseIf secim.ValueByName("dilimorta")=2 then
dom3=33
ElseIf secim.ValueByName("dilimorta")=3 then 
dom3=36
ElseIf secim.ValueByName("dilimorta")=4 then 
dom3=39
ElseIf secim.ValueByName("dilimorta")=5 then 
dom3=42
ElseIf secim.ValueByName("dilimorta")=6 then 
dom3=45
end if

x3=CDbl(cr.x)
y3=CDbl(cr.y)

'Sabit Değerler ITRF96(GRS80)-ED50(HAYFORD) için
if secim.ValueByName("koordinat")=0 then
'ITRF96 GRS80 Dönüşüm Parametreleri
a=6378137
b=6356752.31410
else
'ED50 HAYFORD Dönüşüm Parametreleri
a=6378388
b=6356911.9
end if

'Seçilen Dilime Göre k0 ayarlanır
if secim.ValueByName("dilim")=0 then
k0=0.9996 '3 Derece için
'3 Derecelik sistemdeki koordinatlar 6 Derecelik sisteme çevrilir
dom6=(((dom3+3)/6)+30)
y6=(y3-500000)*k0+500000
x6=(x3*k0)
else
k0=1 '6 Derece için
dom6=dom3
y6=y3
x6=x3
end if

'Hesaplama kısmı
'Bu kısımda ufak tefek hatalarım olmuş olabilir.
'Açıkçası işimi görecek kadar doğruluk yeterli olduğu için görmezden geliyorum şimdilik. 
'36 için sonuçlar gayet iyi diğer domlar için test etme şansım olmadı o kısımlar size ait.
f=(a-b)/a
f1=1/f
e=sqr(1-(b/a)*(b/a))
eisq=e*e/(1-(e*e))
ei=(1-sqr(1-e*e))/(1+sqr(1-e*e))
sin1=21*ei^2/16-55*ei^4/32
kc1=3*ei/2-27*ei^3/32
kc2=21*ei^2/16-55*ei^4/32
kc3=151*ei^3/96
kc4=1097*ei^4/512
x=500000-(y6)
y=x6
yayuzunlugu=x6/k0
mu=yayuzunlugu/(a*(1-(e^2/4)-3*(e^4/64)-5*(e^6/256)))
phi=mu+kc1*Sin(2*mu)+kc2*Sin(4*mu)+kc3*Sin(6*mu)+kc4*Sin(8*mu)
c1=eisq*(Cos(phi)^2)
t1=Tan(phi)^2
n1=a/((1-(e*Sin(phi))^2)^(1/2))
r1=a*(1-e*e)/(1-(e*Sin(phi))^2)^(3/2)
d=x/(n1*k0)
fact1=n1*Tan(phi)/r1
fact2=((d*d)/2)
fact3=(5+(3*t1)+(10*c1)-(4*c1*c1)-(9*eisq))*(d^4/24)
fact4=(61+90*t1+298*c1+45*t1*t1-252*eisq-3*c1*c1)*d^6/720
lofact1=d
lofact2=(1+(2*t1)+c1)*(d^3/6)
lofact3=(5-2*c1+28*t1-3*c1*c1+8*eisq+24*t1*t1)*d^5/120
deltalong=(lofact1-lofact2+lofact3)/(Cos(phi))
zoneDOM=6*dom6-183
rawEnlem=180*(phi-fact1*(fact2+fact3+fact4))/pi

'Tüm hesaplamalara göre enlem ve boylam hesaplanır
enlem=rawEnlem
boylam=zoneDOM-((deltalong*180)/pi)

'Bilgisayarda tanımlı internet tarayıcısında sonuçlar açılır    
url="https://parselsorgu.tkgm.gov.tr/#ara/cografi/"&Cstr(enlem)&"/"&Cstr(boylam)
set objShell = CreateObject("WScript.Shell")
objShell.run(url)  		  
	   
wend
set cr = nothing

set secim = Nothing
end if

end with
end sub

Açıklamalar ve ilgili dosyalar için github linki -> Netcad-Makro-Parsel-Sorgulama-Sayfasini-Ac

Netcad Makro : Netcad'e program kısayolu ekleme



Basit ama sürekli kullanılan programları netcad ekranından ayrılmanıza gerek kalmadan çalıştırılmasını sağlayan ufak bir makro. 


sub main
with netcad
Dim objShell
Set objShell = CreateObject("WScript.Shell")
'Çalıştıracağınız programın ismi ve konumu bu alana gelecek
objShell.Run("""C:\PROGRAM-KONUMU\PROGRAM-İSMİ.exe""/command:repobrowser")
Set objShell = Nothing
end with
end sub

Açıklamalar ve ilgili dosyalar için github linki -> Netcad-Makro-Program-Kisayolu