Noktaları En Yakın Alan Objesine Taşıma (Netcad Makro)

Makro Hakkında:

Netcad projesindeki noktaları, belirlediğiniz kritere göre en yakındaki objeye taşınmasını sağlar. Netcad projelerinde noktalar ile doğruların kesişmediği küçük miktarlı hataların olduğu projelerde ortaya çıkan bu problemin düzeltilmesini sağlar.

• Makroda Üzerinde Çalıştığımız Gelişmeler:
  • Şu anlık üzerinde çalıştığımız bir gelişme bulunmamaktadır. Kullanıcılardan gelen istekler ve editörlerimizin çalışmaları ile olası gelişmeler yayımlanacaktır. Bizi takip ediniz.
• 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:

• Yapılan işlemde önceki noktaların konumu korunmayacaktır.
• Yapılan işlemde birden fazla karakter ayracı varsa ilki esas alınacaktır.
• Bu işlem projenizdeki seçtiğiniz nokta ve alan tabakalarına uygulanır.
• 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 noktacek.sagul  ve ncek.sagul isimli dosyalar 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.
• Bu işlemde geri alma işlemi tek tek yapılmaktadır. Bu nedenle ciddi anlamda yapacağınız değişikliklerde geri alma işleminiz çok uzun sürebilir.
• Bu makroda Kilitli olan tabakalardaki objelerde işlem görecektir. Bu nedenle işlem görmek istemediğiniz tabakaları kilitlemek yerine kapatınız.
• 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.
•  

İ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 i,BD,obj,POLY,j,lineOBJ,say
Dim BD0
dim saban1,saban2,murat
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 fsot, ft
Set fsot = CreateObject("Scripting.FileSystemObject")
Set ft = fsot.OpenTextFile("C:\Sagul\Netcad\Makro\Tanimlar\noktacek.sagul", ForWriting, True)



dim ruhangul

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile("C:\Sagul\Netcad\Makro\Tanimlar\ncek-tampon.sagul", ForReading, True)

do while not f.AtEndOfStream
ruhangul= f.ReadLine()
loop





set BD0 = .NewBDialog("Noktaları en yakın alan objeye taşıma [Harita Akademi, Şaban GÜL]")
 BD0.GetCheck "SAGUL1", "Alanlar Herhangi Bir Tabakadadır", -1
 BD0.GetCheck "SAGUL2", "Noktalar Herhangi Bir Tabakadadır", -1

if BD0.ShowModal then
 saban1=BD0.ValueByName("SAGUL1")
 saban2=BD0.ValueByName("SAGUL2")
 if saban1=0 and saban2=0 then ft.WriteLine 0
 if saban1=0 and saban2=1 then ft.WriteLine 1
 if saban1=1 and saban2=0 then ft.WriteLine 2
 if saban1=1 and saban2=1 then ft.WriteLine 3
 ft.close

if saban1=0 and saban2=0 then murat= 0
 if saban1=0 and saban2=1 then murat= 1
 if saban1=1 and saban2=0 then murat= 2
 if saban1=1 and saban2=1 then murat= 3



else
 exit sub
 end if



set BD = .NewBDialog("Noktaları en yakın alan objeye taşıma [Harita Akademi, Şaban GÜL]")

if saban1=0 then
 BD.GetCombo "PARSEL_ALAN", "Alanların bulunduğu tabakayı seçiniz : ", "0", 0
 for i = 1 to .numlayers - 1
 BD.AddCombo .LayerNameOf(i)
 next
 end if



if saban2=0 then
 BD.GetCombo "PARSEL_NOKTA", "Noktaların bulunduğu tabakayı seçiniz : ", "0", 0
 for i = 1 to .numlayers - 1
 BD.AddCombo .LayerNameOf(i)
 next
 end if

