Пройтись по Shapes("Rectangle 2") всех листов презентации

@Gepar · Регистрация: 01.07.2009

Студворк — интернет-сервис помощи студентам

Нужно как-то пройтись по всех Shapes("Rectangle 2"), те по заголовочным формам, всех листов открытой презентации.
Я могу это сделать так в цикле

Visual Basic
1
2
    ActiveWindow.View.GotoSlide Index:= i 
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select

Но это ведь оно будет мигать, мигать, мигать и потом ещё мигать, мигать, мигать. Так как задание у меня не включает сделать гипно-макрос то как мне добраться к каждому заголовку что есть в моём документе и получить его значение в виде текста?

@ironegg · 17.12.2011, 06:24

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

Visual Basic
1
2
3
4
5
Application.ScreenUpdating = False
'...
    Application.ScreenRefresh  'если требуется
'...
Application.ScreenUpdating = True

@Busine2012 · 17.12.2011, 07:54

Gepar,
выложите образец файла и поясните, что нужно.

@Gepar · 17.12.2011, 14:15 **[ТС]**

ironegg, ну на худой конец и так можно, но это наверное всё же быдло код, наверняка должна быть возможность получать значения заголовков из листов.
Busine2012, прикладываю пример (ppt файл от 2003его офиса), в нём я планирую создавать содержание слайда по заголовкам слайдов, заголовками соответственно в данном случае являются "Первый слайд" ... "Двенадцатый слайд". Макрос my пока что только вставляет новый слайд после первого, пишет в заголовок "Содержание" и переводит курсор на второе поле.

@Gepar · 17.12.2011, 19:28 **[ТС]**

Хотя с этим уже разобрался

Visual Basic
1
2
3
    For i = 1 To SlideCount
        str = str + ActivePresentation.Slides(i).Shapes.Title.TextFrame.TextRange.Text + Chr(13)
    Next

По идеи только моё содержание должно бы вставлять всё это в приемлимом виде чтобы можно было кликнуть по ссылке и перейти к нужному слайду наверное ...

Добавлено через 8 минут
Теперь возникла задача: как определить если ли заголовок (Shapes.Title) на странице, так как если его нет то мой цикл не завершиться.

Добавлено через 42 минуты
Нашёл что есть ActivePresentation.Slides(3).Shapes.Coun t но мне нужно узнавать ведь именно есть ли Title, а count для Title нету чего-то.

Добавлено через 3 часа 58 минут
Помогите пожалуйста, мне ведь надо как-то узнавать есть ли фигура Title на странице с текстом или нет её, сам я разобраться с этим не могу

@Busine2012 · 17.12.2011, 21:42

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Sub My()
 
    Dim SlideCount As Integer 'количество слайдов
    Dim i As Integer
    Dim Прототип As PowerPoint.Shape
    'Чтобы короче писать код, обращаться ко второму слайду к прототипу "Rectangle 3"
    'будем через переменную.
    Dim Содержание As PowerPoint.TextRange
    
    
    'создать новый слайд номер 2.
    ActivePresentation.Slides.Add Index:=2, Layout:=ppLayoutText
    'помещаем в переменную количество слайдов в активной презентации.
    SlideCount = ActivePresentation.Slides.Count
    'написать на втором слайде в первом прототипе "Содержание".
    With ActivePresentation.Slides(2).Shapes("Rectangle 2").TextFrame.TextRange
        .Text = "Содержание"
        With .Font
            .Name = "Arial"
            .Size = 44
            .Bold = msoFalse
            .Italic = msoFalse
            .Underline = msoFalse
            .Shadow = msoFalse
            .Emboss = msoFalse
            .BaselineOffset = 0
            .AutoRotateNumbers = msoFalse
            .Color.SchemeColor = ppTitle
        End With
    End With
    'вставка на второй слайд в прототип "Rectangle 3" заголовков со всей
    'активной презентации, начиная с 3 слайда.
    Set Содержание = ActivePresentation.Slides(2).Shapes("Rectangle 3").TextFrame.TextRange
    For i = 3 To SlideCount Step 1
        For Each Прототип In ActivePresentation.Slides(i).Shapes
            If Прототип.Name = "Rectangle 2" Then
                Содержание.InsertAfter.Text = Прототип.TextFrame.TextRange.Text & _
                     Chr(9) & i & Chr(13)
                'остальные прототипы не просматриваем, чтобы время сэкономить, т.к.
                'имена прототипов уникальные и 2 раза не встретиться прототип
                '"Rectangle 3".
                Exit For
            End If
        Next Прототип
    Next i
    'просто сообщение, что работа сделана.
    MsgBox "Работа сделана", vbInformation
