Looked all around and could not find it. Need a macro so that I can repeat it 695 times, on 695 different files I have. Documentation is kind of uneasy, or I am unlucky.
I could do it in Microsoft VBA as follows:
Sub VbaBlackies
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
With oSl
.FollowMasterBackground = msoFalse
.DisplayMasterShapes = msoFalse
With .background
.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Fill.BackColor.RGB = RGB(0, 0, 0)
End With
End With
Next oSl
End Sub
I am looking for something similar in LibreOffice BASIC. I could get started in the code this way:
Sub Main
Dim oDoc As Object
Dim oDPages As Object
Dim oDPage As Object
oDoc= ThisComponent
oDPages = oDoc.getDrawPAges()
For i=0 To oDPages.count()-1
oDPage = oDPages.getByIndex(i)
oDPage.Background = RGB(0,0,0) 'This does not work.
'I have no idea on how to access the object's properties and alter them.
Next i
End Sub
Any ideas, please?
What you are looking for is in Listing 15.1 of Andrew Pitonyak's macro document, an essential reference for macro programming.
Sub ChangeBackground
Dim oDoc as Object
oDoc = ThisComponent
Dim oDrawPages as Object, oDrawPage as Object
oDrawPages = oDoc.getDrawPages()
oDrawPage = oDrawPages.getByIndex(0)
Dim oBackground as Object
oBackground = oDoc.createInstance("com.sun.star.drawing.Background")
oBackground.FillColor = RGB(250,0,0)
oDrawPage.Background = oBackground
End Sub
API documentation is at https://www.openoffice.org/api/docs/common/ref/com/sun/star/drawing/Background.html.
YES! Worked like a charm, thanks a lot for the answers!
This is the final code that worked out for me:
Sub Main
Dim oDoc As Object
Dim oDPages As Object
Dim oDPage As Object
oDoc = ThisComponent
oDPages = oDoc.getDrawPAges()
For i=0 To oDPages.count()-1
oDPage = oDPages.getByIndex(i)
Dim oBackground As Object
oBackground = oDoc.createInstance("com.sun.star.drawing.Background")
oBackground.FillColor = RGB(0,0,0)
oDPage.Background = oBackground
Next i
End Sub
Related
I'm trying to create a macro I can call with a right-click to change shape line weight and line color. The shapes are custom shapes that I've created in stencil. I was able to do it successfully to a single shape with this code but it doesn't work when multiple shapes are selected:
Sub Macro1()
Dim vsoShape As Visio.Shape
Set vsoShape = Visio.ActiveWindow.Selection.shapeID.Item(1)
vsoShape.CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = "THEMEGUARD(RGB(255,0,0))"
vsoShape.CellsSRC(visSectionObject, visRowLine, visLineWeight).FormulaU = "2.25 pt"
End Sub
I tried iterating through the selected shapes, but haven't found a working way to do it. This was my most recent attempt.
Sub Macro1()
Dim shapeID As Long
Dim vsoShape As Visio.Shape
Dim vsoSel As Visio.Selection
Dim intCounter As Integer
Set vsoSel = Visio.ActiveWindow.Selection
Call vsoSel.GetIDs(shapeIDs)
For intCounter = LBound(shapeIDs) To UBound(shapeIDs)
shapeID = shapeIDs(intCounter)
Set vsoShape = Visio.ActiveWindow.Selection.shapeID.Item(1)
vsoShape.CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = "THEMEGUARD(RGB(255,0,0))"
vsoShape.CellsSRC(visSectionObject, visRowLine, visLineWeight).FormulaU = "2.25 pt"
ActiveWindow.Select vsoSel
Next
End Sub
Well done on your code so far, however there's a couple of issues with your example:
shapeID isn't a property of Selection
Item takes an index (in a collection) rather than an ID (use ItemFromID for that)
You need to declared the array: Dim shapeIDs() As Long
To set the window selection at the end you need to use the Window.Selection property
Having said all of that the Selection object is a collection that you can for each over directly.
For example:
Public Sub Iterate1()
Dim vShp As Visio.Shape
Dim vSel As Visio.Selection
Set vSel = Visio.ActiveWindow.Selection
For Each vShp In vSel
vShp.CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = "THEMEGUARD(RGB(255,0,0))"
vShp.CellsSRC(visSectionObject, visRowLine, visLineWeight).FormulaU = "2.25 pt"
Next
End Sub
And as alternative to the SRC syntax you can also use cell name sytax which is often easier to read:
vShp.CellsU("LineColor").FormulaU = "THEMEGUARD(RGB(255,0,0))"
vShp.CellsU("LineWeight").FormulaU = "2.25 pt"
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 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")
I need to run a PowerPoint sub from R via:
shell(shQuote(normalizePath("C:/.../VBA_Script.vbs"))).
The script VBA_Script should trigger a sub called request_bank, which should open amsgboxwith the value of the variablebank(=J. P. Morgan`).
I get the error:
Application.Run: Invalid request. Sub or function not defined, Code: 80048240, MS PowerPoint 2013.
I just tried all the different Run.-Paths mentioned in this thread Run PowerPoint Sub from Excel. I still get the error. I wonder why the same code is working if I run the same Sub in Excel or if I add the rows:
Dim PSlide
Set PSlide = PPres.Slides(1).Duplicate
But that's no clean solution for me. There must be a better way.
VBS-Script:
Option Explicit
CallPMacro
Sub CallPMacro()
Dim PApp
Dim PPres
'Dim PSlide
Set PApp = CreateObject("PowerPoint.Application")
Set PPres = PApp.Presentations.Open("C:\...\test.pptm", 0, True)
'Set PSlide = PPres.Slides(1).Duplicate
PApp.Visible = True
PApp.Run "request_bank"
PApp.Quit
Set PPres = Nothing
Set PApp = Nothing
End Sub
VBA-Code from the Sub request_bank in the test.pptm:
Sub request_bank()
Dim bank As String
bank = "J.P. Morgan"
MsgBox ("bank: " & bank)
End Sub
Any idea how to fix it?
Sub printDashboard()
Dim sheet1 As Excel.Worksheet
Set sheet1 = ActiveWorkbook.Sheets("PM Dashboard")
Dim pptChart2 As Excel.ChartObject
'Open PowerPoint template
Dim sPath As String
sPath = ActiveWorkbook.Path
Dim pp As PowerPoint.Application, pps As PowerPoint.Presentation
Set pp = New PowerPoint.Application
pp.Visible = True
Set pps = pp.Presentations.Open(sPath & "\template_Slides.pptx")
Dim firstSlide As PowerPoint.Slide
Set firstSlide = pps.Slides(1)
'Paste the second chart
Set pptChart2 = sheet1.ChartObjects("chartPM2")
pptChart2.Copy
Dim myShape2 As Object
Set myShape2 = firstSlide.Shapes.PasteSpecial()
'myShape2.Chart.ApplyChartTemplate (sPath & "\pipelineManagementChartFormat.crtx")
With myShape2
.Top = 1.52 * 72
.Left = 5.33 * 72
.Width = 4.08 * 72
.Height = 2.6 * 72
End With
End Sub
So this code works perfectly in that it:
Correctly opens the PowerPoint file
The Excel chart is pasted in and resized / repositioned
However, I can not figure out how to apply a saved chart template that I have within the same directory. You can see that I have tried to accomplish this with the "ApplyChartTemplate" line that is commented out in the "Paste Second Chart" section.
I would appreciate any help here. I have tried a number of different ways to apply the chart template after pasting it into the slide. I have not had any success with that yet.
Thanks
PasteSpecial returns a shaperange, not shape, but you need to apply a template to a single shape (ie, the chart object). Try this instead:
Set myShape2 = firstSlide.Shapes.PasteSpecial()(1)
It may be a machine-dependant timing issue (pasting from the clipboard can result in the VBA code running ahead prior to the paste operation completing). Try calling this Delay sub immediately after the PasteSpecial line.
Delay 1, True
Public Sub Delay(Seconds As Single, Optional DoAppEvents As Boolean)
Dim TimeNow As Long
TimeNow = Timer
Do While Timer < TimeNow + Seconds
If DoAppEvents = True Then DoEvents
Loop
End Sub