I have a Powerpoint template, picture on Title Slide layout. User can open a custom Userform to change the picture (VBA deletes old pic, then inserts pic-of-choice).
But after the theme was changed by user, subsequent picture changes are not visible. This is as far as I can see because the picture is changed only in the title slide layout of the original theme. Changing the theme actually adds a new slide master.
Is there a way to change the picture on the Title Slide layout on each slide master in my presentation?
Here's the VBA code:
Set shp = ActivePresentation.SlideMaster.CustomLayouts(1).Shapes(strShapeName)
With shp
sngTop = .Top
sngLeft = .Left
sngWidth = .Width
sngHeight = .Height
.Delete
End With
Set shp = ActivePresentation.SlideMaster.CustomLayouts(1).Shapes.AddPicture _
(strFullFileName, msoFalse, msoTrue, _
sngLeft, sngTop, sngWidth, sngHeight)
With shp
.ZOrder msoSendToBack
.Name = strShapeName
End With
Thanks for any suggestion.
Try something like this:
Dim oDes As Design
Dim shp As Shape
For Each oDes In ActivePresentation.Designs
Set shp = oDes.SlideMaster.CustomLayouts(1).Shapes(strShapeName)
With shp
sngTop = .Top
sngLeft = .Left
sngWidth = .Width
sngHeight = .Height
.Delete
End With
Set shp = oDes.SlideMaster.CustomLayouts(1).Shapes.AddPicture _
(strFullFileName, msoFalse, msoTrue, _
sngLeft, sngTop, sngWidth, sngHeight)
With shp
.ZOrder msoSendToBack
.Name = strShapeName
End With
Next ' Design
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 have some code that will put an image onto a document. If there is already a table in the footer, the image appears in the wrong place.
If I manually change the vertical position from 0.44 below 'paragraph' to below 'bottom margin', then it goes to the correct position for all documents.
I can't see any way to access this option in vba however.
Sub myFooter()
' Paste a logo into the footer.
'CTRL+SHIFT+F
Application.ScreenUpdating = False
Dim img As String, shp As Shape, oWD As Word.Document, Sctn As Section
On Error Resume Next
img = "G:\Shared Drives\footer.jpg"
Set oWD = ActiveDocument
For Each Sctn In oWD.Sections
With oWD.Sections(Sctn.Index).Footers(wdHeaderFooterPrimary).Shapes.AddPicture(img)
' for absolute positioning
.Left = CentimetersToPoints(15.75)
.Top = CentimetersToPoints(0.44)
'.below = BottomMargin
End With
Next Sctn
Set shp = Nothing
Application.ScreenUpdating = True
End Sub
Is there some other way to do this, or have I missed something for how to amend the absolute position of the image?
Amend your With section as follows:
With oWD.Sections(Sctn.Index).Footers(wdHeaderFooterPrimary).Shapes.AddPicture(img)
' for absolute positioning
.Left = CentimetersToPoints(15.75)
.RelativeVerticalPosition = wdRelativeVerticalPositionBottomMarginArea
.Top = CentimetersToPoints(0.44)
.TopRelative = wdShapePositionRelativeNone
End With
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
I have basic Macro and VBA knowledge yet cannot get my head around where I am going wrong here. (Code inserted at the bottom) I want my macro to move a selected image into the top centre of the page. The issue I am facing is that it will not work for each image in the document, it works for the first one then no longer performs the task. I am using Microsoft Word 2016.
The main command does what I want it to, I feel my error is within these two lines
Set myDocument = ActiveDocument
With myDocument.Shapes(1)
Whole code;
Sub AlignToCentre()
'
' AlignToCentre
Dim shp As Shape
Set myDocument = ActiveDocument
With myDocument.Shapes(1)
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
End Sub
If you want this to work with the selected image, and only the selected image, then more like this, where you get the Shape from the current selection.
Note how you should first check to make sure a Shape is selected...
Sub PositionSelectedShape()
Dim sel As word.Selection
Dim shp As word.Shape
Set sel = Selection
If sel.Type = wdSelectionShape Then
Set shp = sel.ShapeRange(1)
With shp
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
End If
End Sub
Exactly like Kim Raaness has suggested, you need to loop through all shapes of you would like to centre them all.
Try something like this:
Sub AlignToCentre()
'
' AlignToCentre
Dim shp As Shape
Set myDocument = ActiveDocument
For Each shp in myDocument.Shapes
With shp
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
Next shp
End Sub