\' 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 SubNcsagul Dosya Okuma Makrosu (Netcad)
sabangul67@gmail.com
