 |
www.integro.ru
ЦСИ ИНТЕГРО
|
| Предыдущая тема :: Следующая тема |
| Автор |
Сообщение |
Кузнецов Андрей
Зарегистрирован: 22.04.2005
Сообщения: 28
Откуда: Магнитогорск
|
 Добавлено: Пн 17 Апр 2006 12:24 Заголовок сообщения: Поиск будликатов |
 |
|
Кто-нибудь задавлся задачей поиска дубликатов?
Хотя бы упрощенный вариант - абсалютный будль по геометрии (не включая семантику).
На скриптах сделал тест, но он очень медленный получился, поэтому работоспособным считать его не могу. Пока нет времени изобретать что-то более "хитрое". Если кто-то делал и есть желание обсудить, буду рад.
А вот обственно то, что сделал (сравниваются два слоя):
| Код: |
Dim aDupsForm
Dim ftIsProgress
' Вспомогательные функции
'===============================================
function CreateNewHTMLForm(aCaption, aInnerHTML)
Dim aForm
set aForm = Application.OpenHTMLWindow(ContextCard)
aForm.Caption = aCaption
with aForm.Browser
.Navigate "about:blank"
do while not (.ReadyState = 4 or .ReadyState = 3)
Application.ProcessMessages
loop
end with
set aForm.External = Disp
aForm.Browser.Document.Body.innerHTML = aInnerHTML
Set CreateNewHTMLForm = aForm
end function
Function ContourPartsIsEqual(P1, P2)
Dim i, X1, Y1, C1, X2, Y2, C2
ContourPartsIsEqual = False
if P1.VertexCount <> P2.VertexCount then Exit Function
For i = 0 to P1.VertexCount - 1
P1.sGetVertex i, X1, Y1, C1
P2.sGetVertex i, X2, Y2, C2
if (X1 <> X2) or (Y1 <> Y2) or (C1 <> C2) then
Exit Function
end if
Next
ContourPartsIsEqual = True
End Function
Function ContoursIsEqual(C1, C2)
Dim i
ContoursIsEqual = False
if C1.Count <> C2.Count then Exit Function
For i = 0 to C1.Count - 1
if not ContourPartsIsEqual(C1.Item(i), C2.Item(i)) then
Exit Function
end if
Next
ContoursIsEqual = True
End Function
Function GeometryIsEqual(MO1, MO2)
Dim i
GeometryIsEqual = False
if MO1.Shapes.Count <> MO2.Shapes.Count then Exit Function
For i = 0 to MO1.Shapes.Count - 1
if not ContoursIsEqual(MO1.Shapes.Item(i).Contour, MO2.Shapes.Item(i).Contour) then
Exit Function
end if
Next
GeometryIsEqual = True
End Function
Function GeometryIsEqualByID(MOS, ID1, ID2)
GeometryIsEqualByID = GeometryIsEqual(MOS.GetObject(ID1), MOS.GetObject(ID2))
End Function
Function CompareLayers(MOS, LayerID1, LayerID2)
Dim MOQ1, MOQ2, i, aCount, aDups
Set MOQ1 = MOS.QueryByLayers(LayerID1)
Set MOQ2 = MOS.QueryByLayers(LayerID2)
CompareLayers = 0
aDups = 0
aDupsForm.Browser.Document.all.Div0.InnerHTML = Application.ActiveDB.LayerFromID(LayerID1).Name
aCount = 0
Do While not MOQ1.EOF
aCount = aCount + 1
MOQ1.MoveNext
loop
MOQ1.Reset
i = 0
Do While not MOQ1.EOF
MOQ2.Reset
Do While not MOQ2.EOF
Application.ProcessMessages
if not ftIsProgress then Exit Function
if GeometryIsEqualByID(MOS, MOQ1.ObjectID, MOQ2.ObjectID) then
aDups = aDups + 1
' можно, например выделять дубли в одном слое...
Application.Selection.Select MOQ1.ObjectID, 0
end if
MOQ2.MoveNext
loop
MOQ1.MoveNext
i = i + 1
aDupsForm.Browser.Document.all.Div1.InnerHTML = "Обработано <b>" & i & "</b> из <b>" & aCount & "</b><br>" &_
"Дубликатов: <b>" & aDups & "</b>"
loop
CompareLayers = aDups
End Function
sub OnButtonStopClick
ftIsProgress = False
End Sub
Sub OnFindDupsButtonClick
Dim MOS, aDups
if ftIsProgress then Exit Sub
ftIsProgress = True
Application.Selection.deselectAll
Set MOS = Application.ActiveDB.MapObjects
aDups = CompareLayers MOS, "000B00000410", "000800000413"
ftIsProgress = False
End Sub
Sub StartFindDups
Dim aHTML
if not IsObject(Application.ActiveDB) then
MsgBox "База данных не открыта"
Exit sub
end if
ftIsProgress = False
aHTML = "<b>Поиск дубликатов</b><hr>" & _
"<input type=button value=Начать name=StartButton language=vbscript " &_
"onclick='window.external.OnFindDupsButtonClick'> " &_
"<input type=button value=Остановить name=StopButton language=vbscript " &_
"onclick='window.external.OnButtonStopClick'><br><br>" &_
"<div name=Div0 id=Div0 Width=100% style='border: 1 solid #C0C0C0'>...</div>" &_
"<div name=Div1 id=Div1 Width=100% style='border: 1 solid #C0C0C0'>...</div>"
Set aDupsForm = CreateNewHTMLForm("Поиск дубликатов", aHTML)
aDupsForm.Visible = True
end sub
|
|
|
| Вернуться к началу |
|
 |
