TPE
Tavvafi@gmail.com |
≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡
این ماکرو متن یادداشت های هر اسلاید را در یک فایل متنی مشخص ذخیره می کند:
Sub ExportNotesText() Dim oSlides As Slides Dim oSl As Slide Dim oSh As Shape Dim strNotesText As String Dim strFileName As String Dim intFileNum As Integer Dim lngReturn As Long ' Get a filename to store the collected text strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?") ' did user cancel? If strFileName = "" Then Exit Sub End If ' is the path valid? crude but effective test: try to create the file. intFileNum = FreeFile() On Error Resume Next Open strFileName For Output As intFileNum If Err.Number <> 0 Then ' we have a problem MsgBox "Couldn't create the file: " & strFileName & vbCrLf _ & "Please try again." Exit Sub End If Close #intFileNum ' temporarily ' Get the notes text Set oSlides = ActivePresentation.Slides For Each oSl In oSlides For Each oSh In oSl.NotesPage.Shapes If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then If oSh.HasTextFrame Then If oSh.TextFrame.HasText Then strNotesText = strNotesText & "Slide: " & CStr(oSl.SlideIndex) & vbCrLf _ & oSh.TextFrame.TextRange.Text & vbCrLf & vbCrLf End If End If End If Next oSh Next oSl ' now write the text to file Open strFileName For Output As intFileNum Print #intFileNum, strNotesText Close #intFileNum ' show what we've done lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus) End Sub
کد زیر را در یک ماژول جدید قرار دهید تا لیستی از عناوین و متن یاداداشت های اسلایدهای پرزنتیشن را بدست آورید:
Option Explicit Sub ExportNotesText() Dim oSlides As Slides Dim oSl As Slide Dim oSh As Shape Dim strNotesText As String Dim strFileName As String Dim intFileNum As Integer Dim lngReturn As Long ' Get a filename to store the collected text strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?") ' did user cancel? If strFileName = "" Then Exit Sub End If ' is the path valid? crude but effective test: try to create the file. intFileNum = FreeFile() On Error Resume Next Open strFileName For Output As intFileNum If Err.Number <> 0 Then ' we have a problem MsgBox "Couldn't create the file: " & strFileName & vbCrLf _ & "Please try again." Exit Sub End If Close #intFileNum ' temporarily ' Get the notes text Set oSlides = ActivePresentation.Slides For Each oSl In oSlides strNotesText = strNotesText & "======================================" & vbCrLf strNotesText = strNotesText & SlideTitle(oSl) & vbCrLf strNotesText = strNotesText & NotesText(oSl) & vbCrLf Next oSl ' now write the text to file Open strFileName For Output As intFileNum Print #intFileNum, strNotesText Close #intFileNum ' show what we've done lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus) End Sub Function SlideTitle(oSl As Slide) As String Dim oSh As Shape For Each oSh In oSl.Shapes If oSh.Type = msoPlaceholder Then If oSh.PlaceholderFormat.Type = ppPlaceholderTitle _ Or oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then If Len(oSh.TextFrame.TextRange.Text) > 0 Then SlideTitle = oSh.TextFrame.TextRange.Text Else SlideTitle = "Slide " & CStr(oSl.SlideIndex) End If Exit Function End If End If Next End Function Function NotesText(oSl As Slide) As String Dim oSh As Shape For Each oSh In oSl.NotesPage.Shapes If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then If oSh.HasTextFrame Then If oSh.TextFrame.HasText Then NotesText = oSh.TextFrame.TextRange.Text End If End If End If Next oSh End Function