[CDR 2017-2021] Макрос изменить масштаб объекта без смещения положения

  • Автор темы Автор темы Nameless950
  • Дата начала Дата начала
N

Nameless950

Участник
Топикстартер
Сообщения
30
Реакции
0
Приветствую. Подскажите, пожалуйста, как можно комплексно уменьшить группу объектов в 2 раза без смещения положения? Иными словами подскажите макрос, который будет поочередно выделять объект, менять его масштаб в 2 раза и так по кругу все объекты в группе из выбранных. Ибо если применять изменение масштаба к группе, то изменяется масштаб всей группы. Решение без макросов в голову не идет.
 
Nameless950 сказал(а):
Приветствую. Подскажите, пожалуйста, как можно комплексно уменьшить группу объектов в 2 раза без смещения положения? Иными словами подскажите макрос, который будет поочередно выделять объект, менять его масштаб в 2 раза и так по кругу все объекты в группе из выбранных. Ибо если применять изменение масштаба к группе, то изменяется масштаб всей группы. Решение без макросов в голову не идет.
Нажмите, чтобы раскрыть...
Отсюда

Код: 
Sub Scale_Centered_X_and_Y()
Dim sr As ShapeRange, s As Shape, xc#, yc#, sc#
Set sr = ActiveSelectionRange
sr.SetOutlineProperties ScaleWithShape:=cdrTrue
ActiveDocument.BeginCommandGroup "Scale centered X and Y"
On Error GoTo ErrHandler
sc = InputBox("scale (%)") / 100
For Each s In sr
    xc = s.CenterX
    yc = s.CenterY
    s.SetSize s.SizeWidth * sc, s.SizeHeight * sc
    s.CenterX = xc
    s.CenterY = yc
Next s
ExitSub:
ActiveDocument.EndCommandGroup
Exit Sub
ErrHandler:
MsgBox "Error occured: " & Err.Description
Resume ExitSub
End Sub
 
  • Спасибо
Реакции: Nameless950
DenSen сказал(а):
Отсюда

Код: 
Sub Scale_Centered_X_and_Y()
Dim sr As ShapeRange, s As Shape, xc#, yc#, sc#
Set sr = ActiveSelectionRange
sr.SetOutlineProperties ScaleWithShape:=cdrTrue
ActiveDocument.BeginCommandGroup "Scale centered X and Y"
On Error GoTo ErrHandler
sc = InputBox("scale (%)") / 100
For Each s In sr
    xc = s.CenterX
    yc = s.CenterY
    s.SetSize s.SizeWidth * sc, s.SizeHeight * sc
    s.CenterX = xc
    s.CenterY = yc
Next s
ExitSub:
ActiveDocument.EndCommandGroup
Exit Sub
ErrHandler:
MsgBox "Error occured: " & Err.Description
Resume ExitSub
End Sub
Нажмите, чтобы раскрыть...
Спасибо, изучу.
 
Макрос добавляет обводку объектам.
 
Upd. Объекты смещаются, если были сгруппированы, если разгруппировать, то всё ок. С обводкой еще борюсь.
 
закомментировать эту строку:

sr.SetOutlineProperties ScaleWithShape:=cdrTrue
 
mnemonix сказал(а):
закомментировать эту строку:

sr.SetOutlineProperties ScaleWithShape:=cdrTrue
Нажмите, чтобы раскрыть...
Sub Scale_Centered_X_and_Y()
Dim sr As ShapeRange, s As Shape, xc#, yc#, sc#
Set sr = ActiveSelectionRange
sr.SetOutlineProperties ScaleWithShape:=cdrTrue
ActiveDocument.BeginCommandGroup "Scale centered X and Y"
On Error GoTo ErrHandler
sc = InputBox("scale (%)") / 100
For Each s In sr
xc = s.CenterX
yc = s.CenterY
s.SetSize s.SizeWidth * sc, s.SizeHeight * sc
s.CenterX = xc
s.CenterY = yc
Next s
ExitSub:
ActiveDocument.EndCommandGroup
Exit Sub
ErrHandler:
MsgBox "Error occured: " & Err.Description
Resume ExitSub
End Sub


Это пишу, а всё равно обводит
 
или удалить, т.к. это команда масштабирования обводки
 
  • Спасибо
Реакции: Nameless950
Для ответа нужно войти/зарегистрироваться
Верх Низ