I have found this code to create a shape and to add a hyperlink, which I modified to have the hyperlink go to another slide in the same document, but get compile error at Actionsettings.
Sub Hyper()
Dim pr As PowerPoint.Presentation
Dim sl As PowerPoint.Slide
Dim sh As PowerPoint.Shape
Set pr = ActivePresentation
Set sh = sl.Shapes.AddShape(Type:=msoShapeRectangle, Left:=50, Top:=50, Width:=100, Height:=200)
sh.ActionSettings (ppMouseClick)
.Hyperlink.Address = ""
.SubAddress = "257,2,"
.ScreenTip = ""
.TextToDisplay = "My Name"
End Sub
As #Tim Williams said, SubAddress is a property of Hyperlink
Sub Hyper()
Set pp = ActivePresentation
Set sh = pp.Slides(1).Shapes.AddShape(Type:=msoShapeRectangle, Left:=50, Top:=50, Width:=100, Height:=200)
With sh.ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.SubAddress = pp.Slides(2).SlideNumber 'Hyperlink to Slide Number
End With
End Sub
Related
I am trying to create a hyperlink on the newly created shape oSh to the newly created slide oSlide through VBA.
The shape is on a different slide than the newly created slide.
Code to create the shape and the slide.
Private Function GetSectionNumber( _
ByVal sectionName As String, _
Optional ParentPresentation As Presentation = Nothing) As Long
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
GetSectionNumber = -1
With ParentPresentation.SectionProperties
Dim i As Long
For i = 1 To .Count
If .Name(i) = sectionName Then
GetSectionNumber = i
Exit Function
End If
Next i
End With
End Function
Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
Dim oLayout As CustomLayout
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
If oLayout.Name = LayoutName Then
Set GetLayout = oLayout
Exit For
End If
Next
End Function
Private Sub CommandButton1_Click()
Dim Sld As Slide
Dim Shp As Shape
'ERROR HANDLING
If ActivePresentation.Slides.Count < 5 Then
MsgBox "You do not have any slides in your PowerPoint project."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
If Sld.SlideIndex <> 5 Then
MsgBox "You are not on the correct slide."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
Call AddCustomSlide
Unload UserForm1
End Sub
Sub AddCustomSlide()
'Create new slide
Dim oSlides As Slides, oSlide As Slide
Dim Shp As Shape
Dim Sld As Slide
Dim SecNum As Integer, SlideCount As Integer, FirstSecSlide As Integer
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Processwindow"))
SecNum = GetSectionNumber("Main Process")
With ActivePresentation.SectionProperties
SlideCount = .SlidesCount(SecNum)
FirstSecSlide = .FirstSlide(SecNum)
End With
oSlide.MoveTo toPos:=FirstSecSlide + SlideCount - 1
If oSlide.Shapes.HasTitle = msoTrue Then
oSlide.Shapes.Title.TextFrame.TextRange.Text = TextBox1
End If
'Add SmartArt
'Set Shp = oSlide.Shapes.AddSmartArtApplication.SmartArtLayouts(1)
'Create Flowchart Shape
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeFlowchartPredefinedProcess, 50, 100, 83.52, 41.62)
With oSh
With .TextFrame.TextRange
.Text = TextBox1
With .Font
.Name = "Verdana (Body)"
.Size = 8
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
'.Color.SchemeColor = RGB(255, 255, 255)
End With ' Font
End With ' TextRange
End With ' oSh, the shape itself
End Sub
I'm guessing you want this in the last part that does the font formatting:
Dim URLorLinkLocationText as String
With oSh.TextFrame.TextRange.ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.SubAddress = URLorLinkLocationText
End With
I have the following code, I attempted to modify it so it loops through a list in excel, opens each ppt file in the list and copies that to a new ppt file. But it is getting hung up and has an error during the loop.
Sub tmp()
'Set a VBE reference to Microsoft PowerPoint Object Library
On Error GoTo ErrorHandler
Dim PPApp As PowerPoint.Application
Dim i, j As Integer
Dim pres1, new_pres As PowerPoint.Presentation
Dim oslide, s, oSld As PowerPoint.Slide
Dim oShape, oSh, oshp As PowerPoint.Shape
Dim wb As Workbook
Dim list As Worksheet
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set new_pres = PPApp.Presentations.Add
Set wb = ThisWorkbook
Set list = wb.Worksheets("Powerpoint File List")
LastRow = list.Range("A" & Rows.Count).End(xlUp).Row
new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen
' this is not working
For i = 1 To 1 ' LastRow
filepath = list.Range("A" & i).Value
Set pres1 = PPApp.Presentations.Open(filepath)
For j = 1 To pres1.Slides.Count
pres1.Slides.shapes(j).Copy
new_pres.Slides.Paste
new_pres.Application.CommandBars.ExecuteMso "PasteSourceFormatting")
Next j
pres1.Close
Set pres1 = Nothing
Next I
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub
I got it to work, it was the PasteSourceFormatting that I needed when running from powerpoint that wasn't needed when converting to excel. This pulls every file from the list, opens, copies to a master powerpoint with formatting intact, and closes. in the end I have a new master powerpoint that has all of the presentations that are on the list
Sub tmp()
'Set a VBE reference to Microsoft PowerPoint Object Library
Application.CutCopyMode = False
On Error GoTo ErrorHandler
Dim PPApp As PowerPoint.Application
Dim i As Integer, j As Integer
Dim pres1 As PowerPoint.Presentation, new_pres As PowerPoint.Presentation
Dim oslide As PowerPoint.Slide, s As PowerPoint.Slide, oSld As PowerPoint.Slide
Dim oShape As PowerPoint.Shape, oSh As PowerPoint.Shape, oshp As PowerPoint.Shape
Dim PPShape As Object
Dim wb As Workbook
Dim list As Worksheet
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set new_pres = PPApp.Presentations.Add
Set wb = ThisWorkbook
Set list = wb.Worksheets("Powerpoint File List")
LastRow = list.Range("A" & Rows.Count).End(xlUp).Row
new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen
' this is not working
k = 1
For i = 1 To LastRow
filepath = list.Range("A" & i).Value
Set pres1 = PPApp.Presentations.Open(filepath)
For j = 1 To pres1.Slides.Count
pres1.Slides(j).Copy
new_pres.Slides.Paste
' new_pres.Slides.Paste
' new_pres.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
k = k + 1
Next j
pres1.Close
Set pres1 = Nothing
Next i
For Each oSld In new_pres.Slides
oSld.HeadersFooters.Clear
oSld.HeadersFooters.SlideNumber.Visible = msoFalse
oSld.HeadersFooters.DateAndTime.Visible = msoFalse
Next oSld
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 700, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.InsertSlideNumber
End With
'ActivePresentation.PageSetup.FirstSlideNumber = 0
new_pres.Slides(1).DisplayMasterShapes = msoTrue
Set oshp = Nothing
response = MsgBox(prompt:="Is this For Official Use Only?", Buttons:=vbYesNo)
If response = vbYes Then
txt = "For Official Use Only"
' If statement to check if the yes button was selected.
Else
' The no button was selected.
MsgBox "Then it is assumed this is a Boeing Proprietary presentation"
txt = "Boeing Proprietary"
End If
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 300, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.Text = txt
End With
injdate = InputBox("Please enter the date for the Stand Up")
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 10, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.Text = injdate
End With
Application.CutCopyMode = True
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub
I have created a code with vba which copy data from excel sheet and paste the same as picture in powerpoint slide, but its not working exactly as per my need.
It should copy data from each worksheets and paste it in a given powerpoint slide worksheet wise. Measn worksheet 1 data should be copied in slide 1 followed by worksheet 2 data in slide 2 and so on and at the end it should save the created ppt file.
But my code is copying and pasting all worksheets data overlaping each other in all the slides of the powerpoint.
Since i am new to vba i am not sure where i am going wrong with the below code:
Sub WorkbooktoPowerPoint()
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange1 As String 'Define another Range
Dim MyTitle As String
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim oSlide As Slide
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\FYI\PPT1.pptx"
strNewPresPath = "C:\Users\FYI\new1.pptx"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
For Each oSlide In oPPTFile.Slides
i = oSlide.SlideNumber
oSlide.Select
MyRange = "B2:B5"
MyRange1 = "B8:B11"
For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select Application.Wait(Now + TimeValue("0:00:1"))
xlwksht.Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 65
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400
xlwksht.Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 250
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400
Next xlwksht
Next
oPPTApp.Activate
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub
Please give this a shot. The main change is that I removed the For Each loop. You are already looping through the slides of the deck and can use the slide number to reference the Excel worksheet (they are numbered, as well). It was creating a mess, now it runs smoothly.
Sub WorkbooktoPowerPoint()
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange1 As String 'Define another Range
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim oSlide As Slide
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\FYI\PPT1.pptx"
strNewPresPath = "C:\Users\FYI\new1.pptx"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
For Each oSlide In oPPTFile.Slides
i = oSlide.SlideNumber
' The following line was added after the OPs follow-up
If i > ActiveWorkbook.Sheets.Count Then Exit For
oSlide.Select
MyRange = "B2:B5"
MyRange1 = "B8:B11"
With ActiveWorkbook.Sheets(i)
.Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
With oPPTApp
.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
.ActiveWindow.Selection.ShapeRange.Top = 65
.ActiveWindow.Selection.ShapeRange.Left = 7.2
.ActiveWindow.Selection.ShapeRange.Width = 400
End With
.Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
With oPPTApp
.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
.ActiveWindow.Selection.ShapeRange.Top = 250
.ActiveWindow.Selection.ShapeRange.Left = 7.2
.ActiveWindow.Selection.ShapeRange.Width = 400
End With
End With
Next
oPPTApp.Activate
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub
My goal is to creat ppt via VBA. I have already the template in my desktop that i need to use. This part of the code is ok.
However I did not find how to select slides in the ppt. I try many ways and i get all the times error.
If someone could help me.
Option Explicit
Sub CreatePowerPoint()
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim oPA As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oPS As PowerPoint.SlideRange
Dim strTemplate As String
Dim rng As Range
strTemplate = "C:\Users\290866\Desktop\vba\PPT\Template.potx"
Set oPA = New PowerPoint.Application
oPA.Visible = msoTrue
oPA.Presentations.Open strTemplate, untitled:=msoTrue
If Not oPS Is Nothing Then Set oPS = Nothing
If Not oPP Is Nothing Then Set oPP = Nothing
If Not oPA Is Nothing Then Set oPA = Nothing
Err_PPT:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
Resume Next
End If
Set rng = ThisWorkbook.Sheets("Credit Recommendation").Range("B2:N59")
ActivePresentation.Slides (1)
rng.Copy
mySlide.Shapes.PasteSpecial (ppPasteBitmap)
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
myShapeRange.LockAspectRatio = msoFalse
myShapeRange.Left = 20
myShapeRange.Top = 80
myShapeRange.Height = 400
myShapeRange.Width = 680
Application.CutCopyMode = False
End Sub
Thank you!!!
Here is your code modified to work. I explain the modifications below
Option Explicit
Sub CreatePowerPoint()
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim oPA As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oPS As PowerPoint.SlideRange
Dim strTemplate As String
Dim rng As Range
strTemplate = "C:\Users\290866\Desktop\vba\PPT\Template.potx"
Set oPA = New PowerPoint.Application
oPA.Visible = msoTrue
'changed this line to assign the new presentation to your variable
Set oPP = oPA.Presentations.Open(strTemplate, untitled:=msoTrue)
'If Not oPS Is Nothing Then Set oPS = Nothing
'If Not oPP Is Nothing Then Set oPP = Nothing
'If Not oPA Is Nothing Then Set oPA = Nothing
Err_PPT:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
Resume Next
End If
Set rng = ThisWorkbook.Sheets("sheet1").Range("B2:N59")
Set mySlide = oPP.Slides(1)
rng.Copy
mySlide.Shapes.PasteSpecial (ppPasteBitmap)
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
myShapeRange.LockAspectRatio = msoFalse
myShapeRange.Left = 20
myShapeRange.Top = 80
myShapeRange.Height = 400
myShapeRange.Width = 680
Application.CutCopyMode = False
End Sub
You were declaring variables and never setting them equal to anything. I still did not see where oPS was ever used.
You received the ActiveX error because PowerPoint did not have an active presentation. It is always safer to work with your own objects rather than ActiveAnything within Office. So I set oPP equal to your new presentation and then used oPP rather than ActivePresentation
Also you never need to set things equal to nothing unless you're being picky about the order it happens. Everything declared in the Sub is set to nothing at the end of the sub.
Hope this helps!
Edit: Search and Replace
This is where I got the code, but I modified it to work as a callable Sub because I was calling it from different places many times:
'Find and Replace function
Sub FindAndReplace(sFind As String, sReplace As String, ByRef ppPres As PowerPoint.Presentation)
Dim osld As PowerPoint.Slide
Dim oshp As PowerPoint.Shape
Dim otemp As PowerPoint.TextRange
Dim otext As PowerPoint.TextRange
Dim Inewstart As Integer
For Each osld In ppPres.Slides
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
Set otext = oshp.TextFrame.TextRange
Set otemp = otext.Replace(sFind, sReplace, , msoFalse, msoFalse)
Do While Not otemp Is Nothing
Inewstart = otemp.Start + otemp.Length
Set otemp = otext.Replace(sFind, sReplace, Inewstart, msoFalse, msoFalse)
Loop
End If
End If
Next oshp
Next osld
End Sub
You'll have to pass it the 2 strings and the Presentation object. It'll look like this in your Sub
FindAndReplace("FindMe","ReplaceWithThis", oPP)
I'm relatively new to VBA. I'm trying out the following VBA code but its throwing an error: 'Runtime error 09: subscript out of range'. This error occurs when i'm trying the paste operation in Graph 1 section of the code..
can someone help with figuring out as to where i'm going wrong. I have declared the presentation/slide etc. still i'm facing this problem..
Sub UK()
Dim oPPTApp As PowerPoint.Application
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
Dim SlideNum As Integer
Dim mycells As Range
Set oPPTApp = CreateObject("PowerPoint.Application")
srcdir = "D:\WBR\Week 2"
srcfile = srcdir & "\" & Dir(srcdir + "\*.pptx")
Set oPPTFile = oPPTApp.Presentations.Open(srcfile)
Set oPPTSlide = oPPTFile.Slides(2)
' for graph 1
Set oPPTShape = oPPTFile.Slides(2).Shapes("Picture 3")
oPPTShape.Delete
ThisWorkbook.Sheets("New Charts").Activate
Sheets("New Charts").Shapes.Range(Array("Group 21")).Select
Selection.CopyPicture
oPPTApp.ActivePresentation.Slides(2).Select
Set Picture = oPPTSlide.Shapes.Paste
Picture.Name = "Picture 3"
With oPPTApp.ActivePresentation.Slides(2).Shapes("Picture 3")
.Top = Application.InchesToPoints(3)
.Left = Application.InchesToPoints(0.22)
End With
If I understand you correctly, you want to:
Open a saved presentation
Delete "Picture 3" from Slide 2
Copy Chart/Range from your excel sheet
Paste it in Slide 2
Name it as "Picture 3"
Set it's position on the slide
Well the below code does exactly that:
'Make Sure to load the PowerPoint Object Library
'Tools ---> References ---> Microsoft PowerPoint xx.x Object Library
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim objChart As Chart
Set pptApp = New PowerPoint.Application
'presentation path here
srcdir = "C:\"
Set pptPres = pptApp.Presentations.Open(srcdir & "Presentation" & ".pptx")
Set pptSlide = pptPres.Slides(2)
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
If .Name = "Picture 3" Then
.Delete
End If
End With
Next j
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Change "Chart 1" to the name of your chart if you are copying a chart
Worksheets("New Charts").ChartObjects("Chart 1").Activate
Set objChart = Worksheets("New Charts").ChartObjects("Chart 1").Chart
objChart.CopyPicture
'If you are copying a range of cells then use
Worksheets("New Charts").Range("A1:A10").Copy
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set MyPic = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
With MyPic
.Name = "Picture 3"
End With
With pptSlide.Shapes("Picture 3")
.Top = Application.InchesToPoints(3)
.Left = Application.InchesToPoints(0.22)
End With
'use this line to set focus to slide 2 if you want to
pptPres.Slides(2).Select
pptPres.Save 'use this line to save if you want to
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing