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:SagulNetcad klasörünün içerisine Makro isimli klasör oluşturulur.
  • C:SagulNetcadMakro klasörünün içerisine Tanimlar isimli klasör oluşturulur.
  • C:SagulNetcadMakroTanimlar 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:SagulNetcad\") Then
objFolder.SubFolders.Add \"Netcad\"
End If
Set fso = CreateObject(\"Scripting.FileSystemObject\")
Set objFolder = FSO.GetFolder(\"C:SagulNetcad\")
If Not FSO.FolderExists(\"C:SagulNetcadMakro\") Then
objFolder.SubFolders.Add \"Makro\"
End If
Set fso = CreateObject(\"Scripting.FileSystemObject\")
Set objFolder = FSO.GetFolder(\"C:SagulNetcadMakro\")
If Not FSO.FolderExists(\"C:SagulNetcadMakroTanimlar\") Then
objFolder.SubFolders.Add \"Tanimlar\"
End If
Dim fsot, ft
Set fsot = CreateObject(\"Scripting.FileSystemObject\")
Set ft = fsot.OpenTextFile(\"C:SagulNetcadMakroTanimlarnoktacek.sagul\", ForWriting, True)
dim ruhangul
Set fso = CreateObject(\"Scripting.FileSystemObject\")
Set f = fso.OpenTextFile(\"C:SagulNetcadMakroTanimlarncek-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:SagulNetcadMakroTanimlarncek-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:SagulNetcadMakroTanimlarnoktacek.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