I have a macro to create a new textbox with certain parameters, but when it is created, I still have to go click it (and then use "Enter" as a keyboard shortcut to highlight the text and start typing).
I was wondering if there's a way to have the textbox selected as soon as I run the macro, and even better, if there's a way to auto-highlight the test text (so that there is no step between adding the box and typing).
Code below (copied & slightly modified from The Spreadsheet Guru).
Dim Sld As Slide
Dim Shp As Shape
'ERROR HANDLING
If ActivePresentation.Slides.Count = 0 Then
MsgBox "You do not have any slides in your PowerPoint project."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
'Create shape with Specified Dimensions and Slide Position
Set Shp = Sld.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=24, Top:=65.6, Width:=300, Height:=100)
'FORMAT SHAPE
'No Shape Border
Shp.Line.Visible = msoFalse
'Shape Fill Color
Shp.Fill.Visible = msoFalse
'Shape Text Color
Shp.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
'Text inside Shape
Shp.TextFrame.TextRange.Characters.Text = "Text"
'Center Align Text
Shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
'Vertically Align Text to Middle
Shp.TextFrame2.VerticalAnchor = msoAnchorTop
'Adjust Font Size
Shp.TextFrame2.TextRange.Font.Size = 12
'Adjust Font Style
Shp.TextFrame2.TextRange.Font.Name = "Arial"
Thank you!
Add this line at the end:
Shp.TextFrame.TextRange.Select
Related
I wrote this function to loop through powerpoint slides in a vba macro. I wanted it to then loop through the shapes on each slide and set the text to user defined defaults.
I got this working and now for some reason after tidying up it stopped working. I get Run-time-error '-2147024809 (80070057) The specified value is out of range.
When I debug it works up to a certain slide. In my case it's a test slide with 5 objects of different types with text in. There is a group.
Despite doing some study and training this one has me stumped. Would really appreciate some help. I'm sure it's a simple solution but I can't see what I'm doing wrong.
Sub FontDefaultAllSlidesBody()
'Sets the text for all shapes on all slides in active presentation
'Set variables for functions
Dim oSl As Slide
Dim oSls As Slides
Set oSls = ActivePresentation.Slides
'Set our default font settings
For Each oSl In oSls
For i = 1 To oSl.Shapes.Count
With oSl.Shapes(i).TextFrame.TextRange.Font
.Size = 16
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Color = msoThemeColorAccent1
.Name = "+mn-lt"
End With
Next i
Next oSl
End Sub
This will probably be enough to solve the problem. It tests each shape to see if it can contain text and if so, if it does contain text and only then does it try to modify the text.
I've also changed the loop a bit to use a Shape object; cuts out a lot of typing and (I think) makes it clearer what you're dealing with.
Sub FontDefaultAllSlidesBody()
'Sets the text for all shapes on all slides in active presentation
'Set variables for functions
Dim oSl As Slide
Dim oSls As Slides
' This will make it easier to read:
Dim oSh as Shape
Set oSls = ActivePresentation.Slides
'Set our default font settings
For Each oSl In oSls
For Each oSh in oSl.Shapes
' Add this to keep it from touching shapes that
' can't contain text
If oSh.HasTextFrame Then
' And skip shapes that have no text
If oSh.TextFrame.HasText Then
With oSh.TextFrame.TextRange.Font
.Size = 16
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Color = msoThemeColorAccent1
.Name = "+mn-lt"
End With
End If ' HasText
End If ' HasTextFrame
Next ' Shape
Next oSl
End Sub
I would like to select "Rectangle 132" in each slide, copy the content into the "outline menu" as a title for the slide using VBA.
Ultimately it would be nice to locate the "title" rubric above the actual slide, so it is not displayed on the slide.
Sub LoopThroughSlides()
'PURPOSE: Show how to loop through all slides in the active presentation
Dim sld As Slide
'Loop Through Each Slide in ActivePresentation
For Each sld In ActivePresentation.Slides
'Do something...(ie add a transition to slides)
Function getShapeByName(shapeName As String, Slide As Integer)
Set getShapeByName = ActivePresentation.Slides(Slide).Shapes(shapeName)
End Function
Dim myshape As Shape
myshape = getShapeByName("Rectangle 132", 1)
Next sld
End Function
End Sub
••••ˇˇˇˇ
I've found this but unsure how to apply it:
With ActivePresentation.Slides(1)
If .Layout <> ppLayoutBlank Then
With .Shapes
If Not .HasTitle Then
.AddTitle.TextFrame.TextRange.Text = "Restored title"
End If
End With
End If
End With
Sorry, but titles don't work that way. The Title placeholder has a special status in the program that can't be transferred to other shapes. If you copy the text from Rectangle 132 and paste it to the Title placeholder, it will work as expected.
As an illustration of the special nature of the placeholder, I created a slide using the Blank layout, which has no Title. I opened Outline View, then typed text beside the slide thumbnail. This text is automatically considered the slide title and PowerPoint creates a Title placeholder on the blank slide, even though it didn't previously have one.
When you change your question, please consider starting a new thread, rather than tacking it on to the previous one. Give this VBA a try:
Sub SetTitle()
Dim sld As Slide, oShape As Shape, TitleText As String, TitlePHName As String
For Each sld In ActivePresentation.Slides
For Each oShape In sld.Shapes
If oShape.Name = "Rectangle 132" Then
If oShape.HasTextFrame Then
If oShape.TextFrame2.HasText Then
TitleText = oShape.TextFrame2.TextRange.Text
End If
End If
End If
If Left(oShape.Name, 5) = "Title" Then
TitlePHName = oShape.Name
End If
Next oShape
If sld.Layout <> ppLayoutBlank Then
If sld.Shapes.HasTitle Then
sld.Shapes(TitlePHName).TextFrame2.TextRange.Text = TitleText
Else
sld.Shapes.AddTitle.TextFrame2.TextRange.Text = TitleText
End If
End If
TitlePHName = ""
TitleText = ""
Next sld
End Sub
I'm trying to change the font of all the text in a PowerPoint Presentation depending on what font a user inputs but when I try it doesn't change anything. Where am I going wrong? Is there a nicer way to implement this... say with a font dropdown box or something? As I want to also implement the font size/bold/italic etc too. Thanks!
Sub ChangeFont()
Dim bpFontName As String
bpFontName = InputBox("What font would you like to change EVERYTHING to?")
With ActivePresentation
For Each Slide In .Slides
For Each Shape In Slide.Shapes
With Shape
If .HasTextFrame Then
If .TextFrame.HasText Then
.TextFrame.TextRange.Font.Name = bpFontName
'Set font size below
.TextFrame.TextRange.Font.Size = 30
'Set if you want the font bold below - msoFalse = no
.TextFrame.TextRange.Font.Bold = msoTrue
'Set if you want the font bold below - msoFalse = no
.TextFrame.TextRange.Font.Italic = msoTrue
End If
End If
End With
Next
Next
End With
End Sub
For starters, you didn't dim some of your variables, and it's bad practice to use reserved words (Slide, Shape) as variable names. I've fixed it like so:
Sub ChangeFont()
Dim bpFontName As String
Dim oSld as Slide
Dim oSh as Shape
bpFontName = InputBox("What font would you like to change EVERYTHING to?")
With ActivePresentation
For Each oSld In .Slides
For Each oSh In oSld.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
.TextFrame.TextRange.Font.Name = bpFontName
'Set font size below
.TextFrame.TextRange.Font.Size = 30
'Set if you want the font bold below - msoFalse = no
.TextFrame.TextRange.Font.Bold = msoTrue
'Set if you want the font bold below - msoFalse = no
.TextFrame.TextRange.Font.Italic = msoTrue
End If
End If
End With
Next
Next
End With
End Sub
I am trying to use VBA in PowerPoint to copy 2 shapes and a group of shapes called SP_MP, SP_TEST and the group called SP_MP_START from the active slide in the same slide, in the following location 83.52, 41.62. Issue is I don't know how to reference to the shapes and group to copy them and what commands to use.
Thank you in advance,
Stefan.
Private Sub CommandButton1_Click()
Dim Sld As Slide
Dim Shp As Shape
'ERROR HANDLING
If ActivePresentation.Slides.Count = 0 Then
MsgBox "You do not have any slides in your PowerPoint project."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
'Create shape with Specified Dimensions and Slide Position
Set Shp = Sld.Shapes.AddShape(Type:=msoShapeFlowchartPredefinedProcess, _
Left:=50, Top:=100, Width:=83.52, Height:=41.62)
'FORMAT SHAPE
'Shape Name
Shp.Name = "My Header"
'No Shape Border
Shp.Line.Visible = msoTrue
'Shape Fill Color
Shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
'Shape Text Color
Shp.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
'Text inside Shape
Shp.TextFrame.TextRange.Characters.Text = TextBox1
'Center Align Text
Shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
'Vertically Align Text to Middle
Shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
'Adjust Font Size
Shp.TextFrame2.TextRange.Font.Size = 8
'Adjust Font Style
Shp.TextFrame2.TextRange.Font.Name = "Verdana (Body)"
Unload UserForm4
End Sub
i have typed some image locations in some cells and hyperlinked them. when i click this cells, a macro will be executed and fills a rectangle shape with pictures specified in those cells. this is the macro:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Row = ActiveCell.Row
col = ActiveCell.Column
ActiveSheet.Shapes.Range(Array("Rectangle 38")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture ActiveSheet.Cells(Row, col).Value
End With
End Sub
it works but the picture is stretched. i want the picture to be fitted inside my shape. in excel , as you might know , after filling a shape with picture,there is a fit button under crop option. when you click it, it fits the image inside the picture box and maintains the size of shape. i want to do the exact thing only in VBA.
Use the shape properties of .PictureWidth , .PictureHeight , .PictureOffsetX = .PictureOffsetY.
Code example:
Option Explicit
Public Sub AddPicAndAdjust()
Dim shp As ShapeRange
Set shp = ActiveSheet.Shapes.Range(Array("Rectangle 1"))
With shp.Fill
.Visible = msoTrue
.UserPicture "C:\Users\User\Pictures\MyNicePic.png" '<== Add pic
.TextureTile = msoFalse
.RotateWithObject = msoTrue
End With
'Positioning within fill
With shp.PictureFormat.Crop
.PictureWidth = 231
.PictureHeight = 134
.PictureOffsetX = 50
.PictureOffsetY = 28
End With
With shp
.LockAspectRatio = msoFalse
.IncrementLeft 2
End With
End Sub