How do I return focus to Excel after copy to Powerpoint?
Results 1 to 2 of 2

Thread: How do I return focus to Excel after copy to Powerpoint?
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular Johnny C's Avatar
    Join Date
    Nov 2006
    Location
    Liverpool, UK
    Posts
    974
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    0 Thread(s)

    Default How do I return focus to Excel after copy to Powerpoint?

    I've written some code to copy charts and ranges to Powerpoint. Powerpoint can't be saved and closed at the end.

    How do I get focus back to Excel after the final paste? here's the code. I've tried a few things at the end.

    Code:
    'First we declare the variables we will be using
    Dim ppApp As PowerPoint.Application
    Dim xlApp As Excel.Application
    Dim ppSelected As PowerPoint.Presentation
    Dim activeSlide As PowerPoint.Slide
    Dim sht As Worksheet
    Dim cht As ChartObject
    Dim strSheetName$, strThisSheet$, ppSelectedName$, strControlSheet$, strChartName$, strRangeName$, strSheetEnd$
    Dim strRefersto$, strRangeStem$, strTemplate$, strCopyType$
    Dim intRowCount&, intLastRow&, intPPCount&, intDocNum&, intErrorCount&
    Dim intCount&, intSheetEnd&, intExtSheet&, intNumItems&
    Dim boolCopycharts As Boolean, boolRangeCopy As Boolean, boolRangeother As Boolean, boolCopyRange As Boolean
    Dim shp As PowerPoint.Shape, intShpWidth%, dblShpRatio#
    Dim ppActiveShape As PowerPoint.Shape
    Dim nm As Name
        
        Application.ScreenUpdating = False
        
        strThisSheet = ActiveSheet.Name
    
        'Get the selected powerpoint presentation selected
        ppSelectedName = frmCopyWBControl.cmbOpenDocs.Value
        If ppSelectedName = "" Then
            MsgBox "You need to select a PowerPoint Presentation to copy to"
            Exit Sub
        End If
        'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
        
        strControlSheet = GetWks("wksCopyControl")
        If strControlSheet = "" Then Exit Sub 'Something went wrong, sheet wsa deleted?
        Sheets(strControlSheet).Activate
        
        intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
        intErrorCount = 0
                
                
    ' Now loop through selected items on Listbox and get data items. then copy to PP.
        intNumItems = frmCopyWBControl.lstCopyControl.ListCount
        For intRowCount = 0 To intNumItems - 1
            If frmCopyWBControl.lstCopyControl.Selected(intRowCount) Then
                strCopyType = frmCopyWBControl.lstCopyControl.List(intRowCount, 0)
                strSheetName = frmCopyWBControl.lstCopyControl.List(intRowCount, 1)
                strRangeName = frmCopyWBControl.lstCopyControl.List(intRowCount, 1)
                strChartName = frmCopyWBControl.lstCopyControl.List(intRowCount, 2)
                strRefersto = frmCopyWBControl.lstCopyControl.List(intRowCount, 2)
                intDocNum = frmCopyWBControl.lstCopyControl.List(intRowCount, 3)
                
    ' Check PP is up and running - it should be the macro wouldn't run if it wasn't BUT PP can crash due to
    ' Excel and PP getting out of sync. The macro tries to cope with it but you never know...
                DoEvents
                On Error Resume Next
                Set ppApp = GetObject(, "PowerPoint.Application")
                On Error GoTo 0
                If Err.Number <> 0 Then
                    MsgBox "Powerpoint seems to have been closed down"
                    Exit Sub
                End If
                
    ' Now loop through presentations until wefind the one selected on the userform.
                DoEvents
                For intPPCount = 1 To ppApp.Presentations.Count
                    If ppApp.Presentations.Item(intPPCount).Name = ppSelectedName Then Set ppSelected = ppApp.Presentations.Item(intPPCount)
                Next intPPCount
                DoEvents
                ppApp.ActiveWindow.ViewType = ppViewSlide
                On Error Resume Next
    
    ' Select the slide from the userform PP slide value
                Set activeSlide = ppSelected.Slides(intDocNum)
                If Err.Number <> 0 Then
                    MsgBox "Error - there is no slide " & intDocNum & " on the " & ppSelectedName & " presentation"
                    intErrorCount = intErrorCount + 1
                Else
                    DoEvents
                    
    ' Now check what type of copy was selected and deal with each accordingly.
    ' Copy range is the same as Specified range
                    Select Case strCopyType
                        Case Is = "Chart"
                            Sheets(strSheetName).Activate
                            ActiveSheet.ChartObjects(strChartName).Select
                            ActiveChart.ChartArea.Copy
                            
                            ' When you paste a table, excel and PP get out of sync. This loop lets them catch up with each other.
                            For intCount = 1 To 500: DoEvents: Next
                            activeSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
                            activeSlide.Shapes(activeSlide.Shapes.Count).Fill.BackColor.RGB = RGB(255, 255, 255)
                            For intCount = 1 To 500: DoEvents: Next
                            
                            DoEvents
                            Sheets(strSheetName).Activate
                        Case Is = "Copy range", Is = "Specified range"
                            intSheetEnd = InStr(strRefersto, "!")
                            intExtSheet = InStr(strRefersto, "]")
                            If intSheetEnd <> 0 And intExtSheet = 0 Then   ' This excludes ranges that refer to other ranges and external objects
                                strSheetName = Left(strChartName, intSheetEnd - 1)
                                Sheets(strSheetName).Activate
                                Range(strRangeName).Copy
                                
                                ' When you paste a table, excel and PP get out of sync. This loop lets them catch up with each other.
                                For intCount = 1 To 5000: DoEvents: Next
                                activeSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
                                activeSlide.Shapes(activeSlide.Shapes.Count).Fill.BackColor.RGB = RGB(255, 255, 255)
                                For intCount = 1 To 5000: DoEvents: Next
                                
                                Sheets(strSheetName).Activate
                                DoEvents
                            End If
                        Case Else
                                ' put something here if needed - currently it's not
                    End Select
                End If
            End If
        Next intRowCount
        
        ActiveWorkbook.Sheets(strThisSheet).Activate
    ' Clear objects out of memory
        Set ppApp = Nothing
        Set ppSelected = Nothing
        Set activeSlide = Nothing
        DoEvents
        For intCount = 1 To 50: DoEvents: Next
        Application.ScreenUpdating = True
        xlApp.AppWinStyle.MaximizedFocus
        AppActivate Title:=Application.ActiveWindow.Caption
        ActiveWorkbook.Sheets(strThisSheet).Activate
        AppActivate Application.Caption
        Application.CutCopyMode = False
        Cells(1, 1).Select
    End Sub
    "If you think this Universe is bad, you should see some of the others" - Philip K. DiĘk

  2. #2
    Board Regular Johnny C's Avatar
    Join Date
    Nov 2006
    Location
    Liverpool, UK
    Posts
    974
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    0 Thread(s)

    Default Re: How do I return focus to Excel after copy to Powerpoint?

    Solved...

    it needed this in the macro that opened the Userform.

    Code:
        AppActivate ("Microsoft Excel")
        Application.ScreenUpdating = True
        AppActivate Title:=Application.ActiveWindow.Caption
        AppActivate Application.Caption
    "If you think this Universe is bad, you should see some of the others" - Philip K. DiĘk

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •