TPE
Tavvafi@gmail.com |
≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡
مجموعه sub ها و Functionهای زیر، موجب اضافه کردن یک عبارت تصادفی از یک فایل متنی به یک جعبه متن بر روی هر اسلاید، خواهند شد.
Public rayPhrases() As String Sub PlacePhrases() ' Puts a phrase in the same position on every slide in a presentation ' Excludes title slides Dim oSl As Slide Dim oText As Shape ReDim rayPhrases(1 To 1) As String ' Load an array of phrases to use Call InitPhrases For Each oSl In ActivePresentation.Slides ' Skip Title slides If Not oSl.Layout = ppLayoutTitle Then ' Add the textbox Set oText = oSl.Shapes.AddTextbox(msoTextOrientationHorizontal, 0#, 0#, 100#, 24#) ' Add text and format it With oText.TextFrame .WordWrap = msoFalse With .TextRange ' Comment out one of the following lines ( put a ' in front of it ) and leave the other ' UNcommented out '.Text = GetRandomPhrase ' pull a random phrase from the file .Text = GetPhraseNumber(oSl.SlideIndex) ' pull phrases from the file in sequence With .Font .Name = "Arial" .Size = 24 .Bold = msoFalse ' whatever other defaults you like here .Color.RGB = RGB(255, 0, 0) ' Red End With End With End With ' Tag it so we can find and remove it later Call oText.Tags.Add("PHRASE", "PHRASE") End If Next oSl End Sub Function GetRandomPhrase() As String ' Returns a random phrase from the array of phrases Dim lTodaysPhrase As Long ' index into array of phrases lTodaysPhrase = Int((UBound(rayPhrases) - LBound(rayPhrases) + 1) * Rnd + LBound(rayPhrases)) GetRandomPhrase = rayPhrases(lTodaysPhrase) End Function Function GetPhraseNumber(PhraseNumber As Long) As String ' Returns the Nth phrase from file ' Alternative to GetRandomPhrase If PhraseNumber > UBound(rayPhrases) Then 'GetPhraseNumber = rayPhrases(PhraseNumber) ' Stop ... 'MsgBox "Too many slides, not enough phrases." 'Exit Sub ' or Wrap around ... PhraseNumber = PhraseNumber - (PhraseNumber \ UBound(rayPhrases)) * UBound(rayPhrases) + 1 End If GetPhraseNumber = rayPhrases(PhraseNumber) End Function Sub InitPhrases() ' Loads array of phrases - rewrite to suit your needs ' This version uses a file of phrases in the same folder as current presentation ' Filename = PHRASES.TXT ' ASCII file, one phrase per line Dim PhraseFile As String Dim FileNum As Integer Dim Buffer As String PhraseFile = ActivePresentation.Path & "\" & "PHRASES.TXT" FileNum = FreeFile() Open PhraseFile For Input As FreeFile While Not EOF(FileNum) Line Input #FileNum, Buffer ' Ignore blank lines If Trim(Buffer) <> "" Then Call AddAPhrase(rayPhrases, Buffer) End If Wend Close #FileNum ' This leaves the array with one bogus empty record at end so ReDim Preserve rayPhrases(1 To UBound(rayPhrases) - 1) As String End Sub Sub AddAPhrase(Phrases As Variant, Phrase As String) ' adds a new phrase to the array Phrases(UBound(Phrases)) = Phrase ReDim Preserve Phrases(1 To UBound(Phrases) + 1) As String End Sub Sub DeletePhrases() ' deletes all the phrases we added Dim oSl As Slide Dim oSh As Shape Dim X As Long For Each oSl In ActivePresentation.Slides For X = oSl.Shapes.Count To 1 Step -1 If oSl.Shapes(X).Tags("PHRASE") = "PHRASE" Then oSl.Shapes(X).Delete End If Next X Next oSl End Sub Sub doStuff() MsgBox "I did stuff" End Sub