Добрый день.
Помогите в написании макроса. Заранее благодарен.
На данном форуме нашел макрос по расстановки размеров.
Но есть задача переместить созданную размерную линию на определенный слой.
Для этого встает необходимость в разгруппировки созданной размерной линии для последующего переноса на необходимый слой.
Разгруппировку вроде выполнил но по итогу переношу на слой только текс а сама размерная линия остается на исходном слое.
Помогите пожалуйста выполнить корректно данные действия...
Sub dim_each()
ActiveDocument.BeginCommandGroup "Dimensioner"
ActiveDocument.Unit = cdrMillimeter
Проверка наличия слоев и создание
If ActivePage.Layers.Find("слой2") Is Nothing Then ActivePage.CreateLayer ("слой2")
d = 15
For Each s In ActiveSelection.Shapes
ActiveLayer.CreateLinearDimension(cdrDimensionVertical, s.SnapPoints.BBox(cdrTopMiddle), s.SnapPoints.BBox(cdrBottomMiddle), TextSize:=72).Dimension.TextShape.PositionX = s.LeftX + d
ActiveSelection.Separate
ActiveSelection.MoveToLayer ActivePage.Layers("слой2")
ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, s.SnapPoints.BBox(cdrMiddleLeft), s.SnapPoints.BBox(cdrMiddleRight), TextSize:=72).Dimension.TextShape.PositionY = s.TopY - d
ActiveSelection.Separate
ActiveSelection.MoveToLayer ActivePage.Layers("слой2")
Next s
ActiveDocument.EndCommandGroup
End Sub
Помогите в написании макроса. Заранее благодарен.
На данном форуме нашел макрос по расстановки размеров.
Но есть задача переместить созданную размерную линию на определенный слой.
Для этого встает необходимость в разгруппировки созданной размерной линии для последующего переноса на необходимый слой.
Разгруппировку вроде выполнил но по итогу переношу на слой только текс а сама размерная линия остается на исходном слое.
Помогите пожалуйста выполнить корректно данные действия...
Sub dim_each()
ActiveDocument.BeginCommandGroup "Dimensioner"
ActiveDocument.Unit = cdrMillimeter
Проверка наличия слоев и создание
If ActivePage.Layers.Find("слой2") Is Nothing Then ActivePage.CreateLayer ("слой2")
d = 15
For Each s In ActiveSelection.Shapes
ActiveLayer.CreateLinearDimension(cdrDimensionVertical, s.SnapPoints.BBox(cdrTopMiddle), s.SnapPoints.BBox(cdrBottomMiddle), TextSize:=72).Dimension.TextShape.PositionX = s.LeftX + d
ActiveSelection.Separate
ActiveSelection.MoveToLayer ActivePage.Layers("слой2")
ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, s.SnapPoints.BBox(cdrMiddleLeft), s.SnapPoints.BBox(cdrMiddleRight), TextSize:=72).Dimension.TextShape.PositionY = s.TopY - d
ActiveSelection.Separate
ActiveSelection.MoveToLayer ActivePage.Layers("слой2")
Next s
ActiveDocument.EndCommandGroup
End Sub