I have a subroutine that will create a shape, but I have two problems with the code:
I must specify on which slide this shape will be created. This is a problem if I want to create the same shape on multiple slides simultaneously. How do I achieve that? what do I replace activepresentation.slides(x) with?
I want the shape to have a hyperlink to a specific slide. What is wrong with my code to achieve that? It gives me an error when I try to assign an action to the shape I have created.
Sub createshape()
Dim oshp As Shape
Dim osld As Slide
'old code
Set osld = ActivePresentation.Slides(1)
Set oshp = osld.Shapes.AddShape(msoShapeRectangle, 485, 15, 104, 60)
oshp.ActionSettings (ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.Address = SlideNumber
.Hyperlink.SubAddress = 1 'this should take the hyperlink to slide 1 i hope.
End Sub
I want to automate this function because I will be doing this same thing for many many slides multiple times.
Something like this will act on the current slide. I tested for a slide 2 hyperlink to esnure that the code worked (and didn't use 1 as default)
Sub CreateShape()
Dim oShp As Shape
Dim oSld As Slide
Set oSld = ActivePresentation.Slides(ActiveWindow.Selection.SlideRange.SlideIndex)
Set oShp = oSld.Shapes.AddShape(msoShapeRectangle, 485, 15, 104, 60)
With oShp.ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
'.Hyperlink.Address = SlideNumber
.Hyperlink.SubAddress = 2
End With
End Sub
Related
Trying to add a border color to all tables in Powerpoint and failing. I'm not very good at this.
Sub SetTableBorder()
Dim oShp As Shape
Dim oTbl As Table
Dim oSld As Slide
For Each oSld In ActivePresentation.Slides
For Each oShp In oSl.Shapes
If oShp.HasTable Then
With oShp.Table
.Borders(ppBorderTop).ForeColor.RGB = RGB(235,186,182)
.Borders(ppBorderBottom).ForeColor.RGB = RGB(235,186,182)
.Borders(ppBorderLeft).ForeColor.RGB = RGB(235,186,182)
.Borders(ppBorderRight).ForeColor.RGB = RGB(235,186,182)
End With
End If
Next oShp
Next oSld
End Sub
First, correct the typo: oSl.Shapes --> oSld.Shapes
Next, add Option Explicit above all the subs/functions in this (and ideally all other) module. That'll prevent this kind of thing from biting you.
Next, you want to work with the table's .Rows(1).Cells.Borders(ppBorderTop) and its various properties to set the top border,
Something like .Rows(.Rows.Count).Cells ... etc to set the bottom border for the table.
Then similarly, .Columns(1).Cells ... properties ... to set the left border.
And so on.
I am currently trying to delete shapes (ink shapes drawn by the user and retained when presentation was finished) on a slide with a macro. It looks like this:
Sub EraseInkOnSlide(oSl As Slide)
' Erases any INK shapes drawn by the user and
' retained when the user quits the slide show
Dim oSh As Shape
Dim x As Long
With oSl.Shapes
For x = .Count To 1 Step -1
If .Item(x).Type = 23 Then
.Item(x).Delete
End If
Next
End With
End Sub
Now I just want the macro to delete the ink-shapes on a part of the presentation, for example in a specific square on the slide.
Is this possible, if so how?
With the help of Steve i got it to work. Here is the code:
Sub EraseInkOnSlide(oSl As Slide)
' Erases any INK shapes drawn by the user and
' retained when the user quits the slide show
Dim oSh As Shape
Dim x As Long
With oSl.Shapes
For x = .Count To 1 Step -1
If .Item(x).Type = 23 Then
If ((.Item(x).Top >= "square.top") And (.Item(x).Left >= "square.left")) And (.Item(x).Top + .Item(x).Height <= "square.top" + "square.heigth") And (.Item(x).Left + .Item(x).Width <= "square.left" + square.width") Then
.Item(x).Delete
End If
End If
Next
End With
End Sub
The "square.x" stands for your specific coordinates you set for your square.
I'm just poking around in VBA with PowerPoint and know that what I want to do can be done. I just don't know the write calls/sytanx to use!
I want a macro that will run through all the slides in a presentation and move the video object to specific spot on the slide. The spot will be the same on all slides.
It would be very helpful if someone could show me how to do this! Or at least point me in the right direction. Thanks!
Here's what I found for doing something on every slide
Sub EveryTextBoxOnSlide()
' Performs some operation on every shape that contains text on every slide
' (doesn't affect charts, tables, etc)
Dim oSh As Shape
Dim oSl As Slide
On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
' If font size is mixed, don't touch the font size
If .TextFrame.TextRange.Font.Size > 0 Then
.TextFrame.TextRange.Font.Size = .TextFrame.TextRange.Font.Size + 2
End If
End If
End If
End With
Next ' shape
Next ' slide
NormalExit:
Exit Sub
ErrorHandler:
Resume Next
End Sub
And this is something I found to move the object to desired location (here's where I don't know what to call the video object)
With ActiveWindow.Selection.ShapeRange
.Left = 640 'change the number for desired x position
.Top = 75 'change the number for desired y position
End With
End Sub
Sub ll()
End Sub
So basically, I want to run the last piece as a function of the first one instead of shapes with text. Does that make sense?
I've done some programming in the past, mainly with actionscript and Flash. I could probably write out some basic functions, just not sure how to run it in VBA without learning a whole new language. Which I don't want to do, since I'm an instructional designer and don't have the free time to learn it! :)
Here's a little function that'll return True if the shape you pass to it is a video, and a bit of example code to test it with:
Function IsVideo(oSh As Shape) As Boolean
If oSh.Type = msoMedia Then
If oSh.MediaType = ppMediaTypeMovie Then
IsVideo = True
Exit Function
End If
End If
' Things get a little trickier if the movie is in a placeholder
' Is it a placeholder? and is it a media object?
If oSh.Type = msoPlaceholder Then
If oSh.PlaceholderFormat.ContainedType = msoMedia Then
' it's a media object, but we don't know if it's
' a movie or sound or what, so we duplicate it
' then look at the duplicate (which is now a copy
' of the placeholder content but is not a placeholder itself)
With oSh.Duplicate
If .Type = msoMedia Then
If .MediaType = ppMediaTypeMovie Then
IsVideo = True
End If
End If
' and delete the duplicate
.Delete
End With
End If
End If
End Function
Sub thing()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If IsVideo(oSh) Then
oSh.Left = 0
End If
Next
Next
End Sub
Now you're getting somewhere!
I don't know what kind of shape holds your video, so this modification should help you identify it.
Sub EveryTextBoxOnSlide()
Dim oSh As Shape
Dim oSl As Slide
On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
.Select
End With
Next
Next
NormalExit:
Exit Sub
ErrorHandler:
Resume Next
End Sub
While there is no need whatsoever to use the .Select in your final code, this is only here to help you identify which shape actually holds the video. Put a breakpoint (F9) on that line and run your code (F5), then debug through it with F8 to execute one line at a time and run through your loop looking at each shape until you see that your video has been selected.
Once your video has been selected look at the various properties (using the Immediate Window of the IDE) of oSh until you find the uniqueness that identifies this is your video. (There may be some property about the content type of the shape, or a link on where to find the contents that contains the text string ".avi", ".mpg", ".flv", etc - there will be some sort of identifier you can find.)
Once you've identified what makes the shape the holder of a video, replace
.Select
with
If {my video containing shape criteria is true} Then
With .Selection.ShapeRange
.Left = 640 'change the number for desired x position
.Top = 75 'change the number for desired y position
End With
End If
Changing the values (as commented) to whatever it is that you need.
Important Note: It is very good that your sample code has some error handling built in, but all this error handler is doing is sweeping any errors under the rug. This particular handler is the very long form version of On Error Resume Next which does have its uses, but in very, very limited situations.
As you get your code working, you'll actually want to put something useful in the ErrorHandler: section, but that's the topic for a whole new question.
Ok, here is how I modified the code supplied above to do this in my case:
Sub EveryTextBoxOnSlide() ' Performs some operation on every shape that contains text on every slide ' (doesn't affect charts, tables, etc) Dim oSh As Shape Dim oSl As Slide On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
If .Type = msoMedia Then
If .MediaType = ppMediaTypeMovie Then
.PictureFormat.Crop.PictureHeight = 236
.PictureFormat.Crop.PictureWidth = 314.2115
.PictureFormat.Crop.PictureOffsetX = 8.737323
.PictureFormat.Crop.PictureOffsetY = 0
.PictureFormat.Crop.ShapeHeight = 236.3478
.PictureFormat.Crop.ShapeWidth = 163
.PictureFormat.Crop.ShapeLeft = 796.6956
.PictureFormat.Crop.ShapeTop = 0
End If
End If
End With
Next ' shape Next ' slide
NormalExit: Exit Sub
ErrorHandler: Resume Next
End Sub
I am trying to create a shape on a slide in PowerPoint (2010) VBA
I have created a button and this code:
Private Sub AddShape_Click()
Dim shp As Shape
Dim sld As Slide
Set sld = Application.ActiveWindow.View.Slide
Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=24, Top:=65.6, Width:=672, Height:=26.6)
'No Shape Border
shp.Line.Visible = msoFalse
'Shape Fill Color
shp.Fill.ForeColor.RGB = RGB(137, 143, 75)
shp.Fill.BackColor.RGB = RGB(137, 143, 75)
End Sub
When I run the presentation as a slide show and click the Add Shape button, I get the following error:
Run-time error '-2147188160 (80048240)':
Application (unknown member): Invalid request. There is no currently active document window.
Everything I have found online indicates that this code should run OK.
All assistance appreciated!!!
Carolyn
You will get the No Current Active Document Window error if you run your code while the presentation is in Slideshow (fullscreen) mode. Try this, instead:
set sld = Application.ActivePresentation.SlideShowWindow.View.Slide
Things work differently in slide show view, but a couple very simple modifications will get this fixed up. Add this to the project and assign the AddShape_Click as an Action Setting (Run Macro):
Public Sub AddShape_Click(oBtn As Shape)
' It has to be public for the action setting to see it
Dim shp As Shape
Dim sld As Slide
'Set sld = Application.ActiveWindow.View.Slide
Set sld = oBtn.Parent
Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=24, Top:=65.6, Width:=672, Height:=26.6)
'No Shape Border
shp.Line.Visible = msoFalse
'Shape Fill Color
shp.Fill.ForeColor.RGB = RGB(137, 143, 75)
shp.Fill.BackColor.RGB = RGB(137, 143, 75)
End Sub
You can also get this error if PowerPoint recently crashed and is still running in the background. Try killing any such powerpoint processes using task manager and then try again.
Using Powerpoint 2010 and MS Visual Basic for applications:
I'm trying to pass a specific shape as an argument... Tried different syntax or ways of doing it but no luck, it seems to block at using the oShape Variable between the functions.
Function ClickBtn1() sets the oShape variable to the name of the shape to be modified and the calls the modifying function Incre().
Incre() set a numerical value to 12, updates the text range from the shape to it and then changes the forecolor to 10, 10, 10 and it then redraws the slide...
What I have goes like this:
Dim oShape As Shape
Dim x As Long
Sub ClickBtn1()
MsgBox "Inside ClickBtn1"
oShape = ActivePresentation.Slides(7).Shapes("ParaIcon")
Incre
End Sub
Sub Incre()
MsgBox "inside Incre"
x = 12
oShape.TextFrame.TextRange.Text = x
oShape.Fill.ForeColor.RGB = RGB(10, 10, 10)
SlideShowWindows(7).View.GotoSlide (SlideShowWindows(7).View.Slide.SlideIndex)
End Sub
I have an arrow shape with action set to "run macro ClickButton1" and a rectangle called "ParaIcon" on slide 7 of a Powerpoint document...
Any suggestions?
Thanks!
I'd do it like so instead; avoid global variables and use SET for assigning object references to variables.
Sub ClickBtn1()
Dim oShape as Shape
MsgBox "Inside ClickBtn1"
SET oShape = ActivePresentation.Slides(7).Shapes("ParaIcon")
Incre oShape
End Sub
Sub Incre(oShape as Shape)
Dim x as Long
MsgBox "inside Incre"
x = 12
' Convert numbers to string before assigning text
oShape.TextFrame.TextRange.Text = Cstr(x)
oShape.Fill.ForeColor.RGB = RGB(10, 10, 10)
SlideShowWindows(7).View.GotoSlide (SlideShowWindows(7).View.Slide.SlideIndex)
End Sub