if ruhangul<0.002 then
 ruhangul=0.01
 end if
 BD.GetFloat "TAMPON", "Tampon Mesafesi (Metre Cinsinden): ",ruhangul, 3
 BD.GetCheck "TAMPON2", "Mesafeyi bir sonraki işlemler için sakla", 1







' BD.GetCheck "LIMIT_BUL", "İşlem Sonrası İşlem Gören Parsellerde Limit Bul", -1
 ' BD.GetCheck "LIMIT", "İşlem Sonrası Tüm Limit Bul.", -1



if BD.ShowModal then



dim sagulnet
sagulnet= BD.ValueByName("TAMPON2")

Dim fsot2, ft2
Set fsot2 = CreateObject("Scripting.FileSystemObject")
Set ft2 = fsot.OpenTextFile("C:\Sagul\Netcad\Makro\Tanimlar\ncek-tampon.sagul", ForWriting, True)
 if sagulnet=1 then
 ft2.WriteLine BD.ValueByName("TAMPON")
 else
 ft2.WriteLine 0
 end if
 ft2.close





set obj = .newobject()
 if murat=0 or murat=1 then

.SetFilter nothing, array(BD.ValueByName("PARSEL_ALAN")), array(opline)
 else
 .SetFilter nothing, array(), array(opline)
 end if
 while .GetNextObject2(obj)
 say = say + 1
 set POLY = .newpoly()
 set POLY = obj.GetObjectAsPline()
 if BD.ValueByName("LIMIT_BUL") = 1 then
 .SetCurrentWindow obj.limits, true
 .DrawObject .MakePline("",3,0,0,0,0,POLY), 222
 end if
 '************************************
 for j = 0 to POLY.Num - 2
 set lineOBJ = .newobject()
 set lineOBJ = .MakeLine(POLY.Cor(j),POLY.Cor(j+1),0,0,3)
 pointMove lineOBJ,BD.ValueByName("PARSEL_NOKTA"),BD.ValueByName("TAMPON")
 next
 '************************************
 set POLY = nothing
 .BackMessage : .setMessage "[ " & say & ". ] Alan Objesi Tarandı"
 wend
 .ResetFilter
 set obj = nothing
 .Message 0, say & " Adet Alan İşlem Gördü.", "Belirlenen kritere göre noktalar aynı tabakada taşındı."
 end if
 .backMessage
 if BD.ValueByName("LIMIT") = 1 then .findworld
end with
End Sub







Function pointMove(lineOBJ,pointLAYER,TAMPON)
dim i,ext,obj,POLY,lenght1,lenght2
dim fso,f ,sabangulX



Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile("C:\Sagul\Netcad\Makro\Tanimlar\noktacek.sagul", ForReading, True)

do while not f.AtEndOfStream
sabangulX= f.ReadLine()
loop
 f.close





with netcad
 set ext = .NewWorld(0,0,0,0)
 set ext = lineOBJ.Limits
 ext.Expand TAMPON, TAMPON
 set obj = .newobject()
 if sabangulX="1" or sabangulX="3" then
 .SetFilter ext, array(),array(opoint)
 else
 .SetFilter ext, array(pointLAYER), array(opoint)
 end if
 while .GetNextObject2(obj)
 if NCMath.OnlineSeg(obj.p1,lineOBJ.p1,lineOBJ.p2,TAMPON) then
 lenght1 = NCMath.Distance(obj.p1,lineOBJ.p1,false)
 lenght2 = NCMath.Distance(obj.p1,lineOBJ.p2,false)
 if lenght1 < lenght2 then
 obj.p1.x = lineOBJ.p1.x
 obj.p1.y = lineOBJ.p1.y
 obj.p1.z = lineOBJ.p1.z
 .PutObject .CurObjPos, obj
 else
 obj.p1.x = lineOBJ.p2.x
 obj.p1.y = lineOBJ.p2.y
 obj.p1.z = lineOBJ.p2.z
 .PutObject .CurObjPos, obj
 end if
 end if
 wend
 .resetfilter
 set obj = nothing
end with
end function