| 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 |
|
zurück