🚀 Netcad ile Otomatik Çoklu Doğru Çevirme: Hızlı ve Pratik Çözüm
Fast and Practical Polyline Conversion with Netcad: Automate Your Workflow
Bu makro, Netcad yazılımında alan objelerini otomatik olarak çoklu doğru (polyline) objelerine çevirmek için geliştirilmiştir. Özellikle büyük veri setleriyle çalışan mühendisler ve harita uzmanları için zaman tasarrufu sağlar. Makro, seçilen alan tabakasındaki objeleri tarar, çakışmaları kontrol eder ve sonuçları yeni bir tabakaya (\”0_SAGUL_COKLU\”) aktarır. Lisans kontrolü ile korunan bu makro, yalnızca Netcad ortamında çalışır ve kullanıcı dostu bir arayüz sunar. 🛠️
This macro is designed to automatically convert area objects into polyline objects in Netcad software. It saves time for engineers and mapping professionals working with large datasets. The macro scans objects in the selected area layer, checks for overlaps, and transfers the results to a new layer (\”0_SAGUL_COKLU\”). Protected by a license check, it runs exclusively in the Netcad environment and offers a user-friendly interface. 🛠️
Nasıl Çalışır (How Does It Work)
Kullanıcı Arayüzü: Makro, Netcad üzerinden başlatıldığında bir pencere açar. Kullanıcı, çoklu doğruya çevrilecek alan tabakasını seçer. Filtreleme ve Tarama: Seçilen tabakadaki alan objeleri taranır. Makro, her bir objeyi analiz eder ve çakışmaları tespit eder. Çoklu Doğru Oluşturma: Analiz edilen objeler, çoklu doğru formatına dönüştürülerek \”0_SAGUL_COKLU\” adlı yeni bir tabakaya kaydedilir. Performans İzleme: İşlem sırasında geçen süre ve taranan obje sayısı kullanıcıya gösterilir. Lisans Kontrolü: Makro, sistemin seri numarasını kontrol ederek lisans doğrulaması yapar. Lisanssız kullanım durumunda kullanıcıya bir uyarı mesajı gösterir ve lisans kodu talep eder.
User Interface: When launched in Netcad, the macro opens a dialog window where the user selects the area layer to convert. Filtering and Scanning: The macro scans area objects in the selected layer, analyzing each one and detecting overlaps. Polyline Creation: Processed objects are converted into polylines and saved in a new layer called \”0_SAGUL_COKLU\”. Performance Monitoring: The elapsed time and number of scanned objects are displayed to the user during processing. License Verification: The macro checks the system’s serial number for license validation. If unlicensed, it displays a warning and requests a license code.
Etiket ( Labels )
Netcad Makro, Otomatik Çoklu Doğru, Alan Objesi Çevirme, Harita Mühendisliği, CAD Yazılımı, SagulCAD, Çakışma Kontrolü, Otomasyon Aracı, Netcad Otomasyon, Çoklu Doğru Oluşturma, Veri İşleme, Harita Tasarımı, Mühendislik Yazılımı, Otomatik Tarama, Lisanslı Makro
Netcad Macro, Automatic Polyline, Area Object Conversion, Mapping Engineering, CAD Software, SagulCAD, Overlap Detection, Automation Tool, Netcad Automation, Polyline Creation, Data Processing, Map Design, Engineering Software, Automatic Scanning, Licensed Macro
📝 Netcad NVB Code
VB
Sub Main
'------------------------------------------------------------------------------------------
'Şaban GÜL Tarafından Üretilmiştir. Telif hakkı gereği bu satırı ve alttaki satırları silmeyiniz.
'Bu Makro SagulCAD ile üretilmiştir. Daha fazla bilgi için www.sagul.net adresini ziyaret ediniz.
'İstediğiniz yenilikleri, tespit ettiğiniz hataları bize ileti gönderiniz. E-posta: sagulnet@gmail.com.
'Bu makro sadece Netcad üzerinden çalışır.
'Makroyu çalıştırmak için Netcad Menüsünden Araçlar >> Uygulama Geliştirme >> Makro Çalıştır menüsünden makroyu çalıştırabilirsiniz.
'sagul.net/SagulCAD adresinden daha fazla bilgi edinebilirsiniz.
'------------------------------------------------------------------------------------------
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'''''' BU KODLARI GÖREBİLİYORSANIZ ÇEŞİTLİ YÖNTEMLER İLE
' BU KODLARA ULAŞTINIZ. BU KODLARIN AÇILMASI, KOPYALANMASI
' FARKLI KİŞİLERE VERİLMESİ YASAK OLUP TELİF HAKKINDA
' TABİİDİR. BU KODLARI KULLANMANIZ HUKUKİ SONUÇLAR DOĞURUR
' BU KODLARI AÇARAK ORTAYA ÇIKABİLECEK VERİ İHLALLERİNİN
' TÜM SORUMLULUĞU TARAFINIZA AİTTİR
' sabangul67@gmail.com e-posta adresine durumu anlatan
' bir eposta gönderiniz ve bu kodları bilgisayarınızdan siliniz
' aksi halde ortaya çıkabilecek tüm sorumluluğu kabul etmiş
' sayılırsınız
'Emeğe saygı göstermenizi ve lisanlı ürün kullanmanızı rica ederiz
'------------------------------------------------------------------------------------------
'--------------------------------LİSANS KONTROLÜ BAŞLANGICI -------------------------------
'------------------------------------------------------------------------------------------
'///////////// SERİAL NUMARASI
dim strComputer,objWMIService,str,colItems ,objItem
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\\\" & strComputer & "\\root\\cimv2")
str = ""
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_LogicalDisk Where DeviceID = 'C:'")
For Each objItem In colItems
str = objItem.VolumeSerialNumber
Next
dim d1,d2,d3,d4
dim m1,m2,m3,m4
d1=instr(date,".")
m1=mid(date,1,d1-1)
m2=mid(date,d1+1,len(date)-8)
m3=right(date,4)
if mid(m2,1,1)=0 then m2=mid(m2,2,1)
Dim ds
Set ds = CreateObject("Scripting.FileSystemObject")
dim serial
serial = mid(str,1,8)
serial = Replace(serial,"A",6)
serial = Replace(serial,"B",6)
serial = Replace(serial,"C",6)
serial = Replace(serial,"D",6)
serial = Replace(serial,"E",6)
serial = Replace(serial,"F",6)
serial = Replace(serial,"G",6)
serial = Replace(serial,"H",6)
serial = Replace(serial,"I",6)
serial = Replace(serial,"J",6)
serial = Replace(serial,"K",6)
serial = Replace(serial,"L",6)
serial = Replace(serial,"M",6)
serial = Replace(serial,"N",6)
serial = Replace(serial,"O",6)
serial = Replace(serial,"P",6)
serial = Replace(serial,"R",6)
serial = Replace(serial,"S",6)
serial = Replace(serial,"T",6)
serial = Replace(serial,"U",6)
serial = Replace(serial,"V",6)
serial = Replace(serial,"Y",6)
serial = Replace(serial,"Z",6)
serial = Replace(serial,"Q",6)
serial = Replace(serial,"W",6)
serial = Replace(serial,"X",6)
serial = Replace(serial,".",6)
serial = Replace(serial,"#",6)
serial = Replace(serial,"Ö",6)
serial = Replace(serial,"Ç",6)
serial = Replace(serial,"Ş",6)
serial = Replace(serial,"Ğ",6)
serial = Replace(serial,"ÜA",6)
serial = Replace(serial,"/A",6)
serial = Replace(serial,"+",6)
Dim ser1,ser2,ser3,ser4
ser1=mid(serial,1,2)+1-1
ser2=mid(serial,3,2)+1-1
ser3=mid(serial,5,2)+1-1
ser4=mid(serial,7,2) +1-1
dim netcadx,netcady,netcadz
Set netcadx = CreateObject("System.Collections.ArrayList")
Set netcady = CreateObject("System.Collections.ArrayList")
Set netcadz = CreateObject("System.Collections.ArrayList")
netcadx.Add 1962934272000
netcady.Add "Şaban GÜL"
netcadz.Add "31.12.2020"
netcadx.Add 9206637843465216
netcady.Add "Elif Yaren GÜL3"
netcadz.Add "31.12.2020"
netcadx.Add 181193932800000000
netcady.Add "Elif Yaren GÜL2"
netcadz.Add "31.12.2020"
netcadx.Add 15795179400
netcady.Add "Turan Taşınmaz Geliştirme A.Ş.xxxx"
netcadz.Add "31.12.2020"
netcadx.Add 884669423616
netcady.Add "Kıvırcık Osman"
netcadz.Add "31.12.2020"
netcadx.Add 3332267237376
netcady.Add "Siirtli Hüseyin AĞA"
netcadz.Add "31.12.2020"
dim filename1 , listFile1 , listLines1 , line1 , listecim1
dim fso1,fso2,fso3
Set fso1=CreateObject("Scripting.FileSystemObject")
filename1 = "C:\\SAGULCAD\\AYARLAR\\1.0"
listFile1 = fso1.OpenTextFile(filename1).ReadAll
listLines1 = Split(listFile1, vbCrLf)
Set listecim1 = CreateObject("System.Collections.ArrayList")
For Each line1 In listLines1
listecim1.Add line1
Next
dim filename2 , listFile2 , listLines2 , line2 , listecim2
Set fso2=CreateObject("Scripting.FileSystemObject")
filename2 = "C:\\SAGULCAD\\AYARLAR\\2.0"
listFile2 = fso2.OpenTextFile(filename2).ReadAll
listLines2 = Split(listFile2, vbCrLf)
Set listecim2 = CreateObject("System.Collections.ArrayList")
For Each line2 In listLines2
listecim2.Add line2
Next
dim filename3 , listFile3 , listLines3 , line3 , listecim3
Set fso3=CreateObject("Scripting.FileSystemObject")
filename3 = "C:\\SAGULCAD\\AYARLAR\\3.0"
listFile3 = fso3.OpenTextFile(filename3).ReadAll
listLines3 = Split(listFile3, vbCrLf)
Set listecim3 = CreateObject("System.Collections.ArrayList")
For Each line3 In listLines3
listecim3.Add line3
Next
dim korona
for korona=0 to listecim1.count-1
netcadx.Add listecim1(korona)
netcady.Add listecim2(korona)
netcadz.Add listecim3(korona)
next
dim elifyarengul
dim eyg
eyg=0
for elifyarengul=0 to netcadx.count-1
dim sssserial
sssserial= netcadx(elifyarengul)+1-1
if ser1*ser2*ser2*ser3*ser3*ser4*ser4 = sssserial then
eyg=1
dim xxfsot,xxft
Set xxfsot = CreateObject("Scripting.FileSystemObject")
Set xxft = xxfsot.OpenTextFile("C:\\SAGULCAD\\AYARLAR\\lic.lic", ForWriting, True)
xxft.WriteLine (netcady(elifyarengul))
xxft.WriteLine (netcadz(elifyarengul))
xxft.close
dim xxxfsot,xxxft
Set xxxfsot = CreateObject("Scripting.FileSystemObject")
Set xxxft = xxxfsot.OpenTextFile("C:\\SAGULCAD\\AYARLAR\\mes.lic", ForWriting, True)
xxxft.WriteLine (netcadx(elifyarengul)-123456789)
xxxft.close
end if
next
if eyg=1 then
else
ser1= ser1*ser1 +67
ser2 = ser2+ser2+43
ser3=ser3*ser3+47
ser4=ser4+ser4+72
if len(ser1) =4 then ser1= ser1 & "S"
if len(ser1) =3 then ser1=ser1 & "SG"
if len(ser1) =2 then ser1=ser1 & "SGL"
if len(ser1) =1 then ser1=ser1 & "ABCD"
if len(ser2) =4 then ser2= ser2 & "G"
if len(ser2) =3 then ser2=ser2 & "EY"
if len(ser2) =2 then ser2=ser2 & "GUL"
if len(ser2) =1 then ser2=ser2 & "YARN"
if len(ser3) =4 then ser3= ser3 & "R"
if len(ser3) =3 then ser3=ser3 & "SR"
if len(ser3) =2 then ser3=ser3 & "SRE"
if len(ser3) =1 then ser3=ser3 & "GULS"
if len(ser4) =5 then ser4= ser4 & "E"
if len(ser4) =4 then ser4= ser4 & "EY"
if len(ser4) =3 then ser4=ser4 & "EYG"
if len(ser4) =2 then ser4=ser4 & "ELIF"
if len(ser4) =1 then ser4=ser4 & "RUHAN"
dim addd,sg5
msgbox "Lisanssız Kullanıcı: Az sonra gösterilecek kodu sabangul67@gmail.com e-posta adresine göndererek lisans kodunu alabilirsiniz"
addd= inputbox ("Seri Numarası:","sabangul67@gmail.com adresine bu kodu gönderiniz", ser1 & "-" & ser2 & "-" & ser3& "-" & ser4 )
exit sub
end if
'///////////// SERİAL NUMARASI
'------------------------------------------------------------------------------------------
'--------------------------------LİSANS KONTROLÜ BİTİŞİ------------------------------------
'------------------------------------------------------------------------------------------
dim list1,list2,list3,list4,list5
Set list1 = CreateObject("System.Collections.ArrayList")
Set list2 = CreateObject("System.Collections.ArrayList")
Set list3 = CreateObject("System.Collections.ArrayList")
Set list4 = CreateObject("System.Collections.ArrayList")
Set list5 = CreateObject("System.Collections.ArrayList")
dim pencere
set pencere = netcad.newbdialog ("Sagulcad Otomatik Çoklu Doğru Çevirme")
pencere.GetCombo "ALAN_LAYER","Çoklu Doğruya Çevrilecek Alan Tabakası:","",0
for i = 0 to netcad.numlayers-1
pencere.AddCombo netcad.LayerNameOf(i)
next
pencere.PutPrompt "ÇOKLU DOĞRULAR [0_SAGUL_COKLU] tabakasına alınacaktır."
if pencere.showmodal then
else
exit sub
end if
dim alantab
alantab = pencere.valuebyname("ALAN_LAYER")
dim pline
Dim i,j,coklu1,coklu2,sonuc,l,x,y,yeni,olo
yeni = "CAKISMALAR"
With Netcad 'Netcad işlemleri arasından..
dim tabakas
tabakas=nclayermanager.layer(alantab).name
dim time1,time2
time1= time
.BackMessage
.setmessage " Merhaba "
.SetFilter nothing, array(.foundlayer(tabakas)),array(opline)
set olo = .newobject
dim kolj
kolj=0
while .GetNextObject2(olo)
kolj=kolj+1
wend
.resetfilter
dim kkk
kkk=kolj
.BackMessage
.setmessage "TOPLAM " & kkk & " ADET PARSEL TARANACAK "
Dim calistir
.SetFilter nothing, array(.foundlayer(tabakas)),array(opline)
set olo = .newobject
kolj=0
while .GetNextObject2(olo)
.BackMessage
time2=time
dim suresi,d
suresi=DateDiff("s", time1, time2)
dim dak,san,dakx
suresi = round(suresi/60 ,2)
.setmessage kolj & "/" & KKK & " [Geçen Süre: " & suresi &" Dakika ] Sagulcad İşleminizi Gerçekleştirirken Bekleyiniz."
set calistir = createobject("wscript.shell")
Set coklu1 = olo.getObjectAsPline() 'Çokludoğru olduğunu işlemci de bilsin..
dim z
kolj=kolj+1
if kolj>-50 then '////////////////////////////
z=0
dim cor
dim k
list1.clear
For k = 0 to coklu1.num - 1
dim cor1
dim rize
rize=coklu1.num - 1
set cor1 = .newc(0,0,0)
cor1.y= coklu1.cor(k).y
cor1.x= coklu1.cor(k).x
dim tx
set cor = .newc(0,0,0)
set cc1 = .newc(0,0,0)
set cc2 = .newc(0,0,0)
set cc3 = .newc(0,0,0)
set cc4 = .newc(0,0,0)
cor.y = coklu1.cor(k).y
cor.x = coklu1.cor(k).x
dim cc1,cc2,cc3,cc4
cc1.y=cor.y-0.05
cc1.x=cor.x-0.05
cc2.y=cor.y+0.05
cc2.x=cor.x+0.05
cc3.y=cor.y-0.05
cc3.x=cor.x+0.05
cc4.y=cor.y+0.05
cc4.x=cor.x-0.05
.SetFilter Nothing, array(), array(opline)
set coklu2 = .newobject
while .GetNextObject2(coklu2)
set pline=coklu2.getObjectAsPline()
if ( pline.InPoly(cor) or pline.InPoly(cc1) or pline.InPoly(cc2) or pline.InPoly(cc3) or pline.InPoly(cc4) )and coklu2.area >0.05 and olo.area >0.05 and coklu2.pname <> olo.pname then
list1.add k
End if
wend
.resetfilter
dim r
Dim Tampon
Tampon=0
dim limit,nokta
set Limit = .NewWorld(cor.y-(Tampon), cor.x-(Tampon), cor.y+(Tampon), cor.x+(Tampon))
.SetFilter limit, array(), array(opoint)
set nokta = .newobject
dim sah
sah=0
while .GetNextObject2(nokta)
sah=sah+1
if sah >1 then
list1.add k
end if
wend
.resetfilter
Next
dim sifirkactane,sibel
sifirkactane=-1
for l=0 to list1.count-1
if list1(l) =0 then sifirkactane=sifirkactane+1
next
if sifirkactane>0 then sibel="yok" else sibel="var"
if sibel="yok" then
end if
dim cors
set cors = .newc(0,0,0)
dim m,n,ali,haydar
list2.clear
list2.add 0
for m=0 to list1.count-1
ali= list1(m)
haydar=0
for n=0 to list1.count-1
if list1(n)=ali then haydar=haydar+1
next
if haydar>1 then list2.add list1(m)
next
dim u1,u2,ok,say
list3.clear
if sibel="yok" then list3.add 0
for u1=1 to list2.count-1
ok=list2(u1)
say=0
if ok<>list2(u1-1) then list3.add ok
next
dim oss,p
list3.add 0
dim kk,dd
for kk=0 to list3.count-2
set p = .NewPoly
for dd=list3(kk) to list3(kk+1)
p.AddCoor(.NewC(coklu1.cor(dd).y,coklu1.cor(dd).x,0))
next
set oss = .MakePline(olo.pname,0,0,.createlayer("0_SAGUL_COKLU",2),0,0,p)
.AddObject oss
next
dim h1,h2,h3,h4
h1=list3(list3.count-2)
h1=h1+1-1
h2= 0
h3= 0
h4= list3(0) +1-1
dim kkkk
set p = .NewPoly
for kkkk=h1 to rize
p.AddCoor(.NewC(coklu1.cor(kkkk).y,coklu1.cor(kkkk).x,0))
next
for kkkk=0 to h4
p.AddCoor(.NewC(coklu1.cor(kkkk).y,coklu1.cor(kkkk).x,0))
next
set oss = .MakePline(olo.pname,0,0,.createlayer("0_SAGUL_COKLU",2),0,0,p)
if sibel="var" then .AddObject oss
end if ' //////////////////////gfgdsfh
wend
.resetfilter
Set coklu1 = nothing 'RAM boşaltılıyor..
Set coklu2 = nothing 'RAM boşaltılıyor..
End With
End Subnetcad-otomatik-coklu-dogru-cevir
