Это ясно, мы вернулись к главному вопросу - нахождению похожих объектов.
Sub SimilarOrNot()
Dim S As Shape
Dim T As Shape
Dim SR As New ShapeRange
Set S = ActiveSelectionRange.Shapes.First
SR.Add S
For Each T In ActivePage.Shapes
If IsSimilar(S, T) Then SR.Add T
Next T
SR.CreateSelection
End Sub
Function IsSimilar(S As Shape, T As Shape) As Boolean
IsSimilar = False
Dim V As Shape
Dim W As Shape
Dim Z As Shape
Dim AreaA As Double
Dim AreaB As Double
If S.StaticID <> T.StaticID Then
Set V = T.Duplicate
V.Outline.Color.RGBAssign 255, 0, 0
V.SetSize , S.SizeHeight
V.CenterX = S.CenterX
V.CenterY = S.CenterY
Set W = S.Trim(V, True, True)
Set Z = V.Trim(S, False, True)
If Not W Is Nothing Then
AreaA = W.Curve.Area
W.Delete
End If
If Not Z Is Nothing Then
AreaB = Z.Curve.Area
Z.Delete
End If
If AreaA + AreaB < S.DisplayCurve.Area * 0.1 Then IsSimilar = True
End If
End FunctionV.SetSize , S.SizeHeight ?Что-то я не заметил у вас в коде приведения к общему размеру
У меня создается реальное впечатления что ваш конек это разговоры вокруг да около - есть же код изначальной функции, есть код вашего метода, который мне пришлось написать. Легко проверить.
Этого не может быть потому что этого не может быть никогда
Возможно вы не так смотрите на задачу, точность тут не нужна - задача это найти похожие объекты - т.е. апроксимация тут как раз нужна. Примерный файл это мелкая часть того что обычно в полном файле. И для нестинга мне очень помогает выделить все похожие объекты.
Вы же видите код, просмотрите его пару минут, если надо введите коррекции, покажите что ваш метод лучше и я скажу большое спасибо и соглашусь что был не прав.
Ну как всегда с корелом, все через какие-то обходные пути. А вы, повторюсь, твердили что это все такие базовые функции, совершенно надежные итд.Гм, копнул чуть глубже - функция area реализована косячно по определению. Косяк заключается в том, что она корректно работает только с кривыми без самопересечений. Как только контур пересекает сам себя, площадь полученной фигуры начинает отниматься от общей площади в любом случае. Причем баг тянется с самых ранних версий к последним. Лечится через Create Boundary от фигуры - данная операция (вроде как) создает корректный контур без самопересечений.
Честно говоря, я и сам не ожидал такой подлянки от функции area
При чем тут итерации? Вы вообще запустили тот код, посмотрели как он действует? Один раз создается каталог хэшов всех объектов на странице, потом по хэшу делается выделение нужных объектов.
Sub SelectSimilar()
If CheckDoc(1) Then
'boostStart "Index"
ActiveWindow.ActiveView.Zoom = 256000
Dim S As Shape
Dim T As Shape
Dim SR As New ShapeRange
Dim TR As ShapeRange
Dim A As Long
Dim OurShape As Currency
Set T = ActiveSelectionRange.Shapes.First
SR.Add T
Set TR = ActivePage.Shapes.All
OurShape = SimilarityRating(T)
ReDim Catalogue(TR.Count + 1, 2) As Currency
For A = 1 To TR.Count
Set S = TR(A)
Catalogue(A, 1) = SimilarityRating(S)
Catalogue(A, 2) = S.StaticID
Debug.Print Catalogue(A, 1)
Next A
For A = 1 To TR.Count
If Catalogue(A, 1) = OurShape Then
Set S = ActivePage.FindShape(, , Catalogue(A, 2))
If S.SizeHeight > T.SizeHeight * 0.5 And S.SizeHeight < T.SizeHeight * 1.5 And T.SizeWidth > S.SizeWidth * 0.5 And T.SizeWidth < S.SizeWidth * 1.5 Then
SR.Add S
End If
End If
Next A
SR.CreateSelection
ActiveWindow.ActiveView.ToFitSelection
'boostFinish True
End If
End Sub
Function SimilarityRating(S As Shape) As Currency
Dim X As Double
Dim Y As Double
Dim Size As Double
Dim Steps As Double
Dim Gap As Double
Steps = 4
Dim Index As Currency
Dim A As Byte
Index = 0
A = 0
If S.SizeHeight > S.SizeWidth Then
Size = S.SizeHeight
Else
Size = S.SizeWidth
End If
Gap = Size / Steps
Size = Size - Gap
Gap = Size / Steps
For Y = 0 To Steps
For X = 0 To Steps
If S.IsOnShape((S.CenterX - Size / 2) + X * Gap, (S.CenterY - Size / 2) + Y * Gap, Gap * 0.5) Then
'Debug, can comment out
'ActiveLayer.CreateEllipse2 (S.CenterX - Size / 2) + X * Gap, (S.CenterY - Size / 2) + Y * Gap, Gap * 0.5
Index = Index + 2 ^ A
Else
'Debug, can comment out
'ActiveLayer.CreateEllipse2 (S.CenterX - Size / 2) + X * Gap, (S.CenterY - Size / 2) + Y * Gap, Gap / 8
End If
A = A + 1
Next X
Next Y
'Debug, can comment out
'ActiveLayer.CreateArtisticText S.LeftX, S.BottomY - 1, Index, , , , 32
SimilarityRating = Index
End Function
Ну, только потому что я тут на форуме недавно и мое мнение не совпадает с вашим я вряд ли начинающий программист, с вба в кореле работаю уже лет 11, пожалуй.Но повторяю, б-га ради, если вам так ваш алгоритм нравится, используйте его.
Сколько раз убеждал себя не вступать в спор с начинающими программистами, гордыми собственным творением а все никак не удерживаюсь
Не совсем так. Потому что вы упорно игнорируете все резоны, которые я вам излагаю уже второй день.
Зачем? Это ваша проблема, не моя. Не нравится кореловская модель - пользуйте иллюстраторовскую. Пишите (Лев несколько экранов предлагал как) прямую собственную реализацию IsOnShape, Area и т.д. - флаг в руки! Или пользуйтесь своим алгоритмом если он уж так вам нравится! Я ж с самого начала сказал что не претендую на роль вашего гуру!
Как раз вполне ясно - в ключевых точках от которых вы считаете б-гомерзкий IsOnShape верхние контуры дают одинаковый хэш а нижние - нет