Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Westi on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Unable to update embedded object in Powerpoint

Status
Not open for further replies.
Queryman

Queryman

Programmer
Nov 4, 2002
243
US
I cannot seem to update the embedded excel objects in a few slides in powerpoint. Here is my VBA code. Any help will be appreciated.
Sub PPT_Update()
Dim PPtApp As PowerPoint.Application
Dim pptPrs As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim pptSh As PowerPoint.Shape
Dim strSourceFullName As String
Dim strLinkFile As String
Dim strLinkReference As String
Dim strTemplatePath As String
Dim strThisworkbookPath As String
Dim intDelimiter As Integer
Dim varReturn As Variant
Dim intLinkCount As Integer
Dim strPPTSaveAsName As String
Dim blnNewPresentation As Boolean
Dim whatversion As String
Dim sFileName As String
Dim stringhold As Integer
Dim SlideCount As Long
Dim iCht As Integer
whatversion = Application.Version
Application.ScreenUpdating = False
'capture current file name

sFileName = "C:\ALLERGY\ALLERGY.xls"
stringhold = Len(sFileName)
sFileName = Left(sFileName, stringhold - 4)
sFileName = sFileName & ".ppt"
If Left(whatversion, 1) = "8" Then
Set PPtApp = CreateObject("Powerpoint.Application.8")
Else
Set PPtApp = CreateObject("Powerpoint.Application.10")
End If

'\ make powerpoint window visible
PPtApp.Visible = msoCTrue
'\ force switch back to make Excel window visible
Application.Visible = True


'this code will open powerpoint file by the same client name
strTemplatePath = sFileName

'\ check to see if template exists
varReturn = Dir(strTemplatePath)
If Len(varReturn) = 0 Then
'MsgBox "Powerpoint file does not exist", vbOKOnly
Else 'template is there
'\ create PPT presentation
Set pptPrs = PPtApp.Presentations.Open(Filename:=strTemplatePath, Untitled:=msoTrue)
'\ create PPT name the same as workbook but with PPT extension
strPPTSaveAsName = Sheets("cover").Range("B2").Value 'get the client name from cover sheet
strPPTSaveAsName = strPPTSaveAsName & ".ppt"
'strPPTSaveAsName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & ".ppt"
'\ if this PPT presentation already exists then ask if overwrite is desired
varReturn = Dir(strPPTSaveAsName)
If Len(varReturn) > 0 Then 'ppt file already exists
pptPrs.SaveAs ThisWorkbook.Path & "\" & strPPTSaveAsName
Else
pptPrs.SaveAs ThisWorkbook.Path & "\" & strPPTSaveAsName
End If
End If

'get the original excel file with links to powerpoint
Application.StatusBar = ""
sFileName = Left(sFileName, stringhold - 4)
sFileName = sFileName & ".xls"
strThisworkbookPath = sFileName
intLinkCount = 0

Dim x As Integer
iCht = 1
For iCht = 1 To 9
If iCht = 1 Then
Set pptPrs = PPtApp.ActivePresentation
PPtApp.ActiveWindow.ViewType = ppViewSlide
Set pptSld = pptPrs.Slides(PPtApp.ActiveWindow.Selection.SlideRange.SlideIndex)
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
pptSld.Shapes.Paste.Select
PPtApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue

ElseIf iCht = 6 Then
PPtApp.ActiveWindow.View.gotoslide Index:=6
PPtApp.ActiveWindow.View.gotoslide pptSld.SlideIndex
For i2 = 1 To PPtApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Type = msoEmbeddedOLEObject Then
PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Select
PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.DoVerb Index:=0
With PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.Object.Sheets("SOURCE DATA").Range("a3:f25").Value = Sheets("SLIDE1").Select
ActiveSheet.Range("a2:f25").Value
End With
Exit For
End If
Next i2

