Форум программистов, компьютерный форум, киберфорум
CorelDRAW
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.57/21: Рейтинг темы: голосов - 21, средняя оценка - 4.57
0 / 0 / 0
Регистрация: 21.02.2019
Сообщений: 8
1

Поиск и выделение окружностей одинакового диаметра

21.02.2019, 13:35. Просмотров 4308. Ответов 24

Всем добрый день! Надеюсь на вашу помощь с моим вопросом.

Есть изображение состоящее целиком только из окружностей разного диаметра. Нужно найти и выделить все окружности определенного диаметра.
Через Поиск и замена- Эллипсы- Указать размер ничего не находит.
0
Миниатюры
Поиск и выделение окружностей одинакового диаметра  
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
21.02.2019, 13:35
Ответы с готовыми решениями:

есть ли мячи одинакового цвета или диаметра
помогите пожалуйста решить через цикл ПОКА: Дано N мячей. Имеются сведения о диаметре и цвете...

Выясните есть ли мячи одинакового цвета или диаметра
В детском саду есть N мячей. Имеются сведения о диаметре и цвете каждого мяча. Выясните: а) есть...

Выясните, есть ли мячи одинакового цвета или диаметра
В детском саду есть N мячей. Имеются сведения о диаметре и цвете каждого мяча. Выясните: а) есть...

Узор из 100 окружностей случайного диаметра и цвета
%-)Написать программу, которая выводит на экране узор из 100 колец случайного диаметра, толщины и...

24
12 / 12 / 0
Регистрация: 09.02.2014
Сообщений: 51
21.02.2019, 18:04 2
У меня находит все эллипсы одного и того же диаметра, если искать объекты, соответствующие выделенному. Но лучше вам скинуть этот файл на форум.
0
0 / 0 / 0
Регистрация: 29.12.2017
Сообщений: 5
21.02.2019, 21:50 3
Цитата Сообщение от Shtaked Посмотреть сообщение
Есть изображение состоящее целиком только из окружностей разного диаметра. Нужно найти и выделить все окружности определенного диаметра.
В CorelDraw нет поиска кривой по диаметру, радиусу, площади или длине. Не получится сделать то, что вам нужно.
0
168 / 94 / 24
Регистрация: 26.01.2019
Сообщений: 326
22.02.2019, 08:42 4
Цитата Сообщение от de_Facto Посмотреть сообщение
Не получится сделать то, что вам нужно.
Не вводите людей в заблуждение

Есть штатный функционал выделяете нужный объект кружочек и поиском (Ctrl+F) находите все такие-же
Код
Правка -> Правка и замена -> Найти объекты -> Найти объекты, соответствующие выбранному -> Найти все
Еще, на просторах тырнета, можно найти макрос ObjectReplacer, который меняет выделенные объекты на заранее скопированный в буфер
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub ObjectReplacer()
    Dim s As Shape, p As ShapeRange, ss As ShapeRange, ref
    ActiveDocument.BeginCommandGroup "ObjectReplacer"
    Optimization = True
    EventsEnabled = False
    ActiveDocument.SaveSettings
    ActiveDocument.PreserveSelection = False
    ref = ActiveDocument.ReferencePoint
    ActiveDocument.ReferencePoint = cdrCenter
    Set ss = ActiveSelection.Shapes.All
    Set p = ActiveLayer.PasteEx
    ppx# = p.PositionX
    ppy# = p.PositionY
    For Each s In ss    'ActiveDocument.Selection.Shapes
        'p.SizeHeight = s.SizeHeight
        'p.SizeWidth = s.SizeWidth
        p.Duplicate(s.PositionX - ppx, s.PositionY - ppy).OrderBackOf s
    Next
    p.Delete
    ss.Delete
    ActiveDocument.ReferencePoint = ref
    ActiveDocument.PreserveSelection = True
    ActiveDocument.RestoreSettings
    EventsEnabled = True
    Optimization = False
    ActiveDocument.EndCommandGroup
    ActiveWindow.Refresh
    Application.Refresh
