type mismatch looping through shapes - vba

I'm getting a type mismatch 13 error in the line that loops through the shapes in a slide. I can see that the oSh is Nothing, but if I .Count the shapes, there are plenty of shapes in the slide. How does this make sense?
Brief code:
Dim oPP As PowerPoint.Presentation
Dim oS As Slide
Dim oSh As Shape
For Each oS In oPP.Slides
For Each oSh In oS.Shapes '<-- this line is the error line
On Error Resume Next
If oSh.Type = 14 _
Or oSh.Type = 1 Then
'do stuff
End If
On Error GoTo 0
Next oSh
Next oS
Full code:
Sub PPLateBinding()
Dim pathString As String
'no reference required
Dim PowerPointApplication As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oS As Slide
Dim oSh As Object
Dim pText As String
Dim cellDest As Integer
Dim arrBase() As Variant
Dim arrComp() As Variant
ReDim Preserve arrBase(1)
ReDim Preserve arrComp(1)
Dim fd As FileDialog
Dim FileChosen As Integer
Dim FileName As String
Dim iPresentations As Integer
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'use the standard title and filters, but change the
fd.InitialView = msoFileDialogViewList
'allow multiple file selection
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
'open each of the files chosen
For iPresentations = 1 To fd.SelectedItems.Count
'On Error Resume Next
Set PowerPointApplication = CreateObject("PowerPoint.Application")
Set oPP = PowerPointApplication.Presentations.Open(fd.SelectedItems(iPresentations))
If Err.Number <> 0 Then
Set oPP = Nothing
End If
If Not (oPP Is Nothing) Then
cellDest = 0
'We assume PP is already open and has an active presentation
For Each oS In oPP.Slides
'Debug.Print oPP.Slides.Count
If oS.Shapes.Count > 0 Then
Debug.Print oS.Shapes.Count
For Each oSh In oS.Shapes
Debug.Print "hey"
On Error Resume Next
If oSh.Type = 14 Or oSh.Type = 1 Then
pText = oSh.TextFrame.TextRange.Text
ReDim Preserve arrBase(UBound(arrBase) + 1)
arrBase(UBound(arrBase)) = pText
'Debug.Print pText
ElseIf (oSh.HasTable) Then
Dim i As Integer
For i = 2 To oSh.Table.Rows.Count
ReDim Preserve arrComp(UBound(arrComp) + 1)
arrComp(UBound(arrComp)) = Replace(oSh.Table.Cell(i, 1).Shape.TextFrame.TextRange.Text, vbLf, "") & ":::" & oSh.Table.Cell(i, 3).Shape.TextFrame.TextRange.Text
Next i
End If
On Error GoTo 0
Next oSh
'x = InputData(arrBase, arrComp)
End If
Next oS
'Debug.Print tbl.Shape.TextFrame.TextRange.Text '.Cell(1, 1).Shape.TextRange.Text
oPP.Close
PowerPointApplication.Quit
Set oPP = Nothing
Set PowerPointApplication = Nothing
End If
Next iPresentations
End If
End Sub

Excel has its own Shape type (which is not the same as PowerPoint.Shape type), so you should change
Dim oSh As Shape
to (for earlier binding)
Dim oSh As PowerPoint.Shape
or (for late binding)
Dim oSh As Object
Also note, if you're going to use powerpoint with late binding (as suggests your function name Sub PPLateBinding()), you should change all types PowerPoint.Something to Object (unless you add reference to powerpoint object model, but in this case I don't see any reason for using late binding).

Related

VBA code not working for delete ppt slide

