Powerpoint inserting text from external TXT file between slides - vba

I have been using the code below (not my code) with success to have users open a presentation and from the title slide, be able to select a .txt file from any location on their computer and have Powerpoint import the text into the Powerpoint and create the slides adhering to the master slide formatting I have set.
Sub AddSlides(text As String)
Dim Pre As Presentation
Dim Sld As Slide
Set Pre = ActivePresentation
Set Sld = Pre.Slides.Add(Index:=Pre.Slides.Count + 1, Layout:=1)
Sld.Shapes(1).TextFrame.TextRange = text
End Sub
Sub ReadFile(sFileName As String)
Dim iFileNum As Integer
Dim sBuf As String
' edit this:
'sFileName = "test.csv"
' does the file exist? simpleminded test:
If Len(Dir$(sFileName)) = 0 Then
Exit Sub
End If
iFileNum = FreeFile()
Open sFileName For Input As iFileNum
Do While Not EOF(iFileNum)
Line Input #iFileNum, sBuf
AddSlides (sBuf)
Loop
' close the file
Close iFileNum
End Sub
Sub SelectFile()
Dim In_file As Variant
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(Type:=msoFileDialogOpen)
dlgOpen.AllowMultiSelect = False
If dlgOpen.Show = -1 Then
In_file = dlgOpen.SelectedItems.Item(1)
ReadFile (In_file)
End If
End Sub
However, now I would like to work with sections, effectively creating a title and a conclusion slide. Section 1 would include the title slide and button for users to select their .txt file. Section 2 would consist of a single slide that concludes the presentation. My problem is, when the code generates the slides from the .txt file, it places them after the conclusion slide in Section 2 instead of after the title slide in Section 1.
I have researched various codes for working with sections and codes for importing/inserting from external files and have had no success working with them to achieve this.
Although I wanted the number of slides generated between the first and last slides to be variable, I can specify how many slides can be generated if this is more feasible. If this does need to be specified, I would also be comfortable creating the slides first and have them populated with the text from the .txt file if this is a more workable option.
Appreciate any help with this.
Note: Current code limits text import to single lines on each slide. If there is a simple way to append this to include 2 lines per slide - that would be extremely useful.

Ok, I'll start with where to put the new slides. You need to change the addSlides function so that it places all of the slides in the position of your conclusion slide.
This ones easy, you just change the index from
Index:=Pre.Slides.Count + 1
to
Index:=Pre.Slides.Count
Making the addSlides function as follows:
Sub AddSlides(text As String)
Dim Pre As Presentation
Dim Sld As Slide
Set Pre = ActivePresentation
Set Sld = Pre.Slides.Add(Index:=Pre.Slides.Count, Layout:=1)
Sld.Shapes(1).TextFrame.TextRange = text
End Sub
On your second issue, getting two lines of text per slide, this is mildly more difficult. You need to read each line, and everytime you get to the second line, add the page, then reset the holding variable. Something like the following should work:
Sub ReadFile(sFileName As String)
Dim iFileNum As Integer
Dim sBuf As String
Dim bFlag As Boolean
Dim sHolder As String
' edit this:
'sFileName = "test.csv"
' does the file exist? simpleminded test:
If Len(Dir$(sFileName)) = 0 Then
Exit Sub
End If
iFileNum = FreeFile()
Open sFileName For Input As iFileNum
bFlag = False
Do While Not EOF(iFileNum)
If bFlag = False Then
Line Input #iFileNum, sBuf
holder = sBuf
bFlag = True
Else
Line Input #iFileNum, sBuf
holder = holder & vbCrLf & sBuf
addSlides (holder)
holder = ""
bFlag = False
End If
Loop
' close the file
Close iFileNum
End Sub

Related

How to import bulk pictures in Power Point from folder using Open Dialogue Box to Select Entire Folder and Make New Slide for each Picture

