Activate Excel Workbook Over PPT

[MehmetYıldız]

Hi Everyone,

I am using MS 2010 and i have a question about activate the excel workbook over powerpoint?

I opened and closed a ppt file but a blank ppt screen still on. I cannot activate the excel over ppt.

I have to show the frm1 on screen because it has confirmation message.

Could you please help? By the way, i searched at forum but i cannot find any answer

My code is like below,


Sub PasteChart()


Application.DisplayAlerts = False
Application.ScreenUpdating = False


On Error GoTo Errp:


Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim oSld As PowerPoint.Slide
Dim oSh As PowerPoint.Shape


Set ppApp = New PowerPoint.Application
Set ppPres = ppApp.Presentations.Add
Set ppSlide = ppPres.Slides.Add(1, ppLayoutBlank)


mehmet = Excel.ActiveWorkbook.Name


ppSlide.Select
ActiveChart.ChartArea.Copy


On Error Resume Next


ppSlide.Shapes.PasteSpecial(ppPasteShape, msoFalse, , , , msoFalse).Select


For Each oSld In ppApp.ActivePresentation.Slides
For Each oSh In oSld.Shapes
oSh.LinkFormat.BreakLink
Next
Next


ppSlide.Shapes(1).Copy
ppApp.ActivePresentation.Close


Application.DisplayAlerts = True
Application.ScreenUpdating = True


Workbooks(mehmet).Activate 'Cannot activate the excel. Still PPT blank screen on


With frm1
.Top = Int(((Application.Height / 2) + Application.Top) - (.Height / 2))
.Left = Int(((Application.Width / 2) + Application.Left) - (.Width / 2))
.Show
End With


Set ppApp = Nothing


Exit Sub


Errp:


ppApp.ActivePresentation.Close


Set ppApp = Nothing


Application.DisplayAlerts = True
Application.ScreenUpdating = True


m1 = MsgBox("No Chart Selected. Please Select a Chart to Proceed", vbExclamation, "Dear " & Environ("UserName"))


End Sub

 

[Worf]

Hi
I ran your code from Excel and it worked. Anyway, try this:

Sub PasteChart()


Application.DisplayAlerts = False
Application.ScreenUpdating = False


On Error GoTo Errp:


Dim ppApp As PowerPoint.Application, ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide, oSld As PowerPoint.Slide
Dim oSh As PowerPoint.Shape, mehmet$, m1


Set ppApp = New PowerPoint.Application
Set ppPres = ppApp.Presentations.Add
Set ppSlide = ppPres.Slides.Add(1, ppLayoutBlank)


mehmet = Excel.ActiveWorkbook.Name
ppSlide.Select
ActiveChart.ChartArea.Copy


'On Error Resume Next


ppSlide.Shapes.PasteSpecial(ppPasteShape, msoFalse, , , , msoFalse).Select


For Each oSld In ppApp.ActivePresentation.Slides
    For Each oSh In oSld.Shapes
        oSh.LinkFormat.BreakLink
    Next
Next


ppSlide.Shapes(1).Copy
'ppApp.ActivePresentation.Close


Application.DisplayAlerts = True
Application.ScreenUpdating = True


'Workbooks(mehmet).Activate 'Cannot activate the excel. Still PPT blank screen on
AppActivate "Microsoft Excel"
With frm1
    .Top = Int(((Application.Height / 2) + Application.Top) - (.Height / 2))
    .Left = Int(((Application.Width / 2) + Application.Left) - (.Width / 2))
    .Show
End With
Set ppApp = Nothing


Exit Sub


Errp:
ppApp.ActivePresentation.Close


Set ppApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True


m1 = MsgBox("No Chart Selected. Please Select a Chart to Proceed", vbExclamation, "Dear " & Environ("UserName"))


End Sub

 

[MehmetYıldız]

Hi Worf,

Thank you for your answer an interest but when i ran this line

AppActivate "Microsoft Excel"

Excel crashes. I am using excel 2010 by the way

Hi
I ran your code from Excel and it worked. Anyway, try this:

Sub PasteChart()


Application.DisplayAlerts = False
Application.ScreenUpdating = False


On Error GoTo Errp:


Dim ppApp As PowerPoint.Application, ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide, oSld As PowerPoint.Slide
Dim oSh As PowerPoint.Shape, mehmet$, m1


Set ppApp = New PowerPoint.Application
Set ppPres = ppApp.Presentations.Add
Set ppSlide = ppPres.Slides.Add(1, ppLayoutBlank)


mehmet = Excel.ActiveWorkbook.Name
ppSlide.Select
ActiveChart.ChartArea.Copy


'On Error Resume Next


ppSlide.Shapes.PasteSpecial(ppPasteShape, msoFalse, , , , msoFalse).Select


For Each oSld In ppApp.ActivePresentation.Slides
    For Each oSh In oSld.Shapes
        oSh.LinkFormat.BreakLink
    Next
Next


ppSlide.Shapes(1).Copy
'ppApp.ActivePresentation.Close


Application.DisplayAlerts = True
Application.ScreenUpdating = True


'Workbooks(mehmet).Activate 'Cannot activate the excel. Still PPT blank screen on
AppActivate "Microsoft Excel"
With frm1
    .Top = Int(((Application.Height / 2) + Application.Top) - (.Height / 2))
    .Left = Int(((Application.Width / 2) + Application.Left) - (.Width / 2))
    .Show
End With
Set ppApp = Nothing


Exit Sub


Errp:
ppApp.ActivePresentation.Close


Set ppApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True


m1 = MsgBox("No Chart Selected. Please Select a Chart to Proceed", vbExclamation, "Dear " & Environ("UserName"))


End Sub

 

[Worf]

Can you test the workbook on another computer, preferably with a different Office version?

Can you upload your actual workbook to a hosting site like Dropbox and paste the link here, so that I can test it with Excel 07?

 

[MehmetYıldız]

Can you test the workbook on another computer, preferably with a different Office version?

Can you upload your actual workbook to a hosting site like Dropbox and paste the link here, so that I can test it with Excel 07?

I worked for Samsung and all the excel files have been encrypted due to the security settings.

Sorry for that