Несколько полезных макросов

[dizzy]

На днях перешел работать в типографию... Достались спуски с визитками... Запарился их подгонять, тусовать и прочее... В общем набросал кое че:

Меняет два выделеных объекта местами:

Sub Menyaem()
Dim myShape1 As Shape, myShape2 As Shape, X1 As Double, Y1 As Double, X2 As Double, Y2 As Double
If Documents.Count = 0 Then
    MsgBox "Нет открытых доков"
    GoTo myEnd
End If
If ActiveSelection.Shapes.Count <> 2 Then
    MsgBox "Выберите только два объекта"
    GoTo myEnd
End If
Set myShape1 = ActiveSelection.Shapes(1)
Set myShape2 = ActiveSelection.Shapes(2)
myShape1.GetPosition X1, Y1
myShape2.GetPosition X2, Y2
myShape2.SetPosition X1, Y1
myShape1.SetPosition X2, Y2
myEnd:
End Sub

Подгон выделеных объектов стык в стык по вертикали и горизонтали соответственно:

Sub stykovka_vert()
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrTopLeft
Dim Sh() As mySh
N = ActiveSelection.Shapes.Count
ReDim Sh(1 To N)
For i = 1 To N
    Set Sh(i).mySh = ActiveSelection.Shapes(i)
    Sh(i).mySh.GetPosition Sh(i).X, Sh(i).Y
    Sh(i).mySh.GetSize Sh(i).w, Sh(i).h
    Sh(i).number = 0
Next i

Max = 1

For i = 1 To N
    For J = 1 To N
        If Sh(J).number = 0 Then
            If Sh(J).Y > Sh(Max).Y Then Max = J
        End If
    Next J
    Sh(Max).number = i
    If i <> 1 Then
        Sh(Max).Y = myTop
        Sh(Max).mySh.SetPosition Sh(Max).X, Sh(Max).Y
    End If
    myTop = Sh(Max).Y - Sh(Max).h
    For J = 1 To N
        If Sh(J).number = 0 Then
            Max = J
            Exit For
        End If
    Next J
        
Next i
End Sub
Sub stykovka_horiz()
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrTopLeft
Dim Sh() As mySh
N = ActiveSelection.Shapes.Count
ReDim Sh(1 To N)
For i = 1 To N
    Set Sh(i).mySh = ActiveSelection.Shapes(i)
    Sh(i).mySh.GetPosition Sh(i).X, Sh(i).Y
    Sh(i).mySh.GetSize Sh(i).w, Sh(i).h
    Sh(i).number = 0
Next i

Max = 1

For i = 1 To N
    For J = 1 To N
        If Sh(J).number = 0 Then
            If Sh(J).X < Sh(Max).X Then Max = J
        End If
    Next J
    Sh(Max).number = i
    If i <> 1 Then
        Sh(Max).X = myLeft
        Sh(Max).mySh.SetPosition Sh(Max).X, Sh(Max).Y
    End If
    myLeft = Sh(Max).X + Sh(Max).w
    For J = 1 To N
        If Sh(J).number = 0 Then
            Max = J
            Exit For
        End If
    Next J
        
Next i
End Sub

Еще в кореле в одном доке колонтитулы с номерами страниц как попало раскиданы были. Чтоб не вбивать числа местоположения каждой сделал два макроса. Один метит выбранный объект, а другой выбранный объект подгоняет по местоположению под меченый... Может тоже кому пригодится:

Sub Metim()
If Documents.Count = 0 Then
    MsgBox "Нет открытых доков"
    GoTo myEnd
End If
If ActiveSelection.Shapes.Count <> 1 Then
    MsgBox "Выберите тока один объект"
    GoTo myEnd
End If
Set mySh = ActiveShape
myEnd:
End Sub

Sub Stavim()
ActiveDocument.ReferencePoint = cdrTopLeft
ActiveShape.SetPosition mySh.PositionX, mySh.PositionY
End Sub

 

[lev]

Ответ: Несколько полезных макросов

dizzy , просьба, переписать данную тему в три разных, чтобы каждый макрос можно было бы обсуждать отдельно. Я мог бы это сделать и сам, но тогда автором топиков стану считаться я, чего мне не хочется. А пока тема закрывается, чтобы не было каши.