Office: (Office 2016) PowerPoint VBA Inhaltsverzeichnis mit Abschnitten in hinterste Folie schreiben

Hallo werte Community

Ich habe nun bereits mehr als einen ganzen Arbeitstag mit der Suche nach dem richtigen VBA-Code (respektive Bausteinen dafür) verbracht (kenne mich eigentlich nur mit Excel-VBA ein wenig aus). Völlig verzweifelt wende ich mich nun an euch..!

Herausforderung (um nicht Problem zu sagen):
- Das Makro soll mir ein Inhaltsverzeichnis im einzigen Textfeld der letzten Folie erstellen;
- Es sollen die Namen der Abschnitte eingefügt werden;
- Bei den jeweiligen Positionen der aufgelisteten Abschnitte soll ein Hyperlink hinterlegt werden, der immer auf die erste Folie des jeweiligen Abschnitts verlinkt ist;

Informationen zur Datei:
- Die Datei soll "unendlich" erweiterbar sein, also keinen Code wie: "mach das bei den ersten 5 Abschnitten"
- Die Namen der Abschnitte können variieren. D.h. dass jede potentielle Zeichenabfolge als Name vorkommen kann.


Ihr seid meine letzte Hoffnung, deshalb drücke ich mir mal selbst die Daumen, dass die richtigen Personen meinen Eintrag sehen :)

Liebe Grüsse

Pascal

 

Hallo zusammen

Nach einem erholsamen Wochenende habe ich mich nochmals hochkonzentriert dahinter gesetzt.
Das Ergebnis: Ich hab's geschafft! :D

Hier die Lösung dazu:

Code:

Sub TableOfContent()
'*** Copyright by Pascal Mario Richard, 2017-06-26 ***

Dim i As Long

x = 2 'Agenda-Slide
lsp = ActivePresentation.SectionProperties.count 'No. of sections
L = 1 'first line in shape

'Read and write section titles
With Application.ActivePresentation.SectionProperties
    For i = 1 To lsp
        If i < 2 Then
            ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange.Text = ActivePresentation.SectionProperties.Name(i) & vbCrLf
        Else
                a = ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange
                b = ActivePresentation.SectionProperties.Name(i) & vbCrLf
                ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange.Text = a & b
        End If
    Next i
End With

'Insert hyperlinks
Do
        With ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange.Lines(L).ActionSettings(ppMouseClick)
            .Action = ppActionHyperlink
            .Hyperlink.Address = ""
            .Hyperlink.SubAddress = ActivePresentation.SectionProperties.FirstSlide(L)
        End With
    i = i + 1
    L = L + 1
Loop Until L = lsp + 1

End Sub

 

Hallo,
ich würde das Marko auch gern für meine Präsentation nutzen. Wie kann ich es umbauen das es bei mir auch geht?
Danke im Voraus.

beste grüße lars

 

Hallo Lars
Dafür müsste ich wohl kurz einen Blick in deine Datei werfen.
Hast du denn bereits Abschnitte hinzugefügt und umbenannt?


Grüsse
Pascal

 

Hallo,
ja habe ich eingefügt.

Wie kann ich die Datei dir zuschicken?

Geht das nur über die Abschnitte oder kann man es auch über die Titel erzeugen alles?
Grüße Lars

 

Ja, es funktioniert nur über die Abschnitte. Über Titel hatte ich damals auch probiert, habe es aber nicht hingekriegt.
Über die Abschnitte ist es aber sowieso sauberer in Sachen Gliederung.

Du hast eine PN erhalten mit meiner Mail.
Grüsse
Pascal

 

Hallo Lars
Danke fürs Zusenden deiner Datei.
Lösche in deinem Makro die oberste Zeile (Option Explicit) und entferne ausserdem die folgende Passage:
'control As IRibbonControl)
--> ich habe den Code oben entsprechend angepasst.

Danach sollte es funktionieren (bei mir hat es das jedenfalls).

Am Ende bloss noch die Variable x anpassen (=Foliennummer, wo du das Inhaltsverzeichnis haben willst --> 1 = erste Folie / 2 = zweite Folie / etc.).

Grüsse
Pascal

 

Hallo Pacal,

es funktioniert in der Datei die du mir geschickt hast.

Frage:
- das es sich Automatisch aktualisiert ist das möglich?
- kann man einbauen das eine Gleiderung 1,2,3 etc. der Abschnitte als Inhaktsverzeichnis kommen?

Danke im Voraus.
Gruß Lars

 

Hallo Lars

Zu deinen Fragen:
- Du kannst das Makro meines Wissens ans Starten, Schliessen oder Speichern koppeln, weiss aber gerade nicht wie das funktioniert (zu lange her ;-) )
- Sollte eigentlich möglich sein. Dazu müsstest du in der folgenden Codezeile vor "a & b" noch eine Variable einfügen. "ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange.Text = a & b"
--> beispielsweise Nr & a & b (die Variable Nr natürlich auch noch sauber definieren. Schaffst du bestimmt auch selbst)

Grüsse
Pascal

 

Hallo, Pascal,

mit der (die Variable Nr natürlich auch noch sauber definieren. Schaffst du bestimmt auch selbst) bin ich leider nicht so fit :-(
Kannst du mri da Helfen?

 

Hallo Lars

Klar, hier der angepasste Code.
War dann doch leicht anders, als ich auf den ersten Blick vermutet hatte.

Code:

Sub TableOfContent()
'*** Copyright by Pascal Mario Richard, 2017-06-26 ***

Dim i As Long

x = 2 'Agenda-Slide
lsp = ActivePresentation.SectionProperties.Count 'No. of sections
L = 1 'first line in shape

'Read and write section titles
With Application.ActivePresentation.SectionProperties
    For i = 1 To lsp
        If i < 2 Then
            ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange.Text = ActivePresentation.SectionProperties.Name(i) & vbCrLf
        Else
                a = ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange
                b = ActivePresentation.SectionProperties.Name(i) & vbCrLf
                ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange.Text = a & i & " " & b
        End If
    Next i
    ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange.Text = "1 " & a & i - 1 & " " & b
End With

'Insert hyperlinks
Do
        With ActivePresentation.Slides(x).Shapes(1).TextFrame.TextRange.Lines(L).ActionSettings(ppMouseClick)
            .Action = ppActionHyperlink
            .Hyperlink.Address = ""
            .Hyperlink.SubAddress = ActivePresentation.SectionProperties.FirstSlide(L)
        End With
    i = i + 1
    L = L + 1
Loop Until L = lsp + 1

End Sub

Grüsse
Pascal

 

Danke sehr Pascal :-)