Kot Sıfırlama Makrosu (Elevation Reset Macro)

' Şaban GÜL, sabangul67@gmail.com, sabangul.com
' Yazan : 
' Tarih : 21.10.2010
' Açıklama : Bu makro Netcad complex kapalı çoklu doğrularının, açık çoklu doğruların ve doğruların
'            z koordinat değerlerini 0 kotuna getirir.
'            Hasan Mutlu -- hasan.mutlu@netcad.com.tr

Dim isCorrectClosedPoly,isCorrectLine,isCorrectOpenPoly
Sub Main
Dim i,obj,j,pline,c,x,y,closedPolySay,dogruSay,openPolySay
Dim complexPoly,outColl,inColl,outNum,inNum,complexPoly2
Dim objCount,objNum,newObj,sonucMesaj,dogruMesaj,closedPolyMesaj,openPolyMesaj
'düzeltilen obje sayilaridir.
closedPolySay=0
dogruSay=0
'kullanici secimleridir
isCorrectClosedPoly=1
isCorrectOpenPoly=1
isCorrectLine=1
'kullanicidan hangi objelerin düzeltilecegi bilgileri alinir.
if GetDialogResult=false then
exit sub
end if
'kullanici hiçbir obje türünü duzeltmeyi seçmemiş ise işlem iptal edilir.
if isCorrectClosedPoly=0 and isCorrectLine=0 and isCorrectOpenPoly=0 then
exit sub
end if
with Netcad
set obj=.Newobject
set c=.Newc(0,0,0)
set complexPoly=.NewComplexPoly
objCount=.NumObject
for objNum=0 to objCount-1
set obj=.GetObject(objNum)
'kapalı çoklu doğrular üzerinde işlem yapılır
if obj.tag=opline then
if (obj.flags and 1)>0 and isCorrectClosedPoly=1 then
'yeni complexpoly yaratilir
set complexPoly2=.NewComplexPoly
set complexPoly=obj.GetObjectAsComplexPline()
'dış polyline ların z değerleri sıfırlanır
set outColl=complexPoly.outs
if outColl.Num>0 then
for outNum=0 to outColl.Num-1
set pline=outColl.get(outNum)
SetPlineZero pline
complexPoly2.outs.add pline
pline.destroyPoly()
set pline=nothing
next
end if
'iç polyline ların z değerleri sıfırlanır
set inColl=complexPoly.ins
if inColl.Num>0 then
for inNum=0 to inColl.Num-1
set pline=inColl.get(inNum)
for i=0 to pline.Num-1
pline.Cor(i).z=0.0
next
complexPoly2.ins.add pline
pline.destroyPoly()
set pline=nothing
next
end if
'yeni complex polyline Netcad e eklenir
set newObj=obj.GetCopy
.AddComplexPoly newObj,complexPoly2
'değişen obje sayısı için bir arttırılır
closedPolySay=closedPolySay+1
'kullanılan objeler bellekten silinir.
set complexPoly=nothing
set inColl=nothing
set outColl=nothing
set complexPoly2=nothing
set newObj=nothing
'eski obje mutlaka silinmelidir.
.delObject objNum,obj
elseif (obj.flags and 1)<1 and isCorrectOpenPoly=1 then 'açık çoklu doğruların z degerlerini sifirlar
if MakeZZeroOpenPoly(obj,objNum)=true then
openPolySay=openPolySay+1
end if
end if
elseif obj.Tag=oline and isCorrectLine=1 then
'dogrularin kotlari sifirlanir.
obj.p1.z=0
obj.p2.z=0
.PutObject objNum,obj
dogruSay=dogruSay+1
end if
set obj=nothing
next
end with
'sonuc mesajlari duzeltilir.
dogruMesaj=dogruSay & " tane doğrunun z koordinatı sıfırlanmıştır."
closedPolyMesaj=closedPolySay & " tane kapalı çoklu doğrunun z koordinatı sıfırlanmıştır."
openPolyMesaj=openPolySay & " tane açık çoklu doğrunun z koordinatı sıfırlanmıştır."
if isCorrectClosedPoly=1 then
if sonucMesaj<>"" then
sonucMesaj=sonucMesaj & closedPolyMesaj & VbCrLf
else
sonucMesaj=closedPolyMesaj & VbCrLf
end if
end if
if isCorrectOpenPoly=1 then
if sonucMesaj<>"" then
sonucMesaj=sonucMesaj & openPolyMesaj & VbCrLf
else
sonucMesaj=openPolyMesaj & VbCrLf
end if
end if
if isCorrectLine=1 then
if sonucMesaj<>"" then
sonucMesaj=sonucMesaj & dogruMesaj & VbCrLf
else
sonucMesaj=dogruMesaj & VbCrLf
end if
end if
'mesaj gosterilir.
Msgbox sonucMesaj,0,"Netcad"
End Sub
sub SetPlineZero(pline)
dim i
if not pline is nothing then
for i=0 to pline.Num-1
pline.Cor(i).z=0.0
next
end if
end sub
function GetDialogResult
Dim dlg
with Netcad
set dlg=.newbdialog("Kot Sıfırlama Makrosu")
dlg.GetCheck "cdogruChk","Kapalı çoklu doğruların kotlarını sıfırla",isCorrectClosedPoly
dlg.GetCheck "acikCDogru","Açık çoklu doğruların kotlarını sıfırla",isCorrectOpenPoly
dlg.GetCheck "dogruChk","Doğruların kotlarını sıfırla",isCorrectLine
if dlg.showmodal then
isCorrectClosedPoly=dlg.valueByName("cdogruChk")
isCorrectOpenPoly=dlg.valueByName("acikCDogru")
isCorrectLine=dlg.valueByName("dogruChk")
else
GetDialogResult=false
exit function
end if
end with
GetDialogResult=true
end function
function MakeZZeroOpenPoly(polyObj,objNum)
Dim pline,plineNew,x,y,res,i,c
set pline=polyObj.getObjectAsPline()
with Netcad
if not pline is Nothing then
set plineNew=.NewPoly
for i=0 to pline.Num-1
x=pline.Cor(i).x
y=pline.Cor(i).y
set c=.Newc(y,x,0)
c.flag=pline.Cor(i).flag
plineNew.AddCoor(c)
next
.PutPlineExt polyObj,plineNew
.PutObject objNum,polyObj
res=true
end if
end with
MakeZZeroOpenPoly=res
end function