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")
Related
I want to remove read-only using a PowerPoint macro.
I'm writing a macro that fires when a file is opened.
In that macro, there is a process to delete a specific shape.
The PowerPoint file has a write lock.
Given the above assumptions, when you open the file read-only
The macro will be executed, but an error will occur because it is read-only and the shape cannot be deleted.
So I unlock the read-only lock when the macro is executed
When I'm done deleting a particular shape, I want to lock it again for read-only.
Is there such a way?
I know the write lock password.
Public Sub Ribbon_onLoad(ribbon As IRibbonUI)
Const EXP_DATE As Date = "2021/09/30"
Dim NOW_DATE As Date: NOW_DATE = Format(Date, "yyyy/mm/dd")
Dim pp As PowerPoint.Presentation: Set pp = ActivePresentation
If NOW_DATE <= EXP_DATE Then
MsgBox "OK!"
Call DeleteShapesWithName("expShape")
Else
MsgBox "No!Exp!：" + Format(EXP_DATE, "yyyy/mm/dd")
'ActivePresentation.Close
End If
End Sub
Sub DeleteShapesWithName(ByVal targetName As String)
Dim sld As Slide
Dim shp As Shape
Dim i As Long
i = 1
For Each sld In Application.ActivePresentation.Slides
Do Until i > sld.Shapes.Count
If sld.Shapes(i).Name = targetName Then
sld.Shapes(i).Delete
Else
i = i + 1
End If
Loop
Next
End Sub
------add
I added the modified source after receiving the reply.
Public Sub Ribbon_onLoad(ribbon As IRibbonUI)
Call UnlockPresentation
End Sub
Sub UnlockPresentation()
Dim oPVW As ProtectedViewWindow
Dim oPres As Presentation
Set oPVW = ProtectedViewWindows.Open("C:\test\example_exp.pptm")
oPVW.Edit ModifyPassword:="test"
Call DeleteShapesWithName("expShape")
'Do stuff here
End Sub
Sub DeleteShapesWithName(ByVal targetName As String)
Dim sld As Slide
Dim shp As Shape
Dim i As Long
i = 1
For Each sld In Application.ActivePresentation.Slides
Do Until i > sld.Shapes.Count
If sld.Shapes(i).Name = targetName Then
sld.Shapes(i).Delete
Else
i = i + 1
End If
Loop
Next
End Sub
Here's code to open a read-only presentation so you can modify it. No need to reset the password, just replace "Test" with the actual password. Where the Do stuff here comment is, you can use the ActivePresentation keyword to modify the file:
Sub UnlockPresentation()
Dim oPVW As ProtectedViewWindow
Dim oPres As Presentation
Set oPVW = ProtectedViewWindows.Open("C:\HasModPW.pptx")
oPVW.Edit ModifyPassword:="ExistingModificationPassword"
'Do stuff here
End Sub
Please note: Microsoft's help page on ProtectViewWindow.Edit is wrong. The page currently states this method changes the password, but it actually provides the PW to make editing possible,
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...
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
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
I have to open the webCam and take a photo from MS-Access, I was researching, but it has been impossible to do it work.
I would appreciate any help that you give me.
I found this
Private Sub Command11_Click()
Dim tempfile As String
Dim mydevice As WIA.Device
Dim item As WIA.item
Dim imfile As WIA.imagefile
Dim Commondialog1 As WIA.CommonDialog
'put the path and name for the location of your temp file here.
tempfile = ("C:\Users\Desktop\filename.jpg")
'the next 4 lines deletes the old temp file if it exists
Set filesystemobject = CreateObject("Scripting.FileSystemObject")
If filesystemobject.FileExists(tempfile) Then
Kill (tempfile)
End If
'the next two lines set up the configuration
Set Commondialog1 = New CommonDialog
Set mydevice = Commondialog1.ShowSelectDevice
Set item = mydevice.ExecuteCommand(wiaCommandTakePicture) 'instructs the camera to take the picture
Set imfile = item.Transfer 'transfers the picture from the camera
'this line saves the picture to a specified file
imfile.SaveFile (tempfile)
'this sets the picture on the form to show the new picture
Me.OLEUnbound1.Picture = (tempfile)
MsgBox "Picture taken"
Exit_btnTakePicture_click:
Set mydevice = Nothing
Set item = Nothing
Exit Sub
End Sub
this show me enternal cameras, but I need to use the built-in webcam
how is possible get the built-in webCam through MS Access?