Assuming slideShape is a reference to a Shapes object, to create a text box in a PPT slide, I can use the following code:
slideShape.AddTextBox(Orientation, left, top, width, height)
slideShape.AddTextBox.Text = 'ABC-123 Feb 2015 Mike Smith'
So far so good. But if I want to break the text in 3 lines:
ABC-123
Feb 2015
Mike Smith
and I need to color, re-size, and apply a different font style to each line, I could write three separate slideShape.AddTextBox calls, but doing that will create 3 separate text boxes.
Is it possible to write 3 separate lines in one text box? I don't think AddTextBox allow me to do that. I know it can be done by using some other methods, but I'm not sure how.
Any advice?
Sub Thing()
' Some setup to add a text box
Dim oSl As Slide
Dim oSh As Shape
Set oSl = ActivePresentation.Slides(1)
Set oSh = oSl.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 500, 500)
' But add the tex like so ... with a CR/LF pair at the end of every line:
oSh.TextFrame.TextRange.Text = "ABC-123" & vbCrLf & "Feb 2015" & vbCrLf & "Mike Smith"
' The shape's TextRange has a .Paragraphs collection that you can address
' a paragraph at a time.
' Note: there's also a .Lines collection
With oSh.TextFrame.TextRange
.Paragraphs(1).Font.Color.RGB = RGB(255, 0, 0)
.Paragraphs(2).Font.Color.RGB = RGB(0, 255, 0)
.Paragraphs(3).Font.Color.RGB = RGB(0, 0, 255)
End With
End Sub
With oSh.TextFrame.TextRange
.ParagraphFormat.SpaceAfter = 12
End With
.SpaceAfter is specified in points, as is the text size
Related
I would like to split a standard PowerPoint shape into separate lines so that I can have full control over how and when they appear when using animations. Thus, I would like to see that the shape on top (a standard PowerPoint shape) is decomposed in the one below (without the space betwen the lines.
I hope somebody has some creative ideas.
This may help get started. Look up the docs on the various properties/methods for more information.
Sub thing()
Dim oSh As Shape
Dim x As Long
Dim pointsArray()
Set oSh = ActiveWindow.Selection.ShapeRange(1)
With oSh
Debug.Print .Nodes.Count
With .Nodes
For x = 1 To .Count
Debug.Print "X = " & .Item(x).Points(1, 1)
Debug.Print "Y = " & .Item(x).Points(1, 2)
Next
End With
End With
End Sub
We are putting together a new standard signature using vbs for Outlook.
Everything looks great but design would like the phone numbers to look like the attached image. The "O" for office # in Orange and then the number in blue, the "C" for cell # in Orange and then the number in blue.
I can get the entire cell to be one color, but I don't see how to do 2 colors.
The signature is in a table with the logo in one cell that has 5 rows merged and then the other side has 5 rows.
Here is some of my code:
strName = objUser.FullName
strTitle = objUser.Title
strPhone = objUser.telephoneNumber
strMobile = objUser.mobile
strOffice = "O "
strCell = "C "
objTable.Cell(3,2).Range.Font.Name = "Lato"
objTable.Cell(3,2).Range.Font.Size = "12"
objTable.Cell(3,2).Range.Text = strOffice & strPhone & " " & strCell & strMobile
Start recording a macro do it manually by editing the in the cell or the formula bar. Stop the macro and step into it to get all the colors. I stuck to the main colors on the bottom of the pallet. You'll may have to track ThemeColor, TintAndShade and ThemeFont depending on the colors you choose.
This should get you started
Public Sub AddLogo(r As Range)
Dim i As Integer
Dim ColorArray
ColorArray = Array(-16777024, -16776961, -16727809, -16711681, -11480942, -11489280, -1003520, -4165632, -10477568, -6279056)
r = "Excel Magic"
For i = 0 To UBound(ColorArray)
With r.Characters(Start:=(i + 1), Length:=1).Font
.Color = ColorArray(i)
End With
Next
End Sub
Usage:
AddLogo objTable.Cell(3,2)
I'm trying to write a subroutine that will copy and paste all (and later only some) of the slides from a powerpoint file to another keeping source formatting.
This is the closest I have gotten:
Dim objPowerpointApp, objPresentations
Set objPowerpointApp = CreateObject("Powerpoint.Application")
Set objPresentations = objPowerpointApp.Presentations
Dim objNewPresentation
Set objNewPresentation = objPresentations.Open(strTemplateFile, 0, 0, -1)
Dim objOldPresentation : Set objOldPresentation = objPresentations.Open(tempSlideSet.Path, 0, 0, 0)
Dim tempCurrentSlide
For Each tempCurrentSlide in objOldPresentation.Slides
tempCurrentSlide.Copy
objNewPresentation.Application.CommandBars.ExecuteMso("PasteSourceFormatting")
Next
It throws no errors and even pastes the correct slide masters, but it doesn't actually paste any of the slides.
I've also tried this:
Dim objPowerpointApp, objPresentations
Set objPowerpointApp = CreateObject("Powerpoint.Application")
Set objPresentations = objPowerpointApp.Presentations
Dim objNewPresentation
Set objNewPresentation = objPresentations.Open(strTemplateFile, 0, 0, -1)
Dim objOldPresentation : Set objOldPresentation = objPresentations.Open(tempSlideSet.Path, 0, 0, 0)
Dim tempCurrentSlide
For Each tempCurrentSlide in objOldPresentation.Slides
tempCurrentSlide.Copy
objNewPresentation.Slides.Paste
objNewPresentation.Application.CommandBars.ExecuteMso("PasteSourceFormatting")
Next
Which pastes the correct slide master as well as the slide, but the slide is pasted with the destination formatting.
Naturally, this pastes all the slides correctly, but without any of the source formatting:
Dim objPowerpointApp, objPresentations
Set objPowerpointApp = CreateObject("Powerpoint.Application")
Set objPresentations = objPowerpointApp.Presentations
Dim objNewPresentation
Set objNewPresentation = objPresentations.Open(strTemplateFile, 0, 0, -1)
Dim objOldPresentation : Set objOldPresentation = objPresentations.Open(tempSlideSet.Path, 0, 0, 0)
Dim tempCurrentSlide, lngSlideIndex
For Each tempCurrentSlide in objOldPresentation.Slides
lngSlideIndex = objNewPresentation.Slides.Count
objNewPresentation.Slides.InsertFromFile tempSlideSet.Path, lngSlideIndex
Next
From what I can find in documentation and others' experience, the first option should work as I need, so I really am stuck at this point.
How can I copy and paste a powerpoint slide using VBScript and keep its source formatting??
To anyone struggling with the same issue, here is the subroutine that I managed to create. The objDestPresentation should be a Presentation Object and the sourceSlideRange should be a SlideRange Object.
This will copy the slides from sourceSlideRange to the end of the objDestPresentation. Hopefully this will save someone some of the struggle that I went through!
Private Sub InsertSlide_Source(ByRef objDestPresentation, byVal sourceSlideRange)
sourceSlideRange.Copy
If Not objDestPresentation.Slides.Count = 0 Then
objDestPresentation.Windows(1).View.GotoSlide(objDestPresentation.Slides.Count)
End If
objDestPresentation.Application.CommandBars.ExecuteMso("PasteSourceFormatting")
End Sub
This helped me resolve a long-term frustration with PowerPoint. Thank you so much for posting this. A nuance I found is was important to activate the presentation I wanted to affect before pasting, otherwise the slide could end up in the wrong place. In my case I'm juggling things between three different presentations:
I start out with an empty shell presentation that I then populate
I have a "blank slide" template that I'm using for most of the slides.
I also sometimes have other one-off slides that I need to include.
With regard to activating the proper presentation I used the answer from here:
http://answers.microsoft.com/en-us/msoffice/forum/msoffice_powerpoint-msoffice_custom/powerpoint-vba-making-right-window-active/32c9fa95-fa1d-46f8-912a-09771a63a27a
Code
You first need to Activate the Window of the target slidedeck before pasting with the "PasteSourceFormatting" option
when TargetPPT is the destination presentation in VBA, and if I want to copy all slides of SourcePPT:
SourcePPT.Slides.Range.Copy
TargetPPT.Windows(1).Activate
TargetPPT.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
The slides are pasted at the current active slide
Use
Application.ActiveWindow.View.GotoSlide (5)
to position f.i. on slide 5 first, and paste the new slides after slide 5.
I have many power point slides and each slide has many lines but all those lines are in the same objects. I want now to add some animation including appears for each line with click.
How I can partition the lines in each slide such that every line will be in its own object
Note, I am using powerpoint 2010
Thanks,
AA
This isn't perfect; you'll need to add more code to pick up ALL of the formatting from the original text, but it's a start. Click within the text box you want to modify, then run the TEST sub. Once it's adjusted to your taste, it's a fairly simple matter to extend it to act on every text box in the entire presentation (though not tables, charts, smartart, stuff like that)
Sub Test()
TextBoxToLines ActiveWindow.Selection.ShapeRange(1)
End Sub
Sub TextBoxToLines(oSh As Shape)
Dim oSl As Slide
Dim oNewShape As Shape
Dim oRng As TextRange
Dim x As Long
With oSh
Set oSl = .Parent
With .TextFrame.TextRange
For x = 1 To .Paragraphs.Count
Set oRng = .Paragraphs(x)
Set oNewShape = oSl.Shapes.AddTextbox(msoTextOrientationHorizontal, _
oRng.BoundLeft, oRng.BoundTop, oRng.BoundWidth, oRng.BoundHeight)
With oNewShape
.TextFrame.AutoSize = ppAutoSizeNone
.Left = oRng.BoundLeft
.Top = oRng.BoundTop
.Width = oSh.Width
.Height = oSh.Height
With .TextFrame.TextRange
.Text = oRng.Text
.Font.Name = oRng.Font.Name
.Font.Size = oRng.Font.Size
' etc ... pick up any other font formatting you need
' from oRng, which represents the current paragraph of
' the original text
' Bullets, tabs, etc.
End With
End With
Next
End With
End With
oSh.Delete
End Sub
I am trying to use VBA to automate the Change Picture function when you right click a Shape in Excel/Word/Powerpoint.
However, I am not able to find any reference, can you assist?
So far as I know you can't change the source of a picture, you need to delete the old one and insert a new one
Here's a start
strPic ="Picture Name"
Set shp = ws.Shapes(strPic)
'Capture properties of exisitng picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
ws.Shapes(strPic).Delete
Set shp = ws.Shapes.AddPicture("Y:\our\Picture\Path\And\File.Name", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
shp.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
shp.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
You can change the source of a picture using the UserPicture method as applied to a rectangle shape. However, you will need to resize the rectangle accordingly if you wish to maintain the picture's original aspect ratio, as the picture will take the dimensions of the rectangle.
As an example:
ActivePresentation.Slides(2).Shapes(shapeId).Fill.UserPicture ("C:\image.png")
'change picture without change image size
Sub change_picture()
strPic = "Picture 1"
Set shp = Worksheets(1).Shapes(strPic)
'Capture properties of exisitng picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
Worksheets(1).Shapes(strPic).Delete
Set shp = Worksheets(1).Shapes.AddPicture("d:\pic\1.png", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
End Sub
what I do is lay both images on top of eachother, and assign the macro below to both images. Obviously i've named the images "lighton" and "lightoff", so make sure you change that to your images.
Sub lightonoff()
If ActiveSheet.Shapes.Range(Array("lighton")).Visible = False Then
ActiveSheet.Shapes.Range(Array("lighton")).Visible = True
Else
ActiveSheet.Shapes.Range(Array("lighton")).Visible = False
End If
End Sub
What I've done in the past is create several image controls on the form and lay them on top of each other. Then you programmatically set all images .visible = false except the one you want to show.
In Word 2010 VBA it helps to change the .visible option for that picture element you want to change.
set the .visible to false
change the picture
set the .visilbe to true
that worked for me.
I tried to imitate the original function of 'Change Picture' with VBA in PowerPoinT(PPT)
The code below tries to recover following properties of the original picture:
- .Left, .Top, .Width, .Height
- zOrder
- Shape Name
- HyperLink/ Action Settings
- Animation Effects
Option Explicit
Sub ChangePicture()
Dim sld As Slide
Dim pic As Shape, shp As Shape
Dim x As Single, y As Single, w As Single, h As Single
Dim PrevName As String
Dim z As Long
Dim actions As ActionSettings
Dim HasAnim As Boolean
Dim PictureFile As String
Dim i As Long
On Error GoTo ErrExit:
If ActiveWindow.Selection.Type <> ppSelectionShapes Then MsgBox "Select a picture first": Exit Sub
Set pic = ActiveWindow.Selection.ShapeRange(1)
On Error GoTo 0
'Open FileDialog
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Picture File", "*.emf;*.jpg;*.png;*.gif;*.bmp"
.InitialFileName = ActivePresentation.Path & "\"
If .Show Then PictureFile = .SelectedItems(1) Else Exit Sub
End With
'save some properties of the original picture
x = pic.Left
y = pic.Top
w = pic.Width
h = pic.Height
PrevName = pic.Name
z = pic.ZOrderPosition
Set actions = pic.ActionSettings 'Hyperlink and action settings
Set sld = pic.Parent
If Not sld.TimeLine.MainSequence.FindFirstAnimationFor(pic) Is Nothing Then
pic.PickupAnimation 'animation effect <- only supported in ver 2010 above
HasAnim = True
End If
'insert new picture on the slide
Set shp = sld.Shapes.AddPicture(PictureFile, False, True, x, y)
'recover original property
With shp
.Name = "Copied_ " & PrevName
.LockAspectRatio = False
.Width = w
.Height = h
If HasAnim Then .ApplyAnimation 'recover animation effects
'recover shape order
.ZOrder msoSendToBack
While .ZOrderPosition < z
.ZOrder msoBringForward
Wend
'recover actions
For i = 1 To actions.Count
.ActionSettings(i).action = actions(i).action
.ActionSettings(i).Run = actions(i).Run
.ActionSettings(i).Hyperlink.Address = actions(i).Hyperlink.Address
.ActionSettings(i).Hyperlink.SubAddress = actions(i).Hyperlink.SubAddress
Next i
End With
'delete the old one
pic.Delete
shp.Name = Mid(shp.Name, 8) 'recover name
ErrExit:
Set shp = Nothing
Set pic = Nothing
Set sld = Nothing
End Sub
How to use:
I suggest you to add this macro into the Quick Access Toolbar list.
(Goto Option or Right-click on the Ribbon menu))
First, select a Picture on the slide which you want to change.
Then, if the FileDialog window opens, choose a new picture.
It's done. By using this method, you can bypass the 'Bing Search and One-Drive Window' in ver 2016 when you want to change a picture.
In the code, there might(or should) be some mistakes or something missing.
I'd appreciate it if somebody or any moderator correct those errors in the code.
But mostly, I found that it works fine.
Also, I admit that there are still more properties of the original shape to recover - like the line property of the shape, transparency, pictureformat and so on.
I think this can be a beginning for people who want to duplicate those TOO MANY properties of a shape.
I hope this is helpful to somebody.
i use this code :
Sub changePic(oshp As shape)
Dim osld As Slide
Set osld = oshp.Parent
osld.Shapes("ltkGambar").Fill.UserPicture (ActivePresentation.Path & "\" & oshp.Name & ".png")
End Sub
I'm working in Excel and VBA. I can't overlay images because I have multiple sheets of a variable number and each sheet has the images, so the file would get huge if, say 20 sheets had all 5 images I want to animate.
So I used a combination of these tricks listed here:
1) I inserted an RECTANGLE shape at the location and size I wanted:
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1024#, 512#, 186#, 130#).Select
Selection.Name = "SCOTS_WIZARD"
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture "G:\Users\ScotLouis\Documents\My Spreadsheets\WordFind Wizard\WordFind Wizard 1.jpg"
.TextureTile = msoFalse
End With
2) Now to animate (change) the picture, I only need to change the Shape.Fill.UserPicture:
ActiveSheet.Shapes("SCOTS_WIZARD").Fill.UserPicture _
"G:\Users\ScotLouis\Documents\My Spreadsheets\WordFind Wizard\WordFind Wizard 2.jpg"
So I've accomplished my goal of only having 1 picture per sheet (not 5 as in my animation) and duplicating the sheet only duplicates the active picture, so the animation continues seamlessly with the next picture.
![Please find attached code.
First create a shape in PPT and run the code]1