End Sub
Если раскомментировать пару строк, то новый объект будет брать размеры заменяемого.
В общем, простор для творчества
1
0 / 0 / 0
Регистрация: 21.02.2019
Сообщений: 8
23.02.2019, 01:04  [ТС] 5
Цель состоит не в замене размера или абриса на всех выделенных точках. Каждым диаметрам нужно назначить свой цвет.
НО при команде Найти похожие, выделяются все объекты, без подразделения по размерам.
Кидаю оригинальный файл для проб.
0
Вложения
Тип файла: zip 1111.zip (269.4 Кб, 4 просмотров)
168 / 94 / 24
Регистрация: 26.01.2019
Сообщений: 326
23.02.2019, 10:13 6
Лучший ответ Сообщение было отмечено Shtaked как решение

Решение

Цитата Сообщение от Shtaked Посмотреть сообщение
Цель состоит не в замене размера или абриса на всех выделенных точках. Каждым диаметрам нужно назначить свой цвет.
НО при команде Найти похожие, выделяются все объекты, без подразделения по размерам.
В вашем случае все точки были выполнены в виде замкнутых кривых с одинаковым числом узлов, что в понятиях Corel'а - одно и тоже не зависимо от их размеров.
Поэтому нужно было использовать предложенный макрос.
Кликните здесь для просмотра всего текста
  1. добавить макрос в новый модуль проекта VBA
  2. раскомментировать две строки 'p.SizeHeight = s.SizeHeight и 'p.SizeWidth = s.SizeWidth
  3. нарисовать на листе круг любого размера
  4. скопировать его в буфер
  5. выделить все кривые
  6. запустить макрос

Заменив все кривые на эллипсы аналогичных размеров, поиск (Ctrl+F) начинает работать как надо.
Проделал с вашим файлом все вышеописанное, получил нужный результат
Если не ошибся, то у вас CorelDraw x4?

PS Прошу прощения у de_Facto. Действительно
Цитата Сообщение от de_Facto Посмотреть сообщение
В CorelDraw нет поиска кривой по диаметру, радиусу, площади или длине
Но кривые можно представить в виде других объектов, который корел различает
1
Вложения
Тип файла: rar 1111111to4kami+.rar (324.8 Кб, 2 просмотров)
0 / 0 / 0
Регистрация: 21.02.2019
Сообщений: 8
23.02.2019, 15:48  [ТС] 7
Цитата Сообщение от GeoCod Посмотреть сообщение
добавить макрос в новый модуль проекта VBA
раскомментировать две строки 'p.SizeHeight = s.SizeHeight и 'p.SizeWidth = s.SizeWidth
нарисовать на листе круг любого размера
скопировать его в буфер
выделить все кривые
запустить макрос
Я далек от программирования. Не понял как нужно было раскомметировать эти строки. Добавил ваш макрос целиком по видео из youtube)) При попытке проделать 6 пункт выдает ошибку Invalid outside procedure.

Добавлено через 20 минут
В модуль вставил без проблем. Теперь всегда вылетает ошибка Enable to execute vba code while in break mode
0
168 / 94 / 24
Регистрация: 26.01.2019
Сообщений: 326
23.02.2019, 16:32 8
Цитата Сообщение от Shtaked Посмотреть сообщение
раскомметировать эти строки
значит убрать знаки апострофа вначале этих строк
Кликните здесь для просмотра всего текста


Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub ObjectReplacer()
    Dim s As Shape, p As ShapeRange, ss As ShapeRange, ref
    ActiveDocument.BeginCommandGroup "ObjectReplacer"
    Optimization = True
    EventsEnabled = False
    ActiveDocument.SaveSettings
    ActiveDocument.PreserveSelection = False
    ref = ActiveDocument.ReferencePoint
    ActiveDocument.ReferencePoint = cdrCenter
    Set ss = ActiveSelection.Shapes.All
    Set p = ActiveLayer.PasteEx
    ppx# = p.PositionX
    ppy# = p.PositionY
    For Each s In ss    'ActiveDocument.Selection.Shapes
        p.SizeHeight = s.SizeHeight
        p.SizeWidth = s.SizeWidth
        p.Duplicate(s.PositionX - ppx, s.PositionY - ppy).OrderBackOf s
    Next
    p.Delete
    ss.Delete
    ActiveDocument.ReferencePoint = ref
    ActiveDocument.PreserveSelection = True
    ActiveDocument.RestoreSettings
    EventsEnabled = True
    Optimization = False
    ActiveDocument.EndCommandGroup
    ActiveWindow.Refresh
    Application.Refresh
