[CDR 2017-2021] Расставить объект по центрам других объектов

dastin

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 145
Реакции
2 043
Elvis_44 сказал(а):
смысл даже не в единице размера а в том что размер меняется
Нажмите, чтобы раскрыть...
так и было задумано автором - сохранять размер и угол поворота исходного объекта
...
ниже текст макроса с изменениями - в центр каждой "точки будет поставлен ваш объект подмены - НО!!! ВСЕ объекты будут одинаковы

вместо BoundingBox - только Position
...
Код: 
Sub scatter()
   Dim sh As Shape, sr As ShapeRange, x#, y#, w#, h#, i&
   Dim AgentSmith As Shape, VSR As ShapeRange
  
   If ActiveDocument Is Nothing Then Exit Sub
   Set sr = ActiveSelection.Shapes.FindShapes()
   If sr.Count = 0 Then
      MsgBox "Select target objects, invoke the macro, click Agent Smith shape"
      Exit Sub
   End If
   If ActiveDocument.GetUserClick(x, y, i, -1, Snap:=False, CursorShape:=313) Then _
      Exit Sub
  
   With ActivePage.SelectShapesAtPoint(x, y, SelectUnfilled:=True)
      If .Shapes.Count = 0 Then Beep: Exit Sub
      Set AgentSmith = .Shapes(.Shapes.Count)
   End With

   Set VSR = New ShapeRange
   ActiveDocument.ReferencePoint = cdrCenter
   For Each sh In sr
'      sh.GetBoundingBox x, y, w, h
        sh.GetPosition x, y
      With AgentSmith.TreeNode.GetCopy
         .VirtualShape.RotationAngle = sh.RotationAngle
'         .VirtualShape.SetBoundingBox x, y, w, h, KeepAspect:=True
            .VirtualShape.SetPosition x, y
         .LinkAsChildOf sh.Layer.TreeNode
         VSR.Add .VirtualShape
      End With
   Next
  
   ActiveDocument.LogCreateShapeRange VSR
   sr.Delete ' evaporate originally selected shapes
End Sub

справитесь с заменой кода?
 
  • Спасибо
Реакции: Elvis_44 и _MBK_
E

Elvis_44

Участник
Топикстартер
Сообщения
31
Реакции
0
dastin сказал(а):
так и было задумано автором - сохранять размер и угол поворота исходного объекта
...
ниже текст макроса с изменениями - в центр каждой "точки будет поставлен ваш объект подмены - НО!!! ВСЕ объекты будут одинаковы

вместо BoundingBox - только Position
...
Код: 
Sub scatter()
   Dim sh As Shape, sr As ShapeRange, x#, y#, w#, h#, i&
   Dim AgentSmith As Shape, VSR As ShapeRange
 
   If ActiveDocument Is Nothing Then Exit Sub
   Set sr = ActiveSelection.Shapes.FindShapes()
   If sr.Count = 0 Then
      MsgBox "Select target objects, invoke the macro, click Agent Smith shape"
      Exit Sub
   End If
   If ActiveDocument.GetUserClick(x, y, i, -1, Snap:=False, CursorShape:=313) Then _
      Exit Sub
 
   With ActivePage.SelectShapesAtPoint(x, y, SelectUnfilled:=True)
      If .Shapes.Count = 0 Then Beep: Exit Sub
      Set AgentSmith = .Shapes(.Shapes.Count)
   End With

   Set VSR = New ShapeRange
   ActiveDocument.ReferencePoint = cdrCenter
   For Each sh In sr
'      sh.GetBoundingBox x, y, w, h
        sh.GetPosition x, y
      With AgentSmith.TreeNode.GetCopy
         .VirtualShape.RotationAngle = sh.RotationAngle
'         .VirtualShape.SetBoundingBox x, y, w, h, KeepAspect:=True
            .VirtualShape.SetPosition x, y
         .LinkAsChildOf sh.Layer.TreeNode
         VSR.Add .VirtualShape
      End With
   Next
 
   ActiveDocument.LogCreateShapeRange VSR
   sr.Delete ' evaporate originally selected shapes
End Sub

справитесь с заменой кода?
Нажмите, чтобы раскрыть...

Одинаковые и нужно ) спасибо, уже с работы уехал, дома попробую
 