ElseIf iCht = 7 Then
PPtApp.ActiveWindow.View.gotoslide Index:=7
PPtApp.ActiveWindow.View.gotoslide pptSld.SlideIndex
For i2 = 1 To PPtApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Type = msoEmbeddedOLEObject Then
PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Select
PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.DoVerb Index:=0
With PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.Object.Sheets("SOURCE DATA").Range("a2:b40").Value = Sheets("SLIDE2").Select
ActiveSheet.Range("a2:b40").Value
End With
Exit For
End If
Next i2

ElseIf iCht = 8 Then
PPtApp.ActiveWindow.View.gotoslide Index:=7
PPtApp.ActiveWindow.View.gotoslide pptSld.SlideIndex
For i2 = 1 To PPtApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Type = msoEmbeddedOLEObject Then
PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Select
PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.DoVerb Index:=0
With PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.Object.Sheets("SOURCE DATA").Range("a2:b17").Value = Sheets("SLIDE3").Select
ActiveSheet.Range("a2:b17").Value
End With
Exit For
End If
Next i2
End If
Next iCht

DoEvents
Set pptSld = pptPrs.Slides(1) 'reset to first slide
PPtApp.ActiveWindow.View.gotoslide pptSld.SlideIndex
pptPrs.Save
pptPrs.Close
PPtApp.Quit
Application.StatusBar = False
Set PPtApp = Nothing
Set pptPrs = Nothing
Set pptSld = Nothing
Set pptSh = Nothing

Application.Visible = True
Application.CutCopyMode = False

'go back to allergy.xls
Sheets("Cover").Select
'rename allergy.xls to client name, save it, and close it
strPPTSaveAsName = Sheets("cover").Range("B2").Value 'get the client name from cover sheet
strPPTSaveAsName = strPPTSaveAsName & ".xls"
ActiveWorkbook.SaveAs strPPTSaveAsName
ActiveWorkbook.Close

End Sub







Michael

 
Sort by date Sort by votes
Q-man,

Can you give us a bit more infor about what you expect to happen and what is not happening?

Does your routine error off -- where and message

Does it just not do something? What?

You could make your iCht For...Next sleeker by only setting variables in the IF...ElseIf...Then statements and performing the property assignments/i2 for...next one time

Also don't know what you are trying to do with this statement...
Code: 
With PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.Object.Sheets("SOURCE DATA").Range("a2:b40").Value = Sheets("SLIDE2").Select
               ActiveSheet.Range("a2:b40").Value
End With
It is a misuse of the With...End With couplet.
With Object
.ObjectAttribute....
End with

Skip,
Skip@TheOfficeExperts.com
 
Upvote 0 Downvote
I have an embedded excel object in ppt that consists of two tabs, the 1st is a chart and the second is a worksheet that updates the chart. I am trying with this code to update the worksheet within powerpoint from the values in another excel sheet that exists on my hard drive.

You might ask, why doesn't he just cut & paste. For many reasons that revolve around complete automation of this project using SAS, I dynamically generate an excel sheet with the proper values and using those values I want to update the embedded object worksheet only.

There are no errors generated, everything works including creation of a new powerpoint from an existing template. The only part not working is the updating of the embedded worksheet.
Thanks,



Michael

 
Upvote 0 Downvote
The excel object is supposed to get updated by this piece of code
With PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.Object.Sheets("SOURCE DATA").Range("a2:b40").Value = Sheets("SLIDE2").Select
ActiveSheet.Range("a2:b40").Value
End With



Michael

 
Upvote 0 Downvote
I don't think so. I have never seen an assignment in the With statement.

If fact, I see several problems with your statements
1. With RangeValue = SheetObject - that does not make any sense at all.

2. Sheets(n).Select is a method. It selects an object. If you wanted to equate something to that selection (which does not make any sense either), you would follow the Select statement with SomeObject.Attribute = Selection.Attribute

3. ActiveSheet.Range("a2:b40").Value is just a value. But in this case it cannot have a unique value, because it's a multi-cell range.

Apparently, there are no links to the external workbook. It looks like you want to take the Range("a2:b40") and either Copy or loop thru the cell in order that the values can end up in Sheets("SOURCE DATA").Range("a2:b40") in your presintation.
You'll need a reference to Excel and CreateObject to open the workbook and navigate to...
Code: 
xlWorkbook.xlSheet.xlRange.Copy Destination:=destination:=pptxlSheet.pptxlRange
Something like this ought to work.