I am trying to automate Powerpoint presentation. I found a code on the internet. This code is working well, but it works with the static path in the code. I want to implement it using OpenFolder Dialogue Box. The idea is as, When I click the button import picture, the file dialogue box should be open and I select the folder. The pictures within the folder automatically and the size of the picture should automatically fit the slide. When this process complete, the slide show automatically starts to display the picture using fade animation. The code is as under.
Sub main()
Dim i As Integer
Dim arrFilesInFolder As Variant
arrFilesInFolder = GetAllFilesInDirectory("C:\Users\Admin\OneDrive\Pictures\Screenshots")
For i = LBound(arrFilesInFolder) To UBound(arrFilesInFolder)
Call AddSlideAndImage(arrFilesInFolder(i))
Next
End Sub
Private Function GetAllFilesInDirectory(ByVal strDirectory As String) As Variant
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim arrOutput() As Variant
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strDirectory)
ReDim arrOutput(0)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file path
arrOutput(i - 1) = objFile.Path
ReDim Preserve arrOutput(UBound(arrOutput) + 1)
i = i + 1
Next objFile
ReDim Preserve arrOutput(UBound(arrOutput) - 1)
GetAllFilesInDirectory = arrOutput
End Function
Private Function AddSlideAndImage(ByVal strFile As String)
Dim objPresentaion As presentation
Dim objSlide As slide
Set objPresentaion = ActivePresentation
Set objSlide = objPresentaion.Slides.Add(1, PpSlideLayout.ppLayoutChart)
Call objSlide.Shapes.AddPicture(strFile, msoCTrue, msoCTrue, 100, 100, 650, 450)
End Function
Please someone guide, where I am doing wrong. Thanks
Looks like you need to replace the hard-coded file path with code that prompts the user for one. Seems Application.FileDialog should get you there:
Dim path As String
With Application.FileDialog(Type:=msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show Then
path = .SelectedItems(1)
Else
'user cancelled, bail out:
Exit Sub
End If
End With
Dim arrFilesInFolder As Variant
arrFilesInFolder = GetAllFilesInDirectory(path)
'...rest of the code...

How to copy powerpoint sections to a new presentation using VBA

We typically use powerpoint to facilitate our experiments. We use "sections" in powerpoint to keep groups of slides together for each experimental task. Moving the sections to counterbalance the task order of the experiment has been a lot of work!
I thought we might be able to predefine a counterbalance order (using a string of numbers representing the order) in a CSV or array (haven't built that out yet in VBA). Then using VBA to move the sections and save the file for each order. I am pretty rusty using VBA but I think I have a pretty good start. The problem is on line 24. I have no idea how to copy the section to the new presentation. Is anyone familiar enough to steer me down the right path.
Sub Latin_Square()
Dim amountOfSubjects As Integer
'Declare the amount of subjects you have in your study
amountOfSubjects = 14
Dim filePath As String
filePath = "C:/1.pptx"
Dim amountofsections As Integer
Dim i As Integer
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim desktopPath As String
'find out where user's desktop is
desktopPath = Environ("UserProfile") & "\Desktop\"
Dim oldPresentation As Presentation
Dim newPresentation As Presentation
'open the target presentation
Set oldPresentation = Presentations.Open("C:\1.pptx")
For i = 1 To oldPresentation.Slides.Count
oldPresentation.Slides.Item(i).Copy
newPresentation.Item(1).Slides.Paste
Next i
oldPresentation.Close
With newPresentation
.SaveCopyAs _
FileName:=fso.BuildPath(desktopPath, "Test" & 1 & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
End With
End Sub
If you want to copy slides with their sections, then you can not paste the slide by newPresentation.Slides.Paste only, as that moves the section of the last slide to the newly pasted slide.
Here's an example how to copy slide-by-slide, check if a slide is the beginning of a section, and how to add a new section then:
Public Sub CopySlidesWithSections()
Dim oldPresentation As Presentation, newPresentation As Presentation
Dim oldSlide As Slide, newSlide As Slide
Dim oldSectionProperties As SectionProperties, newSectionProperties As SectionProperties
Dim i As Integer
Set oldPresentation = ActivePresentation
Set oldSectionProperties = oldPresentation.SectionProperties
Set newPresentation = Application.Presentations.Add
Set newSectionProperties = newPresentation.SectionProperties
For Each oldSlide In oldPresentation.Slides
oldSlide.Copy
' Would lead to wrong sectioning: Set newSlide = newPresentation.Slides.Paste.Item(1)
Set newSlide = newPresentation.Slides.Paste(newPresentation.Slides.Count + 1).Item(1)
For i = 1 To oldSectionProperties.Count
If oldSectionProperties.FirstSlide(i) = oldSlide.SlideIndex Then
newSectionProperties.AddBeforeSlide _
newSlide.SlideIndex, _
oldSectionProperties.Name(i)
Exit For
End If
Next i
Next oldSlide
End Sub

OnSlideShowPageChange not running in presentation

I have been tasked with building an automated powerpoint to show new employees during onboarding. I decided to use the text-to-speech function of PPT to narrate the show. I came to the realization that this would require code, so I searched and found some code to use. When I start it within VBA, it runs. However, when in presentation mode, it doesn't fire the code. After hours of searching, I can't seem to find what I've done wrong. Any help is greatly appreciated.
Function SpeakThis(myPhrase As String)
Dim oSpeaker As New SpeechLib.SpVoice
'Set speech properties
oSpeaker.Volume = 100 ' percent
oSpeaker.Rate = 0.1 ' multiplier
oSpeaker.SynchronousSpeakTimeout = 1
oSpeaker.AlertBoundary = SVEWordBoundary
If Not myPhrase = "" Then oSpeaker.Speak myPhrase, SVSFDefault
End Function
Sub OnSlideShowPageChange()
Dim text As String
Dim intSlide As Integer
intSlide = ActiveWindow.Selection.SlideRange.SlideIndex
text = ActivePresentation.Slides(intSlide).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.text
SpeakThis text
End Sub
To get the current slide index, you can use the following:
In Slide View mode: ActiveWindow.View.Slide.SlideIndex
In Slide Show mode: ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
For this to work in presentation mode, change
intSlide = ActiveWindow.Selection.SlideRange.SlideIndex
to
intSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
Note that this throws an error if not in presentation mode.
EDIT: In simplified form, you could also do this:
Sub OnSlideShowPageChange(ByVal Wn As SlideShowWindow)
SpeakThis Wn.View.Slide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.text
End Sub
Here I introduce MY work-around which can meet what you want.
Actually, you can save above TTS sound into an .wav file
which can be inserted and played on entering each slide.
Since you want to play some narration sound on each slide,
I suggest you to convert all the notes into .wav files and insert them as normal audio effects.
To automate the process, I wrote some code.
First, to save each note in an .wav file (given the slide index)
'save the slide's note in a .wav file
'You need to add reference to 'Microsoft Speech Object Library' (*required*)
Function SaveTTSWav(idx As Long)
Const SAFT48kHz16BitStereo = 39
Const SSFMCreateForWrite = 3
Dim oSpeaker As New SpeechLib.SpVoice
Dim oStream As New SpeechLib.SpFileStream
oStream.Format.Type = SAFT48kHz16BitStereo
'filename to save: ex) note1.wav
oStream.Open ActivePresentation.Path & "\note" & idx & ".wav", SSFMCreateForWrite, False
oSpeaker.Volume = 100 '%
oSpeaker.Rate = 1 '1x speed
oSpeaker.SynchronousSpeakTimeout = 1
oSpeaker.AlertBoundary = SVEWordBoundary
Set oSpeaker.AudioOutputStream = oStream
oSpeaker.Speak ActivePresentation.Slides(idx).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.text, SVSFNLPSpeakPunc
oStream.Close
End Function
Then, Insert the 'note(X).wav' files in each slide and add animation effects to them:
'insert the .wav and make it play automatically
Function AddTTSMedia(idx As Long)
Dim sld As Slide
Dim shp As Shape
Dim eft As Effect
Dim wavfile As String
wavfile = ActivePresentation.Path & "\note" & idx & ".wav"
If Len(Dir(wavfile)) = 0 Then Exit Function
Set sld = ActivePresentation.Slides(idx)
Set shp = sld.Shapes.AddMediaObject2(wavfile, False, True, 0, 0, 20, 20)
'shp.Name = Mid(wavfile, InStrRev(wavfile, "\") + 1) '.wav filename
Set eft = sld.TimeLine.MainSequence.AddEffect(shp, msoAnimEffectMediaPlay, , msoAnimTriggerWithPrevious)
eft.MoveTo 1 'make it the first effect
With eft.EffectInformation.PlaySettings 'shp.AnimationSettings.PlaySettings
.HideWhileNotPlaying = True
.PauseAnimation = False
.PlayOnEntry = True
.StopAfterSlides = 1
End With
'Kill wavfile
End Function
Finally, make it happen on every slide:
Sub Add_TTS_Notes()
Dim sld As Slide
'Remove previously inserted note sounds
RemoveNoteWav
For Each sld In ActivePresentation.Slides
'save the note to an .wav file
SaveTTSWav sld.SlideIndex
'add the .wav file onto the slide
AddTTSMedia sld.SlideIndex
Next sld
'ActivePresentation.Save
End Sub
In addition, if you want to cancel and remove all note sounds from your presentation,
you can run the following code manually:
'remove all .wav media(s) in each slide
Sub RemoveNoteWav()
Dim sld As Slide
Dim i As Long
For Each sld In ActivePresentation.Slides
For i = sld.Shapes.Count To 1 Step -1
If sld.Shapes(i).Name Like "note*.wav" Then sld.Shapes(i).Delete
Next i
Next sld
End Sub
All you have to do is to copy all codes above onto your PPT's VBE editor and to run the main macro named "Add_TTS_Notes". It'll take some time to save some TTS sound files.
It will save the notes on all slides in .wav files, insert them on their slides and make them play automatically on each slide. After the job, you can remove VBA codes and save your ppt file as a .pptx or .ppsx which is more handy than a .pptm file since it doesn't require any security agreement.
I'm using PowerPoint 2016, and in my case, I've needed to modify Konahn's codes as below in SaveTTSWav function.
'Dim oSpeaker As New SpeechLib.SpVoice
Dim oSpeaker As Object Set
oSpeaker = CreateObject("SAPI.Spvoice")
&
'Dim oStream As New SpeechLib.SpFileStream
Dim oStream As Object Set
oStream = CreateObject("SAPI.SpFileStream")

Open text file, get number/text from file and increment text/number by 1

I have a .txt file, Supplier Count.txt and in my excel spreadsheet, each time I run a VBA code I want this file to be opened, to read the number value in my text file, e.g. '21' and then increment it by 1.
So say our text file has one line of text, and this line of text is a number, '21'. the vba code should open the file, read this number and increment it by 1 and replace the text, save it and close the text file. so our value is then '22'
does anyone know how I can do this as I am completely new to vba and so far all ive been able to come up with is the opening the text file and reading the number out as a msgbox
Application.ScreenUpdating = False
On Error GoTo ErrHandler12:
Dim FilePath12 As String
Dim Total12 As String
Dim strLine12 As String
FilePath12 = "\\ServerFilePath\assets\Supplier Count.txt"
Open FilePath12 For Input As #1
While EOF(1) = False
'read the next line of data in the text file
Line Input #1, strLine12
Total12 = Total12 & vbNewLine & strLine12
'increment the row counter
i = i + 1
Wend
Close #1
MsgBox Total12
ErrHandler12:
Application.ScreenUpdating = True
First include a reference to the FileSystemObject (see https://stackoverflow.com/a/5798392/380384)
Then run this
Private fso As New FileSystemObject
Public Sub IncrCount()
Dim path As String
path = fso.BuildPath("\\server\share\folder", "SupplierCount.txt")
Dim fs As TextStream
Set fs = fso.OpenTextFile(path, ForReading)
Dim counter As Long
counter = CInt(fs.ReadLine())
fs.Close
Set fs = fso.OpenTextFile(path, ForWriting, True)
fs.WriteLine CStr(counter + 1)
fs.Close
End Sub

PowerPoint VBA: open a text file and show each line on a seperate slide

I want PowerPoint to open an external text file and show line 1 of this file on slide 1 of my presentation, line 2 on slide 2, etc.
If the number of slides is larger than the number of lines in the text file, I would like to start at line 1 again.
Here's what I have so far (mixed code and pseudocode):
Dim FileName, FSO, MyFile
FileName = "C:\test.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set MyFile = FSO.OpenTextFile(FileName, 1)
For i = 1 To ActivePresentation.Slides.Count
If LINE(i) EXISTS IN TEXT FILE THEN
ActivePresentation.Slides(i).Shapes("myshape").TextFrame.TextRange.Text = LINE(i)
ELSE START AT LINE(1) AGAIN
End If
Next
MyFile.Close
How do I refer to the lines in the text file using i, and what would be the best way to do the if/then-statement?
Your help would be greatly appreciated!
Please understand I cannot do the whole thing for you but the logic somehow looks like this:
MoreSlides = true
While moreSlides
Open "mytextfile.txt" For Input As 1
While Not EOF(1) and moreSlides
Line Input #1, myline
' here comes the part inserting the line in the next slide
' You set moreSlides to false if you reach the end
Wend
close #1
Wend