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
Related
With PowerPoint, I have created several templates made of groups of shapes that I would copy to create nice image galleries in a Word document.
My idea is to automate the following process:
select a shape
shape format > shape fill > picture > from a file
picture format > crop > fill
by a macro that would do:
select all shapes in the selected slide
chose a folder and select pictures
fill each shape with the pictures
crop all the pictures in the shapes to fill the shapes
I have a macro that fill a specific shape on a specific slide with an image thanks to the filedialog. Thanks to commandbars I can do the PictureFillCrop.
Sub FillPictureAndFillCrop()
Dim strFilePath As String
With Application.FileDialog(msoFileDialogFilePicker)
If .Show <> 0 Then
strFilePath = .SelectedItems(1)
With ActivePresentation.Slides(1).Shapes(1).Fill
.Visible = msoTrue
.UserPicture strFilePath
End With
ActivePresentation.Slides(1).Shapes(1).Select
CommandBars.ExecuteMso ("PictureFillCrop")
End If
End With
End Sub
I still need to extend this macro to all the shapes of the selected slide with each pictures I have selected.
I have a previous macro with which I can select multiple pictures and add one picture per newly created slide.
I would like to adapt it to the macro above.
Sub AddOneImagePerNewSlide()
Dim ImgI As Long, tmpDIAPO As Slide
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Add "Images", "*.png, *.gif; *.jpg; *.jpeg", 1
If .Show = -1 Then
For ImgI = 1 To .SelectedItems.Count
Set tmpDIAPO = ActivePresentation.Slides.Add(Index:=ImgI, Layout:=ppLayoutBlank)
tmpDIAPO.Shapes.AddPicture FileName:=.SelectedItems.Item(ImgI), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, Top:=0, _
Width:=-1, Height:=-1
Next
End If
End With
End Sub
I think it would be a mix of the 2 above macro would work.
Is it doable?
Yes, it is doable.
With this macro you will not need to select the Shapes.
Sub ShapePictureFitCrop(Shape As Shape)
Dim Width As Double, Height As Double
With Shape
Width = .Width
Height = .Height
.ScaleWidth 1, msoFalse
.ScaleHeight 1, msoFalse
.PictureFormat.CropRight = .Width * Width / 100
.PictureFormat.CropBottom = .Height * Height / 100
End With
End Sub
#Clemleb
To loop through all the shapes on each slide, you'd do something like this:
Option Explicit
Sub EachShape()
Dim oSh As Shape
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' You might add code here to
' ensure that it's the right shape type
' For example, exclude shapes with text
If oSh.HasTextFrame And oSh.TextFrame.HasText Then
' Leave it alone
Else
Call DoSomethingWith(oSh)
End If
Next ' Shape
Next ' Slide
End Sub
Sub DoSomethingWith(oSh As Shape)
' you could call TinMan's example here
ShapePictureFitCrop (oSh)
' then do other things with the shape
End Sub
Sub ShapePictureFitCrop(Shape As Shape)
Dim Width As Double, Height As Double
With Shape
Width = .Width
Height = .Height
.ScaleWidth 1, msoFalse
.ScaleHeight 1, msoFalse
.PictureFormat.CropRight = .Width * Width / 100
.PictureFormat.CropBottom = .Height * Height / 100
End With
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 create a "sticker" macro for PowerPoint. In short terms I have a button that marks selected slides with a shape that says "Done". This macro is working. However, I also need a macro that deletes the done-sticker on selected slides. What I have right now manages to delete the shape if only one slide is selected. I am very new to VBA in PowerPoint.
Add sticker macro (that works):
Sub StickerDone()
Dim StickerText As String
Dim sld As Slide
StickerText = "Done"
Dim shp As Shape
For Each sld In ActiveWindow.Selection.SlideRange
'Create shape with Specified Dimensions and Slide Position
Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=0 * 28.3464567, Top:=0 * 28.3464567, Width:=80, Height:=26.6)
'FORMAT SHAPE
'Shape Name
shp.Name = "StickerDone"
'No Shape Border
shp.Line.Visible = msoFalse
'Shape Fill Color
shp.Fill.ForeColor.RGB = RGB(56, 87, 35)
'Shape Text Color
shp.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
'Text inside Shape
shp.TextFrame.TextRange.Characters.Text = StickerText
'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 = 14
'Adjust Font Style
shp.TextFrame2.TextRange.Font.Name = "Corbel"
'Rotation
shp.Rotation = 0
Next sld
End Sub
Delete sticker macro (that does not work):
Sub StickerDelete()
Dim shp As Shape
Dim sld As Slide
For Each sld In ActiveWindow.Selection.SlideRange
For Each shp In sld.Shapes
If shp.Name Like "StickerDone" Then
shp.Select
shp.Delete
End If
Next shp
Next sld
End Sub
Deleting objects you are iterating over is generally a bad idea. Add them to an array and delete them after your (inner) loop is done.
Try this:
Sub StickerDelete()
Dim shp As Shape
Dim sld As Slide
ReDim ShapesToDelete(0)
Dim ShapeCount
For Each sld In ActiveWindow.Selection.SlideRange
For Each shp In sld.Shapes
If shp.Name Like "StickerDone" Then
'shp.Select
'shp.Delete
ShapeCount = ShapeCount + 1
ReDim Preserve ShapesToDelete(0 To ShapeCount)
Set ShapesToDelete(ShapeCount) = shp
End If
Next shp
Next sld
For i = 1 To ShapeCount
ShapesToDelete(i).Delete
Next
End Sub
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
I am using PowerPoint 2010 and I am trying to add animation to a bunch of shapes that will change their color to green,
but all I get is that the color is changing to dark red
Private Sub CommandButton1_Click()
Dim oshp As Shape
Dim oslide As Slide
Set oslide = ActivePresentation.Slides(1)
'Clear all animations
For i = 1 To oslide.TimeLine.MainSequence.Count
oslide.TimeLine.MainSequence.Item(1).Delete
Next
For i = 1 To 4
Set oshp = oslide.Shapes(i)
' Assign an animation to shape
Set oEffect = oslide.TimeLine.MainSequence.AddEffect(Shape:=oshp, effectId:=msoAnimEffectChangeFillColor, trigger:=msoAnimTriggerAfterPrevious)
oEffect.EffectParameters.Color2.RGB = RGB(0, 255, 0)
oEffect.Timing.SmoothEnd = msoTrue
oEffect.Timing.Duration = 0.2
Next
End Sub