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
Related
I'm currently making an automatic Powerpoint from excel using vba and I would like to set a theme to the document, the "Ion" theme to be precise. I have the following code:
Sub CreateFullPres()
Dim ppt As PowerPoint.Application
Dim pres As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp2 As Shape
'Create Powerpoint
Set ppt = New PowerPoint.Application
Set pres = ppt.Presentations.Add
ppt.Visible = True
'Add Slide
Set Slide1 = pres.Slides.Add(1, ppLayoutTitle).Shapes.Placeholders
SlideTitle = Sheets("FIBO Monthly Update").Range("B4")
SubTitle1 = Sheets("FIBO Monthly Update").Range("B6")
SubTitle2 = Sheets("FIBO Monthly Update").Range("B7")
Slide1.Item(1).TextFrame.TextRange.Text = SlideTitle
Slide1.Item(2).TextFrame.TextRange.Text = SubTitle1 & ": " & SubTitle2
The code continues after this but this is all that is necessary.
Thanks in advance.
pres.ApplyTheme {full path to your thmx file}
Finding the MS-supplied themes can be tricky. It'll be simpler if you create a presentation based on the Ion theme, save it as a THMX to a convenient location, then specify that path/file.thmx in the code above.
By the way, you'll also want to use
Dim shp2 As PowerPoint.Shape
instead of
Dim shp2 As Shape
which dims it as an Excel shape rather than a PowerPoint shape; they're likely to have different properties.
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 a Catia part where I have a few sketches on different planes. I need to be able to convert these sketches into 3D points which I copy to a new part document.
I have tried to use the Search and Selection commands in VB script in order to use a macro to pick up all the 2D points in my sketch and convert them to 3D points but to no avail.
Sub CATMain()
Set oSel = CATIA.ActiveDocument.Selection
strArray(0)=”Part”
Msgbox “Please select parts to join.”
sStatus = oSel.SelectElement3(strArray, “Select parts”, False, CATMultiSelTriggWhenUserValidatesSelection, false)
iCount = oSel.Count
For i= 1 to iCount
Set myObject2 = oSel.Item(i).value
oSel.Search “Name=Point,sel”
ReDim copies(iCount)
For k=1 to iCount
Set copies(k)=oSel.Item(k).Value
oSel.Add copies(k)
oSel.Copy
Next ‘k
Next ‘i
Set part2 = CATIA.Documents.Add(“CATPart”)
part2.Product.PartNumber = “My New Part”
Dim GSet1 As HybridBody
Set GSet1 = part2.Part.HybridBodies.Item(1)
GSet1.Name = “My Geometry”
Set partDocument2= CATIA.ActiveDocument
Dim ActSel As Selection
Set ActSel=partDocument2.Selection
ActSel.Add GSet1
ActSel.PasteSpecial(“CATPrtResultWithOutLink” )
ActSel.Clear
End Sub
You have to disassemble the sketch to get at the points as something you can copy
The disassemble command is exposed in VB via the HybridShapeFactory.AddNewDatums method.
Option Explicit
Sub CATMain()
Dim oPart As part
Set oPart = CATIA.ActiveDocument.part
Dim oHSF As HybridShapeFactory
Set oHSF = oPart.HybridShapeFactory
Dim sx As Sketch
Set sx = oPart.HybridBodies.item("Geometrical Set.1").HybridSketches.item("Sketch.1")
'make a temporary body
Dim targetGS As HybridBody
Set targetGS = oPart.HybridBodies.add
targetGS.name = "TMP_BODY___DELETE_ME"
'create a datum curve from the sketch
Dim sxRef As Reference
Set sxRef = oPart.CreateReferenceFromObject(sx)
'make a zero-translate from the sketch
'This is required because AddNewDatums functions needs a HybridShape feature
Dim oZero As HybridShapeTranslate
Set oZero = oHSF.AddNewTranslate(sxRef, oHSF.AddNewDirectionByCoord(0#, 0#, 1#), 0#)
Call targetGS.AppendHybridShape(oZero)
Call oPart.UpdateObject(oZero)
'now do the disassembly
Dim oZeroRef As Reference
Set oZeroRef = oPart.CreateReferenceFromObject(oZero)
'un-datum the curve by making a zero translate
Dim domains() As Variant
domains = oHSF.AddNewDatums(oZeroRef)
Dim i As Integer
For i = 0 To UBound(domains)
Call targetGS.AppendHybridShape(domains(i))
Next
Call oPart.Update
'now we can copy the resulting points...
Dim oSel As Selection
Set oSel = CATIA.ActiveDocument.Selection
Call oSel.add(targetGS)
Call oSel.Search("'Generative Shape Design'.Point,sel")
'copy paste into the new part
MsgBox ("There are " & oSel.count & " points ready to copy")
< YOUR COPY PASTE CODE GOES HERE>
'delete the temporary geo set
Call oHSF.DeleteObjectForDatum(oPart.CreateReferenceFromObject(targetGS))
End Sub
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")
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