NADI Yazdırma: Nokta Adlarını Otomatik ve Hassas Etiketleme Çözümü 🚀
Point Name Labeling: Automatic and Precise NADI Solution
Bu makro, Netcad ortamında nokta adlarını (NADI) otomatik olarak etiketlemek için tasarlanmıştır. Nokta koordinatlarına uygun konumlarda, okunabilir ve düzenli bir şekilde nokta adlarını yazdırır. Kullanıcı dostu bir arayüzle, etiketlerin yazılacağı tabakayı seçebilirsiniz. Poligon veya nirengi noktalarını algılayarak bu noktalara özel formatlar uygular. Yazı boyutları, proje ölçeğine göre otomatik ayarlanır, böylece haritalarınızda profesyonel ve estetik bir görünüm elde edersiniz. 🗺️
This macro is developed to automatically label point names (NADI) in the Netcad environment. It places point names at optimal coordinates in a clear and organized manner. With a user-friendly interface, you can choose the layer for labeling. It detects polygon or triangulation points and applies specific formatting. Text sizes are adjusted based on the project scale, ensuring a professional and aesthetic look for your maps.
Nasıl Çalışır (How Does It Work)
Tabaka Seçimi: Makro, bir diyalog penceresi ile nokta adlarının yazılacağı tabakayı seçmenizi sağlar.
Nokta Algılama: Seçilen tabakadaki noktaları tarar ve her noktanın adını (pname) analiz eder.
Özel Nokta Tanımlama: Poligon (P.) veya nirengi (N.) noktalarını tespit eder ve bunlara özel yazı formatları uygular.
Konum Hesaplama: GetNoktaNoPozisyon fonksiyonu, nokta adlarının yazılacağı en uygun konumu hesaplar ve çakışmaları önlemek için çevredeki nesneleri kontrol eder.
Yazım ve Formatlama: Nokta adları, ölçeğe uygun yazı boyutları ve hizalamalarla (sol veya orta) belirtilen tabakaya yazılır.
Temizlik: Geçici katmanlar (SILSAGULXXX) işlem sonunda otomatik olarak silinir.
- Layer Selection: The macro opens a dialog box to select the layer for labeling point names.
- Point Detection: It scans points in the selected layer and analyzes each point’s name (pname).
- Special Point Identification: It identifies polygon (P.) or triangulation (N.) points and applies specific text formatting.
- Position Calculation: The GetNoktaNoPozisyon function calculates the optimal position for labeling, checking for overlaps with nearby objects.
- Labeling and Formatting: Point names are written to the specified layer with scale-appropriate text sizes and alignments (left or center).
- Cleanup: Temporary layers (SILSAGULXXX) are automatically deleted at the end.
Etiket ( Labels )
NADI yazdırma, nokta adı etiketleme, otomatik etiketleme, Netcad makro, harita çizimi, jeodezik noktalar, poligon noktaları, nokta koordinatları, harita otomasyonu, CAD makro, Netcad otomasyon, nokta etiketleme, haritacılık, coğrafi bilgi sistemleri, GIS makro, proje çizimi, hassas etiketleme, ölçek uyumlu, profesyonel harita, tabaka yönetimi
NADI labeling, point name labeling, automatic labeling, Netcad macro, map drawing, geodetic points, polygon points, point coordinates, map automation, CAD macro, Netcad automation, point tagging, cartography, geographic information systems, GIS macro, project drafting, precise labeling, scale-adaptive, professional mapping, layer management
📝 Netcad NVB Code
CONST CONST_PART_ACI=20 ' Açı Bölme artış değeri 1-400 aralığında olabilir. Nokta Numaralarını yazarken pozisyon seçmede kullanıyoruz.
CONST GRAD_TO_RAD = 63.6620
Sub Main
Dim obj
dim pts() : redim preserve pts(0)
with Netcad
dim OLCEK ,TXT_SIZE
OLCEK= .getparam(94)
' TXT_SIZE = OLCEK*1.5
dim BD,i
dim t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t10x
dim t1x,t2x,t3x,t4x
set BD = .NewBDialog("Nokta No Yazdır - Sagulcad")
BD.GetCombo "NOKTA_LAYER","Nokta No Yazdırılacak Tabaka:","",0
for i = 0 to .numlayers-1
BD.AddCombo .LayerNameOf(i)
next
' BD.GetString "YENI1","Yeni Oluşturulacak Noktaların Tabakası:","",20
' BD.GetString "YENI2","Yeni Nokta (Düzeltilecek) Tabakası:","",20
' BD.GetString "YENI3","Yeni Nokta (Jeodezik Noktalar) Tabakası:","",20
if BD.ShowModal then
t1= BD.ValueByName("NOKTA_LAYER")
' t2= BD.ValueByName("YENI_1")
' t3= BD.ValueByName("YENI_2")
' t4= BD.ValueByName("YENI_3")
t1x= nclayermanager.layer(t1).name
t2=""
t3=""
t4=""
if t2="" then t2="SAGUL_NOKTA"
if t3="" then t3="SAGUL_NOKTA_DZL"
if t4="" then t4="SAGUL_NOKTA_JEO"
ELSE
exit sub
end if
.setfilter nothing, array(.foundlayer(t1x)),array(opoint)
do
set obj=.getnextobject
if obj is nothing then
exit do
else
redim preserve pts(ubound(pts)+1)
set pts(ubound(pts)-1)=obj
end if
loop
.resetfilter
NoktaNoYaz pts,1.5*OLCEK/1000,1
end with
dim m ,l
m = netcad.numlayers - 1
With nclayermanager
For l =m To 0 step -1
if .layer(l).name = "SILSAGULXXX" then .Delete l, true
next
End With
End Sub
private sub NoktaNoYaz(pts(),TXT_SIZE,sc)
dim i
dim c
dim txt
dim layer,layer1,layer2
dim nno
dim pos
dim pos1
dim pos2
dim flag
dim just
with netcad
LAYER =.createlayer("SAGUL_NOKTA",4)
LAYER1=.createlayer("SAGUL_NOKTA_DZL",10)
LAYER2=.createlayer("SAGUL_NOKTA_JEO",3)
Flag=0
for i=0 to ubound(pts)-1
pos=instr(pts(i).pname,"/")
if pos>0 then
nno=trim(mid(pts(i).pname,pos+1,len(pts(i).pname)))
else
nno=trim(pts(i).pname)
end if
'Poligon veya nirengi ise
if instr(pts(i).pname,"P.") >0 or instr(pts(i).pname,"N.") then
nno= trim(pts(i).pname)
Flag=1
else
Flag=0
end if
if flag=1 then
set c=GetNoktaNoPozisyon(pts(i).p1,nno,sc*1000,sc*1000,CONST_PART_ACI)
else
set c=GetNoktaNoPozisyon(pts(i).p1,nno,sc*1000,TXT_SIZE,CONST_PART_ACI)
end if
if c.z=0 THEN
just="L"
else
just="2"
end if
if pts(i).p1.SamePoint(c)=TRUE then
if flag=1 then
SET TXT= .MakeText(c,nno,0,0, 2*sc,c.z,just,LAYER2)
else
SET TXT= .MakeText(c,nno,0,0, TXT_SIZE*sc,c.z,just,LAYER1)
end if
else
if Flag=1 then
SET TXT= .MakeText(c,nno,0,0, 2 * sc,c.z,just,LAYER2)
else
SET TXT= .MakeText(c,nno,0,0, TXT_SIZE*sc,c.z,just,LAYER)
end if
end if
.addobject txt
pos=0
next
end with
End Sub
Function GetNoktaNoPozisyon(c,txt1,Olcek,SIZE,Partition)
Dim i ,j
Dim Region
Dim Rad
Dim bTest
dim obj
dim c1
dim rec
dim txt
dim pos1
WITH NETCAD
Rad=OLCEK /1000
SET TXT= .MakeText(c, txt1, 0,0, size*OLCEK/1000,0,"L",.CREATELAYER("SILSAGULXXX",0))
set Region=txt.limits
dim dy: dy=region.cur.y-region.cll.y
dim dx: dx=region.cur.x-region.cll.x
'.addobject .MakeCircle(c, rad, 0, 0, 0)
for j=0 to 1
for i=0 to 400 step Partition
set c1=KOORDINAT_HESAPLA(c,i,rad) :c1.z=0
if i =>0 and i<=100 then
set rec=.MakeRect(c1, .newc(c1.y+dy,c1.x+dx,0), i, .CREATELAYER("SILSAGULXXX",0))
elseif i=>101 and i<=200 then
set c1=.newc(c1.y,c1.x-dx,0)
set rec=.MakeRect(c1, .newc(c1.y+dy,c1.x+dx,0), i, .CREATELAYER("SILSAGULXXX",0))
elseif i=>201 and i<=300 then
set c1=.newc(c1.y-dy,c1.x-dx,0)
set rec=.MakeRect(c1, .newc(c1.y+dy,c1.x+dx,0), i, .CREATELAYER("SILSAGULXXX",0))
elseif i=>301 and i<=400 then
set c1=.newc(c1.y-dy,c1.x,0)
set rec=.MakeRect(c1, .newc(c1.y+dy,c1.x+dx,0), i, .CREATELAYER("SILSAGULXXX",0))
end if
if ObjeVarmi(rec,olcek) = 0 then
set GetNoktaNoPozisyon=c1
rec.tabaka=.CREATELAYER("SILSAGULXXX",5)
.ADDOBJECT rec
exit function
'else
' .ADDOBJECT rec
end if
next
rad=rad+rad * 0.5
next
Rad=OLCEK /1000
SET TXT= .MakeText(c, txt1, 0,0, size*OLCEK/1000,1.5708,"2",.CREATELAYER("SILSAGULXXX",0))
set Region=txt.limits
dy=region.cur.y-region.cll.y
dx=region.cur.x-region.cll.x
i=0 : j=0 :
for j=0 to 1
for i=0 to 400 step Partition
set c1=KOORDINAT_HESAPLA(c,i,rad) : c1.z=1.57079
if i =>0 and i<=100 then
set rec=.MakeRect(c1, .newc(c1.y+dy,c1.x+dx,0), i, .CREATELAYER("SILSAGULXXX",0))
elseif i=>101 and i<=200 then
set c1=.newc(c1.y,c1.x-dx,1.57079)
set rec=.MakeRect(c1, .newc(c1.y+dy,c1.x+dx,0), i, .CREATELAYER("SILSAGULXXX",0))
elseif i=>201 and i<=300 then
set c1=.newc(c1.y-dy,c1.x-dx,1.57079)
set rec=.MakeRect(c1, .newc(c1.y+dy,c1.x+dx,0), i, .CREATELAYER("SILSAGULXXX",0))
elseif i=>301 and i<=400 then
set c1=.newc(c1.y-dy,c1.x,1.57079)
set rec=.MakeRect(c1, .newc(c1.y+dy,c1.x+dx,0), i, .CREATELAYER("SILSAGULXXX",0))
end if
.ADDObject rec
if ObjeVarmi(rec,olcek) = 0 then
set GetNoktaNoPozisyon=c1
exit function
end if
next
rad=rad+rad * 0.5
next
c.z=0
set GetNoktaNoPozisyon=c
set GetNoktaNoPozisyon=KOORDINAT_HESAPLA(c,100,rad)
end with
End function
Function KOORDINAT_HESAPLA(pt1,semt,kenar)
dim RO
dim pt2
with netcad
RO=50/ATN(1)
set pt2=.newc(0,0,0)
pt2.y = pt1.y + kenar * sin(semt/RO)
pt2.x = pt1.x + kenar * cos(semt/RO)
set KOORDINAT_HESAPLA=pt2
set pt2=nothing
end with
End function
Function ObjeVarmi(rec,sc)
dim obj
dim test
dim w ,w1
dim i
dim pl
dim Line
dim inter
dim inta
dim rec1
dim rec2
with netcad
test=0
set w=rec.limits
' sc=sc/1000
.setfilter w ,array(),array(opline,otext,oline,opline,oshape) 'Kapalı Alanları Almayalım işlemi hızlandırmak için
do
set obj=.getnextobject
if obj is nothing then
exit do
else
if obj.tag=opline then
' Kapalı Alanın Kenarını kesip kesmediğine bak
set pl=obj.Getobjectaspline
'Çok kırıklı Büyük Parsellerde zaman alıyor .Nasıl Düzeltebiliriz
for i=1 to pl.num-1
set inta=.newpoly
set line=.MakeLine(pl.cor(i), pl.cor(i-1), 0, 0, .CREATELAYER("SILSAGULXXX",0))
inter=.IntersectObjects(rec,obj,inta)
if inter>0 then
test=1
exit do
end if
next
else
if obj.tag=otext then
set inta=.newpoly
set rec1=.MakeRect(obj.limits.cll, obj.limits.cur,"", .CREATELAYER("SILSAGULXXX",0))
inter=.IntersectObjects(rec,rec1,inta)
if inter>0 then
test=1
exit do
end if
elseif obj.tag=oline then
set inta=.newpoly
inter=.IntersectObjects(rec,obj,inta)
if inter>0 then
test=1
exit do
end if
else
test=1
exit do
end if
end if
end if
loop
.resetfilter
end With
ObjeVarmi=test
' keke
End Function
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
sub keke
with netcad
dim alanOBJ ,j ,dy,dx ,aci
set alanOBJ = .newobject()
.setFilter nothing,array(.foundlayer("_SGL_BLOK")),array(opline)
while .GetNextObject2(alanOBJ)
.DrawObject alanOBJ, blue
dim coklu2
Set coklu2 = alanOBJ.getObjectAsPline()
dim k1,k2,k3,k4,nok
For j = 1 to coklu2.num - 1
k1= coklu2.cor(j-1).y
k2= coklu2.cor(j-1).x
k3= coklu2.cor(j).y
k4= coklu2.cor(j).x
set nok = .NewC(0,0,0)
nok.y= k3
nok.x= k4
dim m1,m2
m1= k2/k1
m2= k4/k3
Dim Tampon
Tampon=3
dim a,b
dim pt,enYakinNokta,nokta,Limit,objCizgi,ruhan
set enYakinNokta = .NewC(0,0,0)
set nokta = .NewC(0,0,0)
set Limit = .NewWorld(nok.y-(Tampon+1), nok.x-(Tampon+1), nok.y+(Tampon+1), nok.x+(Tampon+1))
set objCizgi = .NewObject()
.SetFilter Limit, array(.foundlayer("SAGUL_NOKTA")), array(otext)
Do
set ruhan= .GetNextObject
if ruhan is nothing then exit do
a = ruhan.p1.y
b= ruhan.p1.x
dim cor
set cor = .newc(0,0,0)
' dy= k3- k1
' dx= k4-k2
dy= k1- a
dx= k2-b
if dx=0 then dx=0.005
aci=atn(dy/dx)
if coklu2.InPoly(cor) then
tt=1
cor.y = ruhan.p1.y +2*sin(aci)*olcek
cor.x = ruhan.p1.x + 2*cos(aci)*olcek
end if
' dim tx
' set tx=.MakeText(cor,ruhan.pname ,0,0,1.5,sangle,"M",3)
' tx.cls= aci
' if tt=1 then tx.renk=4
' ruhan.cls= cor.y & "_" & cor.x & "_" & sangle
' ruhan.objname= 123456789012345678901234567890123456789012345678901234567890
.PutObject .CurObjPos, ruhan
' .addobject(tx)
Loop
.Resetfilter
' round(aci*200/pi,0)
Next
wend
.Resetfilter
set alanOBJ = nothing
.BackMessage
end with
end subnetcad-nokta-ad-yazdir-duz
