подтягивание 0= 3 подтягивание @ pdtpdt pdt_start pdt_startПодтягивание объектов Џ pdtюy option explicit dim win dim tochange(),tosnap() dim snappoints(10000,1) dim snapcount ' Обработка команды Action1 sub pdt_StartP() ShowPDTWindow end sub ' Вызывается сразу после запуска программного модуля sub Module_StartComplete() Module.LoadActions Script.ContextCard, "pdt", Application.MainWindow.Actions Module.LoadMenu Script.ContextCard, "pdt", Application.MainWindow.Menu.Items("MenusTools").Items end sub sub ShowPDTWindow set win=Application.OpenHTMLWindow(Script.ContextCard) win.Browser.Navigate("about:blank") dim brs,doc set brs=win.Browser set doc=brs.document set win.external=Disp 'задает ширину окна в пикселях win.Width=400 'задает заголовок окна win.Caption="Подтягивание" doc.open() dim html html=GenStartHTML() brs.document.write(html) brs.document.close() win.Visible=true end sub function GenStartHTML() dim html html="
" html=html+""+_ "
"+_ "Максимальное отклонение
"+_ "
"+_
""
GenStartHTML=html
end function
sub b1click
dim i,objid
redim tochange(Selection.Count-1)
for i=0 to Selection.Count-1
tochange(i)=Selection.ids(i)
next
end sub
sub b2click
dim i,objid
redim tosnap(Selection.Count-1)
for i=0 to Selection.Count-1
tosnap(i)=Selection.ids(i)
next
end sub
sub b3click
MakeOperation
end sub
sub MakeOperation
dim e,cc
cc=0
e=Cdbl( win.Browser.Document.GetelementByid("id1").value)
MakeSnapPoints
' MsgBox Cstr(snappoints(0,0))+":"+Cstr(snappoints(0,1))
dim mobjs
set mobjs=ActiveDB.MapObjects
dim i,mobj,shp,cntp,si,ci,vi,x,y,cv,c,nx,ny,r
for i=0 to ubound(tochange)
set mobj=mobjs.GetObject(tochange(i))
for si=0 to mobj.Shapes.Count-1
set shp=mobj.Shapes(si)
if shp.DefineGeometry then
for ci=0 to shp.Contour.Count-1
set cntp=shp.Contour(ci)
for vi=0 to cntp.VertexCount-1
cntp.sGetVertex vi,x,y,cv
FindSnap2 x,y,e,r,nx,ny
if r>0 then
' MsgBox CStr(r)
cc=cc+1
cntp.SetVertex vi,nx,ny,cv
end if
next
next
end if
next
next
mobjs.UpdateChanges
MsgBox "Выполнено "+Cstr(cc)+" точек притянуто"
end sub
sub FindSnap2(x,y,e,res,x2,y2)
dim i,sx,sy,r
' MsgBox "fs "+CStr(e)
res=-1
for i=0 to snapcount-1
sx=snappoints(i,0)
sy=snappoints(i,1)
' MsgBox Cstr(x)+":"+CStr(sx)+"==="+Cstr(y)+":"+CStr(sy)
dim sq
sq=SQR((x-sx)^2+(y-sy)^2)
'if (abs(x-sx)