End Sub

По гиперссылкам недостаточно информации в справке.
Чтобы посмотреть код по гиперссылкам, воспользуйтесь макрорекордером.

@Gepar · 18.12.2011, 04:02 **[ТС]**

Busine2012, спасибо, по ссылкам я посмотрел как они делаются, осталось придумать как их каждый раз вставлять в цикле.

Добавлено через 5 часов 21 минуту
Busine2012, забыли добавить проверку что в "Rectangle 2" есть текст, хотя это не столь важно и я могу сделать это сам. Ещё выглядит не совсем хорошо в плане форматирования так как длины заголовков то разные бывают, сделать бы формат как в word при добавлении оглавления когда страницы добавляются в конец текущей строки после точек (.....), ну да это в принципе потом уже можно будет баловаться с этим. Моё задание ещё требует не только создание оглавления, но и возможность выбора типов заголовков и возможности включения заметок к слайдам в содержание, это как?
Также не могу никак заставить вставляться гиперлинки, если обращаться напрямую к моему содержанию то каждое новое добавление гиперлинка затирает предыдущее и в итоге отаётся только последнее добавление.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Sub My2()
 
    Dim SlideCount As Integer 'количество слайдов
    Dim i As Integer
    Dim Прототип As PowerPoint.Shape
    'Чтобы короче писать код, обращаться ко второму слайду к прототипу "Rectangle 3"
    'будем через переменную.
    Dim Содержание As PowerPoint.TextRange
    
    
    'создать новый слайд номер 2.
    ActivePresentation.Slides.Add Index:=2, Layout:=ppLayoutText
    'помещаем в переменную количество слайдов в активной презентации.
    SlideCount = ActivePresentation.Slides.Count
    'написать на втором слайде в первом прототипе "Содержание".
    With ActivePresentation.Slides(2).Shapes("Rectangle 2").TextFrame.TextRange
        .Text = "Содержание"
        With .Font
            .Name = "Arial"
            .Size = 44
            .Bold = msoFalse
            .Italic = msoFalse
            .Underline = msoFalse
            .Shadow = msoFalse
            .Emboss = msoFalse
            .BaselineOffset = 0
            .AutoRotateNumbers = msoFalse
            .Color.SchemeColor = ppTitle
        End With
    End With
    'вставка на второй слайд в прототип "Rectangle 3" заголовков со всей
    'активной презентации, начиная с 3 слайда.
    Set Содержание = ActivePresentation.Slides(2).Shapes("Rectangle 3").TextFrame.TextRange
    For i = 3 To SlideCount Step 1
        For Each Прототип In ActivePresentation.Slides(i).Shapes
            If Прототип.Name = "Rectangle 2" And Прототип.TextFrame.TextRange.Text <> "" Then
                Содержание.InsertAfter.Text = Прототип.TextFrame.TextRange.Text & _
                     Chr(9) & i & Chr(13)
                    With Содержание.PasteSpecial.ActionSettings(ppMouseClick).Hyperlink
                        .Address = ""
                        .SubAddress = Прототип.TextFrame.TextRange.Text
                        .ScreenTip = ""
                        .TextToDisplay = Прототип.TextFrame.TextRange.Text & _
                     Chr(9) & i & Chr(13)
                    End With
'                    Содержание.PasteSpecial.ActionSettings.Item.Hyperlink.
                'остальные прототипы не просматриваем, чтобы время сэкономить, т.к.
                'имена прототипов уникальные и 2 раза не встретиться прототип
                '"Rectangle 3".
                Exit For
            End If
        Next Прототип
    Next i
    'просто сообщение, что работа сделана.
    MsgBox "Работа сделана", vbInformation
End Sub

@Busine2012 · 18.12.2011, 14:18

Gepar,
в PowerPoint два способа перехода по гиперссылкам:

можно ходить во время слайд-шоу;
через контекстное меню в обычном режиме. Чтобы вызывать контекстное меню - нужно щ. правой кн. мыши по гиперссылке.

