I wrote a code to ask user input a fontname and then use VBA to search the whole presentation for shapes that bears this font and replace to another.
However, my code somehow doesn't work.
I figure the reason is this line "If sh.TextFrame.TextRange.Font.Name = searchFont Then" The fontname return from the user input is just text, but this line need it to be within " ". (eg. "Arial")
if anyone has a solution to this, please kindly help me.
Thanks in advance
Sub ReplaceFont()
Dim sld As Slide
Dim sh As Shape
Dim searchFont As String
searchFont = InputBox("Please enter font to search.", "Font Search Function")
On Error Resume Next
For Each sld In ActivePresentation.Slides
For Each sh In sld.Shapes
If sh.HasTextFrame = True Then
If sh.TextFrame.HasText = True Then
If Ucase(sh.TextFrame.TextRange.Font.Name) = Ucase(searchFont) Then
With sh.TextFrame.TextRange.Font
.Name = "Arial"
End With
End If
End If
End If
Next
Next
End Sub
Related
I received a PowerPoint file with multiple slides which were supposed to be templates (designs - customlayouts) but instead were regular slides.
Transforming them into SlideMaster and custom layouts and replacing the titles and bodys (textboxes) with actual placeholders by hand was a pain.
So I came with this script to make the process faster.
If anybody has a better approach, it's welcome.
Had to look for a workaround to get the customlayout object.
Several things are missing, for example error handling.
To test it, copy a textbox into a slidemaster layout slide, select it and run the ReplaceWithPHTitle macro
Option Explicit
Public Sub ReplaceWithPHTitle()
ReplaceTexboxWithPlaceholder ppPlaceholderTitle
End Sub
Public Sub ReplaceWithPHBody()
ReplaceTexboxWithPlaceholder ppPlaceholderBody
End Sub
Private Sub ReplaceTexboxWithPlaceholder(ByVal placeholderType As PpPlaceholderType)
Dim targetLayout As CustomLayout
Dim activeShape As Shape
Dim newPlaceHolder As Shape
Set activeShape = ActiveWindow.Selection.ShapeRange(1)
Set targetLayout = activeShape.Parent
Set newPlaceHolder = targetLayout.Shapes.AddPlaceholder(Type:=placeholderType, Left:=activeShape.Left, Top:=activeShape.Top, Width:=activeShape.Width + 15, Height:=activeShape.Height)
With newPlaceHolder.TextFrame
.TextRange.Font.Name = activeShape.TextFrame.TextRange.Font.Name
.TextRange.Characters.Font.Color.RGB = activeShape.TextFrame.TextRange.Characters.Font.Color.RGB
.TextRange.Font.Size = activeShape.TextFrame.TextRange.Font.Size
.TextRange.Font.Bold = activeShape.TextFrame.TextRange.Font.Bold
.TextRange.ParagraphFormat.Bullet.Type = activeShape.TextFrame.TextRange.ParagraphFormat.Bullet.Type
.TextRange.ParagraphFormat.SpaceWithin = activeShape.TextFrame.TextRange.ParagraphFormat.SpaceWithin
.TextRange.ParagraphFormat.Alignment = activeShape.TextFrame.TextRange.ParagraphFormat.Alignment
.TextRange.ParagraphFormat.SpaceBefore = activeShape.TextFrame.TextRange.ParagraphFormat.SpaceBefore
.TextRange.ParagraphFormat.SpaceAfter = activeShape.TextFrame.TextRange.ParagraphFormat.SpaceAfter
.TextRange.ParagraphFormat.BaseLineAlignment = activeShape.TextFrame.TextRange.ParagraphFormat.BaseLineAlignment
.TextRange.Text = activeShape.TextFrame.TextRange.Text
End With
With newPlaceHolder.TextFrame2
.TextRange.Font.Spacing = activeShape.TextFrame2.TextRange.Font.Spacing
End With
newPlaceHolder.ZOrder msoSendToBack
newPlaceHolder.Select
End Sub
Any improvements are welcome too.
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 have another questions that asks about the logic behind using several boolean radio buttons to ask survey questions, located here. The largets issue I have had was getting the text boxes to populate a separate slide to display the systems that will affect the customer based on their radio button input.
This post is an attempt to find a way to reduce the code needed to create, place, and format the text boxes. The below code is what I have so far, but it keeps telling me it expects an "=" when I run it.
Public Sub textBox(t As Integer, l As Integer, w As Integer, h As Integer, Sys As String)
Dim myTB As Shape
With ActivePresentation.Slides(7)
Set myTB = .Shapes.AddTextbox(msoTextOrientationHotizontal, l, t, w, h)
myTB.TextFrame.TextRange.Text = Sys
myTB.TextFrame.TextRange.Font.Color.RGB = RGB(255,255,255)
myTB.TextFrame.TextRange.Font.Size = 20
End With
End Sub
I think I may have the logic wrong in declaring the variables. What I want to be able to do is simply place textBox(200,300,200,25, "ERP Name") into my If Then or Case statement to format the boxes. Is there a better way to do this?
You'd need to use
CALL textBox(parm, parm, ... , parm)
or leave out the parentheses.
For clearing everything out, here's a starting point:
Sub ClearTheField()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.Type = msoOLEControlObject Then
If Left$(oSh.OLEFormat.Object.Name, Len("TextBox")) = "TextBox" Then
oSh.OLEFormat.Object.Text = ""
End If
If Left$(oSh.OLEFormat.Object.Name, Len("CheckBox")) = "CheckBox" Then
oSh.OLEFormat.Object.Value = False
End If
If Left$(oSh.OLEFormat.Object.Name, Len("CommandButton")) = "CommandButton" Then
oSh.OLEFormat.Object.Caption = "I changed too"
End If
End If
Next
Next
End Sub
I am trying to select a slide by name. I have added a title via the outline. below is the code that is not working. "item Idaho not found in the slide collection"
ActivePresentation.Slides("Idaho").Select
The slide's name and the text in the title placeholder nave nothing to do with one another.
Unless you've renamed it, the first slide in the presentation will be named "Slide1", the second "Slide2" and so on.
If you specifically need a way to locate the slide whose title text = "Idaho", you'd need to write a function to search all the slides in the presentation and return the first one it finds that meets your criteria. For example:
Sub TestMe()
Dim oSl As Slide
Set oSl = FindSlideByTitle("idaho")
If Not oSl Is Nothing Then
MsgBox "Found your title on slide " & CStr(oSl.SlideIndex)
End If
End Sub
Function FindSlideByTitle(sTextToFind As String) As Slide
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle = oSl
End If
End If
End With
Next
End Function
Reviving an old question, but I wanted to throw this in.
While it's possible that ActivePresentation.Slides("MySlideName").Select doesn't work, this does work for me in PPT 2010:
Dim PPTObj As PowerPoint.Application
Set PPTObj = New PowerPoint.Application
Dim PPTClinic As PowerPoint.Presentation
Set PPTClinic = PPTObj.Presentations.Open(FileName:="Your File Name Here")
PPTClinic.Slides("MySlideName").Select
This, of course, assumes that there is a slide named "MySlideName". Your code will have to deal with gracefully handling the Item MySlideName not found in the Slides collection. error (err.number = -2147188160).
Why doesn't this code work to add text to textbox? I am sure the syntax is off somewhere, but not sure where.
Label5.Text = "Add Text"
Thanks.
Impossible to say w/o a more extensive bit of code.
If the text box is actually an ActiveX Label (as suggested by its name), then like so:
Sub thing()
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.ShapeRange(1)
oSh.OLEFormat.Object.Caption = "Some text"
End Sub
If it's a normal text box or other shape that can contain text:
Sub thing()
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.ShapeRange(1)
oSh.TextFrame.TextRange.Text = "Some text"
End Sub
Its because its a shape. Get the shapes collection and locate the label then access the TextFrame2.TextRange.text