E

Elvis_44

Участник
Топикстартер
Сообщения
31
Реакции
0
dastin сказал(а):
так и было задумано автором - сохранять размер и угол поворота исходного объекта
...
ниже текст макроса с изменениями - в центр каждой "точки будет поставлен ваш объект подмены - НО!!! ВСЕ объекты будут одинаковы

вместо BoundingBox - только Position
...
Код: 
Sub scatter()
   Dim sh As Shape, sr As ShapeRange, x#, y#, w#, h#, i&
   Dim AgentSmith As Shape, VSR As ShapeRange
 
   If ActiveDocument Is Nothing Then Exit Sub
   Set sr = ActiveSelection.Shapes.FindShapes()
   If sr.Count = 0 Then
      MsgBox "Select target objects, invoke the macro, click Agent Smith shape"
      Exit Sub
   End If
   If ActiveDocument.GetUserClick(x, y, i, -1, Snap:=False, CursorShape:=313) Then _
      Exit Sub
 
   With ActivePage.SelectShapesAtPoint(x, y, SelectUnfilled:=True)
      If .Shapes.Count = 0 Then Beep: Exit Sub
      Set AgentSmith = .Shapes(.Shapes.Count)
   End With

   Set VSR = New ShapeRange
   ActiveDocument.ReferencePoint = cdrCenter
   For Each sh In sr
'      sh.GetBoundingBox x, y, w, h
        sh.GetPosition x, y
      With AgentSmith.TreeNode.GetCopy
         .VirtualShape.RotationAngle = sh.RotationAngle
'         .VirtualShape.SetBoundingBox x, y, w, h, KeepAspect:=True
            .VirtualShape.SetPosition x, y
         .LinkAsChildOf sh.Layer.TreeNode
         VSR.Add .VirtualShape
      End With
   Next
 
   ActiveDocument.LogCreateShapeRange VSR
   sr.Delete ' evaporate originally selected shapes
End Sub

справитесь с заменой кода?
Нажмите, чтобы раскрыть...

Всё работает, спасибо ) эти пара кликов очень автоматизируют рабочий процесс )
 
DukereD

DukereD

макрософил
Сообщения
462
Реакции
114
Поделюсь своим кодом которым я меняю выделенные объекты на мастер объект (определенный заранее)

Код: 
    doc.BeginCommandGroup
    ps = Array(1)
    If num_list.Value Then
        Set OS = ActivePage.Shapes
    ElseIf num_doc.Value Then
        Set ps = doc.pages
    Else
        Set OS = ActiveSelectionRange.Shapes
    End If
    uc = 0
    For Each pp In ps
        If num_doc.Value Then Set OS = pp.Shapes
        If ch_last_master.Value Then Set Master = OS.First

        For Each s In OS
            If Not Master Is Nothing And Not s Is Master Then
                Set s1 = Master.Duplicate
                If mkrotate.Value Then s1.RotationAngle = s.RotationAngle
                If by_tl.Value Then
                    s1.LeftX = s.LeftX
                    s1.TopY = s.TopY
                ElseIf by_tc.Value Then
                    s1.CenterX = s.CenterX
                    s1.TopY = s.TopY
                ElseIf by_tr.Value Then
                    s1.RightX = s.RightX
                    s1.TopY = s.TopY
                ElseIf by_cl.Value Then
                    s1.LeftX = s.LeftX
                    s1.CenterY = s.CenterY
                ElseIf by_cc.Value Then
                    s1.CenterX = s.CenterX
                    s1.CenterY = s.CenterY
                ElseIf by_cr.Value Then
                    s1.RightX = s.RightX
                    s1.CenterY = s.CenterY
                ElseIf by_bl.Value Then
                    s1.LeftX = s.LeftX
                    s1.BottomY = s.BottomY
                ElseIf by_bc.Value Then
                    s1.CenterX = s.CenterX
                    s1.BottomY = s.BottomY
                ElseIf by_br.Value Then
                    s1.RightX = s.RightX
                    s1.BottomY = s.BottomY
                End If
                If mkdel.Value Then s.Delete
                uc = uc + 4
            End If
        Next s
    Next pp
    doc.EndCommandGroup
    uc = 1
 
Для ответа нужно войти/зарегистрироваться
Верх Низ