End Sub

В своем предыдущем посте я выкладывал ваш файл, в котором сделал все необходимое. Вы его смотрели?
0
0 / 0 / 0
Регистрация: 21.02.2019
Сообщений: 8
23.02.2019, 20:05  [ТС] 9
Цитата Сообщение от GeoCod Посмотреть сообщение
В своем предыдущем посте я выкладывал ваш файл, в котором сделал все необходимое. Вы его смотрели?
Да, конечно, именно так мне и нужно было. Спасибо вам.
Теперь хочу сам все это проделать, ведь работать придется не только с этим изображением.

Добавлено через 18 минут
Цитата Сообщение от GeoCod Посмотреть сообщение
Set p = ActiveLayer.PasteEx
Ошибка 438. The object doesnt support this property of layer и указывает на эту строку кода.

Добавлено через 15 секунд
Цитата Сообщение от GeoCod Посмотреть сообщение
Set p = ActiveLayer.PasteEx
Ошибка 438. The object doesnt support this property of layer и указывает на эту строку кода.

Добавлено через 13 минут
Залил видео своих попыток запустить. Надеюсь на вашу помощь новичку)
https://youtu.be/B64GeGylNiQ
0
168 / 94 / 24
Регистрация: 26.01.2019
Сообщений: 326
23.02.2019, 20:26 10
Цитата Сообщение от Shtaked Посмотреть сообщение
Да, конечно, именно так мне и нужно было. Спасибо вам.
Всегда пожалуйста. А еще на форуме для выражения благодарностей есть кнопка "+1 спасибо" под сообщениями и возможность указать лучшие ответы по вашему вопросу.
Цитата Сообщение от Shtaked Посмотреть сообщение
Set p = ActiveLayer.PasteEx
Ошибка 438. The object doesnt support this property of layer
Данный макрос был написан давно и не вызывал проблем в старых версиях CorelDraw, у меня в CorelDraw 2017 тоже сработал без проблем.
Думаю, вам необходимо еще раз проделать все по порядку:
  1. нарисовать круг
  2. скопировать его в буфер (Ctrl+C)
  3. выделить все кривые, которые нужно заменить
  4. запустить макрос

Добавлено через 14 минут
Цитата Сообщение от Shtaked Посмотреть сообщение
Залил видео своих попыток запустить. Надеюсь на вашу помощь новичку)
https://youtu.be/B64GeGylNiQ
Слушайте, мы над разными фалами пытаемся решить одну задачу. Так ведь не делается.
Откройте файл из 1111111to4kami+.rar там встроен макрос. Сделайте все вышеописанное. Получается. Видите?

А вы производите другие действия: Импортируете из автокадовского (?) в корел, и пытаетесь получить тот же результат. А там кривыми ли импортировалось? Может еще какие-то особенности появились. Тогда выкладывайте все файлы, что бы можно было это изучить и сделать какие-то соображения
1
0 / 0 / 0
Регистрация: 21.02.2019
Сообщений: 8
23.02.2019, 20:45  [ТС] 11
Цитата Сообщение от GeoCod Посмотреть сообщение
Слушайте, мы над разными фалами пытаемся решить одну задачу. Так ведь не делается.
Откройте файл из 1111111to4kami+.rar там встроен макрос. Сделайте все вышеописанное. Получается. Видите?
А вы производите другие действия: Импортируете из автокадовского (?) в корел, и пытаетесь получить тот же результат. А там кривыми ли импортировалось? Может еще какие-то особенности появились. Тогда выкладывайте все файлы, что бы можно было это изучить и сделать какие-то соображения
Это первое что пришло мне в голову. Если вы уже проделали эту операцию, то макрос тоже должен был остаться там. Но там пусто. Возможно все дело в версии Корела. Установлю 2017 и попробую заново.

Добавлено через 5 минут
Программа, которая переводит изображение в точки экспортирует готовый файл только в формате dfx. Который приходится открывать в автокаде, потом сохранять в формате dwg который открsdftn Corel. Другого способа я не нашел. Поэтому такая путаница с кривыми.

