Word-Dokument seitenweise in Powerpoint-Notizenseite speichern

Ein Word-Dokument seitenweise in eine Powerpoint-Notizenseite speichern.
PlaceholderFormat.Type = ppPlaceholderBody
Das folgende Makro speichert jede einzelne Seite eines geöffneten (aktiven)
Word-Dokumentes in eine Powerpoint-Notizenseite ab.
Hinweis: Verweis auf Microsoft Word Object Library muss im Projekt gesetzt werden.
Function JedeSeiteInNeuesDokument()
Dim wdDocum As Word.Document 'Aktives Word-Dokument
Dim wdRange As Word.Range 'Worddokument-Bereich
Dim wdSeitn As Integer 'Anzahl Seiten Worddokument
Dim ppFolie As Integer 'Anzahl Folien Powerpoint
Dim ppPlace As Integer 'Anzahl Placeholder PP
Dim wd As Integer 'Zähler Word
Dim pp As Integer 'Zähler PP
Dim p2 As Integer 'Zähler PP
'Das Word-Dokument muss aktiv sein; die Ansicht spielt keine Rolle.
'Bei mehreren geöffneten Dokumenten zählt das vordere Fenster;
'das Fenster kann auch minimiert sein...
'Verweis auf Word-Dokument setzen
On Error GoTo ende
Set wdDocum = Word.ActiveDocument
On Error GoTo 0
'Cursor zum Anfang des Word-Dokuments
wdDocum.Range(0, 0).Select
'Word-Browser-Eigenschaft einstellen ("Nach Seite durchsuchen")
Word.Application.Browser.Target = wdBrowsePage
'Anzahl Seiten ermitteln
wdSeitn = wdDocum.ComputeStatistics(wdStatisticPages)
ppFolie = ActivePresentation.Slides.Count
'Möglichkeit, vorher alle Placeholder zu löschen (zum Testen)
' Call Placeholder_Loeschen
'Powerpoint-Ansicht umschalten
ActiveWindow.ViewType = ppViewNotesPage
'Los gehts...
For wd = 1 To wdSeitn
'Verweis auf den zu kopierenden Word-Bereich setzen
Set wdRange = wdDocum.Bookmarks("\Page").Range
VBA.DoEvents
'Den zu kopierenden Word-Bereich überprüfen, ob Seitenwechsel dabei ist
If Right(wdRange.Text, 1) = Chr(12) Then
wdRange.SetRange Start:=wdRange.Start, End:=wdRange.End - 1
End If
ActiveWindow.View.GotoSlide Index:=wd
'prüfen, ob überhaupt ein Placeholder vorhanden ist
ppPlace = ActivePresentation.Slides(wd).NotesPage.Shapes.Placeholders.Count
If ppPlace = 0 Then
'wenn nein, dann PlaceholderBody einfügen
ActiveWindow.Selection.SlideRange.Shapes.AddPlaceholder _
(PowerPoint.PpPlaceholderType.ppPlaceholderBody)
End If
For pp = 1 To ActivePresentation.Slides(wd).NotesPage.Shapes.Placeholders.Count
With ActivePresentation.Slides(wd).NotesPage.Shapes
If .Placeholders(pp).HasTextFrame Then
'neuen Text einfügen nur möglich, wenn der PlaceholderBody vorhanden war!
.Placeholders(pp).TextFrame.TextRange.Text = wdRange.FormattedText
VBA.DoEvents
Else
'Problem: Text einfügen (überschreiben) geht nur, wenn vorher schon Text
'drin war bzw. ein Rahmen existiert (PlaceholderBody)
'...das geht nur mit Fummelei und Fehlermeldung ausschalten...
On Error Resume Next
'PlaceholderBody einfügen
ActiveWindow.Selection.SlideRange.Shapes.AddPlaceholder _
(PowerPoint.PpPlaceholderType.ppPlaceholderBody)
VBA.DoEvents
''' .Placeholders(pp + 1).Select 'wird sowieso selektiert...
'jetzt neuen Text einfügen (und Zähler manuell erhöhen !)
.Placeholders(pp + 1).TextFrame.TextRange.Text = wdRange.FormattedText
On Error GoTo 0
End If
End With
Next pp
'Wenn Word-Seiten größer als PP-Folienzahl, dann neue Folie einfügen
p2 = ActivePresentation.Slides.Count
If wd = p2 And wdSeitn > ppFolie Then
' ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add(Index:=11, _
Layout:=ppLayoutTable).SlideIndex
ActiveWindow.View.GotoSlide _
Index:=ActiveWindow.Selection.SlideRange.Parent.Duplicate.SlideIndex
End If
''' 'Schleife verlassen (wenn Word-Seiten größer als PP-Folienzahl)
''' If wd = ppFolie Then Exit For
'Word-Dokument aktivieren
wdDocum.Activate
'Zur nächsten Seite im Word-Dokument wechseln
Word.Application.Browser.Next
Next wd
'Cursor zum Anfang der Dokumente
wdDocum.Range(0, 0).Select
ActiveWindow.View.GotoSlide Index:=1
ActiveWindow.ViewType = ppViewNormal
'Verweise freigeben
Set wdRange = Nothing
Set wdDocum = Nothing
Exit Function
ende:
MsgBox "Zuerst das Word-Dokument öffnen; dann dieses Programm neu starten!" _
& VBA.vbNewLine & VBA.vbNewLine & "Abbruch.", vbExclamation, "Fehler..."
End Function
Function Placeholder_Loeschen()
Dim oShape As Shape
Dim oSlide As Slide
'Placeholder löschen (Placeholder beinhalten die Notizen)
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.NotesPage.Shapes
If oShape.Type = msoPlaceholder Then
If oShape.PlaceholderFormat.Type = ppPlaceholderBody Then
oShape.Delete
End If
End If
Next oShape
'pro Folie kann max. nur ein Placeholder eingefügt werden!
' oSlide.NotesPage.Shapes.AddPlaceholder Type:=ppPlaceholderBody
Next oSlide
End Function

Mehr Tipps: Notizentext in Textfile speichern

Sponsoren und Investoren

Sponsoren und Investoren sind jederzeit herzlich willkommen!
Wenn Sie die Information(en) auf dieser Seite interessant fanden, freuen wir uns über eine kleine Spende. Empfehlen Sie uns bitte auch in Ihren Netzwerken (z. B. Twitter, Facebook oder Google+). Herzlichen Dank!

Nach oben Sitemap
Impressum & Kontakt