TPE
Tavvafi@gmail.com |
≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡
فایلی شبیه به این درست کنید:
=== 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