I am trying to delete ppt slides using specific keywords.my code is given below:
Private Sub CommandButton1_Click()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim ppMaster
Dim sText As Variant
strFolderName = "D:\Shaon_Paul\pptss"
strFileName = Dir(strFolderName & "\*.pptx*")
sText = InputBox("Give me some input")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
Dim oSld As Slide
Dim oShp As Shape
Dim L As Long
For L = ActivePresentation.Slides.Count To 1 Step -1
Set oSld = ActivePresentation.Slides(L)
For Each oShp In oSld.Shapes
On Error Resume Next
If oShp.HasTextFrame Then
If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
PP.Slides(L).Delete
End If
End If
Next oShp
Next L
Set ppMaster = PP.SlideMaster
With ppMaster
If UBound(Split(.HeadersFooters.Footer.Text, sText)) > 0 Or UBound(Split(.HeadersFooters.Header.Text, sText)) > 0 Then
PP.Slides(L).Delete
End If
End With
PP.Save
PP.Close
strFileName = Dir
Loop
End Sub
Now this code will open a input box where I have to give my keywords and It will delete the slides in a ppt available in the folder where I have mentioned the path name.
Unfortunately while debugging the code
If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
PP.Slides(L).Delete
End If
it will jump without executing this code above and unable to delete the slide by giving specific keyword name. Need help to resolve this issue.

Run-time error 91 on arrays

I'm getting Run-time error 91 on several variable, and I really have no idea what I'm doing wrong...
The variables are: IQRngRef, tempRng, unionVariable
I assume it has something with them all being arrays with the exception of unionVariable (at least it shouldn't be).
Could I get some help here please?
Option Explicit
Private Sub averageScoreRelay()
' 1. Run from PPT and open an Excel file
' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56,iq_72".
' 3. find those words and numbers in the opened Excel file after splitting and re-formating string.
' 3. Copy column into a new sheets and repeat for all "iq_'s" until sheets 2 has a table.
' 4. Copy table from xl Paste Table into ppt
' 5. Do this for every slide
'Timer start
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ShRef As Excel.Worksheet
Dim pptPres As Object
Dim colNumb As Long
Dim rowNumb As Long
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
'xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("C:\Users\Pinlop\Desktop\Gate\Macros\averageScores\pptxlpratice\dummy2.xlsx", True, False, , , , True, Notify:=False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
xlApp.DisplayAlerts = False
'Find # of iq's in workbook
Set ShRef = xlWB.Worksheets("Sheet1")
colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column
rowNumb = ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp).Row
Dim IQRef() As String
Dim iCol As Long
Dim IQRngRef() As Range
ReDim IQRef(colNumb)
ReDim IQRngRef(colNumb)
' capture IQ refs locally
For iCol = 2 To colNumb
IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol)).Value
IQRef(iCol) = ShRef.Cells(1, iCol).Value
Next iCol
'Make pptPres the ppt active
Set pptPres = PowerPoint.ActivePresentation
'Create variables for the slide loop
Dim pptSlide As Slide
Dim Shpe As Shape
Dim pptText As String
Dim iq_Array As Variant
Dim arrayLoop As Long
Dim myShape As Object
Dim outCol As Long
Dim i As Long
Dim lRows As Long
Dim lCols As Long
Dim k As Long
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
i = 0
pptSlide.Select
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
If Not Shpe.HasTextFrame Then GoTo nextShpe 'boom, one less nested If statement
If Not Shpe.TextFrame.HasText Then GoTo nextShpe ' boom, another nested If statement bites the dust
outCol = 0
'Set pptText as the Text in the box, then make it lowercase and trim Spaces and Enters
pptText = Shpe.TextFrame.TextRange
pptText = LCase(Replace(pptText, " ", vbNullString))
pptText = Replace(Replace(Replace(pptText, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)
'Identify if within text there is "iq_"
If InStr(1, pptText, "iq_") <= 0 Then GoTo nextShpe
'set iq_Array as an array of the split iq's
iq_Array = Split(pptText, ",")
Dim hasIQs As Boolean
Dim checkStr As String
Dim pCol As Long
Dim checkOne
checkOne = iq_Array(0)
hasIQs = Left(checkOne, 3) = "iq_"
Dim tempRng() As Range
If hasIQs Then
' paste inital column into temporary worksheet
tempRng(0) = ShRef.Columns(1)
End If
' loop for each iq_ in the array
For arrayLoop = LBound(iq_Array) To UBound(iq_Array)
' Take copy of potential ref and adjust to standard if required
checkStr = iq_Array(arrayLoop)
If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr
' Look for existence of corresponding column in local copy array
pCol = 0
For iCol = 2 To colNumb
If checkStr = IQRef(iCol) Then
pCol = iCol
Exit For
End If
Next iCol
If pCol > 0 Then
' Paste the corresponding column into the forming table
outCol = outCol + 1
tempRng(outCol) = ShRef.Columns(pCol)
End If
Next arrayLoop
If outCol > 1 Then 'data was added
' Copy table
Dim unionVariable As Range
unionVariable = tempRng(0)
For k = 1 To i
unionVariable = Union(unionVariable, tempRng(k))
Next k
unionVariable.Copy ' all the data added to ShWork
tryAgain:
ActiveWindow.ViewType = ppViewNormal
ActiveWindow.Panes(2).Activate
Set myShape = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
On Error GoTo tryAgain
On Error GoTo clrSht
'Set position:
myShape.Left = -200
myShape.Top = 150 + i
i = i + 150
End If
clrSht:
'Clear Sheet2 for next slide
Erase tempRng()
nextShpe:
Next Shpe
nextSlide:
Next pptSlide
xlWB.Close
xlApp.Quit
xlApp.DisplayAlerts = True
'End Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Dim something() As String
That's declaring a dynamically-sized array, where each item is a String. Once it's resized, you can do this (assuming i is within the boundaries of the array):
something(i) = "foo"
Now this:
Dim something() As Range
That's declaring a dynamically-sized array, where each item is a Range. Once it's resized, you can do this (assuming i is within the boundaries of the array):
Set something(i) = Range("A1")
Notice the Set keyword - it's required in VBA, whenever you're assigning an object reference. Range being an object, you need the Set keyword for that assignment.
In your code:
tempRng(0) = ShRef.Columns(1)
That's indeed a Range, but the Set keyword is missing. That will throw the RTE91 you're getting.
Same here:
unionVariable = tempRng(0)
You can't assign an object reference without the Set keyword.
Here though:
IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol)).Value
That's not a Range. It's the .Value of a Range, and that's a Variant - not an object, so adding the Set keyword isn't going to fix anything. If you mean IQRngRef to hold Range objects, you need to do this:
Set IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol))

