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

[Nameless950]

Приветствую. Подскажите, пожалуйста, как можно комплексно уменьшить группу объектов в 2 раза без смещения положения? Иными словами подскажите макрос, который будет поочередно выделять объект, менять его масштаб в 2 раза и так по кругу все объекты в группе из выбранных. Ибо если применять изменение масштаба к группе, то изменяется масштаб всей группы. Решение без макросов в голову не идет.

 

[densen]

Приветствую. Подскажите, пожалуйста, как можно комплексно уменьшить группу объектов в 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]

Отсюда

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

Спасибо, изучу.

 

[mnemonix]

Макрос добавляет обводку объектам.

 

[densen]

Макрос добавляет обводку объектам.

sr.SetOutlineProperties ScaleWithShape:=cdrTrue - данный параметр в макросе не должен это позволять.

 

[Nameless950]

Макрос добавляет обводку объектам.

Да, посмотрел - появляется обводка и объекты смещаются относительно своих изначальных координат. Надо чтобы на месте остались

 

[Nameless950]

Upd. Объекты смещаются, если были сгруппированы, если разгруппировать, то всё ок. С обводкой еще борюсь.

 

[mnemonix]

закомментировать эту строку:

sr.SetOutlineProperties ScaleWithShape:=cdrTrue

 

[Nameless950]

закомментировать эту строку:

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


Это пишу, а всё равно обводит

 

[mnemonix]

или удалить, т.к. это команда масштабирования обводки

 

[Nameless950]

или удалить, т.к. это команда масштабирования обводки

Удалил, пропала обводка, спасибо