Прихожу к выводу (не связано с тем, что я писал выше), что переход к конкретному слайду возможен только, если на слайде есть титульный прототип.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Sub My2()
 
    Dim i As Integer
    Dim Прототип As PowerPoint.Shape
    'Чтобы короче писать код, обращаться ко второму слайду к прототипу "Rectangle 3"
    'будем через переменную.
    Dim Содержание As PowerPoint.TextRange
    
    
    'создать новый слайд номер 2.
    ActivePresentation.Slides.Add Index:=2, Layout:=ppLayoutText
    'написать на втором слайде в первом прототипе "Содержание".
    With ActivePresentation.Slides(2).Shapes("Rectangle 2").TextFrame.TextRange
        .Text = "Содержание"
        With .Font
            .Name = "Arial"
            .Size = 44
            .Bold = msoFalse
            .Italic = msoFalse
            .Underline = msoFalse
            .Shadow = msoFalse
            .Emboss = msoFalse
            .BaselineOffset = 0
            .AutoRotateNumbers = msoFalse
            .Color.SchemeColor = ppTitle
        End With
    End With
    'вставка на второй слайд в прототип "Rectangle 3" заголовков со всей
    'активной презентации, начиная с 3 слайда.
    Set Содержание = ActivePresentation.Slides(2).Shapes("Rectangle 3").TextFrame.TextRange
    For i = 3 To ActivePresentation.Slides.Count Step 1
        For Each Прототип In ActivePresentation.Slides(i).Shapes
            'если прототип имеет имя "Rectangle 2" и может содержать текст, то
            If Прототип.Name = "Rectangle 2" And Прототип.HasTextFrame Then
                'если в прототипе нет текста (вдруг только пробелы есть), то.
                If Trim(Прототип.TextFrame.TextRange.Text) <> "" Then
                    'Вставить гиперссылку можно только к определённому тексту,
                    'поэтому сначала просто текст вставляем, а затем создаём
                    'на его основе гиперссылку.
                    Содержание.InsertAfter.Text = Прототип.TextFrame.TextRange.Text
                    'Теперь вставляем гиперссылку.
                    With Содержание.Paragraphs(Содержание.Paragraphs.Count).ActionSettings(ppMouseClick).Hyperlink
                        .Address = ""
                        .SubAddress = "," & CStr(i) & ","
                        .ScreenTip = ""
                        .TextToDisplay = Прототип.TextFrame.TextRange.Text & Chr(9) & i & Chr(13)
                    End With
                    'остальные прототипы не просматриваем, чтобы время сэкономить, т.к.
                    'имена прототипов уникальные и 2 раза не встретиться прототип "Rectangle 3".
                    Exit For
                End If
            End If
        Next Прототип
    Next i
    'просто сообщение, что работа сделана.
    MsgBox "Работа сделана", vbInformation
End Sub

Сообщение от Gepar

возможность выбора типов заголовков и возможности включения заметок к слайдам в содержание

выложите презентацию, как это должно выглядеть.

Сообщение от Gepar

после точек (.....)

пока прихожу к выводу, что такие точки нельзя сделать в PowerPoint.

Остаётся использовать обычные точки (как при нажатии на клавишу Точка на клавиатуре).

@Gepar · 18.12.2011, 15:22 **[ТС]**

Сообщение от Busine2012

выложите презентацию, как это должно выглядеть.

Если бы я знал как, задание только в текстовом виде, в пн. уточню у преподавателя чтобы он показал тогда что именно он хотел делая эту приписку. Ссылки теперь вставляются корректно, а точки (....) я вообще вставлять хотел чисто с эстетической точки зрения чтобы номера страниц писались на одном уровне справа, хотя можно бы наверное поэкспериментировать с длиной строки, что-то типа вставки точек в цикле For i=1 To 20-Len(тайтла) Then.

Добавлено через 23 минуты
А нет, не получиться этот фокус с точечками так как из-за различных размеров букв в шрифте оно всё равно сдвиг получается приличный и страницы всё равно выходят не на одном уровне справа.

@Busine2012 · 18.12.2011, 15:32

Gepar,
надо максимально подстраиваться под программу и если нет возможности использовать что-то, то нужно принять программу такой, какая есть.

В данном случае рационально отказаться от точек.

К тому же, на первом месте всё-таки важна информация в документах: когда вы читаете какую-нибудь инструкцию к купленной технике, то вряд ли вы даже задумаетесь об этих точках.
За собой такое наблюдал.

Появилась идея использовать таблицу, состоящую из двух столбцов. В первом столбце будут заголовки, а во втором - номера страниц.

Но надо на опыте реализовать эту идею.

@Gepar · 18.12.2011, 16:36 **[ТС]**

Сообщение от Busine2012

Появилась идея использовать таблицу, состоящую из двух столбцов. В первом столбце будут заголовки, а во втором - номера страниц.
Но надо на опыте реализовать эту идею.

Меня такая идея тоже в начале посещала, но оно что-то когда текст в две колонки формируешь то объекты Rectangle рандомно начинают нумероваться на странице то 3,4, 5 то 4,5,6. Ладно, оставлю пока эту затею и буду думать о том как отформатировать всё в две колонки только если преподаватель потребует это сделать.

