SagulCAD – Netcad TKGM Parsel Sorgu Makrosu
Netcad içerisinden tek tıklamayla TKGM parsel verisini sorgulayın, parsel geometrisini projenize aktarın ve parsel bilgilerini otomatik olarak çizimin üzerine yerleştirin.
Bu makro, Netcad üzerinde çalışan pratik bir parsel sorgulama aracıdır. Kullanıcı yalnızca harita üzerinde sorgulamak istediği noktayı seçer. Makro aktif projenin koordinat sistemini dikkate alarak seçilen noktayı coğrafi koordinata dönüştürür, TKGM Parsel Sorgu altyapısından ilgili taşınmazı bulur ve gelen parsel geometrisini tekrar Netcad proje koordinat sistemine dönüştürerek çizime aktarır.
⬇ Makroyu İndir
SagulCAD – TKGM Parsel Sorgu Makrosu
İndirme bağlantısı daha sonra bu butona eklenecektir.
Dosya türü: .NVB
Platform: Netcad
Geliştirici: SagulCAD
Şaban GÜL – Harita Mühendisi
NVB Makro Kodu
WordPress düzenleyicisinde buraya bir Kod bloğu ekleyip makronun güncel .NVB içeriğini yerleştirebilirsin.
JavaScript
' =============================================================================
' Şaban GÜL Tarafından Üretilmiştir
' Daha Fazlası İçin: www.sabangul.com
' Hata, İstek ve Öneriler İçin: sabangul67@gmail.com
' Tarih: 13.08.2026
'
' MAKRO: TKGM PARSEL SORGU -> NETCAD'E DOĞRUDAN ÇİZİM
' -----------------------------------------------------------------------------
' AMAÇ
' - Aktif Netcad projesinin tanımlı projeksiyonunu okur.
' - Kullanıcı Netcad ekranında parselin içine bir nokta tıklar.
' - Netcad Y/X koordinatını coğrafi WGS84 enlem/boylama çevirir.
' - TKGM MEGSİS CBS parsel servisinden tıklanan parselin GeoJSON geometrisini alır.
' - Gelen Polygon / MultiPolygon koordinatlarını aktif Netcad projeksiyonuna çevirir.
' - Parsel sınırlarını TKGM_PARSEL tabakasına kapalı çoklu doğru olarak çizer.
' - Parselin ağırlık merkezine ADA_PARSEL başlığı ve TKGM properties içindeki
' tüm alanları 0.40 m temel yazı boylu, sola dayalı çizgili tablo halinde
' TKGM_PARSEL_BILGI tabakasına yazar.
' - Bilgi tablosunun en altında SagulCAD | Şaban GÜL | Harita Mühendisi imzası bulunur.
' - Obje/parsel sorgu taraması açıktır: her çizimden sonra yeni parsel seçimi devam eder.
' - ESC ile seçim biter.
'
' ÖNEMLİ
' - Aktif projedeki mevcut objelerin projeksiyonu DEĞİŞTİRİLMEZ.
' - SetToCurrentProject TRUE kullanılmaz.
' - Netcad koordinat düzeni: Y = Easting / Doğu, X = Northing / Kuzey.
' - TKGM geometrisi: [boylam, enlem] (WGS84 coğrafi).
' - Delikli Polygon / MultiPolygon geometrilerde her halka ayrı kapalı opline olarak
' çizilir; böylece sınır geometrisi kaybolmaz. Bu sürüm halkaları tek bir complex
' polygon topolojisine birleştirmez.
' - ED50 datumunda doğru ve güvenilir datum dönüşümü için bölgesel dönüşüm parametresi
' gerektiğinden bu sürüm ED50 projelerinde bilerek işlemi durdurur.
' =============================================================================
Option Explicit
Const SABANGUL_LAYER_NAME = "TKGM_PARSEL"
Const SABANGUL_INFO_LAYER_NAME = "TKGM_PARSEL_BILGI"
Const SABANGUL_API_V31 = "https://cbsapi.tkgm.gov.tr/megsiswebapi.v3.1/api/parsel/"
Const SABANGUL_API_V3 = "https://cbsapi.tkgm.gov.tr/megsiswebapi.v3/api/parsel/"
Const SABANGUL_HTTP_TIMEOUT_MS = 22000
Sub Main
Dim sabangul_prj
Dim sabangul_projType, sabangul_datum, sabangul_zone
Dim sabangul_layer, sabangul_infoLayer
Dim sabangul_click
Dim sabangul_lat, sabangul_lon
Dim sabangul_json, sabangul_httpError
Dim sabangul_geomType, sabangul_coords, sabangul_geomError
Dim sabangul_name
Dim sabangul_added, sabangul_totalParsel, sabangul_totalObject, sabangul_failed
Dim sabangul_projectionError
Dim sabangul_centerY, sabangul_centerX, sabangul_infoAdded
sabangul_totalParsel = 0
sabangul_totalObject = 0
sabangul_failed = 0
With Netcad
' ---------------------------------------------------------------------
' 1) AKTİF PROJE PROJEKSİYONUNU OKU
' ---------------------------------------------------------------------
Set sabangul_prj = .NewProjection
On Error Resume Next
Err.Clear
sabangul_prj.GetFromCurrentProject
sabangul_projectionError = Err.Number
Err.Clear
On Error GoTo 0
If sabangul_projectionError <> 0 Then
MsgBox "Aktif projenin projeksiyon bilgisi okunamadı." & vbCrLf & _
"Projeye doğru koordinat sistemi tanımlandıktan sonra tekrar çalıştırın.", _
48, "TKGM Parsel Sorgu [sabangul.com]"
Set sabangul_prj = Nothing
Exit Sub
End If
sabangul_projType = sabangul_prj.ProjectionType
sabangul_datum = sabangul_prj.Datum
sabangul_zone = sabangul_prj.Zone
If CLng(sabangul_projType) = 0 Then
MsgBox "Aktif projede tanımlı bir projeksiyon bulunamadı." & vbCrLf & _
"Bu makro koordinatı tahmin etmez; önce projeksiyonu tanımlayın.", _
48, "TKGM Parsel Sorgu [sabangul.com]"
Set sabangul_prj = Nothing
Exit Sub
End If
' Tarihsel Netcad NVBASIC örneklerinde ED50 datum kodu 4 olarak kullanılır.
If CLng(sabangul_datum) = 4 Then
MsgBox "Aktif proje ED50 datumunda görünüyor." & vbCrLf & vbCrLf & _
"Parsel sınırının yanlış parsele kaymaması için yaklaşık ED50-WGS84" & vbCrLf & _
"dönüşümü kullanılmadı. ED50 için ayrı, hassas datum dönüşümlü sürüm gerekir.", _
48, "TKGM Parsel Sorgu [sabangul.com]"
Set sabangul_prj = Nothing
Exit Sub
End If
If Not SabangulProjectionSupported(sabangul_projType, sabangul_zone) Then
MsgBox "Bu aktif proje projeksiyonu bu sürümde desteklenmiyor." & vbCrLf & _
"ProjectionType=" & CStr(sabangul_projType) & _
" Zone=" & CStr(sabangul_zone) & _
" Datum=" & CStr(sabangul_datum) & vbCrLf & vbCrLf & _
"Desteklenenler: Coğrafi, UTM 3° ve UTM 6° (WGS84 / ITRF / GRS80).", _
48, "TKGM Parsel Sorgu [sabangul.com]"
Set sabangul_prj = Nothing
Exit Sub
End If
' ---------------------------------------------------------------------
' 2) TKGM PARSEL TABAKASINI HAZIRLA
' ---------------------------------------------------------------------
sabangul_layer = .FoundLayer(SABANGUL_LAYER_NAME)
If sabangul_layer = -1 Then
sabangul_layer = .CreateLayer(SABANGUL_LAYER_NAME, LightRed)
End If
If sabangul_layer = -1 Then
MsgBox "TKGM_PARSEL tabakası oluşturulamadı.", 16, _
"TKGM Parsel Sorgu [sabangul.com]"
Set sabangul_prj = Nothing
Exit Sub
End If
' ---------------------------------------------------------------------
' 2.1) TKGM PARSEL BİLGİ TABAKASINI HAZIRLA
' ---------------------------------------------------------------------
sabangul_infoLayer = .FoundLayer(SABANGUL_INFO_LAYER_NAME)
If sabangul_infoLayer = -1 Then
sabangul_infoLayer = .CreateLayer(SABANGUL_INFO_LAYER_NAME, LightCyan)
End If
If sabangul_infoLayer = -1 Then
MsgBox "TKGM_PARSEL_BILGI tabakası oluşturulamadı.", 16, _
"TKGM Parsel Sorgu [sabangul.com]"
Set sabangul_prj = Nothing
Exit Sub
End If
' ---------------------------------------------------------------------
' 3) KULLANICI İPTAL EDENE KADAR PARSEL SORGULA
' ---------------------------------------------------------------------
Set sabangul_click = .NewC(0, 0, 0)
While .SelectPoint("TKGM Parsel Sorgu: Parselin içine bir nokta göster (ESC: Bitir)", sabangul_click, -1)
sabangul_lat = 0
sabangul_lon = 0
If Not SabangulProjectToGeographic( _
CDbl(sabangul_click.y), _
CDbl(sabangul_click.x), _
CLng(sabangul_projType), _
CDbl(sabangul_zone), _
CLng(sabangul_datum), _
sabangul_lat, _
sabangul_lon) Then
sabangul_failed = sabangul_failed + 1
MsgBox "Tıklanan Y/X koordinatı coğrafi koordinata dönüştürülemedi." & vbCrLf & _
"Y=" & CStr(sabangul_click.y) & " X=" & CStr(sabangul_click.x), _
48, "TKGM Parsel Sorgu [sabangul.com]"
ElseIf sabangul_lat < 33 Or sabangul_lat > 44.5 Or sabangul_lon < 23 Or sabangul_lon > 50.5 Then
sabangul_failed = sabangul_failed + 1
MsgBox "Dönüştürülen koordinat Türkiye sınırları dışında görünüyor." & vbCrLf & _
"Enlem=" & SabangulInvariantString(sabangul_lat) & vbCrLf & _
"Boylam=" & SabangulInvariantString(sabangul_lon) & vbCrLf & vbCrLf & _
"Aktif proje projeksiyonu / dilim bilgisini kontrol edin.", _
48, "TKGM Parsel Sorgu [sabangul.com]"
Else
sabangul_json = ""
sabangul_httpError = ""
If SabangulQueryTkgm(sabangul_lat, sabangul_lon, sabangul_json, sabangul_httpError) Then
sabangul_geomType = ""
sabangul_coords = ""
sabangul_geomError = ""
If SabangulExtractGeometry(sabangul_json, sabangul_geomType, sabangul_coords, sabangul_geomError) Then
sabangul_name = SabangulBuildParcelName(sabangul_json)
' Bilgi bloğu için güvenli başlangıç noktası: kullanıcının tıkladığı nokta.
' Dış halka başarıyla oluşursa SabangulDrawGeometry bunu gerçek
' CenterOfMass koordinatıyla değiştirir.
sabangul_centerY = CDbl(sabangul_click.y)
sabangul_centerX = CDbl(sabangul_click.x)
sabangul_added = SabangulDrawGeometry( _
sabangul_coords, _
sabangul_geomType, _
sabangul_name, _
sabangul_layer, _
CLng(sabangul_projType), _
CDbl(sabangul_zone), _
CLng(sabangul_datum), _
sabangul_centerY, _
sabangul_centerX)
If sabangul_added > 0 Then
sabangul_infoAdded = SabangulDrawParcelInfo( _
sabangul_json, _
sabangul_infoLayer, _
CDbl(sabangul_centerY), _
CDbl(sabangul_centerX), _
CLng(sabangul_projType), _
CDbl(sabangul_lat), _
CDbl(sabangul_lon))
sabangul_totalParsel = sabangul_totalParsel + 1
sabangul_totalObject = sabangul_totalObject + sabangul_added + sabangul_infoAdded
.NetcadCommand "REGEN"
Else
sabangul_failed = sabangul_failed + 1
MsgBox "TKGM geometrisi alındı ancak Netcad objesi üretilemedi.", _
48, "TKGM Parsel Sorgu [sabangul.com]"
End If
Else
sabangul_failed = sabangul_failed + 1
MsgBox "TKGM yanıtından Polygon geometrisi okunamadı." & vbCrLf & _
sabangul_geomError, 48, "TKGM Parsel Sorgu [sabangul.com]"
End If
Else
sabangul_failed = sabangul_failed + 1
MsgBox "TKGM parsel servisine ulaşılamadı veya bu noktada parsel bulunamadı." & vbCrLf & vbCrLf & _
sabangul_httpError, 48, "TKGM Parsel Sorgu [sabangul.com]"
End If
End If
Wend
Set sabangul_click = Nothing
Set sabangul_prj = Nothing
If sabangul_totalParsel > 0 Or sabangul_failed > 0 Then
MsgBox "Parsel sorgu tamamlandı." & vbCrLf & vbCrLf & _
"Başarılı parsel : " & CStr(sabangul_totalParsel) & vbCrLf & _
"Çizilen obje : " & CStr(sabangul_totalObject) & vbCrLf & _
"Başarısız sorgu : " & CStr(sabangul_failed) & vbCrLf & _
"Parsel tabakası : " & SABANGUL_LAYER_NAME & vbCrLf & _
"Bilgi tabakası : " & SABANGUL_INFO_LAYER_NAME, _
64, "TKGM Parsel Sorgu [sabangul.com]"
End If
End With
End Sub
' =============================================================================
' PROJEKSİYON
' Netcad tarihsel makro örneklerindeki ProjectionType değerleri:
' 1 = Coğrafi, 2 = UTM 6 Derecelik, 3 = UTM 3 Derecelik
' =============================================================================
Function SabangulProjectionSupported(ByVal sabangul_type, ByVal sabangul_zone)
Dim sabangul_t, sabangul_z
sabangul_t = CLng(sabangul_type)
sabangul_z = CDbl(sabangul_zone)
SabangulProjectionSupported = False
If sabangul_t = 1 Then
SabangulProjectionSupported = True
ElseIf sabangul_t = 3 Then
If sabangul_z >= 24 And sabangul_z <= 51 Then SabangulProjectionSupported = True
ElseIf sabangul_t = 2 Then
If sabangul_z >= 1 And sabangul_z <= 60 Then SabangulProjectionSupported = True
End If
End Function
Function SabangulProjectToGeographic(ByVal sabangul_y, ByVal sabangul_x, _
ByVal sabangul_type, ByVal sabangul_zone, _
ByVal sabangul_datum, _
ByRef sabangul_lat, ByRef sabangul_lon)
Dim sabangul_a, sabangul_invF, sabangul_k0, sabangul_lon0
SabangulProjectToGeographic = False
If CLng(sabangul_type) = 1 Then
' Netcad Y/X geleneği: Y=boylam, X=enlem
sabangul_lon = CDbl(sabangul_y)
sabangul_lat = CDbl(sabangul_x)
SabangulProjectToGeographic = True
Exit Function
End If
SabangulEllipsoid sabangul_datum, sabangul_a, sabangul_invF
If CLng(sabangul_type) = 3 Then
' UTM 3° / TM: Zone, orta meridyendir (27,30,33,36,...)
sabangul_lon0 = CDbl(sabangul_zone)
sabangul_k0 = 1
ElseIf CLng(sabangul_type) = 2 Then
' UTM 6°: Zone, UTM zon numarasıdır (35,36,37,38 gibi)
sabangul_lon0 = CDbl(sabangul_zone) * 6 - 183
sabangul_k0 = 0.9996
Else
Exit Function
End If
SabangulTMInverse CDbl(sabangul_y), CDbl(sabangul_x), _
sabangul_lon0, sabangul_a, sabangul_invF, sabangul_k0, _
sabangul_lat, sabangul_lon
If sabangul_lat >= -90 And sabangul_lat <= 90 And _
sabangul_lon >= -180 And sabangul_lon <= 180 Then
SabangulProjectToGeographic = True
End If
End Function
Function SabangulGeographicToProject(ByVal sabangul_lat, ByVal sabangul_lon, _
ByVal sabangul_type, ByVal sabangul_zone, _
ByVal sabangul_datum, _
ByRef sabangul_y, ByRef sabangul_x)
Dim sabangul_a, sabangul_invF, sabangul_k0, sabangul_lon0
SabangulGeographicToProject = False
If CLng(sabangul_type) = 1 Then
sabangul_y = CDbl(sabangul_lon)
sabangul_x = CDbl(sabangul_lat)
SabangulGeographicToProject = True
Exit Function
End If
SabangulEllipsoid sabangul_datum, sabangul_a, sabangul_invF
If CLng(sabangul_type) = 3 Then
sabangul_lon0 = CDbl(sabangul_zone)
sabangul_k0 = 1
ElseIf CLng(sabangul_type) = 2 Then
sabangul_lon0 = CDbl(sabangul_zone) * 6 - 183
sabangul_k0 = 0.9996
Else
Exit Function
End If
SabangulTMForward CDbl(sabangul_lat), CDbl(sabangul_lon), _
sabangul_lon0, sabangul_a, sabangul_invF, sabangul_k0, _
sabangul_y, sabangul_x
SabangulGeographicToProject = True
End Function
Sub SabangulEllipsoid(ByVal sabangul_datum, ByRef sabangul_a, ByRef sabangul_invF)
' Datum 0 tarihsel Netcad örneklerinde WGS84'tür.
' ITRF / GRS80 tarafında GRS80 elipsoidi kullanılır.
sabangul_a = 6378137
If CLng(sabangul_datum) = 0 Then
sabangul_invF = 298.257223563
Else
sabangul_invF = 298.257222101
End If
End Sub
Sub SabangulTMForward(ByVal sabangul_latDeg, ByVal sabangul_lonDeg, _
ByVal sabangul_lon0Deg, ByVal sabangul_a, _
ByVal sabangul_invF, ByVal sabangul_k0, _
ByRef sabangul_easting, ByRef sabangul_northing)
Dim sabangul_pi, sabangul_f, sabangul_e2, sabangul_ep2
Dim sabangul_lat, sabangul_lon, sabangul_lon0
Dim sabangul_sinLat, sabangul_cosLat, sabangul_tanLat
Dim sabangul_N, sabangul_T, sabangul_C, sabangul_tmA, sabangul_M
sabangul_pi = 4 * Atn(1)
sabangul_f = 1 / sabangul_invF
sabangul_e2 = sabangul_f * (2 - sabangul_f)
sabangul_ep2 = sabangul_e2 / (1 - sabangul_e2)
sabangul_lat = sabangul_latDeg * sabangul_pi / 180
sabangul_lon = sabangul_lonDeg * sabangul_pi / 180
sabangul_lon0 = sabangul_lon0Deg * sabangul_pi / 180
sabangul_sinLat = Sin(sabangul_lat)
sabangul_cosLat = Cos(sabangul_lat)
sabangul_tanLat = sabangul_sinLat / sabangul_cosLat
sabangul_N = sabangul_a / Sqr(1 - sabangul_e2 * sabangul_sinLat * sabangul_sinLat)
sabangul_T = sabangul_tanLat * sabangul_tanLat
sabangul_C = sabangul_ep2 * sabangul_cosLat * sabangul_cosLat
sabangul_tmA = sabangul_cosLat * (sabangul_lon - sabangul_lon0)
sabangul_M = sabangul_a * ( _
(1 - sabangul_e2 / 4 - 3 * (sabangul_e2 ^ 2) / 64 - 5 * (sabangul_e2 ^ 3) / 256) * sabangul_lat _
- (3 * sabangul_e2 / 8 + 3 * (sabangul_e2 ^ 2) / 32 + 45 * (sabangul_e2 ^ 3) / 1024) * Sin(2 * sabangul_lat) _
+ (15 * (sabangul_e2 ^ 2) / 256 + 45 * (sabangul_e2 ^ 3) / 1024) * Sin(4 * sabangul_lat) _
- (35 * (sabangul_e2 ^ 3) / 3072) * Sin(6 * sabangul_lat))
sabangul_easting = 500000 + sabangul_k0 * sabangul_N * ( _
sabangul_tmA _
+ (1 - sabangul_T + sabangul_C) * (sabangul_tmA ^ 3) / 6 _
+ (5 - 18 * sabangul_T + (sabangul_T ^ 2) + 72 * sabangul_C - 58 * sabangul_ep2) * (sabangul_tmA ^ 5) / 120)
sabangul_northing = sabangul_k0 * ( _
sabangul_M + sabangul_N * sabangul_tanLat * ( _
(sabangul_tmA ^ 2) / 2 _
+ (5 - sabangul_T + 9 * sabangul_C + 4 * (sabangul_C ^ 2)) * (sabangul_tmA ^ 4) / 24 _
+ (61 - 58 * sabangul_T + (sabangul_T ^ 2) + 600 * sabangul_C - 330 * sabangul_ep2) * (sabangul_tmA ^ 6) / 720))
End Sub
Sub SabangulTMInverse(ByVal sabangul_easting, ByVal sabangul_northing, _
ByVal sabangul_lon0Deg, ByVal sabangul_a, _
ByVal sabangul_invF, ByVal sabangul_k0, _
ByRef sabangul_latDeg, ByRef sabangul_lonDeg)
Dim sabangul_pi, sabangul_f, sabangul_e2, sabangul_ep2
Dim sabangul_x, sabangul_y, sabangul_M, sabangul_mu, sabangul_e1
Dim sabangul_J1, sabangul_J2, sabangul_J3, sabangul_J4, sabangul_fp
Dim sabangul_sinFp, sabangul_cosFp, sabangul_tanFp
Dim sabangul_C1, sabangul_T1, sabangul_N1, sabangul_R1, sabangul_D
Dim sabangul_lat, sabangul_lon
sabangul_pi = 4 * Atn(1)
sabangul_f = 1 / sabangul_invF
sabangul_e2 = sabangul_f * (2 - sabangul_f)
sabangul_ep2 = sabangul_e2 / (1 - sabangul_e2)
sabangul_x = sabangul_easting - 500000
sabangul_y = sabangul_northing
sabangul_M = sabangul_y / sabangul_k0
sabangul_mu = sabangul_M / (sabangul_a * _
(1 - sabangul_e2 / 4 - 3 * (sabangul_e2 ^ 2) / 64 - 5 * (sabangul_e2 ^ 3) / 256))
sabangul_e1 = (1 - Sqr(1 - sabangul_e2)) / (1 + Sqr(1 - sabangul_e2))
sabangul_J1 = 3 * sabangul_e1 / 2 - 27 * (sabangul_e1 ^ 3) / 32
sabangul_J2 = 21 * (sabangul_e1 ^ 2) / 16 - 55 * (sabangul_e1 ^ 4) / 32
sabangul_J3 = 151 * (sabangul_e1 ^ 3) / 96
sabangul_J4 = 1097 * (sabangul_e1 ^ 4) / 512
sabangul_fp = sabangul_mu _
+ sabangul_J1 * Sin(2 * sabangul_mu) _
+ sabangul_J2 * Sin(4 * sabangul_mu) _
+ sabangul_J3 * Sin(6 * sabangul_mu) _
+ sabangul_J4 * Sin(8 * sabangul_mu)
sabangul_sinFp = Sin(sabangul_fp)
sabangul_cosFp = Cos(sabangul_fp)
sabangul_tanFp = sabangul_sinFp / sabangul_cosFp
sabangul_C1 = sabangul_ep2 * sabangul_cosFp * sabangul_cosFp
sabangul_T1 = sabangul_tanFp * sabangul_tanFp
sabangul_N1 = sabangul_a / Sqr(1 - sabangul_e2 * sabangul_sinFp * sabangul_sinFp)
sabangul_R1 = sabangul_a * (1 - sabangul_e2) / _
((1 - sabangul_e2 * sabangul_sinFp * sabangul_sinFp) ^ 1.5)
sabangul_D = sabangul_x / (sabangul_N1 * sabangul_k0)
sabangul_lat = sabangul_fp - (sabangul_N1 * sabangul_tanFp / sabangul_R1) * ( _
(sabangul_D ^ 2) / 2 _
- (5 + 3 * sabangul_T1 + 10 * sabangul_C1 - 4 * (sabangul_C1 ^ 2) - 9 * sabangul_ep2) * (sabangul_D ^ 4) / 24 _
+ (61 + 90 * sabangul_T1 + 298 * sabangul_C1 + 45 * (sabangul_T1 ^ 2) - 252 * sabangul_ep2 - 3 * (sabangul_C1 ^ 2)) * (sabangul_D ^ 6) / 720)
sabangul_lon = sabangul_lon0Deg * sabangul_pi / 180 + ( _
sabangul_D _
- (1 + 2 * sabangul_T1 + sabangul_C1) * (sabangul_D ^ 3) / 6 _
+ (5 - 2 * sabangul_C1 + 28 * sabangul_T1 - 3 * (sabangul_C1 ^ 2) + 8 * sabangul_ep2 + 24 * (sabangul_T1 ^ 2)) * (sabangul_D ^ 5) / 120) / sabangul_cosFp
sabangul_latDeg = sabangul_lat * 180 / sabangul_pi
sabangul_lonDeg = sabangul_lon * 180 / sabangul_pi
End Sub
' =============================================================================
' TKGM HTTP SORGUSU
' =============================================================================
Function SabangulQueryTkgm(ByVal sabangul_lat, ByVal sabangul_lon, _
ByRef sabangul_json, ByRef sabangul_errorText)
Dim sabangul_bases, sabangul_i, sabangul_url
Dim sabangul_response, sabangul_error
sabangul_bases = Array(SABANGUL_API_V31, SABANGUL_API_V3)
sabangul_json = ""
sabangul_errorText = ""
SabangulQueryTkgm = False
For sabangul_i = 0 To UBound(sabangul_bases)
sabangul_url = CStr(sabangul_bases(sabangul_i)) & _
SabangulInvariantString(sabangul_lat) & "/" & _
SabangulInvariantString(sabangul_lon) & "/"
sabangul_response = ""
sabangul_error = ""
If SabangulHttpGet(sabangul_url, sabangul_response, sabangul_error) Then
If Len(Trim(sabangul_response)) > 0 Then
sabangul_json = sabangul_response
SabangulQueryTkgm = True
Exit Function
End If
End If
If Len(sabangul_error) > 0 Then
If Len(sabangul_errorText) > 0 Then sabangul_errorText = sabangul_errorText & vbCrLf
sabangul_errorText = sabangul_errorText & sabangul_error
End If
Next
End Function
Function SabangulHttpGet(ByVal sabangul_url, ByRef sabangul_response, ByRef sabangul_errorText)
Dim sabangul_http, sabangul_status, sabangul_createError
SabangulHttpGet = False
sabangul_response = ""
sabangul_errorText = ""
sabangul_createError = 0
Set sabangul_http = Nothing
On Error Resume Next
Err.Clear
Set sabangul_http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
sabangul_createError = Err.Number
Err.Clear
On Error GoTo 0
If sabangul_http Is Nothing Then
On Error Resume Next
Err.Clear
Set sabangul_http = CreateObject("MSXML2.XMLHTTP.6.0")
sabangul_createError = Err.Number
Err.Clear
On Error GoTo 0
End If
If sabangul_http Is Nothing Then
sabangul_errorText = "Windows MSXML HTTP bileşeni oluşturulamadı. Hata=" & CStr(sabangul_createError)
Exit Function
End If
On Error Resume Next
Err.Clear
' ServerXMLHTTP destekliyorsa zaman aşımı uygula.
sabangul_http.setTimeouts 5000, 5000, SABANGUL_HTTP_TIMEOUT_MS, SABANGUL_HTTP_TIMEOUT_MS
Err.Clear
sabangul_http.Open "GET", sabangul_url, False
If Err.Number <> 0 Then
sabangul_errorText = "HTTP bağlantısı açılamadı: " & Err.Description
Err.Clear
Set sabangul_http = Nothing
On Error GoTo 0
Exit Function
End If
sabangul_http.setRequestHeader "Accept", "application/geo+json, application/json, text/plain;q=0.8"
Err.Clear
sabangul_http.setRequestHeader "Cache-Control", "no-cache"
Err.Clear
sabangul_http.Send
If Err.Number <> 0 Then
sabangul_errorText = "HTTP isteği gönderilemedi: " & Err.Description
Err.Clear
Set sabangul_http = Nothing
On Error GoTo 0
Exit Function
End If
sabangul_status = 0
sabangul_status = sabangul_http.Status
If Err.Number <> 0 Then
sabangul_errorText = "HTTP durum kodu okunamadı: " & Err.Description
Err.Clear
ElseIf sabangul_status >= 200 And sabangul_status < 300 Then
sabangul_response = sabangul_http.ResponseText
SabangulHttpGet = True
Else
sabangul_errorText = "TKGM HTTP " & CStr(sabangul_status) & " · " & sabangul_url
End If
Set sabangul_http = Nothing
On Error GoTo 0
End Function
Function SabangulInvariantString(ByVal sabangul_value)
Dim sabangul_s
sabangul_s = CStr(CDbl(sabangul_value))
sabangul_s = Replace(sabangul_s, ",", ".")
SabangulInvariantString = sabangul_s
End Function
' =============================================================================
' JSON / GEOJSON AYIKLAMA
' Tam JSON kütüphanesi gerektirmez; yalnız geometry.type ve coordinates bloğunu
' güvenli biçimde ayıklar. Koordinat dizisi daha sonra bracket-depth ile okunur.
' =============================================================================
Function SabangulExtractGeometry(ByVal sabangul_json, _
ByRef sabangul_geomType, _
ByRef sabangul_coordsText, _
ByRef sabangul_errorText)
Dim sabangul_gPos, sabangul_typePos, sabangul_coordPos
Dim sabangul_start, sabangul_finish
SabangulExtractGeometry = False
sabangul_geomType = ""
sabangul_coordsText = ""
sabangul_errorText = ""
sabangul_gPos = InStr(1, sabangul_json, Chr(34) & "geometry" & Chr(34), vbTextCompare)
If sabangul_gPos = 0 Then
sabangul_errorText = "Yanıtta geometry alanı bulunamadı."
Exit Function
End If
sabangul_coordPos = InStr(sabangul_gPos, sabangul_json, Chr(34) & "coordinates" & Chr(34), vbTextCompare)
If sabangul_coordPos = 0 Then
sabangul_errorText = "Yanıtta coordinates alanı bulunamadı."
Exit Function
End If
sabangul_typePos = InStr(sabangul_gPos, sabangul_json, Chr(34) & "type" & Chr(34), vbTextCompare)
If sabangul_typePos = 0 Or sabangul_typePos > sabangul_coordPos Then
sabangul_errorText = "Geometri type alanı bulunamadı."
Exit Function
End If
sabangul_geomType = SabangulReadJsonStringAfterKey(sabangul_json, sabangul_typePos)
If LCase(sabangul_geomType) <> "polygon" And LCase(sabangul_geomType) <> "multipolygon" Then
sabangul_errorText = "Desteklenmeyen geometri: " & sabangul_geomType
Exit Function
End If
sabangul_start = InStr(sabangul_coordPos, sabangul_json, "[")
If sabangul_start = 0 Then
sabangul_errorText = "Koordinat dizisinin başlangıcı bulunamadı."
Exit Function
End If
sabangul_finish = SabangulFindMatchingBracket(sabangul_json, sabangul_start)
If sabangul_finish = 0 Then
sabangul_errorText = "Koordinat dizisinin sonu bulunamadı."
Exit Function
End If
sabangul_coordsText = Mid(sabangul_json, sabangul_start, sabangul_finish - sabangul_start + 1)
SabangulExtractGeometry = True
End Function
Function SabangulReadJsonStringAfterKey(ByVal sabangul_json, ByVal sabangul_keyPos)
Dim sabangul_colon, sabangul_i, sabangul_start, sabangul_ch, sabangul_escaped
SabangulReadJsonStringAfterKey = ""
sabangul_colon = InStr(sabangul_keyPos, sabangul_json, ":")
If sabangul_colon = 0 Then Exit Function
sabangul_i = sabangul_colon + 1
Do While sabangul_i <= Len(sabangul_json) And _
(Mid(sabangul_json, sabangul_i, 1) = " " Or _
Mid(sabangul_json, sabangul_i, 1) = vbTab Or _
Mid(sabangul_json, sabangul_i, 1) = vbCr Or _
Mid(sabangul_json, sabangul_i, 1) = vbLf)
sabangul_i = sabangul_i + 1
Loop
If sabangul_i > Len(sabangul_json) Then Exit Function
If Mid(sabangul_json, sabangul_i, 1) <> Chr(34) Then Exit Function
sabangul_start = sabangul_i + 1
sabangul_i = sabangul_start
sabangul_escaped = False
Do While sabangul_i <= Len(sabangul_json)
sabangul_ch = Mid(sabangul_json, sabangul_i, 1)
If sabangul_escaped Then
sabangul_escaped = False
ElseIf sabangul_ch = "\" Then
sabangul_escaped = True
ElseIf sabangul_ch = Chr(34) Then
SabangulReadJsonStringAfterKey = Mid(sabangul_json, sabangul_start, sabangul_i - sabangul_start)
Exit Function
End If
sabangul_i = sabangul_i + 1
Loop
End Function
Function SabangulFindMatchingBracket(ByVal sabangul_text, ByVal sabangul_start)
Dim sabangul_i, sabangul_depth, sabangul_ch
SabangulFindMatchingBracket = 0
sabangul_depth = 0
For sabangul_i = sabangul_start To Len(sabangul_text)
sabangul_ch = Mid(sabangul_text, sabangul_i, 1)
If sabangul_ch = "[" Then
sabangul_depth = sabangul_depth + 1
ElseIf sabangul_ch = "]" Then
sabangul_depth = sabangul_depth - 1
If sabangul_depth = 0 Then
SabangulFindMatchingBracket = sabangul_i
Exit Function
End If
End If
Next
End Function
' =============================================================================
' PARSEL META / İSİM
' SGIS'teki alan eşleştirmeleriyle uyumlu anahtarlar kullanılır.
' =============================================================================
Function SabangulBuildParcelName(ByVal sabangul_json)
Dim sabangul_ada, sabangul_parsel, sabangul_name
' Obje adında köy / mahalle adı kullanılmaz.
' Standart ad: ADA_PARSEL (örn. 216_8).
sabangul_ada = SabangulFirstJsonScalar(sabangul_json, Array("adaNo", "ada", "ada_no"))
sabangul_parsel = SabangulFirstJsonScalar(sabangul_json, Array("parselNo", "parsel", "parsel_no"))
sabangul_name = ""
If Len(Trim(sabangul_ada)) > 0 Then sabangul_name = Trim(sabangul_ada)
If Len(Trim(sabangul_parsel)) > 0 Then
If Len(sabangul_name) > 0 Then sabangul_name = sabangul_name & "_"
sabangul_name = sabangul_name & Trim(sabangul_parsel)
End If
sabangul_name = SabangulSafeName(sabangul_name)
If Len(sabangul_name) = 0 Then sabangul_name = "TKGM_PARSEL"
SabangulBuildParcelName = Left(sabangul_name, 50)
End Function
Function SabangulFirstJsonScalar(ByVal sabangul_json, ByVal sabangul_keys)
Dim sabangul_i, sabangul_value
SabangulFirstJsonScalar = ""
For sabangul_i = 0 To UBound(sabangul_keys)
sabangul_value = SabangulJsonScalar(sabangul_json, CStr(sabangul_keys(sabangul_i)))
If Len(Trim(sabangul_value)) > 0 Then
SabangulFirstJsonScalar = Trim(sabangul_value)
Exit Function
End If
Next
End Function
Function SabangulJsonScalar(ByVal sabangul_json, ByVal sabangul_key)
Dim sabangul_keyText, sabangul_p, sabangul_colon, sabangul_i
Dim sabangul_ch, sabangul_start, sabangul_escaped, sabangul_value
SabangulJsonScalar = ""
sabangul_keyText = Chr(34) & sabangul_key & Chr(34)
sabangul_p = InStr(1, sabangul_json, sabangul_keyText, vbTextCompare)
If sabangul_p = 0 Then Exit Function
sabangul_colon = InStr(sabangul_p + Len(sabangul_keyText), sabangul_json, ":")
If sabangul_colon = 0 Then Exit Function
sabangul_i = sabangul_colon + 1
Do While sabangul_i <= Len(sabangul_json) And _
(Mid(sabangul_json, sabangul_i, 1) = " " Or _
Mid(sabangul_json, sabangul_i, 1) = vbTab Or _
Mid(sabangul_json, sabangul_i, 1) = vbCr Or _
Mid(sabangul_json, sabangul_i, 1) = vbLf)
sabangul_i = sabangul_i + 1
Loop
If sabangul_i > Len(sabangul_json) Then Exit Function
sabangul_ch = Mid(sabangul_json, sabangul_i, 1)
If sabangul_ch = Chr(34) Then
sabangul_start = sabangul_i + 1
sabangul_i = sabangul_start
sabangul_escaped = False
Do While sabangul_i <= Len(sabangul_json)
sabangul_ch = Mid(sabangul_json, sabangul_i, 1)
If sabangul_escaped Then
sabangul_escaped = False
ElseIf sabangul_ch = "\" Then
sabangul_escaped = True
ElseIf sabangul_ch = Chr(34) Then
sabangul_value = Mid(sabangul_json, sabangul_start, sabangul_i - sabangul_start)
sabangul_value = Replace(sabangul_value, "\/", "/")
sabangul_value = Replace(sabangul_value, "\\", "\")
SabangulJsonScalar = sabangul_value
Exit Function
End If
sabangul_i = sabangul_i + 1
Loop
Else
sabangul_start = sabangul_i
Do While sabangul_i <= Len(sabangul_json)
sabangul_ch = Mid(sabangul_json, sabangul_i, 1)
If sabangul_ch = "," Or sabangul_ch = "}" Or sabangul_ch = "]" Or _
sabangul_ch = " " Or sabangul_ch = vbTab Or _
sabangul_ch = vbCr Or sabangul_ch = vbLf Then Exit Do
sabangul_i = sabangul_i + 1
Loop
sabangul_value = Mid(sabangul_json, sabangul_start, sabangul_i - sabangul_start)
If LCase(sabangul_value) <> "null" Then SabangulJsonScalar = sabangul_value
End If
End Function
Function SabangulSafeName(ByVal sabangul_value)
Dim sabangul_s
sabangul_s = Trim(CStr(sabangul_value))
sabangul_s = Replace(sabangul_s, "/", "_")
sabangul_s = Replace(sabangul_s, "\", "_")
sabangul_s = Replace(sabangul_s, ":", "_")
sabangul_s = Replace(sabangul_s, "*", "_")
sabangul_s = Replace(sabangul_s, "?", "_")
sabangul_s = Replace(sabangul_s, Chr(34), "_")
sabangul_s = Replace(sabangul_s, "<", "_")
sabangul_s = Replace(sabangul_s, ">", "_")
sabangul_s = Replace(sabangul_s, "|", "_")
Do While InStr(sabangul_s, "__") > 0
sabangul_s = Replace(sabangul_s, "__", "_")
Loop
SabangulSafeName = sabangul_s
End Function
' =============================================================================
' GEOJSON KOORDİNATLARINI NETCAD OPLINE OLARAK ÇİZ
' Polygon ring depth = 2, point depth = 3
' MultiPolygon ring depth = 3, point depth = 4
' =============================================================================
Function SabangulDrawGeometry(ByVal sabangul_coordsText, ByVal sabangul_geomType, _
ByVal sabangul_baseName, ByVal sabangul_layer, _
ByVal sabangul_projType, ByVal sabangul_zone, _
ByVal sabangul_datum, ByRef sabangul_centerY, _
ByRef sabangul_centerX)
Dim sabangul_ringDepth, sabangul_pointDepth
Dim sabangul_depth, sabangul_i, sabangul_ch
Dim sabangul_polyIndex, sabangul_ringIndex, sabangul_globalRing
Dim sabangul_pointValueCount, sabangul_lng, sabangul_lat
Dim sabangul_tokenStart, sabangul_token, sabangul_number
Dim sabangul_poly, sabangul_c, sabangul_o
Dim sabangul_y, sabangul_x
Dim sabangul_vertexCount, sabangul_added
Dim sabangul_objName
Dim sabangul_center, sabangul_centerFound, sabangul_centerError
SabangulDrawGeometry = 0
sabangul_centerFound = False
If LCase(sabangul_geomType) = "polygon" Then
sabangul_ringDepth = 2
sabangul_polyIndex = 1
sabangul_ringIndex = 0
ElseIf LCase(sabangul_geomType) = "multipolygon" Then
sabangul_ringDepth = 3
sabangul_polyIndex = 0
sabangul_ringIndex = 0
Else
Exit Function
End If
sabangul_pointDepth = sabangul_ringDepth + 1
sabangul_depth = 0
sabangul_i = 1
sabangul_globalRing = 0
sabangul_pointValueCount = 0
sabangul_vertexCount = 0
sabangul_added = 0
Set sabangul_poly = Nothing
Do While sabangul_i <= Len(sabangul_coordsText)
sabangul_ch = Mid(sabangul_coordsText, sabangul_i, 1)
If SabangulIsNumberStart(sabangul_ch) Then
sabangul_tokenStart = sabangul_i
sabangul_i = sabangul_i + 1
Do While sabangul_i <= Len(sabangul_coordsText) And _
SabangulIsNumberChar(Mid(sabangul_coordsText, sabangul_i, 1))
sabangul_i = sabangul_i + 1
Loop
sabangul_token = Mid(sabangul_coordsText, sabangul_tokenStart, sabangul_i - sabangul_tokenStart)
If sabangul_depth = sabangul_pointDepth Then
sabangul_number = SabangulParseJsonNumber(sabangul_token)
sabangul_pointValueCount = sabangul_pointValueCount + 1
If sabangul_pointValueCount = 1 Then
sabangul_lng = sabangul_number
ElseIf sabangul_pointValueCount = 2 Then
sabangul_lat = sabangul_number
End If
End If
Else
If sabangul_ch = "[" Then
sabangul_depth = sabangul_depth + 1
If LCase(sabangul_geomType) = "multipolygon" And sabangul_depth = 2 Then
sabangul_polyIndex = sabangul_polyIndex + 1
sabangul_ringIndex = 0
End If
If sabangul_depth = sabangul_ringDepth Then
sabangul_ringIndex = sabangul_ringIndex + 1
sabangul_globalRing = sabangul_globalRing + 1
sabangul_vertexCount = 0
Set sabangul_poly = Netcad.NewPoly
ElseIf sabangul_depth = sabangul_pointDepth Then
sabangul_pointValueCount = 0
sabangul_lng = 0
sabangul_lat = 0
End If
ElseIf sabangul_ch = "]" Then
If sabangul_depth = sabangul_pointDepth Then
If sabangul_pointValueCount >= 2 And Not (sabangul_poly Is Nothing) Then
sabangul_y = 0
sabangul_x = 0
If SabangulGeographicToProject( _
CDbl(sabangul_lat), CDbl(sabangul_lng), _
CLng(sabangul_projType), CDbl(sabangul_zone), CLng(sabangul_datum), _
sabangul_y, sabangul_x) Then
Set sabangul_c = Netcad.NewC(CDbl(sabangul_y), CDbl(sabangul_x), 0)
sabangul_poly.AddCoor sabangul_c
sabangul_vertexCount = sabangul_vertexCount + 1
Set sabangul_c = Nothing
End If
End If
End If
If sabangul_depth = sabangul_ringDepth Then
If Not (sabangul_poly Is Nothing) And sabangul_vertexCount >= 3 Then
' İlk dış halkanın gerçek ağırlık merkezini bilgi bloğu konumu olarak al.
If sabangul_ringIndex = 1 And Not sabangul_centerFound Then
On Error Resume Next
Err.Clear
Set sabangul_center = sabangul_poly.CenterOfMass
sabangul_centerError = Err.Number
Err.Clear
On Error GoTo 0
If sabangul_centerError = 0 And Not (sabangul_center Is Nothing) Then
sabangul_centerY = CDbl(sabangul_center.y)
sabangul_centerX = CDbl(sabangul_center.x)
sabangul_centerFound = True
End If
Set sabangul_center = Nothing
End If
sabangul_objName = SabangulRingName(sabangul_baseName, sabangul_polyIndex, sabangul_ringIndex)
Set sabangul_o = Netcad.MakePline( _
Left(sabangul_objName, 50), _
POLYCLOSED, _
sabangul_layer, _
0, 0, 0, _
sabangul_poly)
sabangul_o.renk = LightRed
Netcad.AddObject sabangul_o
sabangul_added = sabangul_added + 1
Set sabangul_o = Nothing
End If
Set sabangul_poly = Nothing
sabangul_vertexCount = 0
End If
sabangul_depth = sabangul_depth - 1
End If
sabangul_i = sabangul_i + 1
End If
Loop
Set sabangul_poly = Nothing
SabangulDrawGeometry = sabangul_added
End Function
' =============================================================================
' TKGM PARSEL BİLGİ TABLOSU · KOMPAKT SÜRÜM
' - Tablo parsel ağırlık merkezi çevresine yerleştirilir.
' - Metinler sola dayalıdır; eski merkez hizalı dağınık görünüm kaldırılmıştır.
' - Ana bilgi yazı yüksekliği projeksiyonlu projelerde 0.40 m'dir.
' - ADA_PARSEL başlığı 0.70 m'dir; çok uzunsa otomatik küçülür.
' - Etiket ve değerler ayrı sütunlarda yazılır; boşluk ile hizalama yapılmaz.
' - Dış çerçeve, başlık ayırıcı, satır çizgileri ve kolon ayırıcı çizilir.
' - Uzun değerler veri kaybı olmadan aynı hücreye sığacak kadar otomatik küçültülür.
' - Bütün tablo objeleri TKGM_PARSEL_BILGI tabakasındadır.
' =============================================================================
Function SabangulDrawParcelInfo(ByVal sabangul_json, ByVal sabangul_infoLayer, _
ByVal sabangul_centerY, ByVal sabangul_centerX, _
ByVal sabangul_projType, ByVal sabangul_queryLat, _
ByVal sabangul_queryLon)
Dim sabangul_ada, sabangul_parsel, sabangul_header
Dim sabangul_propText, sabangul_keys, sabangul_values, sabangul_propCount
Dim sabangul_i, sabangul_dataRows, sabangul_rowNo, sabangul_added
Dim sabangul_headerSize, sabangul_infoSize, sabangul_rowHeight
Dim sabangul_headerHeight, sabangul_pad, sabangul_labelWidth, sabangul_valueWidth
Dim sabangul_tableWidth, sabangul_tableHeight
Dim sabangul_leftY, sabangul_rightY, sabangul_topX, sabangul_bottomX
Dim sabangul_splitY, sabangul_rowTopX, sabangul_rowBottomX, sabangul_textX
Dim sabangul_label, sabangul_value, sabangul_labelSize, sabangul_valueSize
Dim sabangul_minTextSize, sabangul_headerTextSize
Dim sabangul_footerText, sabangul_footerSize, sabangul_footerTopX
SabangulDrawParcelInfo = 0
sabangul_added = 0
sabangul_ada = SabangulFirstJsonScalar(sabangul_json, Array("adaNo", "ada", "ada_no"))
sabangul_parsel = SabangulFirstJsonScalar(sabangul_json, Array("parselNo", "parsel", "parsel_no"))
If Len(Trim(sabangul_ada)) > 0 Or Len(Trim(sabangul_parsel)) > 0 Then
sabangul_header = Trim(sabangul_ada) & "_" & Trim(sabangul_parsel)
If Left(sabangul_header, 1) = "_" Then sabangul_header = Mid(sabangul_header, 2)
If Right(sabangul_header, 1) = "_" Then sabangul_header = Left(sabangul_header, Len(sabangul_header) - 1)
Else
sabangul_header = "ADA_PARSEL"
End If
SabangulInfoTableMetrics CLng(sabangul_projType), _
sabangul_headerSize, sabangul_infoSize, sabangul_rowHeight, _
sabangul_headerHeight, sabangul_pad, sabangul_labelWidth, _
sabangul_valueWidth, sabangul_minTextSize
sabangul_propText = SabangulExtractPropertiesObject(sabangul_json)
sabangul_propCount = 0
If Len(sabangul_propText) > 0 Then
SabangulParsePropertyPairs sabangul_propText, sabangul_keys, sabangul_values, sabangul_propCount
End If
' -------------------------------------------------------------------------
' Gösterilecek gerçek veri satırı sayısını önce bul.
' ADA/PARSEL başlıkta gösterildiğinden tablonun gövdesinde tekrarlanmaz.
' Son dört satır sorgu enlem, sorgu boylam, kaynak ve SagulCAD imzasıdır.
' -------------------------------------------------------------------------
sabangul_dataRows = 4
If sabangul_propCount > 0 Then
For sabangul_i = 0 To sabangul_propCount - 1
If Not SabangulIsAdaParselKey(CStr(sabangul_keys(sabangul_i))) Then
sabangul_value = SabangulCleanDisplayValue(CStr(sabangul_values(sabangul_i)))
If Len(Trim(sabangul_value)) > 0 Then sabangul_dataRows = sabangul_dataRows + 1
End If
Next
End If
' -------------------------------------------------------------------------
' Tabloyu ağırlık merkezinin çevresinde ortala.
' Netcad koordinat düzeni: Y yatay, X düşey kabul edilmiştir.
' -------------------------------------------------------------------------
sabangul_tableWidth = sabangul_pad + sabangul_labelWidth + sabangul_pad + _
sabangul_valueWidth + sabangul_pad
sabangul_tableHeight = sabangul_headerHeight + (sabangul_dataRows * sabangul_rowHeight)
sabangul_leftY = CDbl(sabangul_centerY) - (sabangul_tableWidth / 2)
sabangul_rightY = CDbl(sabangul_centerY) + (sabangul_tableWidth / 2)
sabangul_topX = CDbl(sabangul_centerX) + (sabangul_tableHeight / 2)
sabangul_bottomX = CDbl(sabangul_centerX) - (sabangul_tableHeight / 2)
sabangul_splitY = sabangul_leftY + sabangul_pad + sabangul_labelWidth + (sabangul_pad / 2)
' Dış çerçeve: alan objesi kullanılmaz; dört bağımsız açık çizgiden oluşur.
sabangul_added = sabangul_added + SabangulAddInfoRectangle( _
sabangul_leftY, sabangul_topX, sabangul_rightY, sabangul_bottomX, _
sabangul_infoLayer, LightGray)
' Başlık alt çizgisi.
sabangul_rowTopX = sabangul_topX - sabangul_headerHeight
SabangulAddInfoLine sabangul_leftY, sabangul_rowTopX, sabangul_rightY, sabangul_rowTopX, _
sabangul_infoLayer, LightGray
sabangul_added = sabangul_added + 1
' Kolon ayırıcı yalnız veri gövdesinde; en alttaki SagulCAD imza satırı tam genişliktir.
sabangul_footerTopX = sabangul_bottomX + sabangul_rowHeight
SabangulAddInfoLine sabangul_splitY, sabangul_rowTopX, sabangul_splitY, sabangul_footerTopX, _
sabangul_infoLayer, LightGray
sabangul_added = sabangul_added + 1
' Gövde satır çizgileri.
For sabangul_i = 1 To sabangul_dataRows - 1
sabangul_rowBottomX = sabangul_rowTopX - (sabangul_i * sabangul_rowHeight)
SabangulAddInfoLine sabangul_leftY, sabangul_rowBottomX, sabangul_rightY, sabangul_rowBottomX, _
sabangul_infoLayer, LightGray
sabangul_added = sabangul_added + 1
Next
' -------------------------------------------------------------------------
' Başlık: sola dayalı, belirgin ama artık aşırı büyük değil.
' -------------------------------------------------------------------------
sabangul_headerTextSize = SabangulFitInfoTextSize( _
sabangul_header, sabangul_headerSize, _
sabangul_tableWidth - (2 * sabangul_pad), sabangul_minTextSize)
sabangul_textX = sabangul_topX - (sabangul_headerHeight * 0.70)
SabangulAddInfoText sabangul_leftY + sabangul_pad, sabangul_textX, sabangul_header, _
sabangul_headerTextSize, Yellow, sabangul_infoLayer
sabangul_added = sabangul_added + 1
' -------------------------------------------------------------------------
' Properties satırları: etiket ve değer ayrı text objeleridir.
' Böylece orantılı fontta boşluk karakteri ile yapılan sahte hizalama kalkar.
' -------------------------------------------------------------------------
sabangul_rowNo = 0
If sabangul_propCount > 0 Then
For sabangul_i = 0 To sabangul_propCount - 1
If Not SabangulIsAdaParselKey(CStr(sabangul_keys(sabangul_i))) Then
sabangul_label = SabangulPrettyPropertyLabel(CStr(sabangul_keys(sabangul_i)))
sabangul_value = SabangulCleanDisplayValue(CStr(sabangul_values(sabangul_i)))
If Len(Trim(sabangul_value)) > 0 Then
sabangul_rowNo = sabangul_rowNo + 1
sabangul_textX = sabangul_rowTopX - ((sabangul_rowNo - 1) * sabangul_rowHeight) - (sabangul_rowHeight * 0.68)
sabangul_labelSize = SabangulFitInfoTextSize( _
sabangul_label, sabangul_infoSize, _
sabangul_labelWidth - sabangul_pad, sabangul_minTextSize)
sabangul_valueSize = SabangulFitInfoTextSize( _
sabangul_value, sabangul_infoSize, _
sabangul_valueWidth - sabangul_pad, sabangul_minTextSize)
SabangulAddInfoText sabangul_leftY + sabangul_pad, sabangul_textX, _
sabangul_label, sabangul_labelSize, LightCyan, sabangul_infoLayer
SabangulAddInfoText sabangul_splitY + sabangul_pad, sabangul_textX, _
sabangul_value, sabangul_valueSize, LightGray, sabangul_infoLayer
sabangul_added = sabangul_added + 2
End If
End If
Next
End If
' -------------------------------------------------------------------------
' Sorgu koordinatı ve kaynak satırları.
' -------------------------------------------------------------------------
sabangul_rowNo = sabangul_rowNo + 1
SabangulDrawInfoTableRow sabangul_rowNo, sabangul_rowTopX, sabangul_rowHeight, _
sabangul_leftY, sabangul_splitY, sabangul_pad, _
sabangul_labelWidth, sabangul_valueWidth, _
"SORGU ENLEM", SabangulInvariantString(sabangul_queryLat), _
sabangul_infoSize, sabangul_minTextSize, sabangul_infoLayer
sabangul_added = sabangul_added + 2
sabangul_rowNo = sabangul_rowNo + 1
SabangulDrawInfoTableRow sabangul_rowNo, sabangul_rowTopX, sabangul_rowHeight, _
sabangul_leftY, sabangul_splitY, sabangul_pad, _
sabangul_labelWidth, sabangul_valueWidth, _
"SORGU BOYLAM", SabangulInvariantString(sabangul_queryLon), _
sabangul_infoSize, sabangul_minTextSize, sabangul_infoLayer
sabangul_added = sabangul_added + 2
sabangul_rowNo = sabangul_rowNo + 1
SabangulDrawInfoTableRow sabangul_rowNo, sabangul_rowTopX, sabangul_rowHeight, _
sabangul_leftY, sabangul_splitY, sabangul_pad, _
sabangul_labelWidth, sabangul_valueWidth, _
"KAYNAK", "TKGM MEGSIS CBS API", _
sabangul_infoSize, sabangul_minTextSize, sabangul_infoLayer
sabangul_added = sabangul_added + 2
' -------------------------------------------------------------------------
' En alt tam genişlik imza satırı. Bilgi satırlarından daha küçük ve sade.
' -------------------------------------------------------------------------
sabangul_rowNo = sabangul_rowNo + 1
sabangul_footerText = "SagulCAD | Şaban GÜL | Harita Mühendisi"
sabangul_footerSize = sabangul_infoSize * 0.70
If sabangul_footerSize < sabangul_minTextSize Then sabangul_footerSize = sabangul_minTextSize
sabangul_footerSize = SabangulFitInfoTextSize( _
sabangul_footerText, sabangul_footerSize, _
sabangul_tableWidth - (2 * sabangul_pad), sabangul_minTextSize)
sabangul_textX = sabangul_rowTopX - ((sabangul_rowNo - 1) * sabangul_rowHeight) - (sabangul_rowHeight * 0.68)
SabangulAddInfoText sabangul_leftY + sabangul_pad, sabangul_textX, _
sabangul_footerText, sabangul_footerSize, LightCyan, sabangul_infoLayer
sabangul_added = sabangul_added + 1
SabangulDrawParcelInfo = sabangul_added
End Function
' =============================================================================
' KOMPAKT TABLO ÖLÇÜLERİ
' Projeksiyonlu projelerde ana bilgi yüksekliği tam olarak 0.40 m seçilmiştir.
' =============================================================================
Sub SabangulInfoTableMetrics(ByVal sabangul_projType, ByRef sabangul_headerSize, _
ByRef sabangul_infoSize, ByRef sabangul_rowHeight, _
ByRef sabangul_headerHeight, ByRef sabangul_pad, _
ByRef sabangul_labelWidth, ByRef sabangul_valueWidth, _
ByRef sabangul_minTextSize)
If CLng(sabangul_projType) = 1 Then
' Yaklaşık metre karşılıkları: 0.70 / 0.40 / 0.72 / 1.15 / 0.30 / 5.4 / 13.8 m
sabangul_headerSize = 0.00000630
sabangul_infoSize = 0.00000360
sabangul_rowHeight = 0.00000650
sabangul_headerHeight = 0.00001035
sabangul_pad = 0.00000270
sabangul_labelWidth = 0.00004850
sabangul_valueWidth = 0.00012400
sabangul_minTextSize = 0.00000165
Else
sabangul_headerSize = 0.70
sabangul_infoSize = 0.40
sabangul_rowHeight = 0.72
sabangul_headerHeight = 1.15
sabangul_pad = 0.30
sabangul_labelWidth = 5.40
sabangul_valueWidth = 13.80
sabangul_minTextSize = 0.18
End If
End Sub
' =============================================================================
' Bir metnin hücre sınırından taşmaması için yaklaşık karakter genişliği üzerinden
' yazı yüksekliğini küçültür. Metnin kendisi ASLA kısaltılmaz.
' =============================================================================
Function SabangulFitInfoTextSize(ByVal sabangul_text, ByVal sabangul_baseSize, _
ByVal sabangul_availableWidth, ByVal sabangul_minSize)
Dim sabangul_len, sabangul_estimatedWidth, sabangul_newSize
sabangul_len = Len(CStr(sabangul_text))
If sabangul_len <= 0 Then
SabangulFitInfoTextSize = CDbl(sabangul_baseSize)
Exit Function
End If
sabangul_estimatedWidth = CDbl(sabangul_len) * CDbl(sabangul_baseSize) * 0.58
If sabangul_estimatedWidth <= CDbl(sabangul_availableWidth) Then
SabangulFitInfoTextSize = CDbl(sabangul_baseSize)
Else
sabangul_newSize = CDbl(sabangul_availableWidth) / (CDbl(sabangul_len) * 0.58)
If sabangul_newSize < CDbl(sabangul_minSize) Then sabangul_newSize = CDbl(sabangul_minSize)
SabangulFitInfoTextSize = sabangul_newSize
End If
End Function
' =============================================================================
' Tek bir tablo satırındaki etiket ve değeri ayrı ayrı sola dayalı yazar.
' =============================================================================
Sub SabangulDrawInfoTableRow(ByVal sabangul_rowNo, ByVal sabangul_bodyTopX, _
ByVal sabangul_rowHeight, ByVal sabangul_leftY, _
ByVal sabangul_splitY, ByVal sabangul_pad, _
ByVal sabangul_labelWidth, ByVal sabangul_valueWidth, _
ByVal sabangul_label, ByVal sabangul_value, _
ByVal sabangul_infoSize, ByVal sabangul_minTextSize, _
ByVal sabangul_infoLayer)
Dim sabangul_textX, sabangul_labelSize, sabangul_valueSize
sabangul_textX = CDbl(sabangul_bodyTopX) - ((CLng(sabangul_rowNo) - 1) * CDbl(sabangul_rowHeight)) - (CDbl(sabangul_rowHeight) * 0.68)
sabangul_labelSize = SabangulFitInfoTextSize( _
CStr(sabangul_label), sabangul_infoSize, _
CDbl(sabangul_labelWidth) - CDbl(sabangul_pad), sabangul_minTextSize)
sabangul_valueSize = SabangulFitInfoTextSize( _
CStr(sabangul_value), sabangul_infoSize, _
CDbl(sabangul_valueWidth) - CDbl(sabangul_pad), sabangul_minTextSize)
SabangulAddInfoText CDbl(sabangul_leftY) + CDbl(sabangul_pad), sabangul_textX, _
CStr(sabangul_label), sabangul_labelSize, LightCyan, sabangul_infoLayer
SabangulAddInfoText CDbl(sabangul_splitY) + CDbl(sabangul_pad), sabangul_textX, _
CStr(sabangul_value), sabangul_valueSize, LightGray, sabangul_infoLayer
End Sub
' =============================================================================
' Sola dayalı Netcad yazısı.
' =============================================================================
Sub SabangulAddInfoText(ByVal sabangul_y, ByVal sabangul_x, ByVal sabangul_text, _
ByVal sabangul_size, ByVal sabangul_color, ByVal sabangul_layer)
Dim sabangul_c, sabangul_t
Set sabangul_c = Netcad.NewC(CDbl(sabangul_y), CDbl(sabangul_x), 0)
Set sabangul_t = Netcad.MakeText(sabangul_c, CStr(sabangul_text), 0, 0, _
CDbl(sabangul_size), 0, "L", sabangul_layer)
sabangul_t.renk = sabangul_color
Netcad.AddObject sabangul_t
Set sabangul_t = Nothing
Set sabangul_c = Nothing
End Sub
' =============================================================================
' Tablo dış çerçevesi.
' =============================================================================
Function SabangulAddInfoRectangle(ByVal sabangul_leftY, ByVal sabangul_topX, _
ByVal sabangul_rightY, ByVal sabangul_bottomX, _
ByVal sabangul_layer, ByVal sabangul_color)
' Netcad.NewPoly.Add bu Netcad/VBScript sürümünde desteklenmediği için
' çerçeve bir alan/poligon üretmeden dört açık çizgi olarak oluşturulur.
SabangulAddInfoLine sabangul_leftY, sabangul_topX, sabangul_rightY, sabangul_topX, sabangul_layer, sabangul_color
SabangulAddInfoLine sabangul_rightY, sabangul_topX, sabangul_rightY, sabangul_bottomX, sabangul_layer, sabangul_color
SabangulAddInfoLine sabangul_rightY, sabangul_bottomX, sabangul_leftY, sabangul_bottomX, sabangul_layer, sabangul_color
SabangulAddInfoLine sabangul_leftY, sabangul_bottomX, sabangul_leftY, sabangul_topX, sabangul_layer, sabangul_color
SabangulAddInfoRectangle = 4
End Function
' =============================================================================
' Tablo iç çizgileri.
' =============================================================================
Sub SabangulAddInfoLine(ByVal sabangul_y1, ByVal sabangul_x1, _
ByVal sabangul_y2, ByVal sabangul_x2, _
ByVal sabangul_layer, ByVal sabangul_color)
Dim sabangul_poly, sabangul_c, sabangul_o,POLYOPEN
Set sabangul_poly = Netcad.NewPoly
Set sabangul_c = Netcad.NewC(CDbl(sabangul_y1), CDbl(sabangul_x1), 0)
sabangul_poly.AddCoor sabangul_c
Set sabangul_c = Netcad.NewC(CDbl(sabangul_y2), CDbl(sabangul_x2), 0)
sabangul_poly.AddCoor sabangul_c
Set sabangul_o = Netcad.MakePline("TKGM_BILGI_CIZGI", POLYOPEN, _
sabangul_layer, 0, 0, 0, sabangul_poly)
sabangul_o.renk = sabangul_color
Netcad.AddObject sabangul_o
Set sabangul_o = Nothing
Set sabangul_c = Nothing
Set sabangul_poly = Nothing
End Sub
Function SabangulExtractPropertiesObject(ByVal sabangul_json)
Dim sabangul_keyText, sabangul_p, sabangul_colon, sabangul_i, sabangul_end
SabangulExtractPropertiesObject = ""
sabangul_keyText = Chr(34) & "properties" & Chr(34)
sabangul_p = InStr(1, sabangul_json, sabangul_keyText, vbTextCompare)
If sabangul_p = 0 Then Exit Function
sabangul_colon = InStr(sabangul_p + Len(sabangul_keyText), sabangul_json, ":")
If sabangul_colon = 0 Then Exit Function
sabangul_i = sabangul_colon + 1
SabangulSkipJsonSpaces sabangul_json, sabangul_i
If sabangul_i > Len(sabangul_json) Then Exit Function
If Mid(sabangul_json, sabangul_i, 1) <> "{" Then Exit Function
sabangul_end = SabangulFindJsonClosing(sabangul_json, sabangul_i, "{", "}")
If sabangul_end <= sabangul_i Then Exit Function
SabangulExtractPropertiesObject = Mid(sabangul_json, sabangul_i, sabangul_end - sabangul_i + 1)
End Function
Sub SabangulParsePropertyPairs(ByVal sabangul_propText, ByRef sabangul_keys, _
ByRef sabangul_values, ByRef sabangul_count)
Dim sabangul_i, sabangul_key, sabangul_value, sabangul_ch
Dim sabangul_next, sabangul_start, sabangul_end
sabangul_count = 0
sabangul_i = 2
Do While sabangul_i < Len(sabangul_propText)
SabangulSkipJsonSpaces sabangul_propText, sabangul_i
Do While sabangul_i < Len(sabangul_propText) And Mid(sabangul_propText, sabangul_i, 1) = ","
sabangul_i = sabangul_i + 1
SabangulSkipJsonSpaces sabangul_propText, sabangul_i
Loop
If sabangul_i >= Len(sabangul_propText) Then Exit Do
If Mid(sabangul_propText, sabangul_i, 1) <> Chr(34) Then Exit Do
sabangul_key = SabangulReadJsonStringAt(sabangul_propText, sabangul_i, sabangul_next)
sabangul_i = sabangul_next
SabangulSkipJsonSpaces sabangul_propText, sabangul_i
If sabangul_i > Len(sabangul_propText) Or Mid(sabangul_propText, sabangul_i, 1) <> ":" Then Exit Do
sabangul_i = sabangul_i + 1
SabangulSkipJsonSpaces sabangul_propText, sabangul_i
If sabangul_i > Len(sabangul_propText) Then Exit Do
sabangul_ch = Mid(sabangul_propText, sabangul_i, 1)
sabangul_value = ""
If sabangul_ch = Chr(34) Then
sabangul_value = SabangulReadJsonStringAt(sabangul_propText, sabangul_i, sabangul_next)
sabangul_i = sabangul_next
ElseIf sabangul_ch = "{" Then
sabangul_end = SabangulFindJsonClosing(sabangul_propText, sabangul_i, "{", "}")
If sabangul_end = 0 Then Exit Do
sabangul_value = Mid(sabangul_propText, sabangul_i, sabangul_end - sabangul_i + 1)
sabangul_i = sabangul_end + 1
ElseIf sabangul_ch = "[" Then
sabangul_end = SabangulFindJsonClosing(sabangul_propText, sabangul_i, "[", "]")
If sabangul_end = 0 Then Exit Do
sabangul_value = Mid(sabangul_propText, sabangul_i, sabangul_end - sabangul_i + 1)
sabangul_i = sabangul_end + 1
Else
sabangul_start = sabangul_i
Do While sabangul_i <= Len(sabangul_propText)
sabangul_ch = Mid(sabangul_propText, sabangul_i, 1)
If sabangul_ch = "," Or sabangul_ch = "}" Then Exit Do
sabangul_i = sabangul_i + 1
Loop
sabangul_value = Trim(Mid(sabangul_propText, sabangul_start, sabangul_i - sabangul_start))
If LCase(sabangul_value) = "null" Then sabangul_value = ""
End If
If sabangul_count = 0 Then
ReDim sabangul_keys(0)
ReDim sabangul_values(0)
Else
ReDim Preserve sabangul_keys(sabangul_count)
ReDim Preserve sabangul_values(sabangul_count)
End If
sabangul_keys(sabangul_count) = sabangul_key
sabangul_values(sabangul_count) = sabangul_value
sabangul_count = sabangul_count + 1
Loop
End Sub
Sub SabangulSkipJsonSpaces(ByVal sabangul_text, ByRef sabangul_i)
Dim sabangul_ch
Do While sabangul_i <= Len(sabangul_text)
sabangul_ch = Mid(sabangul_text, sabangul_i, 1)
If sabangul_ch = " " Or sabangul_ch = vbTab Or sabangul_ch = vbCr Or sabangul_ch = vbLf Then
sabangul_i = sabangul_i + 1
Else
Exit Do
End If
Loop
End Sub
Function SabangulReadJsonStringAt(ByVal sabangul_text, ByVal sabangul_quotePos, _
ByRef sabangul_nextPos)
Dim sabangul_i, sabangul_ch, sabangul_escaped, sabangul_result
SabangulReadJsonStringAt = ""
sabangul_nextPos = sabangul_quotePos
sabangul_result = ""
sabangul_escaped = False
sabangul_i = sabangul_quotePos + 1
Do While sabangul_i <= Len(sabangul_text)
sabangul_ch = Mid(sabangul_text, sabangul_i, 1)
If sabangul_escaped Then
Select Case sabangul_ch
Case Chr(34), "\", "/"
sabangul_result = sabangul_result & sabangul_ch
Case "n", "r", "t"
sabangul_result = sabangul_result & " "
Case Else
sabangul_result = sabangul_result & sabangul_ch
End Select
sabangul_escaped = False
ElseIf sabangul_ch = "\" Then
sabangul_escaped = True
ElseIf sabangul_ch = Chr(34) Then
SabangulReadJsonStringAt = sabangul_result
sabangul_nextPos = sabangul_i + 1
Exit Function
Else
sabangul_result = sabangul_result & sabangul_ch
End If
sabangul_i = sabangul_i + 1
Loop
sabangul_nextPos = sabangul_i
SabangulReadJsonStringAt = sabangul_result
End Function
Function SabangulFindJsonClosing(ByVal sabangul_text, ByVal sabangul_start, _
ByVal sabangul_openCh, ByVal sabangul_closeCh)
Dim sabangul_i, sabangul_depth, sabangul_ch, sabangul_inString, sabangul_escaped
SabangulFindJsonClosing = 0
sabangul_depth = 0
sabangul_inString = False
sabangul_escaped = False
For sabangul_i = sabangul_start To Len(sabangul_text)
sabangul_ch = Mid(sabangul_text, sabangul_i, 1)
If sabangul_inString Then
If sabangul_escaped Then
sabangul_escaped = False
ElseIf sabangul_ch = "\" Then
sabangul_escaped = True
ElseIf sabangul_ch = Chr(34) Then
sabangul_inString = False
End If
Else
If sabangul_ch = Chr(34) Then
sabangul_inString = True
ElseIf sabangul_ch = sabangul_openCh Then
sabangul_depth = sabangul_depth + 1
ElseIf sabangul_ch = sabangul_closeCh Then
sabangul_depth = sabangul_depth - 1
If sabangul_depth = 0 Then
SabangulFindJsonClosing = sabangul_i
Exit Function
End If
End If
End If
Next
End Function
Function SabangulIsAdaParselKey(ByVal sabangul_key)
Dim sabangul_k
sabangul_k = LCase(Trim(CStr(sabangul_key)))
SabangulIsAdaParselKey = _
sabangul_k = "adano" Or sabangul_k = "ada" Or sabangul_k = "ada_no" Or _
sabangul_k = "parselno" Or sabangul_k = "parsel" Or sabangul_k = "parsel_no"
End Function
Function SabangulPrettyPropertyLabel(ByVal sabangul_key)
Dim sabangul_k
sabangul_k = LCase(Trim(CStr(sabangul_key)))
Select Case sabangul_k
Case "ilad", "iladi", "il", "province": SabangulPrettyPropertyLabel = "İL"
Case "ilcead", "ilceadi", "ilce", "district": SabangulPrettyPropertyLabel = "İLÇE"
Case "mahallead", "mahalleadi", "mahalle", "neighborhood": SabangulPrettyPropertyLabel = "MAHALLE"
Case "mahalleid", "mahalle_id": SabangulPrettyPropertyLabel = "MAHALLE ID"
Case "ilid", "il_id": SabangulPrettyPropertyLabel = "İL ID"
Case "ilceid", "ilce_id": SabangulPrettyPropertyLabel = "İLÇE ID"
Case "mevkii", "mevki": SabangulPrettyPropertyLabel = "MEVKİİ"
Case "pafta", "paftano", "pafta_no": SabangulPrettyPropertyLabel = "PAFTA"
Case "nitelik", "vasif", "cinsi": SabangulPrettyPropertyLabel = "NİTELİK"
Case "alan", "yuzolcum", "area": SabangulPrettyPropertyLabel = "ALAN"
Case "durum": SabangulPrettyPropertyLabel = "DURUM"
Case "zeminkmdurum": SabangulPrettyPropertyLabel = "ZEMİN KM DURUMU"
Case "ozet": SabangulPrettyPropertyLabel = "ÖZET"
Case "gittigiparselliste": SabangulPrettyPropertyLabel = "GİTTİĞİ PARSEL"
Case "gittigiparselsebep": SabangulPrettyPropertyLabel = "GİTTİĞİ PARSEL SEBEP"
Case Else: SabangulPrettyPropertyLabel = UCase(Replace(CStr(sabangul_key), "_", " "))
End Select
End Function
Function SabangulCleanDisplayValue(ByVal sabangul_value)
Dim sabangul_s
sabangul_s = Trim(CStr(sabangul_value))
sabangul_s = Replace(sabangul_s, vbCr, " ")
sabangul_s = Replace(sabangul_s, vbLf, " ")
sabangul_s = Replace(sabangul_s, vbTab, " ")
Do While InStr(sabangul_s, " ") > 0
sabangul_s = Replace(sabangul_s, " ", " ")
Loop
SabangulCleanDisplayValue = sabangul_s
End Function
Function SabangulPadRight(ByVal sabangul_value, ByVal sabangul_len)
Dim sabangul_s
sabangul_s = CStr(sabangul_value)
If Len(sabangul_s) >= CLng(sabangul_len) Then
SabangulPadRight = Left(sabangul_s, CLng(sabangul_len))
Else
SabangulPadRight = sabangul_s & Space(CLng(sabangul_len) - Len(sabangul_s))
End If
End Function
Function SabangulRingName(ByVal sabangul_baseName, ByVal sabangul_polyIndex, ByVal sabangul_ringIndex)
Dim sabangul_s
sabangul_s = CStr(sabangul_baseName)
If sabangul_polyIndex > 1 Then sabangul_s = sabangul_s & "_P" & CStr(sabangul_polyIndex)
If sabangul_ringIndex > 1 Then sabangul_s = sabangul_s & "_IC" & CStr(sabangul_ringIndex - 1)
SabangulRingName = Left(SabangulSafeName(sabangul_s), 50)
End Function
Function SabangulIsNumberStart(ByVal sabangul_ch)
SabangulIsNumberStart = _
(sabangul_ch >= "0" And sabangul_ch <= "9") Or _
sabangul_ch = "-" Or sabangul_ch = "+" Or sabangul_ch = "."
End Function
Function SabangulIsNumberChar(ByVal sabangul_ch)
SabangulIsNumberChar = _
(sabangul_ch >= "0" And sabangul_ch <= "9") Or _
sabangul_ch = "-" Or sabangul_ch = "+" Or sabangul_ch = "." Or _
sabangul_ch = "e" Or sabangul_ch = "E"
End Function
Function SabangulParseJsonNumber(ByVal sabangul_token)
Dim sabangul_s, sabangul_i, sabangul_sign, sabangul_value
Dim sabangul_fracFactor, sabangul_inFraction
Dim sabangul_expSign, sabangul_expValue, sabangul_inExponent
Dim sabangul_ch, sabangul_digit
sabangul_s = Trim(CStr(sabangul_token))
sabangul_sign = 1
sabangul_value = 0
sabangul_fracFactor = 0.1
sabangul_inFraction = False
sabangul_expSign = 1
sabangul_expValue = 0
sabangul_inExponent = False
sabangul_i = 1
If Len(sabangul_s) > 0 Then
If Mid(sabangul_s, 1, 1) = "-" Then
sabangul_sign = -1
sabangul_i = 2
ElseIf Mid(sabangul_s, 1, 1) = "+" Then
sabangul_i = 2
End If
End If
Do While sabangul_i <= Len(sabangul_s)
sabangul_ch = Mid(sabangul_s, sabangul_i, 1)
If sabangul_ch = "e" Or sabangul_ch = "E" Then
sabangul_inExponent = True
sabangul_i = sabangul_i + 1
If sabangul_i <= Len(sabangul_s) Then
If Mid(sabangul_s, sabangul_i, 1) = "-" Then
sabangul_expSign = -1
sabangul_i = sabangul_i + 1
ElseIf Mid(sabangul_s, sabangul_i, 1) = "+" Then
sabangul_i = sabangul_i + 1
End If
End If
ElseIf sabangul_ch = "." And Not sabangul_inExponent Then
sabangul_inFraction = True
sabangul_i = sabangul_i + 1
ElseIf sabangul_ch >= "0" And sabangul_ch <= "9" Then
sabangul_digit = Asc(sabangul_ch) - 48
If sabangul_inExponent Then
sabangul_expValue = sabangul_expValue * 10 + sabangul_digit
ElseIf sabangul_inFraction Then
sabangul_value = sabangul_value + sabangul_digit * sabangul_fracFactor
sabangul_fracFactor = sabangul_fracFactor / 10
Else
sabangul_value = sabangul_value * 10 + sabangul_digit
End If
sabangul_i = sabangul_i + 1
Else
sabangul_i = sabangul_i + 1
End If
Loop
If sabangul_expValue <> 0 Then
sabangul_value = sabangul_value * (10 ^ (sabangul_expSign * sabangul_expValue))
End If
SabangulParseJsonNumber = sabangul_sign * sabangul_value
End Function
Kod bloğunda koyu arka plan kullanıyorsan yazı rengini beyaz veya açık gri seçmeni öneririm. Böylece WordPress sitesinin açık ve koyu temalarında kod rahat okunur.
Netcad İçinden TKGM Parsel Sorgulama
SagulCAD TKGM Parsel Sorgu Makrosunun temel amacı, web tarayıcısına geçmeden parsel sorgulama işlemini doğrudan Netcad çalışma ortamının içerisine taşımaktır.
Normalde bir parseli sorgulamak için koordinatı bulmak, coğrafi sisteme çevirmek, parsel sorgulama servisine gitmek, doğru taşınmazı tespit etmek ve geometrisini yeniden CAD ortamına aktarmak gerekir.
Bu makro bütün bu süreci tek bir işlem altında toplar.
Netcad’de noktayı seç → Parseli sorgula → Geometriyi getir → Netcad’e çiz → Parsel bilgilerini yazdır.
Makro Nasıl Çalışıyor?
- Makro Netcad içerisinde çalıştırılır.
- Aktif Netcad projesinin koordinat/projeksiyon bilgisi okunur.
- Kullanıcı sorgulamak istediği parselin içerisinde bir noktaya tıklar.
- Netcad koordinatı coğrafi koordinata dönüştürülür.
- Seçilen koordinat TKGM parsel sorgulama servisine gönderilir.
- Noktanın içerisinde bulunduğu parsel tespit edilir.
- Parselin geometrisi ve öznitelik bilgileri alınır.
- Gelen parsel koordinatları aktif Netcad projesinin koordinat sistemine dönüştürülür.
- Parsel sınırı TKGM_PARSEL tabakasına aktarılır.
- Parsel bilgileri parselin uygun konumuna yerleştirilir.
- Bilgi yazıları TKGM_PARSEL_BILGI tabakasında tutulur.
- İşlem tamamlandıktan sonra kullanıcı başka bir parsele tıklayarak sorgulamaya devam edebilir.
TKGM_PARSEL Tabakası
TKGM’den alınan gerçek parsel geometrileri ayrı bir Netcad tabakasında tutulur:
TKGM_PARSEL
Böylece sorgulama sonucu gelen geometriler mevcut proje objeleriyle karışmaz.
Tabakayı istediğiniz zaman açabilir, kapatabilir, seçebilir, düzenleyebilir veya proje içerisinde diğer CAD verileriyle birlikte kullanabilirsiniz.
TKGM_PARSEL_BILGI Tabakası
Parsel hakkında TKGM servisinden alınabilen bilgi alanları ayrı bir bilgi tabakasına yazdırılır:
TKGM_PARSEL_BILGI
Bilgi bloğu mümkün olduğunca kompakt tasarlanmıştır. Yazılar sola dayalıdır ve büyük alan kaplamaması için yaklaşık 0.40 yazı yüksekliği kullanılır.
Parselin en önemli bilgisi olan ADA / PARSEL değeri diğer bilgilerden daha belirgin gösterilir.
Örneğin:
216 / 8
İL : İstanbul
İLÇE : Çatalca
MAHALLE : Kabakça
ADA : 216
PARSEL : 8
NİTELİK : Tarla
MEVKİ : Köy Kenarı
ALAN : 13.238,23 m²
PAFTA : ...
SORGU ENLEM : ...
SORGU BOYLAM : ...
KAYNAK : TKGM MEGSİS CBS APIServisten gelen kullanılabilir diğer bilgiler de bilgi bloğuna eklenebilir.
Daha Temiz Bir Netcad Çizimi
İlk tasarımda bütün bilgilerin merkezden dağılarak yazdırılması özellikle küçük ve dar parsellerde okunabilirliği azaltabiliyordu.
Bu nedenle bilgi yapısı daha kompakt hale getirildi.
Bilgiler artık mümkün olduğunca sola dayalı ve düzenli satırlar halinde gösterilir. Yazı boylarının küçük tutulması sayesinde parselin dışına gereksiz taşma azaltılır.
Amaç klasik CAD yazısından çok, küçük bir parsel bilgi kartı görünümü oluşturmaktır.
Obje Adlandırması
Parsel objelerinin adlandırılmasında gereksiz tekrarların önüne geçilmiştir.
Özellikle obje adının başına mahalle veya köy adı eklenmez.
Böylece Netcad obje listesinde daha kısa, sade ve okunabilir bir yapı elde edilir.
Parseli tanımlayan temel değerlerin kullanılması tercih edilir.
Obje Taraması
Makro tarafından oluşturulan parsel objeleri Netcad içerisinde normal CAD objesi olarak kullanılabilir.
Obje taraması açık olacak şekilde düşünülmüştür.
Bu sayede sorguyla gelen parseller daha sonra seçim, sorgulama, obje bilgi görüntüleme ve diğer Netcad işlemlerinde kullanılabilir.
Aktif Projeksiyonu Kullanır
Makronun önemli özelliklerinden biri, kullanıcıdan her sorguda tekrar koordinat sistemi istemek yerine mevcut Netcad projesinin projeksiyon bilgisinden yararlanmasıdır.
Netcad üzerinde tıklanan koordinat önce coğrafi koordinata dönüştürülür.
TKGM’den gelen coğrafi parsel geometrisi ise tekrar aktif proje sistemine dönüştürülür.
Bu nedenle parsel, web haritasında kalmaz; Netcad projenizin kendi koordinat sisteminde gerçek CAD geometrisi haline gelir.
Neden Faydalı?
Klasik yöntemde parsel sorgulama ile CAD ortamı birbirinden ayrı iki süreçtir.
SagulCAD yaklaşımında ise parsel sorgulama, koordinat dönüşümü ve CAD çizimi tek iş akışında birleştirilir.
Özellikle kamulaştırma, kadastro, güzergâh projeleri, altyapı çalışmaları, taşınmaz yönetimi, arazi edinimi ve saha kontrollerinde çok sayıda parsel ile çalışan kullanıcılar için önemli zaman kazandırabilir.
Kullanım Alanları
Makro özellikle kamulaştırma projeleri, karayolu ve demiryolu projeleri, enerji projeleri, altyapı güzergâhları, kadastro kontrolleri, taşınmaz araştırmaları, CBS/CAD veri hazırlama ve saha çalışmaları sırasında yardımcı araç olarak kullanılabilir.
Tek tek internet üzerinden parsel aramak yerine doğrudan proje üzerindeki konuma tıklamak, çalışma akışını ciddi biçimde sadeleştirir.
İnternet Bağlantısı
Parsel bilgileri çevrimiçi TKGM servisinden alındığı için sorgulama sırasında internet bağlantısının bulunması gerekir.
İnternet erişimi yalnızca parsel sorgusunun gerçekleştirilmesi için kullanılır.
Netcad’e aktarılan geometri ise işlem tamamlandıktan sonra projenin normal CAD objesi haline gelir.
Dikkat Edilmesi Gerekenler
TKGM servislerinin yapısı, erişim politikaları veya döndürdüğü veri alanları zaman içerisinde değişebilir.
Bu nedenle makro tarafından getirilen bilgilerin resmî işlem, tapu işlemi, aplikasyon, hukuki değerlendirme veya kesin mülkiyet tespiti öncesinde ilgili resmî kayıtlarla kontrol edilmesi gerekir.
Makro temel olarak CAD/CBS çalışma ve sorgulama yardımcısıdır.
SagulCAD
Bu çalışma, Netcad üzerinde günlük olarak yapılan işlemleri daha hızlı ve daha pratik hale getirmek amacıyla geliştirilen SagulCAD araçlarından biridir.
Amaç yalnızca tek bir işlemi otomatikleştirmek değil; CAD, CBS, web servisleri ve mekânsal verileri aynı çalışma düzeni içerisinde bir araya getirmektir.
SagulCAD
Şaban GÜL
Harita Mühendisi