Skip,
Skip@TheOfficeExperts.com
 
Upvote 0 Downvote
I made some changes, It does not work, I am really stumped on this one. Here are the changes

Sub PPT_Update()
Dim PPtApp As PowerPoint.Application
Dim pptPrs As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim pptSh As PowerPoint.Shape
Dim pptxlsheet As PowerPoint.Shape
Dim strSourceFullName As String
Dim strLinkFile As String
Dim strLinkReference As String
Dim strTemplatePath As String
Dim strThisworkbookPath As String
Dim intDelimiter As Integer
Dim varReturn As Variant
Dim intLinkCount As Integer
Dim strPPTSaveAsName As String
Dim blnNewPresentation As Boolean
Dim whatversion As String
Dim sFileName As String
Dim stringhold As Integer
Dim SlideCount As Long
Dim iCht As Integer
whatversion = Application.Version
Application.ScreenUpdating = False

Dim xlBook As Excel.Workbook, xlApp As Excel.Application

Application.DisplayAlerts = wdAlertsNone

Set xlApp = CreateObject("Excel.Application")
Set xlBook = CreateObject("C:\ALLERGY\ALLERGY.xls")





'capture current file name

sFileName = "C:\ALLERGY\ALLERGY.xls"
stringhold = Len(sFileName)
sFileName = Left(sFileName, stringhold - 4)
sFileName = sFileName & ".ppt"
If Left(whatversion, 1) = "8" Then
Set PPtApp = CreateObject("Powerpoint.Application.8")
Else
Set PPtApp = CreateObject("Powerpoint.Application.10")
End If

'\ make powerpoint window visible
PPtApp.Visible = msoCTrue
'\ force switch back to make Excel window visible
Application.Visible = True


'this code will open powerpoint file by the same client name
strTemplatePath = sFileName

'\ check to see if template exists
varReturn = Dir(strTemplatePath)
If Len(varReturn) = 0 Then
'MsgBox "Powerpoint file does not exist", vbOKOnly
Else 'template is there
'\ create PPT presentation
Set pptPrs = PPtApp.Presentations.Open(Filename:=strTemplatePath, Untitled:=msoTrue)
'\ create PPT name the same as workbook but with PPT extension
strPPTSaveAsName = Sheets("cover").Range("B2").Value 'get the client name from cover sheet
strPPTSaveAsName = strPPTSaveAsName & ".ppt"
'strPPTSaveAsName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & ".ppt"
'\ if this PPT presentation already exists then ask if overwrite is desired
varReturn = Dir(strPPTSaveAsName)
If Len(varReturn) > 0 Then 'ppt file already exists
pptPrs.SaveAs ThisWorkbook.Path & "\" & strPPTSaveAsName
Else
pptPrs.SaveAs ThisWorkbook.Path & "\" & strPPTSaveAsName
End If
End If

'get the original excel file with links to powerpoint
Application.StatusBar = ""
sFileName = Left(sFileName, stringhold - 4)
sFileName = sFileName & ".xls"
strThisworkbookPath = sFileName
intLinkCount = 0

Dim x As Integer
iCht = 1
For iCht = 1 To 9
If iCht = 1 Then
Set pptPrs = PPtApp.ActivePresentation
PPtApp.ActiveWindow.ViewType = ppViewSlide
Set pptSld = pptPrs.Slides(PPtApp.ActiveWindow.Selection.SlideRange.SlideIndex)
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
pptSld.Shapes.Paste.Select
PPtApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue

ElseIf iCht = 6 Then
PPtApp.ActiveWindow.View.gotoslide Index:=6
' PPtApp.ActiveWindow.View.gotoslide pptSld.SlideIndex
For i2 = 1 To PPtApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Type = msoEmbeddedOLEObject Then
PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Select
PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.DoVerb Index:=0
' With PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.Object.Sheets("SOURCE DATA").Range("a2:f25").Value = xlApp.Workbook(xl_workbook).Sheets("SLIDE1").Range("a2:f25").Value