VBA Excel --> PWP - Blank when copy

I have a little issue with my macro. I know it's not the perfect one but at least it works.
The only thing is that when I go step by step it is going perfectly but when I run it all the new slides are blank.
Do you have an idea how to improve that ?
Sub paste_toPPT()
Dim PowerPointApp As Object
Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(Class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject(Class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)
Windows("KPI List - P2P KPI.xlsm").Activate
count = WorksheetFunction.CountA(Sheets("KPI List").Range("E:E")) - 1
For i = 8 To count
Worksheets("KPI List").Select
'ThisWorkbook.Sheets("KPI List").Select
IDe = Worksheets("KPI List").Range(Cells(i, 5), Cells(i, 5))
ThisWorkbook.Sheets("ID").Range("F4:F4") = IDe
'Set the range to copy
Windows("KPI List - P2P KPI.xlsm").Activate
Worksheets("ID").Select
Worksheets("ID").Shapes.Range(Array("Group 57")).Select
Selection.Copy
'Add slide & Paste data
pptPres.Windows(1).Activate
Set mySlide = pptPres.Slides.Add(1, 12)
mySlide.Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i
pptPres.SaveAs DestinationPPT
End Sub
Try the code below, explanations inside the code as comments:
Sub paste_toPPT()
Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer
' added 2 worksheet objects
Dim wsKPI As Worksheet
Dim wsID As Worksheet
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(, "PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject("PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)
' no need to Activate the workbook first, just set the worksheet objects
Set wsKPI = Workbooks("KPI List - P2P KPI.xlsm").Sheets("KPI List")
Set wsID = Workbooks("KPI List - P2P KPI.xlsm").Sheets("ID")
count = WorksheetFunction.CountA(ws.Range("E:E")) - 1
For i = 8 To count
IDe = wsKPI.Range(wsKPI.Cells(i, 5), wsKPI.Cells(i, 5))
wsID.Range("F4:F4") = IDe
' first add the slide , later do the copy>>paste as close as can be
Set mySlide = pptPres.Slides.Add(1, 12)
' Set the range to copy (no need to Select first)
wsID.Shapes.Range(Array("Group 57")).Copy
mySlide.Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i
pptPres.Save
End Sub

Export queries from Access-Form to Excel with Loop in VBA

I want to Export large data stock from Access to Excel. I'm doing that with a form.
My code with "DoCmd.TransferSpreadsheet acExport..." works normally, but the program breaks off because of the large data stock.
Perhaps with queries I can solve this Problem, or what do you think?
I am thankful for each tip! =)
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'=======================
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'''PPT
Sub pptExoprort()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim slideNum As Integer
Dim chartName As String
Dim tableName As String
Dim PPTCount As Integer
Dim PPSlideCount As Long
Dim oPPTShape As PowerPoint.Shape
Dim ShpNm As String
Dim ShtNm As String
Dim NewSlide As String
Dim myChart As PowerPoint.Chart
Dim wb As Workbook
Dim rngOp As Range
Dim ro As Range
Dim p As Integer
Dim v, v1, v2, v3, Vtot, VcaGr
Dim ws As Worksheet
Dim ch
Dim w As Worksheet
Dim x, pArr
Dim rN As String
Dim rt As String
Dim ax
Dim yTbN As String
'Call InitializeGlobal
''start year offset
prodSel = shtSet.Range("rSelProd")
x = shtSet.Range("rngMap").Value
pArr = fretPrVal(x, prodSel)
TY = 11 'number of years in chart
ThisWorkbook.Activate
Set w = ActiveSheet
Set PPApp = GetObject("", "Powerpoint.Application") '******************
PPTCount = PPApp.Presentations.Count
If PPTCount = 0 Then
MsgBox ("Please open a PPT to export the Charts!")
Exit Sub
End If
Set PPPres = PPApp.ActivePresentation '******************
For j = 0 To UBound(pArr)
If j = 0 Then
rN = "janport"
slideNum = 3
yTbN = "runport"
Else
rN = "janprod" & j
slideNum = 3 + j
yTbN = "runprod" & j
End If
chartName = "chtSalesPort"
Set PPSlide = PPPres.Slides(slideNum) '**************
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
Set myChart = PPSlide.Shapes(chartName).Chart '******************
myChart.ChartData.Activate '********************
Set wb = myChart.ChartData.Workbook '***********
Set ws = wb.Worksheets(1) '**************
Set rngOp = w.Range(rN).Offset(0, 1).Resize(12, 6)
Set ro = rngOp
' v1 = ro.Offset(1, 22).Resize(Lc, 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$B$" & Ty + 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$" & Chr(Lc + 1 + 64) & "$" & Ty + 1)
ws.Range("B2:g13").ClearContents '***********
rngOp.Copy '**********
ws.Range("B2:g13").PasteSpecial xlPasteValues '******************
End Sub
Sub Picture62_Click()
Dim charNamel As String
Dim leftm As Integer
Dim toptm As Integer
charNamel = "Chart 1"
leftm = 35
toptm = 180
Call chartposition(leftm, toptm, charNamel)
End Sub
Sub chartposition(leftm, toptm, charNamel)
ActiveSheet.ChartObjects(charNamel).Activate
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim activslidenumber As Integer
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
' If newPowerPoint.Presentations.Count = 0 Then
' newPowerPoint.Presentations.Add
' End If
'Show the PowerPoint
newPowerPoint.Visible = True
On Error GoTo endd:
activslidenumber = Str(GetActiveSlide(newPowerPoint.ActiveWindow).SlideIndex)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(activslidenumber)
ActiveChart.ChartArea.Copy
On Error GoTo endddd:
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse).Select
endddd:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = leftm
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = toptm
GoTo enddddd:
endd:
MsgBox ("Please keep your PPT file opened")
enddddd:
End Sub

Macro for PPT - Move TextBox contents to Placeholder - Maintain links and lists

I have PPTs that are being generated via software that I have no control over. Upon generation, the software puts all text into TextBoxes instead of my Placeholders.
I created a script to move the text from the TextBoxes into the placeholders and this works great; however, I am unable to maintain the links and the lists are always showing as Bulleted despite some being numbers. Basically, if there is a link in the textbox, it should still be a link in the Placeholder. FYI, this script also changes shape 3 on each slide into the Title Placeholder
How can I preserve the formatting when I am moving the text over? I attempted to use pastespecial, but that still was only moving the text into the format of the placeholder.
Sub TextBoxFix()
Dim osld As Slide, oshp As Shape, oTxR As TextRange, SlideIndex As Long, myCount As Integer, numShapesOnSlide As Integer
Dim tempBulletFormat As PowerPoint.PpBulletType
For Each osld In ActivePresentation.Slides
myCount = 1
With ActivePresentation
'For Each oshp In osld.Shapes
osld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
For i = osld.Shapes.Count To 1 Step -1
Set oshp = osld.Shapes(i)
If i = 3 Then
osld.Shapes.Placeholders.Item(1).TextFrame.TextRange = oshp.TextFrame.TextRange.Characters
osld.Shapes.Placeholders.Item(1).Visible = msoTrue
oshp.Delete
ElseIf i > 3 And oshp.Type = msoTextBox Then
oshp.TextFrame.TextRange.Copy
osld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(oshp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = oshp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
oshp.Delete
End If
Next i
End With
Next osld
End Sub
This may have some formatting issues that need to be addressed, but this will insert the hyperlinks that you are looking for. Code is likely not the cleanest, but it works. You will also need to set the vba to break only on unhandled errors, or it will break in the middle of the code. See here.
Class Module - Hyper
Private shp As Shape
Private chrStart As Integer
Private hypAddr As String
Private hypText As String
Private Sub Class_Initialize()
End Sub
Public Sub InitializeWithValues(newShp As Shape, newChrStart As Integer, newHypAddress As String, newHypText As String)
Set shp = newShp
chrStart = newChrStart
hypAddr = newHypAddress
hypText = newHypText
End Sub
Public Function getShape() As Shape
Set getShape = shp
End Function
Public Function getchrStart() As Integer
getchrStart = chrStart
End Function
Public Function getHypAddr() As String
getHypAddr = hypAddr
End Function
Public Function getHypText() As String
getHypText = hypText
End Function
Class Module - hyperColl
Private myCollection As Collection
Private Sub Class_Initialize()
Set myCollection = New Collection
End Sub
Public Sub Add_Item(newHyper As Hyper)
Dim newArray() As Hyper
If Me.Exists(newHyper.getShape().Name) Then
newArray = myCollection(newHyper.getShape().Name)
ReDim Preserve newArray(0 To UBound(newArray) + 1)
Set newArray(UBound(newArray)) = newHyper
myCollection.Remove (newHyper.getShape().Name)
myCollection.Add newArray, newHyper.getShape().Name
Else
ReDim newArray(0)
Set newArray(0) = newHyper
myCollection.Add newArray, newHyper.getShape().Name
End If
End Sub
Public Function GetArray(shapeName As String) As Hyper()
GetArray = myCollection(shapeName)
End Function
Public Function Exists(shapeName As String) As Boolean
Dim myHyper() As Hyper
On Error Resume Next
myHyper = myCollection(shapeName)
On Error GoTo 0
If Err.Number = 5 Then 'Not found in collection
Exists = False
Else
Exists = True
End If
Err.Clear
End Function
Regular Module (Call it whatever you want)
Sub textBoxFix()
Dim sld As Slide
Dim shp As Shape
Dim shp2 As Shape
Dim oHl As Hyperlink
Dim hypAddr As String
Dim hypText As String
Dim hypTextLen As Integer
Dim hypTextStart As Integer
Dim hypShape As Shape
Dim hypCollection As hyperColl
Dim newHyper As Hyper
Dim hypArray() As Hyper
Dim hypToAdd As Hyper
Dim i As Long
Dim j As Long
Dim bolCopy As Boolean
Set sld = ActivePresentation.Slides(1)
sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape
Set shp = sld.Shapes(1)
For Each oHl In sld.Hyperlinks
If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
hypAddr = oHl.Address
hypText = oHl.TextToDisplay
hypTextLen = Len(hypText)
If TypeName(oHl.Parent.Parent) = "TextRange" Then
hypTextStart = oHl.Parent.Parent.start
Set hypShape = oHl.Parent.Parent.Parent.Parent
End If
Set newHyper = New Hyper
newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
hypCollection.Add_Item newHyper
End If
Next oHl
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
bolCopy = False
If j = 3 Then
Set shp2 = sld.Shapes.Placeholders.Item(1)
bolCopy = True
ElseIf j > 3 And shp.Type = msoTextBox Then
Set shp2 = sld.Shapes.Placeholders.Item(2)
bolCopy = True
End If
If bolCopy = True Then
shp2.TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
If hypCollection.Exists(shp.Name) Then
hypArray = hypCollection.GetArray(shp.Name)
For i = LBound(hypArray) To UBound(hypArray)
Set hypToAdd = hypArray(i)
With shp2.TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
.Action = ppActionHyperlink
.Hyperlink.Address = hypToAdd.getHypAddr
End With
Next i
End If
End If
shp.Delete
Next j
End Sub
I used OpiesDad's code as a starting point, and made some minor modifications. I was getting an error related to the GetArray function when textboxes didn't exist. In addition, I modified the code to run on all slides of the PPT. I also had to make some modifications to the TextBoxFix Sub because the content was being deleted, but wasn't populating in my Placeholders.
See my updates below:
Reused Class Module - Hyper
Removed "On Error GoTo 0" from the Exists Function in hyperColl
Revised TextBoxFix below:
Sub TextBoxFix()
Dim shp As Shape
Dim shp2 As Shape
Dim oHl As Hyperlink
Dim hypAddr As String
Dim hypText As String
Dim hypTextLen As Integer
Dim hypTextStart As Integer
Dim hypShape As Shape
Dim hypCollection As hyperColl
Dim newHyper As Hyper
Dim hypArray() As Hyper
Dim hypToAdd As Hyper
Dim i As Long
Dim j As Long
Dim bolCopy As Boolean
For Each sld In ActivePresentation.Slides
With ActivePresentation
sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape
Set shp = sld.Shapes(1)
For Each oHl In sld.Hyperlinks
If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
hypAddr = oHl.Address
hypText = oHl.TextToDisplay
hypTextLen = Len(hypText)
If TypeName(oHl.Parent.Parent) = "TextRange" Then
hypTextStart = oHl.Parent.Parent.Start
Set hypShape = oHl.Parent.Parent.Parent.Parent
End If
Set newHyper = New Hyper
newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
hypCollection.Add_Item newHyper
End If
Next oHl
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
bolCopy = False
If j = 3 Then
sld.Shapes.Placeholders.Item(1).TextFrame.TextRange = shp.TextFrame.TextRange.Characters
sld.Shapes.Placeholders.Item(1).Visible = msoTrue
shp.Delete
ElseIf j > 3 And shp.Type = msoTextBox Then
sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
If hypCollection.Exists(shp.Name) Then
hypArray = hypCollection.GetArray(shp.Name)
For i = LBound(hypArray) To UBound(hypArray)
Set hypToAdd = hypArray(i)
With sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
.Action = ppActionHyperlink
.Hyperlink.Address = hypToAdd.getHypAddr
End With
Next i
End If
shp.Delete
End If
Next j
End With
Next sld
End Sub