ведомость 0Х- - vdomostюу, 'сведения о формате вызова методов Ингео можно посмотреть в файле IngeoIntfs.chm который обычно находится в папке с файлами Ингео option explicit dim win 'окно HTML const cw1=20 'ширина первого столбца const cw2=20 'ширина второго столбца const cw3=20 'ширина третьего столбца const cw4=20 'ширина четвертого столбца 'размер шрифта , имя шрифта и признак жирности для заголовка const headerfontsize=14 const headerfontname="Times New Roman" const headerfontbold=true 'размер шрифта , имя шрифта и признак жирности для заголовка столбца const columnheaderfontsize=12 const columnheaderfontname="Times New Roman" const columnheaderfontbold=true 'размер шрифта , имя шрифта и признак жирности для данных const coordfontsize=12 const coordfontname="Times New Roman" const coordfontbold=false 'размер шрифта , имя шрифта и признак жирности для площади const sqfontsize=12 const sqfontname="Times New Roman" const sqfontbold=true 'текст верхнего центрального колонтитула const upcentertext="Чертеж межевания территории.dwg" 'текст нижнего левого колонтитула const downlefttext="Исполнитель" 'переменные для хранения поля номера, названия, папки для записи, исполнителя dim field1,field2,folder1,field3 'список объектов для обработки dim objlist() ' Обработка команды Action1 sub vdomost_MakeVedom() ShowVedomostWindow ' MakeVedomost end sub 'показывает окно ведомости sub ShowVedomostWindow 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=800 'задает заголовок окна win.Caption="Ведомость координат" doc.open() dim html html=GenStartHTML() brs.document.write(html) brs.document.close() win.Visible=true end sub 'формирует HTML страницу для окна function GenStartHTML() dim html html="
"+_ " Выделенные объекты"+_ "Поле для номера участка"+_ MakeSelectForSemdata("idfield1",field1)+"
"+_ "Поле для названия территории"+_ MakeSelectForSemdata("idfield2",field2)+"
"+_ "Поле для исполнителя "+_ MakeSelectForSemdata("idfield3",field3)+"
"+_ "Папка для сохранения файлов (если оставить пустым сохранения не будет) "+vbNewLine+_ "
" +vbNewLine+_ ""+_ "" GenStartHTML=html end function ' показывает окно выбора папки function SelectFolder dim sh,fldr,fi,el set sh=CreateObject("Shell.Application") set fldr=sh.BrowseForFolder(0,"Выберите папку",0) if not(fldr is nothing) then set fi=fldr.self set el=win.browser.document.getElementById("idfolder") el.value=fi.path end if end function ' формирует элемент SELECT для семантики текущего слоя function MakeSelectForSemData(id,dvalue) dim sht, sd,ac,alar,i,st,j,sel set alar=ActiveProjectView.ActiveLayerView.Layer set sd=alar.SemTables sht="" MakeSelectForSemData=sht end function ' Вызывается сразу после запуска программного модуля sub Module_StartComplete() Module.LoadActions Script.ContextCard, "vdomost", Application.MainWindow.Actions Module.LoadMenu Script.ContextCard, "vdomost", Application.MainWindow.Menu.Items("MenusTools").Items if not (ActiveDb is nothing) then LoadParams end if end sub ' формирует список id выделенных объектов sub MakeSelectedList redim objlist(Selection.Count-1) dim i for i=0 to Selection.Count-1 objlist(i)=selection.ids(i) next end sub ' формирует список id всех объектов слоя sub MakeAllList ' думаю что объектов может быть не более 10000 redim objlist(10000) dim cc,i,mq,lar,larid,objid,sid cc=0 lar=ActiveProjectView.ActiveLayerView.Layer.ID set mq=ActiveDB.MapObjects.QueryByLayers(lar) while not mq.EOF mq.sFetch larid,objid,sid objlist(cc)=objid cc=cc+1 wend ' обрезаем список до фактического количества redim preserve objlist(cc-1) end sub ' сохраняет выбранные в окне значения в переменные sub SaveSelectedFolders dim el set el=win.browser.document.getElementByID("idfield1") field1=el.value set el=win.browser.document.getElementByID("idfield2") field2=el.value set el=win.browser.document.getElementByID("idfield3") field3=el.value set el=win.browser.document.getElementByID("idfolder") folder1=el.value ' folder end sub 'вычисление параметров дуги ' x1,y1 начало дуги ' x2,y2 конец дуги ' c кривизна ' x3,y3 получение центра дуги ' r получение радиуса sub GetArcParams(x1,y1,x2,y2,c,x3,y3,r) dim l,vx,vy l=sqr((x1-x2)^2+(y1-y2)^2) if l<1e-6 then r=0 x3=x1 y3=x1 exit sub end if r=abs(l*(1+c^2)/4/c) vx=(x1+x2)/2 vy=(y1+y2)/2 vx=vx-(y2-y1)/2*c '// (x+lx)/2; vy=vy+(x2-x1)/2*c x3=vx ';//+ (y-ly)*c; //-y y3=vy ';//+ (lx-x)*c; //x end sub ' формирует ведомость вызывается из HTML sub MakeVedomost dim ex,mobjs,mobj,shp,cntp,ash,i,si,el,el2 set mobjs=ActiveDB.MapObjects SaveSelectedFolders 'выбирается способ создания списка объектов set el=win.browser.document.getElementByID("ids1") if el.checked then MakeSelectedList else MakeAllList end if ' цикл обраотки списка объектов for i= 0 to ubound(objlist) set mobj=mobjs.GetObject(objlist(i)) set ex=CreateObject("Excel.Application") ex.Workbooks.Add set ash=ex.ActiveWorkBook.ActiveSheet 'объединение ячеек в заголовке ash.Range("A1:D1").Merge ash.Cells(1,1).value="Ведомость координат поворотных точек границ земельного участка №"+mobj.FormatText(field1)+","+_ mobj.FormatText(field2) ash.Cells(2,1).value="№ точки" ash.Cells(2,2).value="X" ash.Cells(2,3).value="Y" ash.Cells(2,4).value="R" dim rc,cvs,ci rc=3 dim vi,x,y,cv,x2,y2,cv2,cvr,cr,x3,y3 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) cvr=0 for vi=0 to cntp.VertexCount-1 cntp.sGetVertex vi,x,y,cv if cv=0 then cvs="" ash.Cells(rc,1)=Cstr(vi+1+cvr) ash.Cells(rc,2)=y ash.Cells(rc,3)=x ash.Cells(rc,4)=cvs rc=rc+1 else if vi=0 then cntp.sGetVertex cntp.VertexCount-1,x2,y2,cv2 else cntp.sGetVertex vi-1,x2,y2,cv2 end if GetArcParams x,y,x2,y2,cv,x3,y3,cr ash.Cells(rc,1)=Cstr(vi+1+cvr) ash.Cells(rc,2)=y3 ash.Cells(rc,3)=x3 ash.Cells(rc,4)=cr rc=rc+1 cvr=cvr+1 ash.Cells(rc,1)=Cstr(vi+1+cvr) ash.Cells(rc,2)=y ash.Cells(rc,3)=x ash.Cells(rc,4)="" rc=rc+1 end if next next end if next ash.Cells(rc,1)="S="+FormatNumber(mobj.Square,0)+" кв.м." ' задание ширин столбцов ash.columns(1).columnwidth=cw1 ash.columns(2).columnwidth=cw2 ash.columns(3).columnwidth=cw3 ash.columns(4).columnwidth=cw4 dim r,fn ' задание формата данных set r=ash.Range("A2:D"+Cstr(rc-1)) r.horizontalAlignment=3 'выравнивание текста 0 авто 1 влево 2 вправо 3 по центру r.Borders(11).LineStyle=1 'внутренняя горизонтальная 'стиль линии 1 сплошная -4115 пунктир 4 пунктир точка 5 пунктир точка точка -4118 точки -4119 двойная 13 не пробовал (slantdashdot) -4142 нет линии r.Borders(12).LineStyle=1 'внутренняя вертикальная r.Borders(7).LineStyle=1 ' внешняя левая r.Borders(8).LineStyle=1 ' внешняя верхняя r.Borders(9).LineStyle=1 ' внешняя нижняя r.Borders(10).LineStyle=1 ' внешняя правая ' толщина линии 1 очень тонкая, 2 тонкая, 4 очень толстая, -4138 средняя r.Borders(7).Weight=-4138 r.Borders(8).Weight=-4138 r.Borders(9).Weight=-4138 r.Borders(10).Weight=-4138 ' задание числового формата set r=ash.Range("B3:D"+Cstr(rc-1)) r.NumberFormat="0.00" ex.Visible=true ' задание формата заголовка set r=ash.Range("A1") ':D"+Cstr(rc-1)) r.horizontalAlignment=3 r.Font.Name=headerfontname r.Font.Size=headerfontsize r.Font.bold=headerfontbold r.WrapText=true 'включаем перенос текста ' высота 1 строки ash.Rows("1").RowHeight=headerfontsize*3 ' задаем формат заголовка столбцов set r=ash.Range("A2:D2") r.Font.Name=columnheaderfontname r.Font.Size=columnheaderfontsize r.Font.bold=columnheaderfontbold r.Borders(7).Weight=-4138 r.Borders(8).Weight=-4138 r.Borders(9).Weight=-4138 r.Borders(10).Weight=-4138 ' задаем формат данных set r=ash.Range("A3:D"+Cstr(rc-1)) r.Font.Name=coordfontname r.Font.Size=coordfontsize r.Font.bold=coordfontbold ' задаем формат площади set r=ash.Range("A"+Cstr(rc)) r.Font.Name=sqfontname r.Font.Size=sqfontsize r.Font.bold=sqfontbold ' заполняем колонтитулы with ash.PageSetup .LeftHeader=Cstr(Date) .CenterHeader=upcentertext .RightHeader="&P" .LeftFooter="Исполнитель"+vbNewLine+mobj.FormatText(field3) end with ' если папка задана сохраняем и закрываем файл if folder1<>"" then fn=folder1+"\"+mobj.FormatText(field1)+".xls" ex.ActiveWorkBook.SaveAs fn ex.ActiveWorkBook.Close end if next end sub ' Вызывается перед остановкой программного модуля sub Module_WillStop() ' if not (win is nothing) then ' set win=nothing ' end if if not (ActiveDb is nothing) then SAveParams end if end sub ' База данных открыта sub Application_OpenDbComplete() LoadParams end sub ' База данных будет закрыта sub Application_DbWillClose() SaveParams end sub ' загрузить параметры sub LoadParams field1=userProfile.Get(1,"","vdmst_f1","") field2=userProfile.Get(1,"","vdmst_f2","") field3=userProfile.Get(1,"","vdmst_f3","") folder1=userProfile.Get(1,"","vdmst_folder1","")+ userProfile.Get(1,"","vdmst_folder2","")+userProfile.Get(1,"","vdmst_folder3","") end sub ' сохранить парметры sub SAveParams userProfile.Put 1,"","vdmst_f1",field1 userProfile.Put 1,"","vdmst_f2",field2 userProfile.Put 1,"","vdmst_f3",field3 userProfile.Put 1,"","vdmst_folder1", Left(folder1,100) userProfile.Put 1,"","vdmst_folder2", Mid(folder1,101,100) userProfile.Put 1,"","vdmst_folder3", Mid(folder1,201,100) end sub VBScript f vdomostvdomost MakeVedom ВедомостьСоздать ведомость координат V` vdomostvdomost_MakeVedomN vdomostvdomost MenuItem1 MakeVedomСоздать ведомость координат 0