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