' 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
Option Explicit
Const ForReading = 1
Sub Main
Dim fso, f, BD, inputFile, line, fields, objType, isHeader, layerName, layerId
Dim projectPath, defaultInputPath, points, pointPairs, k, poly
Dim netcadObj, sabangul_i
' Netcad nesnesi ile çalış
With Netcad
' Proje dosyasının yolunu al
projectPath = .GetParam(PNC_CURRENTFILE)
' Proje klasörünü çıkar ve varsayılan giriş yolunu ayarla
Set fso = CreateObject("Scripting.FileSystemObject")
defaultInputPath = fso.BuildPath(fso.GetParentFolderName(projectPath), "ncsagul.ncs")
' Diyalog penceresi oluştur
Set BD = .NewBDialog("Netcad Obje Okuma [Harita Akademi, Şaban GÜL]")
BD.PutPrompt "Okunacak Dosyayı Seçiniz"
BD.GetFileName "inputFile", "Giriş Dosyası:", defaultInputPath, "Text Dosyaları|*.ncsagul|Tüm Dosyalar|*.*", "ncsagul"
BD.PutPrompt "Tamam'a basarak işlemi başlatın."
If Not BD.ShowModal Then
Exit Sub
End If
' Kullanıcı girişini al
inputFile = BD.ValueByName("inputFile")
' Dosya var mı kontrol et
If Not fso.FileExists(inputFile) Then
MsgBox "Dosya bulunamadı: " & inputFile, 16, "Hata"
Exit Sub
End If
' Dosyayı oku
Set f = fso.OpenTextFile(inputFile, ForReading, False)
objType = ""
isHeader = False
Set netcadObj = .NewObject
Do Until f.AtEndOfStream
line = f.ReadLine
' Boş satırı işle
If Len(Trim(line)) = 0 Then
isHeader = False
objType = ""
ElseIf Left(line, 3) = "###" Then
' Obje türü değişti
objType = Mid(line, 4, Len(line) - 6) ' ###CIZGI### -> CIZGI
isHeader = True
ElseIf isHeader Then
' Başlık satırını atla
isHeader = False
Else
' Obje satırını işle
fields = Split(line, "|")
' Tabaka veya obje işleme
Select Case objType
Case "TABAKALAR"
If UBound(fields) >= 10 Then
layerName = fields(1)
With ncLayerManager
layerId = -1
For sabangul_i = 0 To .NumLayer - 1
If UCase(.Layer(sabangul_i).name) = UCase(layerName) Then
layerId = sabangul_i
Exit For
End If
Next
If layerId = -1 Then
layerId = netcad.createlayer(layerName,5)
End If
' Tabaka özelliklerini uygula
.Layer(layerId).name=layerName
.Layer(layerId).color = CLng(fields(3))
.Layer(layerId).VisStartScale=CDbl(fields(9))
.Layer(layerId).VisEndScale = CDbl(fields(10))
if fields(5) ="Doğru" then netcad.openlayer(layerId) else netcad.closelayer(layerId)
if fields(7) ="Doğru" then .layer(layerId).LockActive=True else .layer(layerId).LockActive=False
if fields(8) ="Doğru" then .layer(layerId).PrintableActive=True else .layer(layerId).PrintableActive=False
End With
End If
Case Else
' Mevcut tabaka kontrolü
If UBound(fields) > 1 Then
layerName = fields(1)
With ncLayerManager
layerId = -1
For sabangul_i = 0 To .NumLayer - 1
If UCase(.Layer(sabangul_i).name) = UCase(layerName) Then
layerId = sabangul_i
Exit For
End If
Next
If layerId = -1 Then
layerId = netcad.createlayer(layerName,5)
Randomize
'.SetLayerColor layerId, Int(Rnd * 256)
End If
End With
End If
' Obje türüne göre işleme
Select Case objType
Case "CIZGI"
If UBound(fields) >= 11 Then
netcadObj.tag = 2
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.pname = fields(4)
netcadObj.w = CDbl(fields(5))
netcadObj.lt = CInt(fields(6))
netcadObj.p1.x = CDbl(fields(8))
netcadObj.p1.y = CDbl(fields(9))
netcadObj.p2.x = CDbl(fields(10))
netcadObj.p2.y = CDbl(fields(11))
.AddObject netcadObj
End If
Case "COKLUDOGRU"
If UBound(fields) >= 11 Then
netcadObj.tag = 7
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.pname = fields(4)
netcadObj.w = CDbl(fields(5))
netcadObj.lt = CInt(fields(6))
netcadObj.tarea = CDbl(fields(8))
'netcadObj.area = CDbl(fields(9))
netcadObj.flags = fields(10)
Set poly = .newpoly
points = Split(fields(11), "#")
For k = 0 To UBound(points)
pointPairs = Split(points(k), "$")
If UBound(pointPairs) = 1 Then
Dim c
Set c = .newc(CDbl(pointPairs(1)), CDbl(pointPairs(0)), 0)
poly.addcoor c
End If
Next
Dim alanss
Dim tabks
tabks = 0
For k = 0 To NCLayerManager.NumLayer - 1
If NCLayerManager.layer(k).name = fields(1) Then tabks = k
Next
Set alanss = .MakePline("ADI!", fields(10), fields(8), tabks, 0, 0, poly)
alanss.cls = fields(2)
alanss.objname = fields(3)
alanss.pname = fields(4)
alanss.w = CDbl(fields(5))
alanss.lt = CInt(fields(6))
alanss.tarea = CDbl(fields(8))
.AddObject(alanss)
Set poly = Nothing
End If
Case "DAIRE"
If UBound(fields) >= 8 Then
netcadObj.tag = 3
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.p1.x = CDbl(fields(4))
netcadObj.p1.y = CDbl(fields(5))
netcadObj.p1.z = CDbl(fields(6))
netcadObj.rad = CDbl(fields(7))
.AddObject netcadObj
End If
Case "NOKTA"
If UBound(fields) >= 8 Then
netcadObj.tag = 1
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.pname = fields(4)
netcadObj.pcode = fields(5)
netcadObj.p1.x = CDbl(fields(6))
netcadObj.p1.y = CDbl(fields(7))
netcadObj.p1.z = CDbl(fields(8))
.AddObject netcadObj
End If
Case "YAY"
If UBound(fields) >= 11 Then
netcadObj.tag = 4
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.pname = fields(4)
netcadObj.p1.x = CDbl(fields(5))
netcadObj.p1.y = CDbl(fields(6))
netcadObj.p1.z = CDbl(fields(7))
netcadObj.rad = CDbl(fields(8))
netcadObj.angle = CDbl(fields(9))
netcadObj.stangle = CDbl(fields(10))
netcadObj.enangle = CDbl(fields(11))
.AddObject netcadObj
End If
Case "YAZI"
If UBound(fields) >= 11 Then
netcadObj.tag = 5
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.s = fields(4)
netcadObj.p1.x = CDbl(fields(5))
netcadObj.p1.y = CDbl(fields(6))
netcadObj.angle = CDbl(fields(7))
netcadObj.wsc = CDbl(fields(8))
netcadObj.sc = CDbl(fields(9))
netcadObj.just = fields(10)
netcadObj.flags = fields(11)
.AddObject netcadObj
End If
Case "SEMBOL"
If UBound(fields) >= 10 Then
netcadObj.tag = 6
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.pname = fields(4)
netcadObj.p1.x = CDbl(fields(5))
netcadObj.p1.y = CDbl(fields(6))
netcadObj.p1.z = CDbl(fields(7))
netcadObj.angle = CDbl(fields(8))
netcadObj.sembolno = CDbl(fields(9))
netcadObj.sc = CDbl(fields(10))
.AddObject netcadObj
End If
Case "SPIRAL"
If UBound(fields) >= 7 Then
netcadObj.tag = 9
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.pname = fields(4)
netcadObj.renk = CLng(fields(5))
netcadObj.w = CDbl(fields(6))
netcadObj.lt = CInt(fields(7))
.AddObject netcadObj
End If
Case "IZOHIPS"
If UBound(fields) >= 8 Then
netcadObj.tag = 16
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.pname = fields(4)
netcadObj.renk = CLng(fields(5))
netcadObj.w = CDbl(fields(6))
netcadObj.lt = CInt(fields(7))
netcadObj.elevation = CDbl(fields(8))
.AddObject netcadObj
End If
Case "KUTU"
If UBound(fields) >= 13 Then
netcadObj.tag = 12
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.pname = fields(4)
netcadObj.renk = CLng(fields(5))
netcadObj.w = CDbl(fields(6))
netcadObj.lt = CInt(fields(7))
netcadObj.p1.x = CDbl(fields(8))
netcadObj.p1.y = CDbl(fields(9))
netcadObj.p1.z = CDbl(fields(10))
netcadObj.p2.x = CDbl(fields(11))
netcadObj.p2.y = CDbl(fields(12))
netcadObj.p2.z = CDbl(fields(13))
.AddObject netcadObj
End If
Case "PAFTA"
If UBound(fields) >= 7 Then
netcadObj.tag = 20
netcadObj.tabaka = layerId
netcadObj.cls = fields(2)
netcadObj.objname = fields(3)
netcadObj.pname = fields(4)
netcadObj.renk = CLng(fields(5))
netcadObj.w = CDbl(fields(6))
netcadObj.lt = CInt(fields(7))
.AddObject netcadObj
End If
End Select
End Select
End If
Loop
' Temizlik
f.Close
Set f = Nothing
Set fso = Nothing
Set netcadObj = Nothing
Set BD = Nothing
MsgBox "Obje bilgileri başarıyla " & inputFile & " dosyasından okundu ve projeye eklendi.", 64, "Harita Akademi, Şaban GÜL"
End With
End Sub
⚠️ Dikkat! Netcad Makrosu Kullanımı Hakkında Bilgilendirme
✅ Makroyu kullanmadan önce lütfen aşağıdaki uyarıları dikkatlice okuyunuz:
• Obje sayısı yüksekse işlem uzun sürebilir ve Netcad yazılımı yanıt veremez hale gelebilir.
• Bu nedenle tüm projelerinizi önceden yedeklemeniz önemle tavsiye edilir.
• Makro çalıştıktan sonra işlemi geri almak mümkün olmayabilir.
• Makrolar periyodik olarak güncellenmektedir; sayfamızı takip ederek güncel sürümleri kullanmaya özen gösteriniz.
💾 Makrolar yalnızca Netcad yazılımında çalışır ve .nps formatında sunulur. Bu format düzenlenemez; özelleştirme talepleriniz için bizimle iletişime geçebilirsiniz.
✉️ Görüş, öneri ve hata bildirimleri için: sabangul67@gmail.com
⚙️ Bu makrolar Kadastro, 2B, Orman, Kamulaştırma, Değerleme, CBS, Halihazır Harita, İmar Planı, Etüt-Proje gibi birçok alanda kullanılabilir.
🔐 Makrolar e-posta eki veya sosyal medya üzerinden paylaşılmaz. Talepte bulunmanız durumunda yalnızca e-posta adresinize bilgilendirme yapılır. Makrolar yalnızca internet sitemiz üzerinden paylaşılır.
📥 Makroları indirerek kullanım sorumluluğunu kabul etmiş sayılırsınız. Oluşabilecek tüm sorunlar kullanıcı sorumluluğundadır.
✅ Makroyu kullanmadan önce lütfen aşağıdaki uyarıları dikkatlice okuyunuz:
• Obje sayısı yüksekse işlem uzun sürebilir ve Netcad yazılımı yanıt veremez hale gelebilir.
• Bu nedenle tüm projelerinizi önceden yedeklemeniz önemle tavsiye edilir.
• Makro çalıştıktan sonra işlemi geri almak mümkün olmayabilir.
• Makrolar periyodik olarak güncellenmektedir; sayfamızı takip ederek güncel sürümleri kullanmaya özen gösteriniz.
💾 Makrolar yalnızca Netcad yazılımında çalışır ve .nps formatında sunulur. Bu format düzenlenemez; özelleştirme talepleriniz için bizimle iletişime geçebilirsiniz.
✉️ Görüş, öneri ve hata bildirimleri için: sabangul67@gmail.com
⚙️ Bu makrolar Kadastro, 2B, Orman, Kamulaştırma, Değerleme, CBS, Halihazır Harita, İmar Planı, Etüt-Proje gibi birçok alanda kullanılabilir.
🔐 Makrolar e-posta eki veya sosyal medya üzerinden paylaşılmaz. Talepte bulunmanız durumunda yalnızca e-posta adresinize bilgilendirme yapılır. Makrolar yalnızca internet sitemiz üzerinden paylaşılır.
📥 Makroları indirerek kullanım sorumluluğunu kabul etmiş sayılırsınız. Oluşabilecek tüm sorunlar kullanıcı sorumluluğundadır.