Добавлено через 50 секунд
Программа, которая переводит изображение в точки экспортирует готовый файл только в формате dfx. Который приходится открывать в автокаде, потом сохранять в формате dwg который открsdftn Corel. Другого способа я не нашел. Поэтому такая путаница с кривыми.
0
168 / 94 / 24
Регистрация: 26.01.2019
Сообщений: 326
23.02.2019, 20:50 12
Цитата Сообщение от Shtaked Посмотреть сообщение
Установлю 2017 и попробую заново.
скачал файл, макрос на месте, все работает. Видимо X4 их не видит. + может быть в Х4 что-то по другому было устроено (объектная модель другая, или еще что).

Добавлено через 3 минуты
Цитата Сообщение от Shtaked Посмотреть сообщение
Программа, которая переводит изображение в точки экспортирует готовый файл только в формате dfx
DXF ?
По крайней мере последние версии Corel стали дружить с кадовскими файлами (DXFи DVG открывает напрямую) и меньше конфликтов вызывают. Выкладывайте кадовский файл, посмотрим как его в кореле обрабатывать
1
0 / 0 / 0
Регистрация: 21.02.2019
Сообщений: 8
23.02.2019, 20:57  [ТС] 13
Кидаю первый прямой сейв
0
Вложения
Тип файла: zip Izobrajenie.zip (63.0 Кб, 3 просмотров)
168 / 94 / 24
Регистрация: 26.01.2019
Сообщений: 326
23.02.2019, 21:15 14
Лучший ответ Сообщение было отмечено Shtaked как решение

Решение

Цитата Сообщение от Shtaked Посмотреть сообщение
Кидаю первый прямой сейв
У меня никаких проблем с заменой кривых на эллипсы не возникло.
Создал пустой документ, перетащил файл Izobrajenie.dxf в поле документа, нажал ОК.
Разгруппировал объекты, в VBA (Alt+F11) создал новый модуль, вставил макрос.
В поле документа создал эллипс - Ctrl+C - выделил все кривые - запустил макрос - с минуту молчания и все готово.
Прикрепляю файл в формате Corel Draw 2017 с макросом и результатом
1
Вложения
Тип файла: rar Изображение1.rar (665.1 Кб, 5 просмотров)
12 / 12 / 0
Регистрация: 09.02.2014
Сообщений: 51
24.02.2019, 11:10 15
Господа, я нашел более простое решение, скрипт просто перекрашивает каждый круг в цвет, который "создается из размера":
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub ColorRazmerAll()
    Dim s As Shape
    Dim sSizeHeight As Double
    Dim sSizeWidth As Double
    Dim eColor As Integer
    
    For Each s In ActivePage.Shapes
        s.GetSize sSizeHeight, sSizeWidth
        sSizeHeight = Round(sSizeHeight, 3)
        'sSizeWidth = Round(sSizeWidth, 3)
        eColor = Int(sSizeHeight * 1000)
                
        s.Fill.UniformColor.RGBAssign eColor, 50, 50
Next s
End Sub
Просто запустить макрос, ничего не выделяя и не копируя. Следует учесть, что кривые, выглядящие одинакового размера на самом деле имеют немного разный размер, хотя в долях миллиметра это незаметно. Поэтому в скрипте применяется скругление значения размера. После чего можно просто выделить все объекты одного цвета. Если нужно обработать много изображений, то целесообразно запустить сразу несколько экземпляров корела.
1
0 / 0 / 0
Регистрация: 21.02.2019
Сообщений: 8
24.02.2019, 14:20  [ТС] 16
Цитата Сообщение от GeoCod Посмотреть сообщение
Изображение1.rar (665.1 Кб, 3 просмотров)
Спасибо, у меня все получилось. НЕ думал что найду решение этой проблемы, вы мне очень помогли.

Добавлено через 3 минуты
Цитата Сообщение от Fllex Посмотреть сообщение
Просто запустить макрос, ничего не выделяя и не копируя. Следует учесть, что кривые, выглядящие одинакового размера на самом деле имеют немного разный размер, хотя в долях миллиметра это незаметно. Поэтому в скрипте применяется скругление значения размера. После чего можно просто выделить все объекты одного цвета. Если нужно обработать много изображений, то целесообразно запустить сразу несколько экземпляров корела.
Это инетересно, хотя пока не очень понятно. Первый метод мне очень подходит.Хотя часто Corel закрывается сам собой.
0
12 / 12 / 0
Регистрация: 09.02.2014
Сообщений: 51
24.02.2019, 14:36 17
Цитата Сообщение от Shtaked Посмотреть сообщение
пока не очень понятно
Смысл в том, что два круга, которые в вашем файле имеют размер 1,952 мм при переводе в пункты могут быть 5,534 п. и 5,535 п. Т.е. не одного и того же размера, очень немного, но различаться.