Добавлено через 1 минуту
Преподавателю я задание должен показывать завтра так что ждать долго не придётся, хотя он небось потребует добавить ещё тот выбор заголовков его, но пускай с начала объяснит что он имел в виду под этим.

@Busine2012 · 18.12.2011, 16:51

Вот работа с таблицей без циклов (ключевые моменты).
Перед тестированием кода - создайте слайд два.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Процедура1()
'Ширина и высота в пунктах.
Dim Прототип As PowerPoint.Shape
Dim Строка As PowerPoint.Row
ActivePresentation.Slides(2).Shapes("Rectangle 3").Delete
Set Прототип = ActivePresentation.Slides(2).Shapes.AddTable(NumRows:=1, NumColumns:=2, Left:=36.875, Top:=126, Width:=648)
With Прототип.Table
    With .Rows(1)
        .Height = 30
    End With
    With .Columns(2)
        .Width = 50
    End With
End With
Прототип.Width = 648
With Прототип.Table
    'Добавление строки в таблицу.
    Set Строка = .Rows.Add(BeforeRow:=-1)
    'Помещение в новую строку текста.
    Строка.Cells(1).Shape.TextFrame.TextRange.Text = "Заголовок"
    Строка.Cells(2).Shape.TextFrame.TextRange.Text = CStr(1)
End With
End Sub

Новые блоги и статьи Все статьи Все блоги /
Автозаполнение реквизита при выборе элемента справочника Maks 27.03.2026 Программный код из решения ниже на примере нетипового документа "ЗаявкаНаРемонтСпецтехники" разработанного в конфигурации КА2. При выборе "Спецтехники" (Тип Справочник. Спецтехника), заполняется. . .	Сумматор с применением элементов трёх состояний. Hrethgir 26.03.2026 Тут. https:/ / fips. ru/ EGD/ ab3c85c8-836d-4866-871b-c2f0c5d77fbc Первый документ красиво выглядит, но без схемы. Это конечно не даёт никаких плюсов автору, но тем не менее. . . всё может быть. . .	Автозаполнение реквизитов при создании документа Maks 26.03.2026 Программный код из решения ниже размещается в модуле объекта документа, в процедуре "ПриСозданииНаСервере". Алгоритм проверки заполнения реализован для исключения перезаписи значения реквизита,. . .	Команды формы и диалоговое окно Maks 26.03.2026 1. Команда формы "ЗаполнитьЗапчасти". Программный код из решения ниже на примере нетипового документа "ЗаявкаНаРемонтСпецтехники" разработанного в конфигурации КА2. В качестве источника данных. . .
Кому нужен AOT? DevAlt 26.03.2026 Решил сделать простой ланчер Написал заготовку: dotnet new console --aot -o UrlHandler var items = args. Split(":"); var tag = items; var id = items; var executable = args;. . .	Отправка уведомления на почту при создании или изменении элементов справочника Maks 24.03.2026 Программная отправка письма электронной почты на примере типового справочника "Склады" в конфигурации БП3. Перед реализацией необходимо выполнить настройку системной учетной записи электронной. . .	модель ЗдравоСохранения 5. Меньше увольнений- больше дохода! anaschu 24.03.2026 Теперь система здравосохранения уменьшает количество увольнений. 9TO2GP2bpX4 a42b81fb172ffc12ca589c7898261ccb/ https:/ / rutube. ru/ video/ a42b81fb172ffc12ca589c7898261ccb/ Слева синяя линия -. . .	Midnight Chicago Blues kumehtar 24.03.2026 Такой Midnight Chicago Blues, знаешь?. . Когда вечерние улицы становятся ночными, а ты не можешь уснуть. Ты идёшь в любимый старый бар, и бармен наливает тебе виски. Ты смотришь на пролетающие. . .

@Busine2012 1302 / 404 / 22 Регистрация: 21.10.2011 Сообщений: 1,285
	17.12.2011, 07:54
	Gepar, выложите образец файла и поясните, что нужно. 0

@Busine2012 1302 / 404 / 22 Регистрация: 21.10.2011 Сообщений: 1,285
	18.12.2011, 15:32
	Gepar, надо максимально подстраиваться под программу и если нет возможности использовать что-то, то нужно принять программу такой, какая есть. В данном случае рационально отказаться от точек. К тому же, на первом месте всё-таки важна информация в документах: когда вы читаете какую-нибудь инструкцию к купленной технике, то вряд ли вы даже задумаетесь об этих точках. За собой такое наблюдал. Появилась идея использовать таблицу, состоящую из двух столбцов. В первом столбце будут заголовки, а во втором - номера страниц. Но надо на опыте реализовать эту идею. 1