'End With
xlWorkbook.xlSheet("slide1").xlRange("a2:f25").Copy Destination:=pptxlsheet("SOURCE DATA").pptxlRange("a2:f25")

Exit For
End If

Next i2

ElseIf iCht = 7 Then
PPtApp.ActiveWindow.View.gotoslide Index:=7
' PPtApp.ActiveWindow.View.gotoslide pptSld.SlideIndex
For i2 = 1 To PPtApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Type = msoEmbeddedOLEObject Then
PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Select
PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.DoVerb Index:=0
' With PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.Object.Sheets("SOURCE DATA").Range("a2:b40").Value = xlApp.Workbooks(xl_workbook).Sheets("SLIDE2").Range("a2:b40").Value
xlWorkbook.xlSheet("slide2").xlRange("a2:b40").Copy Destination:=pptxlsheet("SOURCE DATA").pptxlRange("a2:b40")

' End With
Exit For
End If
Next i2

ElseIf iCht = 8 Then
PPtApp.ActiveWindow.View.gotoslide Index:=8
' PPtApp.ActiveWindow.View.gotoslide pptSld.SlideIndex
For i2 = 1 To PPtApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Type = msoEmbeddedOLEObject Then
PPtApp.ActiveWindow.Selection.SlideRange.Shapes(i2).Select
PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.DoVerb Index:=0
' With PPtApp.ActiveWindow.Selection.ShapeRange.OLEFormat.Object.Sheets("SOURCE DATA").Range("a2:b17").Value = xlApp.Workbooks(xl_workbook).Sheets("SLIDE3").Range("a2:b17").Value

xlWorkbook.xlSheet("slide3").xlRange("a2:b17").Copy Destination:=pptxlsheet("SOURCE DATA").pptxlRange("a2:b17")
' End With
Exit For
End If
Next i2
End If
Next iCht

DoEvents
Set pptSld = pptPrs.Slides(1) 'reset to first slide
PPtApp.ActiveWindow.View.gotoslide pptSld.SlideIndex
pptPrs.Save
pptPrs.Close
PPtApp.Quit
Application.StatusBar = False
Set PPtApp = Nothing
Set pptPrs = Nothing
Set pptSld = Nothing
Set pptSh = Nothing
xlApp.DisplayAlerts = False
xlBook.Close
Set xlBook = Nothing
Set xlApp = Nothing

Application.Visible = True
Application.CutCopyMode = False

'go back to allergy.xls
Sheets("Cover").Select
'rename allergy.xls to client name, save it, and close it
strPPTSaveAsName = Sheets("cover").Range("B2").Value 'get the client name from cover sheet
strPPTSaveAsName = strPPTSaveAsName & ".xls"
ActiveWorkbook.SaveAs strPPTSaveAsName
ActiveWorkbook.Close

End Sub







Michael

 
Upvote 0 Downvote
xlWorkbook is a workbook object that you need to set
xlSheet is a worksheet object that you need to set or assign
xlRange is a range object that you need to set or assign...
Code: 
Set xlWorkbook = CreateObject...
Set xlSHeet = xlWorkkbook.Worksheets...
etc

Skip,
Skip@TheOfficeExperts.com
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

remeng
  • Locked
  • Solved
Run-time error '429': ActiveX component can't create object From Excel to Word
Replies
9
Views
1K
remeng
remeng
morechocolate
  • Locked
  • Question
run-tune error 3704 operation is not allowed when the object is codes: I don't think so.
Replies
7
Views
1K
morechocolate
morechocolate
sal21
  • Locked
  • Question
scrping in listbox in a web page
Replies
0
Views
468
sal21
sal21
Andrzejek
  • Locked
  • Question
Hyperlinks in Word cut at #
Replies
2
Views
234
Andrzejek
Andrzejek
Andrzejek
  • Locked
  • Question
Data Type in ADODB.Recordset
Replies
6
Views
835
strongm
strongm

Part and Inventory Search

Sponsor

Back
Top