TPE

[e-mail]

---

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

فایلی شبیه به این درست کنید:

=== Slide 1
Here is the notes text for slide 1
=== Slide 2
Here is the notes text for slide 2
=== 
The "===" as the first three characters on the line separates each slide's notes text.
Any characters after the first three "===" are ignored, so you can use them
for comments or to identify the slides. Or just use "===" if you like.
===
And so on
=== 
=== === followed by nothing means "No notes text for this slide"
And so forth.

پرزنتیشنی را که می خواهید متن را به آن وار کنید باز کنید، کد ماکروی زیر را در آن، کپی و اجرا کنید:

Option Explicit


' Should we append imported text to any existing notes text:
' Or should we overwrite any existing notes text with the imported text:
' Comment one or the other of these out
'Const AppendNotesText As Boolean = False    ' Overwrite existing text
Const AppendNotesText As Boolean = True     ' Append imported text to existing text


Sub TxtToNotes()
' Run this ONLY on a COPY of your real presentation
'
' Pulls text from a notepad TXT file into current
' presentation's Notes text
'
' Each slide's worth of notes is delineated by ===
'
' Notes text file must be in same folder as PPT
'  and must have the same base name
'  ex:  Blah.ppt looks for Blah.txt

    Dim sNotesFileName As String
    Dim iNotesFileNum As Integer
    Dim sCurrentFolder As String
    Dim lSlideNumber As Long
    Dim sBuf As String
    Dim sNotes As String
    Dim oNotesShape As Shape

    sCurrentFolder = ActivePresentation.Path & "\"
    ' get everything to the left of "." in current filename
    sNotesFileName = Mid$(ActivePresentation.Name, _
        1, InStr(ActivePresentation.Name, ".") - 1)
    ' and add a .TXT extension
    sNotesFileName = sNotesFileName & ".TXT"

    ' is it there? quit if not
    If Len(Dir$(sCurrentFolder & sNotesFileName)) = 0 Then
        MsgBox sCurrentFolder & sNotesFileName & " is missing"
        Exit Sub
    End If

    ' open the file and go to work
    iNotesFileNum = FreeFile()
    Open sCurrentFolder & sNotesFileName For Input As iNotesFileNum

    lSlideNumber = 1

    ' test for leading ===
    Line Input #iNotesFileNum, sBuf
    If Left$(sBuf, 3) = "===" Then
        ' ignore it
    Else
        sNotes = sBuf
    End If

    While Not EOF(iNotesFileNum)

        Line Input #iNotesFileNum, sBuf

        If Left$(sBuf, 3) = "===" Then
                lSlideNumber = lSlideNumber + 1
                ' reset the current notes for the next round
                sNotes = ""
        Else
            sNotes = sBuf
            Set oNotesShape = GetNotesBody(ActivePresentation.Slides(lSlideNumber))
            If Not oNotesShape Is Nothing Then
                ' Append or overwrite:
                If AppendNotesText Then
                    If Len(oNotesShape.TextFrame.TextRange.Text) > 0 Then
                        oNotesShape.TextFrame.TextRange.Text = _
                        oNotesShape.TextFrame.TextRange.Text & vbCrLf & sNotes
                    Else
                        oNotesShape.TextFrame.TextRange.Text = sNotes
                    End If
                Else
                    oNotesShape.TextFrame.TextRange.Text = sNotes
                End If
            End If
        End If
    Wend

    ' if we're at the end of the file and there's still text
    ' in the buffer, write it to the next slide
    If ActivePresentation.Slides.Count >= lSlideNumber Then
        Set oNotesShape = GetNotesBody(ActivePresentation.Slides(lSlideNumber))
        If Not oNotesShape Is Nothing Then
            oNotesShape.TextFrame.TextRange.Text = sNotes
        End If
    End If

    ' close the file
    Close iNotesFileNum

End Sub

' Add'l code courtesy of Shyam Pillai  ------------------------------------------------------------------------
' Description: Returns shape reference (Object)to a placeholder type passed
' to it. Returns NOTHING if placeholder not found on the slide.
'
' Arguments: Pass the slide object and the placeholder type for which the shape
' reference is required.
' ------------------------------------------------------------------------
Function GetNotesBody(oSld As Slide, Optional oPHType As Integer = 2) As Shape 'ppPlaceholderBody=2
    Dim oShp As Object
    On Error GoTo ErrGetNotesBody
    For Each oShp In oSld.NotesPage.Shapes.Placeholders
        If oShp.PlaceholderFormat.Type = oPHType Then
            Set GetNotesBody = oShp
            Exit Function
        End If
    Next oShp
ErrGetNotesBody:
    Set GetNotesBody = Nothing
End Function

---