А вам это нужно для гравировки какой-то или растрирование для какой-то печати? Если так, то имхо, должны быть другие технологии цветоделения и растрирования, нежели кореловские макросы.
0
0 / 0 / 0
Регистрация: 21.02.2019
Сообщений: 8
24.02.2019, 14:51  [ТС] 18
Цитата Сообщение от Fllex Посмотреть сообщение
А вам это нужно для гравировки какой-то или растрирование для какой-то печати?
Нет, это для перфарирования металла, для ручной гравировки. Поэтому идеальные размеры не обязательны. Главное цвет.
0
168 / 94 / 24
Регистрация: 26.01.2019
Сообщений: 326
24.02.2019, 16:14 19
Цитата Сообщение от Fllex Посмотреть сообщение
Господа, я нашел более простое решение, скрипт просто перекрашивает каждый круг в цвет, который "создается из размера":
Хороший вариант для автоматизации перекрашивания , только бы отключить обновление экрана и задавать цвет Red, Green и Blue по значению eCollor, а не только красный. Немного дополнил:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub ColorRazmerAll()
Dim s As Shape
Dim sSizeHeight As Double
Dim sSizeWidth As Double
Dim eColor As Integer
 
Optimization = True
EventsEnabled = False
For Each s In ActivePage.Shapes
   s.GetSize sSizeHeight, sSizeWidth
   sSizeHeight = Round(sSizeHeight, 3)
   'sSizeWidth = Round(sSizeWidth, 3)
   eColor = Int(sSizeHeight * 1000) * 5
   s.Fill.UniformColor.RGBAssign eColor, eColor / 2, eColor * 3 / 2
Next s
    EventsEnabled = True
    Optimization = False
End Sub
Единственное, по результату получается достаточно плавный переход между эллипсами, т.к. и разница в размерах у них минимальная. Думаю, нужно сделать какие-то округление до десятков, что бы получилось несколько контрастных градаций
1
12 / 12 / 0
Регистрация: 09.02.2014
Сообщений: 51
24.02.2019, 17:10 20
Цитата Сообщение от GeoCod Посмотреть сообщение
Хороший вариант для автоматизации перекрашивания
Вот собственно об этом и думал. Обычно в станках лазерной гравировки разный цвет используется для разных режимов мощности и скорости.
Цитата Сообщение от GeoCod Посмотреть сообщение
только бы отключить обновление экрана и задавать цвет Red, Green и Blue по значению eCollor, а не только красный
Только есть два нюанса:
1. Без обновления экрана не создается палитра документа внизу. А ее можно использовать для выделения посредством поиска и замены. Но можно и тут что другое придмуать.
2.
Visual Basic
1
eColor = Int(sSizeHeight * 1000) * 5
Нужно учесть, что получаемое в этом случае значение выходит за 255, так что лучше так:

Visual Basic
1
eColor = Int(sSizeHeight * 100) * 5
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
24.02.2019, 17:10

Заказываю контрольные, курсовые, дипломные и любые другие студенческие работы здесь.

Начертить 100 окружностей случайного диаметра и цвета
Написать программу, которая вычерчивает на экране узор из 100 окружностей случайного диаметра и...

Вывести на экране узор из 5 концентрических окружностей различного диаметра и цвета
4.Написать программу, которая вычерчивает на экране узор из 5 концентрических окружностей...

Как нарисовать на форме 100 окружностей случайного диаметра и цвета?
Ребята, объясните каким образом можно реализовать подобное в C#. Никогда не работал с такими...

Вывести на экран узор из 100 окружностей случайного диаметра и цвета
Составить программу, которая выводит на экран узор из 100 окружностей случайного диаметра и цвета


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
20
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2020, vBulletin Solutions, Inc.