Кузнецов Андрей
Зарегистрирован: 22.04.2005
Сообщения: 28
Откуда: Магнитогорск
|
| Добавлено: Пн 17 Апр 2006 12:32 Заголовок сообщения: |
|
|
| Прошу прощения за опечатку в названии темы |
|
| Вернуться к началу |
|
|
Марина
Зарегистрирован: 18.07.2005
Сообщения: 8
Откуда: Самарский центр недвижимости
|
| Добавлено: Пн 17 Апр 2006 13:40 Заголовок сообщения: Re: Поиск дубликатов |
|
|
У нас такой вопрос тоже стоял, но до реализации дело пока не дошло.
Но первое, что приходит на ум: для убыстрения процесса надо с объектом из одного слоя сравнивать только те объекты из другого слоя, которые попадают в квадрат границ объекта.
Возможность реализовать запрос с использованием геометрии по-моему есть:
| Код: | | MapObjects.QueryByRect |
|
|
| Вернуться к началу |
|
|
andreichernov
Зарегистрирован: 14.02.2005
Сообщения: 209
Откуда: Самара
|
| Добавлено: Вт 18 Апр 2006 09:25 Заголовок сообщения: |
|
|
Я делал скрипт поиска двойных объектов. Могу прислать.
Относительно твоего кода - проще сделать через
QueryByContour |
|
| Вернуться к началу |
|
|
Кузнецов Андрей
Зарегистрирован: 22.04.2005
Сообщения: 28
Откуда: Магнитогорск
|
| Добавлено: Вт 18 Апр 2006 10:28 Заголовок сообщения: |
|
|
Марина и Андрей, спасибо за отклики.
Андрей, QueryByContour, полагаю будет эффективен, если объекты состоят из одной формы. Здесь я думаю предложение Марины использовать MapObjects.QueryByRect будет корректнее. Как найду время попробую реализовать и оценить скорость работы.
А на счет "скрипта поиска двойных объектов" - вышлите, обязательно посмотрю, адрес: Andrew-G-K@yandex.ru.
Вообще задача эта всплывала давно, но без острой необходимости.
Сейчас обострилась в связи с такой ситуацией: есть две базы одна из другой сделанные путем простого копирования файлов (т.е. некорректно). Теперь их нужно объеденить. Но каждая из них уже поросла глюками и экспорт из них не проходит. Делаю переидентификацию этих баз (пространства идентификаторов, ситсемные объекты, геометрию), потом проверяю целостность. После этого объединяю. Все проходит нормально, но как следствие получаю дубли карт, слоев и объектов. Ладно с системными объектами - их не много и имена совпадают, а вот с пространственными объектами гораздо хуже. Мысли пока такие: вычислить объекты у котрых полностью совпадает геометрия (количество форм, координаты контуров), а затем сравнить семантику. Т.к. типы полей в таблицах "простые" (число или строка) и структара таблиц одинаковая, то думаю это реализовать тоже можно. Как вы уже знаете первое с чего начал - это геометрия.
Если инструмент получится, то думаю его можно будет применять и в других случаях.
А может есть решения моей задачи другими методами? Буду рад подсказкам. |
|
| Вернуться к началу |
|
|
andreichernov
Зарегистрирован: 14.02.2005
Сообщения: 209
Откуда: Самара
|
| Добавлено: Вт 18 Апр 2006 11:11 Заголовок сообщения: |
|
|
Зря так сделаешь.
Умрешь.
Мы для устранения подобной фигни написали импорт и экспорт через собственный XML-файл.
При импорте проверяется, объект с таким ID в этом слое или нет,
если нет (то есть это дубликат), создается с новым идентификатором.
Ну то четь производится слияние двух некорректных баз через специальную процедуру импорта.
Вроде работает. [/i] |
|
| Вернуться к началу |
|
|
Кузнецов Андрей
Зарегистрирован: 22.04.2005
Сообщения: 28
Откуда: Магнитогорск
|
| Добавлено: Вт 18 Апр 2006 13:19 Заголовок сообщения: |
|
|
Писать такую глобальную вещь я один не в силах. Попытался изменить начатый мною код.
Переписал функцию "CompareLayers" и пример отработал примерно в 150 раз быстрее (спасибо Марине).
Вот код:
| Код: |
Function CompareLayers(MOS, LayerID1, LayerID2)
Dim MOQ1, MOQ2, i, aCount, aDups, MO, X1, X2, Y1, Y2
Set MOQ1 = MOS.QueryByLayers(LayerID1)
CompareLayers = 0
aDups = 0
aDupsForm.Browser.Document.all.Div0.InnerHTML = Application.ActiveDB.LayerFromID(LayerID1).Name
aCount = 0
Do While not MOQ1.EOF
aCount = aCount + 1
MOQ1.MoveNext
loop
MOQ1.Reset
i = 0
Do While not MOQ1.EOF
' возьмем область немного пошире
Set MO = MOS.GetObject(MOQ1.ObjectID)
X1 = MO.X1 - 1
X2 = MO.X2 + 1
Y1 = MO.Y1 - 1
Y2 = MO.Y2 + 1
Set MO = Nothing
Set MOQ2 = MOS.QueryByRect(LayerID2, X1, Y1, X2, Y2, True)
Do While not MOQ2.EOF
Application.ProcessMessages
if not ftIsProgress then Exit Function
if GeometryIsEqualByID(MOS, MOQ1.ObjectID, MOQ2.ObjectID) then
if not Application.Selection.IsSelected(MOQ1.ObjectID) then
aDups = aDups + 1
Application.Selection.Select MOQ1.ObjectID, 0
end if
end if
MOQ2.MoveNext
loop
MOQ1.MoveNext
i = i + 1
aDupsForm.Browser.Document.all.Div1.InnerHTML = "Обработано <b>" & i & "</b> из <b>" & aCount & "</b><br>" &_
"Дубликатов: <b>" & aDups & "</b>"
loop
CompareLayers = aDups
End Function
|
|
|
| Вернуться к началу |
|
|
|
|
Вы не можете начинать темы
Вы не можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете голосовать в опросах
Вы не можете добавлять приложения в этом форуме
Вы можете скачивать файлы в этом форуме
|
|
FAQ
Поиск
Пользователи
Группы
Регистрация
Профиль
Войти и проверить личные сообщения
Вход
