проверка пересечения 0!\ ф proverkaюЩ option explicit
dim mwin, lar1,lar2
dim selcntrs(2000),selcntrcount
selcntrcount=0
lar1=""
lar2=""
' Обработка команды Action1
sub proverka_Action1()
ShowMainWindow
end sub
function MakeHTML
dim html
html="
"+_
"слой 1
"+_
"слой 2
"+_
"непроверяемый объект
"+_
"
"+_
"
"+_
""
MakeHTMl=html
end function
sub ClearCheck
selcntrcount=0
Mainwindow.mapwindow.invalidate
end sub
sub SelectNObj
if selection.count=1 then
mwin.browser.document.getelementbyid("idn").value=selection.ids(0)
end if
end sub
sub CheckObject
selcntrcount=0
dim mobj,cntr,i,x1,x2,y1,y2,mobjs,mq,oid,mcntr,nid
dim lars()
set mobjs=Activedb.mapobjects
if selection.count=0 then
MsgBox "Не выбран объект!"
exit sub
end if
if selection.count>1 then
MsgBox "Только один объект должен быть выделен!"
exit sub
end if
nid=mwin.browser.document.getelementbyid("idn").value
set mcntr=nothing
set mobj=mobjs.getobject(selection.ids(0))
for i=0 to mobj.shapes.count-1
if mobj.shapes(i).definegeometry then
set mcntr=mobj.shapes(i).contour
exit for
end if
next
redim lars(2)
lars(1)=lar1
lars(2)=lar2
lars(0)=mobj.LayerID
if lars(2)="" then
if lars(1)="" then redim preserve lars(0) else redim preserve lars(1)
end if
set mq= mobjs.querybyrect(lars,mobj.x1,mobj.y1,mobj.x2,mobj.y2,false)
while not mq.eof
oid=mq.objectid
if (oid<>nid) and (oid<>mobj.id) then CheckOneObject mcntr,oid
mq.MoveNext
wend
MsgBox selcntrcount
MainWindow.Mapwindow.Invalidate
end sub
sub CheckOneObject(mcntr,oid)
dim dcntr,obj,i,scntr
set dcntr=Application.CreateObject(0,0)
dcntr.AddPartsfrom mcntr
set obj=Activedb.MapObjects.GetObject(oid)
for i=0 to obj.shapes.count-1
if obj.shapes(i).definegeometry then
set scntr=obj.Shapes(i).Contour
exit for
end if
next
dcntr.Combine 2,scntr
if dcntr.square>0 then
set selcntrs(selcntrcount)=dcntr
selcntrcount=selcntrcount+1
end if
end sub
sub SelectLar(i)
dim sl
sl=winmanager.SelectLayer("")
if i=1 then
lar1=sl
mwin.browser.document.getelementbyid("idlar1").value=sl
end if
if i=2 then
lar2=sl
mwin.browser.document.getelementbyid("idlar2").value=sl
end if
end sub
sub ShowMainWindow
set mwin=winmanager.MakeWindow(makehtml)
mwin.browser.document.getelementbyid("idlar1").value=lar1
mwin.browser.document.getelementbyid("idlar2").value=lar2
mwin.visible=true
end sub
' Вызывается сразу после запуска программного модуля
sub Module_StartComplete()
Module.LoadActions Script.ContextCard, "proverka", Application.MainWindow.Actions
Module.LoadMenu Script.ContextCard, "proverka", Application.MainWindow.Menu.Items("MenusTools").Items
end sub
' Вызывается при перерисовке окна карты
sub MapEditors_Paint(aSurface)
dim i
aSurface.Pen.Style=0
aSurface.Pen.Color=vbRed
aSurface.Pen.Widthinmm=2
aSurface.Pen.ForZoomscale=0
aSurface.Pen.Mode=4
aSurface.Brush.Style=1
for i=0 to selcntrcount-1
aSurface.PaintContour selcntrs(i),true
next
end sub
VBScript ` proverkaproverka start_proverka Проверка на пересечения G` proverkaproverka_Action1V proverkaproverka start_proverkastart_proverkaПроверка на пересечения ^L
winmanagerюAL option explicit
dim mwin,tstyle,ttable,tfield,vstyle,tinterval,swin,selwin,gelid,active,cntrt,cntrt2,cntrv
dim lastsd1,lastsd2,cpx,cpy,npx,npy,val1,val2,val3
tinterval=1
active=false
' Обработка команды Action1
function SelectStyle(elid)
' dim selwin
gelid=elid
set selwin=winmanager.MakeWindow(GenSelStyleHTML(elid))
selwin.ShowModal
SelectStyle=gelid
end function
function SelectLayer(elid)
' dim selwin
gelid=elid
set selwin=winmanager.MakeWindow(GenSelLayerHTML(elid))
selwin.ShowModal
SelectLayer=gelid
end function
function MakeWindow(html)
dim win
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
doc.open()
' dim html
' html=GenMakeHTML()
brs.document.write(html)
brs.document.close()
set MakeWindow=win
end function
function GenSelStyleHTML(elid)
GenSelStyleHTML=_
""+_
""+_
"
"+_
" "+_
" hover"+_
" "+_
" "+_
" "+_
"
"+_
MakeMenu+_
"
"+_
" "+_
" "+_
""
' ""+_
' "Стиль текста "+_
' "
"+_
' "Стиль линии выноски "+_
' "
"+_
' "Таблица
"+_
' "Поле для текста
"+_
' "Интервал
"+_
' ""+_
' ""
end function
function GenSelLayerHTML(elid)
GenSelLayerHTML=_
""+_
""+_
"
"+_
" "+_
" hover"+_
" "+_
" "+_
" "+_
"
"+_
MakeMenu2+_
"
"+_
" "+_
" "+_
""
' ""+_
' "Стиль текста "+_
' "
"+_
' "Стиль линии выноски "+_
' "
"+_
' "Таблица
"+_
' "Поле для текста
"+_
' "Интервал
"+_
' ""+_
' ""
end function
function MakeMenu
dim map,lar,stl,i,li,si,menu
menu=""
for i=0 to ActiveProjectView.MapViews.Count-1
set map=ActiveProjectView.MapViews(i).Map
if map.MapType=2 then
menu=menu+"
"+map.Name+"
"
for li=0 to map.Layers.Count-1
set lar=map.Layers(li)
menu=menu+"
"+lar.Name+"
"
for si=0 to lar.Styles.Count-1
set stl=lar.Styles(si)
menu=menu+"
"+stl.Name+"
"
next
menu=menu+"
"
next
menu=menu+"
"
end if
next
MakeMenu=menu
' MsgBox menu
end function
function MakeMenu2
dim map,lar,stl,i,li,si,menu
menu=""
for i=0 to ActiveProjectView.MapViews.Count-1
set map=ActiveProjectView.MapViews(i).Map
if map.MapType=2 then
menu=menu+"
"+map.Name+"
"
for li=0 to map.Layers.Count-1
set lar=map.Layers(li)
menu=menu+"
"+lar.Name+""
menu=menu+"
"
next
menu=menu+"
"
end if
next
MakeMenu2=menu
' MsgBox menu
end function
sub StyleSelected(el)
gelid=el.id
selwin.Close
' ReloadTables
' MsgBox el.id
end sub
sub LayerSelected(el)
gelid=el.id
selwin.Close
' ReloadTables
' MsgBox el.id
end sub
sub ReloadTables
dim lar,stl,stlid,ti,fi,table,el
stlid=swin.browser.document.GetElementById("idtstyle").value
set el=swin.browser.document.GetElementById("idtable")
winmanager.ClearOptions el
if ActiveDB.StyleExists(stlid) then
set stl=ActiveDB.StyleFromID(stlid)
set lar=stl.Layer
for ti=0 to lar.SemTables.Count-1
set table=lar.SemtAbles(ti)
for fi=0 to table.FieldInfos.Count-1
winmanager.AddOption el,table.Name+"."+table.FieldInfos(fi).FieldName,table.Name+"|"+table.FieldInfos(fi).FieldName
next
next
end if
end sub
' Перерисовка инверсных элементов
sub DrawElements(surf)
' MsgBox CStr(cpx)+" "+CStr(cpy)
surf.Pen.Style=0
Surf.Pen.Color=vbRed
Surf.Pen.Widthinmm=1
Surf.Pen.ForZoomScale=1/1000
surf.Pen.Mode=14
surf.PaintContour cntrt,true
surf.PaintContour cntrt2,true
surf.PaintContour cntrv,true
dim ccr,cntp
set ccr=Application.CreateObject(0,0)
set cntp=ccr.Insert(-1)
cntp.InsertVertex -1,npx-1,npy-1,0
cntp.InsertVertex -1,npx+1,npy-1,0
cntp.InsertVertex -1,npx+1,npy+1,0
cntp.InsertVertex -1,npx-1,npy+1,0
cntp.closed=true
Surf.Pen.Color=vbBlue
Surf.Pen.Widthinmm=1
surf.PaintContour ccr,True
end sub
sub CheckActive
if IsObject(mwin) then
active= mwin.visible
else
active=false
end if
end sub
sub Calculate(wx,wy)
dim mode1,mode2
mode1=mwin.browser.document.GetElementByID("idwrktype").value
mode2=mwin.browser.document.GetElementByID("idwrk").value
if mode1="1" then
if mode2="1" then
CalcXYToLine wx,wy
else
CalcXYToFree wx,wy
end if
else
if mode2="1" then
CalcAngleToLine wx,wy
else
CalcAngleToFree wx,wy
end if
end if
end sub
function CalcAngle(x1,y1,x2,y2)
dim dx,dy,aa,a,g,m,s,f
dx=x2-x1
dy=y2-y1
if abs(dy)<1e-10 then
a=3.1415926/2
else
' MsgBox CStr(dx)+" "+CStr(dy)
a=Atn(dx/dy)
end if
if dy>0 then
aa=3.1415926/2-a
else
aa=3.1415926*3/2-a
end if
' a=-a-3.1415926/2-3.1415926
' MsgBox Cstr(aa*180/3.1415926)
' if a<0 then a=a+3.1415926*2
' MsgBox a
' dim aa
aa=aa*180/3.1415926
g=Int(aa)
f=Round((aa-g)*3600)
m=int(f/60)
s=int(f) mod 60
CalcAngle=FormatNumber(g,0)+" "+FormatNumber(m,0)+"'"+FormatNumber(s,0)+""""
end function
sub CalcAngleToLine(wx,wy)
dim x1,y1,x2,y2,px,py,vx,vy,cx,cy,tf
tf=Replace(ttable,"|",".")
GetNearPointAndLine wx,wy,px,py,x1,y1,x2,y2,cx,cy
if px<>wx then
' MsgBox CStr(cx)+" "+CStr(cy)
end if
' MsgBox CStr(x1)+" "+Cstr(y1)+" "+CStr(x2)+" "+Cstr(y2)
' GetNearLine wx,wy,x1,y1,x2,y2
' CalcNearestPoint wx,wy,x1,y1,x2,y2,cx,cy
' MsgBox "no finish"
vx=x2-x1
vy=y2-y1
if vy<0 then
vx=-vx
vy=-vy
end if
cntrt.Clear
cntrt2.clear
dim ovx,ovy,l,intr
intr=Cdbl(tinterval)
l=SQR(vx^2+vy^2)
if l<1e-10 then exit sub
ovx=vx/l
ovy=vy/l
' MsgBox CStr(intr)
dim tx,ty
tx=cx+(-ovy)*intr
ty=cy+ovx*intr
dim cntp
set cntp=cntrt.Insert(-1)
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
' MsgBox CStr(tx)+" " +CSTr(ty)
tx=cx-(-ovy)*intr/10
ty=cy-ovx*intr/10
' dim cntp
set cntp=cntrt2.Insert(-1)
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
lastsd1=tf+"="+FormatNumber(px,2)
lastsd2=tf+"="+FormatNumber(py,2)
cntrv.Clear
cpx=cx
cpy=cy
npx=px
npy=py
val1=CalcAngle(x1,y1,x2,y2)
val2=FormatNumber(l,2)
' val1=
' MsgBox "finish"
end sub
sub CalcXYToLine(wx,wy)
dim x1,y1,x2,y2,px,py,vx,vy,cx,cy,tf
tf=Replace(ttable,"|",".")
GetNearPointAndLine wx,wy,px,py,x1,y1,x2,y2,cx,cy
if px<>wx then
' MsgBox CStr(cx)+" "+CStr(cy)
end if
' MsgBox CStr(x1)+" "+Cstr(y1)+" "+CStr(x2)+" "+Cstr(y2)
' GetNearLine wx,wy,x1,y1,x2,y2
' CalcNearestPoint wx,wy,x1,y1,x2,y2,cx,cy
' MsgBox "no finish"
vx=x2-x1
vy=y2-y1
if vy<0 then
vx=-vx
vy=-vy
end if
cntrt.Clear
cntrt2.clear
dim ovx,ovy,l,intr
intr=Cdbl(tinterval)
l=SQR(vx^2+vy^2)
if l<1e-10 then exit sub
ovx=vx/l
ovy=vy/l
' MsgBox CStr(intr)
dim tx,ty
tx=cx+(-ovy)*intr
ty=cy+ovx*intr
dim cntp
set cntp=cntrt.Insert(-1)
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
' MsgBox CStr(tx)+" " +CSTr(ty)
tx=cx-(-ovy)*intr/10
ty=cy-ovx*intr/10
' dim cntp
set cntp=cntrt2.Insert(-1)
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
lastsd1=tf+"="+FormatNumber(px,2)
lastsd2=tf+"="+FormatNumber(py,2)
cntrv.Clear
cpx=cx
cpy=cy
npx=px
npy=py
val1=FormatNumber(py,2)
val2=FormatNumber(px,2)
' val1=
' MsgBox "finish"
end sub
sub CalcXYToFree(wx,wy)
dim x1,y1,x2,y2,px,py,vx,vy,cx,cy,tf
tf=Replace(ttable,"|",".")
GetNearPointAndLine wx,wy,px,py,x1,y1,x2,y2,cx,cy
if px<>wx then
' MsgBox CStr(cx)+" "+CStr(cy)
end if
' MsgBox CStr(x1)+" "+Cstr(y1)+" "+CStr(x2)+" "+Cstr(y2)
' GetNearLine wx,wy,x1,y1,x2,y2
' CalcNearestPoint wx,wy,x1,y1,x2,y2,cx,cy
' MsgBox "no finish"
' vx=x2-x1
' vy=y2-y1
' if vy<0 then
' vx=-vx
' vy=-vy
' end if
vx=0
vy=1
cx=wx
cy=wy
cntrt.Clear
cntrt2.clear
dim ovx,ovy,l,intr
intr=Cdbl(tinterval)
l=SQR(vx^2+vy^2)
if l<1e-10 then exit sub
ovx=vx/l
ovy=vy/l
' MsgBox CStr(intr)
dim tx,ty
tx=cx+(-ovy)*intr
ty=cy+ovx*intr
dim cntp
set cntp=cntrt.Insert(-1)
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
' MsgBox CStr(tx)+" " +CSTr(ty)
tx=cx-(-ovy)*intr/10
ty=cy-ovx*intr/10
' dim cntp
set cntp=cntrt2.Insert(-1)
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
lastsd1=tf+"="+FormatNumber(px,2)
lastsd2=tf+"="+FormatNumber(py,2)
cntrv.Clear
set cntp=cntrv.Insert(-1)
cntp.InsertVertex -1,px,py,0
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
cpx=cx
cpy=cy
npx=px
npy=py
val1=FormatNumber(py,2)
val2=FormatNumber(px,2)
' val1=
' MsgBox "finish"
end sub
sub CalcAngleToFree(wx,wy)
dim x1,y1,x2,y2,px,py,vx,vy,cx,cy,tf,xxx,yyy
tf=Replace(ttable,"|",".")
GetNearPointAndLine wx,wy,px,py,x1,y1,x2,y2,cx,cy
if px<>wx then
' MsgBox CStr(cx)+" "+CStr(cy)
end if
' MsgBox CStr(x1)+" "+Cstr(y1)+" "+CStr(x2)+" "+Cstr(y2)
' GetNearLine wx,wy,x1,y1,x2,y2
' CalcNearestPoint wx,wy,x1,y1,x2,y2,cx,cy
' MsgBox "no finish"
' vx=x2-x1
' vy=y2-y1
' if vy<0 then
' vx=-vx
' vy=-vy
' end if
vx=0
vy=1
xxx=cx
yyy=cy
cx=wx
cy=wy
cntrt.Clear
cntrt2.clear
dim ovx,ovy,l,intr
intr=Cdbl(tinterval)
l=SQR(vx^2+vy^2)
' if l<1e-10 then exit sub
ovx=vx/l
ovy=vy/l
' MsgBox CStr(intr)
dim tx,ty
tx=cx+(-ovy)*intr
ty=cy+ovx*intr
dim cntp
set cntp=cntrt.Insert(-1)
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
' MsgBox CStr(tx)+" " +CSTr(ty)
tx=cx-(-ovy)*intr/10
ty=cy-ovx*intr/10
' dim cntp
set cntp=cntrt2.Insert(-1)
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
lastsd1=tf+"="+FormatNumber(px,2)
lastsd2=tf+"="+FormatNumber(py,2)
cntrv.Clear
set cntp=cntrv.Insert(-1)
cntp.InsertVertex -1,xxx,yyy,0
cntp.InsertVertex -1,tx,ty,0
cntp.InsertVertex -1,tx+ovx*10,ty+ovy*10,0
cpx=cx
cpy=cy
npx=px
npy=py
' val1=FormatNumber(py,2)
' val2=FormatNumber(px,2)
dim ll
ll=SQR((x2-x1)^2+(y2-y1)^2)
val1=CalcAngle(x1,y1,x2,y2)
val2=FormatNumber(ll,2)
' val1=
' MsgBox "finish"
end sub
sub GetNearPointAndLine(wx,wy,px,py,x1,y1,x2,y2,ccx,ccy)
dim larid ,lar,mq,rx1,ry1,rx2,ry2,cx,cy,rs,objid,obj,mins,xx1,yy1,xx2,yy2,minl
set lar=ActiveProjectView.ActiveLayerView.Layer
rs=MainWindow.MapWindow.Surface.SizeDeviceToWorld(300)
' cx= MAinWindow.MapWindow.Surface.Navigator.CenterX
' cy= MAinWindow.MapWindow.Surface.Navigator.CenterY
cx=wx
cy=wy
rx1=cx-rs
ry1=cy-rs
rx2=cx+rs
ry2=cy+rs
mins=1e10
minl=1e10
set mq=ActiveDB.MapObjects.QueryByRect(lar.id,rx1,ry1,rx2,ry2,false)
while not mq.eof
objid=mq.objectid
set obj=ActiveDB.MapObjects.GetObject(objid)
dim si,ci,vi,shp
for si=0 to obj.Shapes.Count-1
set shp=obj.Shapes(si)
if shp.DefineGeometry then
for ci=0 to shp.Contour.Count-1
dim cntp,xx,yy,cc
set cntp=shp.Contour(ci)
for vi=0 to cntp.VertexCount-1
cntp.sGetVertex vi,xx,yy,cc
dim s
s=SQR((xx-wx)^2+(yy-wy)^2)
' MsgBox CStr(s)
if (s1e-6) and IsPointNearLine(wx,wy,xx1,yy1,xx2,yy2,l,cx,cy) then
if l1e9 then
px=wx
py=wy
end if
end sub
function IsPointNearLine(wx,wy,x1,y1,x2,y2,l,ccx,ccy)
dim a1,b1,c1,a2,b2,c2,vx,vy,cx,cy
vx=x2-x1
vy=y2-y1
a1=-vy
b1=vx
'ax+by+c=0 c=-ax-by
c1=-a1*x1-b1*y1
a2=vx
b2=vy
c2=-a2*wx-b2*wy
'a1x+b1y+c1=0
'a2x+b1y+c2=0
if (abs(a1*b2-a2*b1)<1e-6) then
IsPointNearLine=false
exit function
end if
cx=(b1*c2-b2*c1)/(a1*b2-a2*b1)
cy=(c1*a2-c2*a1)/(a1*b2-a2*b1)
ccx=cx
ccy=cy
l=SQR((cx-wx)^2+(cy-wy)^2)
if InRect(cx,cy,x1,y1,x2,y2) then
IsPointNearLine=true
else
IsPointNearLine=false
end if
end function
function InRect(x,y,x1,y1,x2,y2)
dim rx1,ry1,rx2,ry2
if x1>x2 then
rx1=x2
rx2=x1
else
rx1=x1
rx2=x2
end if
if y1>y2 then
ry1=y2
ry2=y1
else
ry1=y1
ry2=y2
end if
if (x>=rx1) and (x<=rx2) and (y>=ry1) and (y<=ry2) then
InRect=true
else
InRect=false
end if
end function
sub GetNearLine(wx,wy,x1,y1,x2,y2)
end sub
' Вызывается при нажатии клавиши мыши над окном карты
sub Drawdata(txt)
' MainWindow.SetStatusText(txt)
end subVBScript 0